From 279a662adc83dba2e24bd0b99f7da9d63455f840 Mon Sep 17 00:00:00 2001
From: jpmoresmau <jp@moresmau.fr>
Date: Tue, 20 Jan 2015 18:27:16 +0100
Subject: Links to source location of class instance definitions

---
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 18 +++++++++---------
 1 file changed, 9 insertions(+), 9 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Xhtml/Decl.hs')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 3bf4322d..d24a3f04 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -18,7 +18,6 @@ module Haddock.Backends.Xhtml.Decl (
   tyvarNames
 ) where
 
-
 import Haddock.Backends.Xhtml.DocMarkup
 import Haddock.Backends.Xhtml.Layout
 import Haddock.Backends.Xhtml.Names
@@ -270,7 +269,7 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode
       = subEquations qual $ map (ppTyFamEqn . unLoc) eqns
 
       | otherwise
-      = ppInstances instances docname unicode qual
+      = ppInstances links instances docname unicode qual
 
     -- Individual equation of a closed type family
     ppTyFamEqn TyFamEqn { tfe_tycon = n, tfe_rhs = rhs
@@ -492,18 +491,19 @@ ppClassDecl summary links instances fixities loc d subdocs
     ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a+++" | "+++b) $ map (ppMinimal False) fs
       where wrap | p = parens | otherwise = id
 
-    instancesBit = ppInstances instances nm unicode qual
+    instancesBit = ppInstances links instances nm unicode qual
 
 ppClassDecl _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
 
 
-ppInstances :: [DocInstance DocName] -> DocName -> Unicode -> Qualification -> Html
-ppInstances instances baseName unicode qual
-  = subInstances qual instName (map instDecl instances)
+ppInstances :: LinksInfo -> [DocInstance DocName] -> DocName -> Unicode -> Qualification -> Html
+ppInstances links instances baseName unicode qual
+  = subInstances qual instName links True baseName (map instDecl instances)
+  -- force Splice = True to use line URLs
   where
     instName = getOccString $ getName baseName
-    instDecl :: DocInstance DocName -> SubDecl
-    instDecl (inst, maybeDoc) = (instHead inst, maybeDoc, [])
+    instDecl :: DocInstance DocName -> (SubDecl,SrcSpan)
+    instDecl (L l inst, maybeDoc) = ((instHead inst, maybeDoc, []),l)
     instHead (n, ks, ts, ClassInst cs) = ppContextNoLocs cs unicode qual
         <+> ppAppNameTypes n ks ts unicode qual
     instHead (n, ks, ts, TypeInst rhs) = keyword "type"
@@ -582,7 +582,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl
                                      (map unLoc (con_names (unLoc c)))) fixities
       ]
 
-    instancesBit = ppInstances instances docname unicode qual
+    instancesBit = ppInstances links instances docname unicode qual
 
 
 
-- 
cgit v1.2.3


From 89fc5605c865d0e0ce5ed7e396102e678426533b Mon Sep 17 00:00:00 2001
From: Alan Zimmerman <alan.zimm@gmail.com>
Date: Tue, 9 Sep 2014 01:03:27 -0500
Subject: Follow API changes in D538

Signed-off-by: Austin Seipp <aseipp@pobox.com>
(cherry picked from commit d61bbc75890e4eb0ad508b9c2a27b91f691213e6)
---
 haddock-api/src/Haddock/Backends/Hoogle.hs     |  6 +++---
 haddock-api/src/Haddock/Backends/LaTeX.hs      | 22 +++++++++++-----------
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 26 +++++++++++++-------------
 haddock-api/src/Haddock/Convert.hs             | 22 +++++++++++-----------
 haddock-api/src/Haddock/GhcUtils.hs            | 14 +++-----------
 haddock-api/src/Haddock/Interface/Create.hs    | 18 +++++++++---------
 haddock-api/src/Haddock/Interface/Rename.hs    | 18 +++++++++---------
 haddock-api/src/Haddock/Utils.hs               |  4 ++--
 8 files changed, 61 insertions(+), 69 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Xhtml/Decl.hs')

diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index dd10bb0a..fe656a4b 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -145,7 +145,7 @@ ppClass dflags x = out dflags x{tcdSigs=[]} :
             concatMap (ppSig dflags . addContext . unL) (tcdSigs x)
     where
         addContext (TypeSig name (L l sig) nwcs) = TypeSig name (L l $ f sig) nwcs
-        addContext (MinimalSig sig) = MinimalSig sig
+        addContext (MinimalSig src sig) = MinimalSig src sig
         addContext _ = error "expected TypeSig"
 
         f (HsForAllTy a b c con d) = HsForAllTy a b c (reL (context : unLoc con)) d
@@ -189,7 +189,7 @@ ppCtor dflags dat subdocs con
     where
         f (PrefixCon args) = [typeSig name $ args ++ [resType]]
         f (InfixCon a1 a2) = f $ PrefixCon [a1,a2]
-        f (RecCon recs) = f (PrefixCon $ map cd_fld_type (map unLoc recs)) ++ concat
+        f (RecCon (L _ recs)) = f (PrefixCon $ map cd_fld_type (map unLoc recs)) ++ concat
                           [(concatMap (lookupCon dflags subdocs) (cd_fld_names r)) ++
                            [out dflags (map unL $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]]
                           | r <- map unLoc recs]
@@ -203,7 +203,7 @@ ppCtor dflags dat subdocs con
         resType = case con_res con of
             ResTyH98 -> apps $ map (reL . HsTyVar) $
                         (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvBndrs $ tyClDeclTyVars dat]
-            ResTyGADT x -> x
+            ResTyGADT _ x -> x
 
 
 ---------------------------------------------------------------------
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index ee5bc861..125e1b3a 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -477,7 +477,7 @@ rDoc = maybeDoc . fmap latexStripTrailingWhitespace
 
 
 ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName
-           -> LHsTyVarBndrs DocName -> [Located ([DocName], [DocName])]
+           -> LHsTyVarBndrs DocName -> [Located ([Located DocName], [Located DocName])]
            -> Bool -> LaTeX
 ppClassHdr summ lctxt n tvs fds unicode =
   keyword "class"
@@ -486,13 +486,13 @@ ppClassHdr summ lctxt n tvs fds unicode =
   <+> ppFds fds unicode
 
 
-ppFds :: [Located ([DocName], [DocName])] -> Bool -> LaTeX
+ppFds :: [Located ([Located DocName], [Located DocName])] -> Bool -> LaTeX
 ppFds fds unicode =
   if null fds then empty else
     char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds))
   where
-    fundep (vars1,vars2) = hsep (map ppDocName vars1) <+> arrow unicode <+>
-                           hsep (map ppDocName vars2)
+    fundep (vars1,vars2) = hsep (map (ppDocName . unLoc) vars1) <+> arrow unicode <+>
+                           hsep (map (ppDocName . unLoc) vars2)
 
 
 ppClassDecl :: [DocInstance DocName] -> SrcSpan
@@ -598,8 +598,8 @@ ppDataDecl instances subdocs _loc doc dataDecl unicode
     (whereBit, leaders)
       | null cons = (empty,[])
       | otherwise = case resTy of
-        ResTyGADT _ -> (decltt (keyword "where"), repeat empty)
-        _           -> (empty, (decltt (text "=") : repeat (decltt (text "|"))))
+        ResTyGADT _ _ -> (decltt (keyword "where"), repeat empty)
+        _             -> (empty, (decltt (text "=") : repeat (decltt (text "|"))))
 
     constrBit
       | null cons = Nothing
@@ -636,7 +636,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
                  map (ppLParendType unicode) args))
       <-> rDoc mbDoc <+> nl
 
-    RecCon fields ->
+    RecCon (L _ fields) ->
       (decltt (header_ unicode <+> ppOcc)
         <-> rDoc mbDoc <+> nl)
       $$
@@ -648,11 +648,11 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
                  ppLParendType unicode arg2 ])
       <-> rDoc mbDoc <+> nl
 
-  ResTyGADT resTy -> case con_details con of
+  ResTyGADT _ resTy -> case con_details con of
     -- prefix & infix could also use hsConDeclArgTys if it seemed to
     -- simplify the code.
     PrefixCon args -> doGADTCon args resTy
-    cd@(RecCon fields) -> doGADTCon (hsConDeclArgTys cd) resTy <+> nl $$
+    cd@(RecCon (L _ fields)) -> doGADTCon (hsConDeclArgTys cd) resTy <+> nl $$
                                      doRecordFields fields
     InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy
 
@@ -948,8 +948,8 @@ ppr_mono_ty _ (HsTyLit t) u = ppr_tylit t u
 
 
 ppr_tylit :: HsTyLit -> Bool -> LaTeX
-ppr_tylit (HsNumTy n) _ = integer n
-ppr_tylit (HsStrTy s) _ = text (show s)
+ppr_tylit (HsNumTy _ n) _ = integer n
+ppr_tylit (HsStrTy _ s) _ = text (show s)
   -- XXX: Ok in verbatim, but not otherwise
   -- XXX: Do something with Unicode parameter?
 
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index d24a3f04..405a13f8 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -145,7 +145,7 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep)
 
 ppForAll :: LHsTyVarBndrs DocName -> Unicode -> Qualification -> Html
 ppForAll tvs unicode qual =
-  case [ppKTv n k | L _ (KindedTyVar n k) <- hsQTvBndrs tvs] of
+  case [ppKTv n k | L _ (KindedTyVar (L _ n) k) <- hsQTvBndrs tvs] of
     [] -> noHtml
     ts -> forallSymbol unicode <+> hsep ts +++ dot
   where ppKTv n k = parens $
@@ -380,7 +380,7 @@ ppHsContext cxt unicode qual = parenList (map (ppType unicode qual) cxt)
 
 
 ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName
-           -> LHsTyVarBndrs DocName -> [Located ([DocName], [DocName])]
+           -> LHsTyVarBndrs DocName -> [Located ([Located DocName], [Located DocName])]
            -> Unicode -> Qualification -> Html
 ppClassHdr summ lctxt n tvs fds unicode qual =
   keyword "class"
@@ -389,13 +389,13 @@ ppClassHdr summ lctxt n tvs fds unicode qual =
   <+> ppFds fds unicode qual
 
 
-ppFds :: [Located ([DocName], [DocName])] -> Unicode -> Qualification -> Html
+ppFds :: [Located ([Located DocName], [Located DocName])] -> Unicode -> Qualification -> Html
 ppFds fds unicode qual =
   if null fds then noHtml else
         char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds))
   where
         fundep (vars1,vars2) = ppVars vars1 <+> arrow unicode <+> ppVars vars2
-        ppVars = hsep . map (ppDocName qual Prefix True)
+        ppVars = hsep . map ((ppDocName qual Prefix True) . unLoc)
 
 ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan
                  -> [(DocName, DocForDecl DocName)]
@@ -469,7 +469,7 @@ ppClassDecl summary links instances fixities loc d subdocs
                            -- there are different subdocs for different names in a single
                            -- type signature?
 
-    minimalBit = case [ s | L _ (MinimalSig s) <- lsigs ] of
+    minimalBit = case [ s | L _ (MinimalSig _ s) <- lsigs ] of
       -- Miminal complete definition = every shown method
       And xs : _ | sort [getName n | Var (L _ n) <- xs] ==
                    sort [getName n | L _ (TypeSig ns _ _) <- lsigs, L _ n <- ns]
@@ -572,7 +572,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl
     whereBit
       | null cons = noHtml
       | otherwise = case resTy of
-        ResTyGADT _ -> keyword "where"
+        ResTyGADT _ _ -> keyword "where"
         _ -> noHtml
 
     constrBit = subConstructors qual
@@ -600,7 +600,7 @@ ppShortConstrParts summary dataInst con unicode qual = case con_res con of
     PrefixCon args ->
       (header_ unicode qual +++ hsep (ppOcc
             : map (ppLParendType unicode qual) args), noHtml, noHtml)
-    RecCon fields ->
+    RecCon (L _ fields) ->
       (header_ unicode qual +++ ppOcc <+> char '{',
        doRecordFields fields,
        char '}')
@@ -609,7 +609,7 @@ ppShortConstrParts summary dataInst con unicode qual = case con_res con of
             ppOccInfix, ppLParendType unicode qual arg2],
        noHtml, noHtml)
 
-  ResTyGADT resTy -> case con_details con of
+  ResTyGADT _ resTy -> case con_details con of
     -- prefix & infix could use hsConDeclArgTys if it seemed to
     -- simplify the code.
     PrefixCon args -> (doGADTCon args resTy, noHtml, noHtml)
@@ -617,7 +617,7 @@ ppShortConstrParts summary dataInst con unicode qual = case con_res con of
     -- Constr :: (Context) => { field :: a, field2 :: b } -> Ty (a, b)
     -- (except each field gets its own line in docs, to match
     -- non-GADT records)
-    RecCon fields -> (ppOcc <+> dcolon unicode <+>
+    RecCon (L _ fields) -> (ppOcc <+> dcolon unicode <+>
                             ppForAllCon forall_ ltvs lcontext unicode qual <+> char '{',
                             doRecordFields fields,
                             char '}' <+> arrow unicode <+> ppLType unicode qual resTy)
@@ -682,7 +682,7 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, field
             ppLParendType unicode qual arg2]
           <+> fixity
 
-      ResTyGADT resTy -> case con_details con of
+      ResTyGADT _ resTy -> case con_details con of
         -- prefix & infix could also use hsConDeclArgTys if it seemed to
         -- simplify the code.
         PrefixCon args -> doGADTCon args resTy
@@ -690,7 +690,7 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, field
         InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy
 
     fieldPart = case con_details con of
-        RecCon fields -> [doRecordFields fields]
+        RecCon (L _ fields) -> [doRecordFields fields]
         _ -> []
 
     doRecordFields fields = subFields qual
@@ -907,8 +907,8 @@ ppr_mono_ty _ (HsNamedWildcardTy name) _ q = ppDocName q Prefix True name
 ppr_mono_ty _ (HsTyLit n) _ _ = ppr_tylit n
 
 ppr_tylit :: HsTyLit -> Html
-ppr_tylit (HsNumTy n) = toHtml (show n)
-ppr_tylit (HsStrTy s) = toHtml (show s)
+ppr_tylit (HsNumTy _ n) = toHtml (show n)
+ppr_tylit (HsStrTy _ s) = toHtml (show s)
 
 
 ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Unicode -> Qualification -> Html
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index ac7f8bd8..5cbf5f97 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -31,7 +31,7 @@ import Kind ( splitKindFunTys, synTyConResKind, isKind )
 import Name
 import PatSyn
 import PrelNames (ipClassName)
-import SrcLoc ( Located, noLoc, unLoc )
+import SrcLoc ( Located, noLoc, unLoc, noSrcSpan )
 import TcType ( tcSplitSigmaTy )
 import TyCon
 import Type (isStrLitTy, mkFunTys)
@@ -74,9 +74,9 @@ tyThingToLHsDecl t = case t of
          , tcdLName = synifyName cl
          , tcdTyVars = synifyTyVars (classTyVars cl)
          , tcdFDs = map (\ (l,r) -> noLoc
-                        (map getName l, map getName r) ) $
+                        (map (noLoc . getName) l, map (noLoc . getName) r) ) $
                          snd $ classTvsFds cl
-         , tcdSigs = noLoc (MinimalSig . fmap noLoc $ classMinimalDef cl) :
+         , tcdSigs = noLoc (MinimalSig mempty . fmap noLoc $ classMinimalDef cl) :
                       map (noLoc . synifyIdSig DeleteTopLevelQuantification)
                         (classMethods cl)
          , tcdMeths = emptyBag --ignore default method definitions, they don't affect signature
@@ -145,7 +145,7 @@ synifyTyCon coax tc
     DataDecl { tcdLName = synifyName tc
              , tcdTyVars =       -- tyConTyVars doesn't work on fun/prim, but we can make them up:
                          let mk_hs_tv realKind fakeTyVar
-                                = noLoc $ KindedTyVar (getName fakeTyVar)
+                                = noLoc $ KindedTyVar (noLoc (getName fakeTyVar))
                                                       (synifyKindSig realKind)
                          in HsQTvs { hsq_kvs = []   -- No kind polymorphism
                                    , hsq_tvs = zipWith mk_hs_tv (fst (splitKindFunTys (tyConKind tc)))
@@ -264,8 +264,8 @@ synifyDataCon use_gadt_syntax dc =
   linear_tys = zipWith (\ty bang ->
             let tySyn = synifyType WithinType ty
                 src_bang = case bang of
-                             HsUnpack {} -> HsSrcBang (Just True) True
-                             HsStrict    -> HsSrcBang (Just False) True
+                             HsUnpack {} -> HsSrcBang Nothing (Just True) True
+                             HsStrict    -> HsSrcBang Nothing (Just False) True
                              _           -> bang
             in case src_bang of
                  HsNoBang -> tySyn
@@ -278,13 +278,13 @@ synifyDataCon use_gadt_syntax dc =
                 (dataConFieldLabels dc) linear_tys
   hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of
           (True,True) -> Left "synifyDataCon: contradiction!"
-          (True,False) -> return $ RecCon field_tys
+          (True,False) -> return $ RecCon (noLoc field_tys)
           (False,False) -> return $ PrefixCon linear_tys
           (False,True) -> case linear_tys of
                            [a,b] -> return $ InfixCon a b
                            _ -> Left "synifyDataCon: infix with non-2 args?"
   hs_res_ty = if use_gadt_syntax
-              then ResTyGADT (synifyType WithinType res_ty)
+              then ResTyGADT noSrcSpan (synifyType WithinType res_ty)
               else ResTyH98
  -- finally we get synifyDataCon's result!
  in hs_arg_tys >>=
@@ -312,7 +312,7 @@ synifyTyVars ktvs = HsQTvs { hsq_kvs = map tyVarName kvs
     (kvs, tvs) = partition isKindVar ktvs
     synifyTyVar tv
       | isLiftedTypeKind kind = noLoc (UserTyVar name)
-      | otherwise             = noLoc (KindedTyVar name (synifyKindSig kind))
+      | otherwise             = noLoc (KindedTyVar (noLoc name) (synifyKindSig kind))
       where
         kind = tyVarKind tv
         name = getName tv
@@ -383,8 +383,8 @@ synifyType s forallty@(ForAllTy _tv _ty) =
 synifyType _ (LitTy t) = noLoc $ HsTyLit $ synifyTyLit t
 
 synifyTyLit :: TyLit -> HsTyLit
-synifyTyLit (NumTyLit n) = HsNumTy n
-synifyTyLit (StrTyLit s) = HsStrTy s
+synifyTyLit (NumTyLit n) = HsNumTy mempty n
+synifyTyLit (StrTyLit s) = HsStrTy mempty s
 
 synifyKindSig :: Kind -> LHsKind Name
 synifyKindSig k = synifyType WithinType k
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 416f5d71..5caefa77 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -91,8 +91,8 @@ filterSigNames p (FixSig (FixitySig ns ty)) =
   case filter (p . unLoc) ns of
     []       -> Nothing
     filtered -> Just (FixSig (FixitySig filtered ty))
-filterSigNames _ orig@(MinimalSig _)           = Just orig
-filterSigNames p (TypeSig ns ty nwcs)    =
+filterSigNames _ orig@(MinimalSig _ _)      = Just orig
+filterSigNames p (TypeSig ns ty nwcs) =
   case filter (p . unLoc) ns of
     []       -> Nothing
     filtered -> Just (TypeSig filtered ty nwcs)
@@ -169,14 +169,6 @@ before :: Located a -> Located a -> Bool
 before = (<) `on` getLoc
 
 
-instance Foldable (GenLocated l) where
-  foldMap f (L _ x) = f x
-
-
-instance Traversable (GenLocated l) where
-  mapM f (L l x) = (return . L l) =<< f x
-  traverse f (L l x) = L l <$> f x
-
 -------------------------------------------------------------------------------
 -- * NamedThing instances
 -------------------------------------------------------------------------------
@@ -197,7 +189,7 @@ class Parent a where
 instance Parent (ConDecl Name) where
   children con =
     case con_details con of
-      RecCon fields -> map unL $ concatMap (cd_fld_names . unL) fields
+      RecCon fields -> map unL $ concatMap (cd_fld_names . unL) (unL fields)
       _             -> []
 
 instance Parent (TyClDecl Name) where
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 98a715a9..9ef3d1b1 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -194,8 +194,8 @@ moduleWarning dflags gre (WarnAll w) = Just $ parseWarning dflags gre w
 
 parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> Doc Name
 parseWarning dflags gre w = force $ case w of
-  DeprecatedTxt msg -> format "Deprecated: " (concatFS $ map unLoc msg)
-  WarningTxt    msg -> format "Warning: "    (concatFS $ map unLoc msg)
+  DeprecatedTxt _ msg -> format "Deprecated: " (concatFS $ map unLoc msg)
+  WarningTxt    _ msg -> format "Warning: "    (concatFS $ map unLoc msg)
   where
     format x xs = DocWarning . DocParagraph . DocAppend (DocString x)
                   . processDocString dflags gre $ HsDocString xs
@@ -335,7 +335,7 @@ subordinates instMap decl = case decl of
                   | c <- cons, cname <- con_names c ]
         fields  = [ (unL n, maybeToList $ fmap unL doc, M.empty)
                   | RecCon flds <- map con_details cons
-                  , L _ (ConDeclField ns _ doc) <- flds
+                  , L _ (ConDeclField ns _ doc) <- (unLoc flds)
                   , n <- ns ]
 
 -- | Extract function argument docs from inside types.
@@ -496,7 +496,7 @@ mkExportItems
     Just exports -> liftM concat $ mapM lookupExport exports
   where
     lookupExport (IEVar (L _ x))         = declWith x
-    lookupExport (IEThingAbs t)          = declWith t
+    lookupExport (IEThingAbs (L _ t))    = declWith t
     lookupExport (IEThingAll (L _ t))    = declWith t
     lookupExport (IEThingWith (L _ t) _) = declWith t
     lookupExport (IEModuleContents (L _ m)) =
@@ -553,7 +553,7 @@ mkExportItems
 
                   L loc (TyClD cl@ClassDecl{}) -> do
                     mdef <- liftGhcToErrMsgGhc $ minimalDef t
-                    let sig = maybeToList $ fmap (noLoc . MinimalSig . fmap noLoc) mdef
+                    let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . fmap noLoc) mdef
                     return [ mkExportDecl t
                       (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_ ]
 
@@ -745,7 +745,7 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap
         return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices))
     mkExportItem (L l (TyClD cl@ClassDecl{ tcdLName = L _ name, tcdSigs = sigs })) = do
       mdef <- liftGhcToErrMsgGhc $ minimalDef name
-      let sig = maybeToList $ fmap (noLoc . MinimalSig . fmap noLoc) mdef
+      let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . fmap noLoc) mdef
       expDecl (L l (TyClD cl { tcdSigs = sig ++ sigs })) l name
     mkExportItem decl@(L l d)
       | name:_ <- getMainDeclBinder d = expDecl decl l name
@@ -785,7 +785,7 @@ extractDecl name mdl decl
       InstD (ClsInstD ClsInstDecl { cid_datafam_insts = insts }) ->
         let matches = [ d | L _ d <- insts
                           , L _ ConDecl { con_details = RecCon rec } <- dd_cons (dfid_defn d)
-                          , ConDeclField { cd_fld_names = ns } <- map unLoc rec
+                          , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec)
                           , L _ n <- ns
                           , n == name
                       ]
@@ -818,13 +818,13 @@ extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found"
 
 extractRecSel nm mdl t tvs (L _ con : rest) =
   case con_details con of
-    RecCon fields | ((n,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields ->
+    RecCon (L _ fields) | ((n,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields ->
       L (getLoc n) (TypeSig [noLoc nm] (noLoc (HsFunTy data_ty (getBangType ty))) [])
     _ -> extractRecSel nm mdl t tvs rest
  where
   matching_fields flds = [ (n,f) | f@(L _ (ConDeclField ns _ _)) <- flds, n <- ns, unLoc n == nm ]
   data_ty
-    | ResTyGADT ty <- con_res con = ty
+    | ResTyGADT _ ty <- con_res con = ty
     | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) tvs
 
 
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 7f69b91e..ee9f8fc4 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -250,10 +250,10 @@ renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName)
 renameLTyVarBndr (L loc (UserTyVar n))
   = do { n' <- rename n
        ; return (L loc (UserTyVar n')) }
-renameLTyVarBndr (L loc (KindedTyVar n kind))
+renameLTyVarBndr (L loc (KindedTyVar (L lv n) kind))
   = do { n' <- rename n
        ; kind' <- renameLKind kind
-       ; return (L loc (KindedTyVar n' kind')) }
+       ; return (L loc (KindedTyVar (L lv n') kind')) }
 
 renameLContext :: Located [LHsType Name] -> RnM (Located [LHsType DocName])
 renameLContext (L loc context) = do
@@ -330,9 +330,9 @@ renameTyClD d = case d of
 
   where
     renameLFunDep (L loc (xs, ys)) = do
-      xs' <- mapM rename xs
-      ys' <- mapM rename ys
-      return (L loc (xs', ys'))
+      xs' <- mapM rename (map unLoc xs)
+      ys' <- mapM rename (map unLoc ys)
+      return (L loc (map noLoc xs', map noLoc ys'))
 
     renameLSig (L loc sig) = return . L loc =<< renameSig sig
 
@@ -377,9 +377,9 @@ renameCon decl@(ConDecl { con_names = lnames, con_qvars = ltyvars
                    , con_details = details', con_res = restype', con_doc = mbldoc' })
 
   where
-    renameDetails (RecCon fields) = do
+    renameDetails (RecCon (L l fields)) = do
       fields' <- mapM renameConDeclFieldField fields
-      return (RecCon fields')
+      return (RecCon (L l fields'))
     renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps
     renameDetails (InfixCon a b) = do
       a' <- renameLType a
@@ -387,7 +387,7 @@ renameCon decl@(ConDecl { con_names = lnames, con_qvars = ltyvars
       return (InfixCon a' b')
 
     renameResType (ResTyH98) = return ResTyH98
-    renameResType (ResTyGADT t) = return . ResTyGADT =<< renameLType t
+    renameResType (ResTyGADT l t) = return . ResTyGADT l =<< renameLType t
 
 
 renameConDeclFieldField :: LConDeclField Name -> RnM (LConDeclField DocName)
@@ -414,7 +414,7 @@ renameSig sig = case sig of
   FixSig (FixitySig lnames fixity) -> do
     lnames' <- mapM renameL lnames
     return $ FixSig (FixitySig lnames' fixity)
-  MinimalSig s -> MinimalSig <$> traverse renameL s
+  MinimalSig src s -> MinimalSig src <$> traverse renameL s
   -- we have filtered out all other kinds of signatures in Interface.Create
   _ -> error "expected TypeSig"
 
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index 9a821b2e..4fed3a1e 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -154,8 +154,8 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]
       case con_details d of
         PrefixCon _ -> Just d
         RecCon fields
-          | all field_avail fields -> Just d
-          | otherwise -> Just (d { con_details = PrefixCon (field_types (map unL fields)) })
+          | all field_avail (unL fields) -> Just d
+          | otherwise -> Just (d { con_details = PrefixCon (field_types (map unL (unL fields))) })
           -- if we have *all* the field names available, then
           -- keep the record declaration.  Otherwise degrade to
           -- a constructor declaration.  This isn't quite right, but
-- 
cgit v1.2.3


From 10437c8cfe3524eee7e1cc297cd6ae7dff16dbb3 Mon Sep 17 00:00:00 2001
From: Mateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk>
Date: Thu, 26 Mar 2015 16:31:40 +0000
Subject: Remove now redundant imports

---
 haddock-api/src/Haddock/Backends/Xhtml.hs              | 1 -
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs         | 1 -
 haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs    | 2 --
 haddock-api/src/Haddock/Backends/Xhtml/Themes.hs       | 2 --
 haddock-api/src/Haddock/GhcUtils.hs                    | 1 -
 haddock-api/src/Haddock/Interface/LexParseRn.hs        | 1 -
 haddock-api/src/Haddock/Interface/ParseModuleHeader.hs | 1 -
 haddock-api/src/Haddock/InterfaceFile.hs               | 1 -
 8 files changed, 10 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Xhtml/Decl.hs')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index 65a7e6c4..948ef641 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -36,7 +36,6 @@ import Haddock.GhcUtils
 
 import Control.Monad         ( when, unless )
 import Data.Char             ( toUpper )
-import Data.Functor          ( (<$>) )
 import Data.List             ( sortBy, groupBy, intercalate, isPrefixOf )
 import Data.Maybe
 import System.FilePath hiding ( (</>) )
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 405a13f8..952d29c9 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -27,7 +27,6 @@ import Haddock.GhcUtils
 import Haddock.Types
 import Haddock.Doc (combineDocumentation)
 
-import           Control.Applicative
 import           Data.List             ( intersperse, sort )
 import qualified Data.Map as Map
 import           Data.Maybe
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
index 96d734eb..e807eb94 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
@@ -19,8 +19,6 @@ module Haddock.Backends.Xhtml.DocMarkup (
   docElement, docSection, docSection_,
 ) where
 
-import Control.Applicative ((<$>))
-
 import Data.List
 import Haddock.Backends.Xhtml.Names
 import Haddock.Backends.Xhtml.Utils
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs b/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs
index 79b093ec..10d6ab10 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs
@@ -18,7 +18,6 @@ module Haddock.Backends.Xhtml.Themes (
 
 import Haddock.Options
 
-import Control.Applicative
 import Control.Monad (liftM)
 import Data.Char (toLower)
 import Data.Either (lefts, rights)
@@ -206,4 +205,3 @@ liftEither f = either Left (Right . f)
 
 concatEither :: [Either a [b]] -> Either a [b]
 concatEither = liftEither concat . sequenceEither
-
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 5caefa77..ce4ca38a 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -16,7 +16,6 @@
 module Haddock.GhcUtils where
 
 
-import Control.Applicative  ( (<$>) )
 import Control.Arrow
 import Data.Function
 
diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs
index 35abf8a6..614e606b 100644
--- a/haddock-api/src/Haddock/Interface/LexParseRn.hs
+++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs
@@ -18,7 +18,6 @@ module Haddock.Interface.LexParseRn
   , processModuleHeader
   ) where
 
-import Control.Applicative
 import Data.IntSet (toList)
 import Data.List
 import Documentation.Haddock.Doc (metaDocConcat)
diff --git a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
index d92e8b2a..e7d2a085 100644
--- a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
+++ b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
@@ -11,7 +11,6 @@
 -----------------------------------------------------------------------------
 module Haddock.Interface.ParseModuleHeader (parseModuleHeader) where
 
-import Control.Applicative ((<$>))
 import Control.Monad (mplus)
 import Data.Char
 import DynFlags
diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs
index b0df5491..4b39d315 100644
--- a/haddock-api/src/Haddock/InterfaceFile.hs
+++ b/haddock-api/src/Haddock/InterfaceFile.hs
@@ -25,7 +25,6 @@ import Haddock.Utils hiding (out)
 
 import Control.Monad
 import Data.Array
-import Data.Functor ((<$>))
 import Data.IORef
 import Data.List
 import qualified Data.Map as Map
-- 
cgit v1.2.3


From 3d11080b9f56a901593b6237d674d617a429e64a Mon Sep 17 00:00:00 2001
From: jpmoresmau <jp@moresmau.fr>
Date: Sun, 17 May 2015 15:31:03 +0200
Subject: Attach to instance location the name that has the same location file

Fixes #383
---
 haddock-api/src/Haddock/Backends/LaTeX.hs          |  4 ++--
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs     |  6 +++---
 haddock-api/src/Haddock/Backends/Xhtml/Layout.hs   | 24 +++++++++++-----------
 .../src/Haddock/Interface/AttachInstances.hs       | 23 ++++++++++++++++-----
 haddock-api/src/Haddock/Interface/Rename.hs        |  5 +++--
 haddock-api/src/Haddock/Types.hs                   |  2 +-
 6 files changed, 39 insertions(+), 25 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Xhtml/Decl.hs')

diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 125e1b3a..2febd5ae 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -544,14 +544,14 @@ ppDocInstances unicode (i : rest)
     (is, rest') = spanWith isUndocdInstance rest
 
 isUndocdInstance :: DocInstance a -> Maybe (InstHead a)
-isUndocdInstance (L _ i,Nothing) = Just i
+isUndocdInstance (i,Nothing,_) = Just i
 isUndocdInstance _ = Nothing
 
 -- | Print a possibly commented instance. The instance header is printed inside
 -- an 'argBox'. The comment is printed to the right of the box in normal comment
 -- style.
 ppDocInstance :: Bool -> DocInstance DocName -> LaTeX
-ppDocInstance unicode (L _ instHead, doc) =
+ppDocInstance unicode (instHead, doc, _) =
   declWithDoc (ppInstDecl unicode instHead) (fmap docToLaTeX $ fmap _doc doc)
 
 
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 952d29c9..df85a492 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -497,12 +497,12 @@ ppClassDecl _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppS
 
 ppInstances :: LinksInfo -> [DocInstance DocName] -> DocName -> Unicode -> Qualification -> Html
 ppInstances links instances baseName unicode qual
-  = subInstances qual instName links True baseName (map instDecl instances)
+  = subInstances qual instName links True (map instDecl instances)
   -- force Splice = True to use line URLs
   where
     instName = getOccString $ getName baseName
-    instDecl :: DocInstance DocName -> (SubDecl,SrcSpan)
-    instDecl (L l inst, maybeDoc) = ((instHead inst, maybeDoc, []),l)
+    instDecl :: DocInstance DocName -> (SubDecl,Located DocName)
+    instDecl (inst, maybeDoc,l) = ((instHead inst, maybeDoc, []),l)
     instHead (n, ks, ts, ClassInst cs) = ppContextNoLocs cs unicode qual
         <+> ppAppNameTypes n ks ts unicode qual
     instHead (n, ks, ts, TypeInst rhs) = keyword "type"
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
index 923958a7..e686d648 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
@@ -44,7 +44,6 @@ import Haddock.Backends.Xhtml.Types
 import Haddock.Backends.Xhtml.Utils
 import Haddock.Types
 import Haddock.Utils (makeAnchorId)
-
 import qualified Data.Map as Map
 import Text.XHtml hiding ( name, title, p, quote )
 
@@ -148,20 +147,21 @@ subTable qual decls = Just $ table << aboves (concatMap subRow decls)
        docElement td << fmap (docToHtml Nothing qual) mdoc)
       : map (cell . (td <<)) subs
 
+
 -- | Sub table with source information (optional).
-subTableSrc :: Qualification -> LinksInfo -> Bool -> DocName -> [(SubDecl,SrcSpan)] -> Maybe Html
-subTableSrc _ _  _ _ [] = Nothing
-subTableSrc qual lnks splice dn decls = Just $ table << aboves (concatMap subRow decls)
+subTableSrc :: Qualification -> LinksInfo -> Bool -> [(SubDecl,Located DocName)] -> Maybe Html
+subTableSrc _ _  _ [] = Nothing
+subTableSrc qual lnks splice decls = Just $ table << aboves (concatMap subRow decls)
   where
-    subRow ((decl, mdoc, subs),loc) =
+    subRow ((decl, mdoc, subs),L loc dn) =
       (td ! [theclass "src"] << decl
-      <+> linkHtml loc
+      <+> linkHtml loc dn
       <->
       docElement td << fmap (docToHtml Nothing qual) mdoc
       )
       : map (cell . (td <<)) subs
-    linkHtml loc@(RealSrcSpan _) = links lnks loc splice dn
-    linkHtml _ = noHtml
+    linkHtml loc@(RealSrcSpan _) dn = links lnks loc splice dn
+    linkHtml _ _ = noHtml
 
 subBlock :: [Html] -> Maybe Html
 subBlock [] = Nothing
@@ -191,12 +191,12 @@ subEquations qual = divSubDecls "equations" "Equations" . subTable qual
 -- | Generate sub table for instance declarations, with source
 subInstances :: Qualification
              -> String -- ^ Class name, used for anchor generation
-             -> LinksInfo -> Bool -> DocName
-             -> [(SubDecl,SrcSpan)] -> Html
-subInstances qual nm lnks splice dn = maybe noHtml wrap . instTable
+             -> LinksInfo -> Bool
+             -> [(SubDecl,Located DocName)] -> Html
+subInstances qual nm lnks splice = maybe noHtml wrap . instTable
   where
     wrap = (subSection <<) . (subCaption +++)
-    instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTableSrc qual lnks splice dn
+    instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTableSrc qual lnks splice
     subSection = thediv ! [theclass "subs instances"]
     subCaption = paragraph ! collapseControl id_ True "caption" << "Instances"
     id_ = makeAnchorId $ "i:" ++ nm
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index 37203d63..fc530507 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -38,6 +38,7 @@ import MonadUtils (liftIO)
 import Name
 import Outputable (text, sep, (<+>))
 import PrelNames
+import SrcLoc
 import TcRnDriver (tcRnGetInfo)
 import TcType (tcSplitSigmaTy)
 import TyCon
@@ -68,11 +69,11 @@ attachToExportItem :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap
                    -> Ghc (ExportItem Name)
 attachToExportItem expInfo iface ifaceMap instIfaceMap export =
   case attachFixities export of
-    e@ExportDecl { expItemDecl = L _ (TyClD d) } -> do
+    e@ExportDecl { expItemDecl = L eSpan (TyClD d) } -> do
       mb_info <- getAllInfo (tcdName d)
       insts <- case mb_info of
         Just (_, _, cls_instances, fam_instances) ->
-          let fam_insts = [ (L (getSrcSpan n) $ synifyFamInst i opaque, doc)
+          let fam_insts = [ (synifyFamInst i opaque, doc,spanNameE n (synifyFamInst i opaque) (L eSpan (tcdName d)) )
                           | i <- sortBy (comparing instFam) fam_instances
                           , let n = getName i
                           , let doc = instLookup instDocMap n iface ifaceMap instIfaceMap
@@ -80,14 +81,14 @@ attachToExportItem expInfo iface ifaceMap instIfaceMap export =
                           , not $ any (isTypeHidden expInfo) (fi_tys i)
                           , let opaque = isTypeHidden expInfo (fi_rhs i)
                           ]
-              cls_insts = [ (L (getSrcSpan n) $ synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap)
+              cls_insts = [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, spanName n (synifyInstHead i) (L eSpan (tcdName d)))
                           | let is = [ (instanceHead' i, getName i) | i <- cls_instances ]
                           , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is
                           , not $ isInstanceHidden expInfo cls tys
                           ]
               -- fam_insts but with failing type fams filtered out
-              cleanFamInsts = [ (L l fi, n) | (L l (Right fi), n) <- fam_insts ]
-              famInstErrs = [ errm | (L _ (Left errm), _) <- fam_insts ]
+              cleanFamInsts = [ (fi, n, L l r) | (Right fi, n, L l (Right r)) <- fam_insts ]
+              famInstErrs = [ errm | (Left errm, _, _) <- fam_insts ]
           in do
             dfs <- getDynFlags
             let mkBug = (text "haddock-bug:" <+>) . text
@@ -106,6 +107,18 @@ attachToExportItem expInfo iface ifaceMap instIfaceMap export =
       ] }
 
     attachFixities e = e
+    -- spanName: attach the location to the name that is the same file as the instance location
+    spanName s (clsn,_,_,_) (L instL instn) =
+        let s1 = getSrcSpan s
+            sn = if srcSpanFileName_maybe s1 == srcSpanFileName_maybe instL
+                    then instn
+                    else clsn
+        in L (getSrcSpan s) sn
+    -- spanName on Either
+    spanNameE s (Left e) _ =  L (getSrcSpan s) (Left e)
+    spanNameE s (Right ok) linst =
+      let L l r = spanName s ok linst
+      in L l (Right r)
 
 
 instLookup :: (InstalledInterface -> Map.Map Name a) -> Name
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index ee9f8fc4..1a559764 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -498,10 +498,11 @@ renameExportItem item = case item of
     decl' <- renameLDecl decl
     doc'  <- renameDocForDecl doc
     subs' <- mapM renameSub subs
-    instances' <- forM instances $ \(L l inst, idoc) -> do
+    instances' <- forM instances $ \(inst, idoc, L l n) -> do
       inst' <- renameInstHead inst
+      n' <- rename n
       idoc' <- mapM renameDoc idoc
-      return (L l inst', idoc')
+      return (inst', idoc',L l n')
     fixities' <- forM fixities $ \(name, fixity) -> do
       name' <- lookupRn name
       return (name', fixity)
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index f9cf6e17..14995098 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -300,7 +300,7 @@ instance OutputableBndr a => Outputable (InstType a) where
   ppr (DataInst  a) = text "DataInst"  <+> ppr a
 
 -- | An instance head that may have documentation and a source location.
-type DocInstance name = (Located (InstHead name), Maybe (MDoc name))
+type DocInstance name = (InstHead name, Maybe (MDoc name), Located name)
 
 -- | The head of an instance. Consists of a class name, a list of kind
 -- parameters, a list of type parameters and an instance type
-- 
cgit v1.2.3


From acdbdc035468374cbea2ba2043987dac95c44bfe Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Thu, 6 Aug 2015 20:54:59 +0200
Subject: Fix quote syntax for promoted types.

---
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs  | 6 ++++--
 haddock-api/src/Haddock/Backends/Xhtml/Utils.hs | 7 ++++++-
 2 files changed, 10 insertions(+), 3 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Xhtml/Decl.hs')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index df85a492..d3900f16 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -874,8 +874,10 @@ ppr_mono_ty _         (HsSpliceTy {})     _ _ = error "ppr_mono_ty HsSpliceTy"
 ppr_mono_ty _         (HsQuasiQuoteTy {}) _ _ = error "ppr_mono_ty HsQuasiQuoteTy"
 ppr_mono_ty _         (HsRecTy {})        _ _ = error "ppr_mono_ty HsRecTy"
 ppr_mono_ty _         (HsCoreTy {})       _ _ = error "ppr_mono_ty HsCoreTy"
-ppr_mono_ty _         (HsExplicitListTy _ tys) u q = quote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys
-ppr_mono_ty _         (HsExplicitTupleTy _ tys) u q = quote $ parenList $ map (ppLType u q) tys
+ppr_mono_ty _         (HsExplicitListTy _ tys) u q =
+    promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys
+ppr_mono_ty _         (HsExplicitTupleTy _ tys) u q =
+    promoQuote $ parenList $ map (ppLType u q) tys
 ppr_mono_ty _         (HsWrapTy {})       _ _ = error "ppr_mono_ty HsWrapTy"
 
 ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode qual
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
index 26bcbf6d..98ff4007 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
@@ -21,7 +21,7 @@ module Haddock.Backends.Xhtml.Utils (
   keyword, punctuate,
 
   braces, brackets, pabrackets, parens, parenList, ubxParenList,
-  arrow, comma, dcolon, dot, darrow, equals, forallSymbol, quote,
+  arrow, comma, dcolon, dot, darrow, equals, forallSymbol, quote, promoQuote,
 
   hsep, vcat,
 
@@ -150,6 +150,11 @@ quote :: Html -> Html
 quote h = char '`' +++ h +++ '`'
 
 
+-- | Promoted type quote (e.g. @'[a, b]@, @'(a, b, c)@).
+promoQuote :: Html -> Html
+promoQuote h = char '\'' +++ h
+
+
 parens, brackets, pabrackets, braces :: Html -> Html
 parens h        = char '(' +++ h +++ char ')'
 brackets h      = char '[' +++ h +++ char ']'
-- 
cgit v1.2.3


From 33fe6286907592b1783a4b9b7c4b7f63ae080cde Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Thu, 6 Aug 2015 21:12:00 +0200
Subject: Apply promoted type quoting to type-level consing.

---
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 7 ++++++-
 1 file changed, 6 insertions(+), 1 deletion(-)

(limited to 'haddock-api/src/Haddock/Backends/Xhtml/Decl.hs')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index d3900f16..5f6f60eb 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -892,7 +892,12 @@ ppr_mono_ty ctxt_prec (HsOpTy ty1 (_, op) ty2) unicode qual
   = maybeParen ctxt_prec pREC_FUN $
     ppr_mono_lty pREC_OP ty1 unicode qual <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual
   where
-    ppr_op = ppLDocName qual Infix op
+    -- `(:)` is valid in type signature only as constructor to promoted list
+    -- and needs to be quoted in code so we explicitly quote it here too.
+    ppr_op
+        | (getOccString . getName . unLoc) op == ":" = promoQuote ppr_op'
+        | otherwise = ppr_op'
+    ppr_op' = ppLDocName qual Infix op
 
 ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual
 --  = parens (ppr_mono_lty pREC_TOP ty)
-- 
cgit v1.2.3


From 92f0b1eacb2e1169dedd22df26976219c3fbc637 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Tue, 14 Jul 2015 18:03:58 +0200
Subject: Make HTML class instance printer take optional signature argument.

---
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 23 ++++++++++++++---------
 1 file changed, 14 insertions(+), 9 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Xhtml/Decl.hs')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 5f6f60eb..a5f3676e 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -268,7 +268,7 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode
       = subEquations qual $ map (ppTyFamEqn . unLoc) eqns
 
       | otherwise
-      = ppInstances links instances docname unicode qual
+      = ppInstances links instances Nothing docname unicode qual
 
     -- Individual equation of a closed type family
     ppTyFamEqn TyFamEqn { tfe_tycon = n, tfe_rhs = rhs
@@ -439,6 +439,8 @@ ppClassDecl summary links instances fixities loc d subdocs
   | otherwise = classheader +++ docSection Nothing qual d
                   +++ minimalBit +++ atBit +++ methodBit +++ instancesBit
   where
+    sigs = map unLoc lsigs
+
     classheader
       | any isVanillaLSig lsigs = topDeclElem links loc splice [nm] (hdr unicode qual <+> keyword "where" <+> fixs)
       | otherwise = topDeclElem links loc splice [nm] (hdr unicode qual <+> fixs)
@@ -458,7 +460,7 @@ ppClassDecl summary links instances fixities loc d subdocs
                             subfixs = [ f | f@(n',_) <- fixities, n == n' ] ]
 
     methodBit = subMethods [ ppFunSig summary links loc doc names typ subfixs splice unicode qual
-                           | L _ (TypeSig lnames (L _ typ) _) <- lsigs
+                           | TypeSig lnames (L _ typ) _ <- sigs
                            , let doc = lookupAnySubdoc (head names) subdocs
                                  subfixs = [ f | n <- names
                                                , f@(n',_) <- fixities
@@ -468,15 +470,15 @@ ppClassDecl summary links instances fixities loc d subdocs
                            -- there are different subdocs for different names in a single
                            -- type signature?
 
-    minimalBit = case [ s | L _ (MinimalSig _ s) <- lsigs ] of
+    minimalBit = case [ s | MinimalSig _ s <- sigs ] of
       -- Miminal complete definition = every shown method
       And xs : _ | sort [getName n | Var (L _ n) <- xs] ==
-                   sort [getName n | L _ (TypeSig ns _ _) <- lsigs, L _ n <- ns]
+                   sort [getName n | TypeSig ns _ _ <- sigs, L _ n <- ns]
         -> noHtml
 
       -- Minimal complete definition = the only shown method
       Var (L _ n) : _ | [getName n] ==
-                        [getName n' | L _ (TypeSig ns _ _) <- lsigs, L _ n' <- ns]
+                        [getName n' | TypeSig ns _ _ <- sigs, L _ n' <- ns]
         -> noHtml
 
       -- Minimal complete definition = nothing
@@ -490,13 +492,16 @@ ppClassDecl summary links instances fixities loc d subdocs
     ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a+++" | "+++b) $ map (ppMinimal False) fs
       where wrap | p = parens | otherwise = id
 
-    instancesBit = ppInstances links instances nm unicode qual
+    instancesBit = ppInstances links instances (Just sigs) nm unicode qual
 
 ppClassDecl _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
 
 
-ppInstances :: LinksInfo -> [DocInstance DocName] -> DocName -> Unicode -> Qualification -> Html
-ppInstances links instances baseName unicode qual
+ppInstances :: LinksInfo
+            -> [DocInstance DocName] -> Maybe [Sig DocName] -> DocName
+            -> Unicode -> Qualification
+            -> Html
+ppInstances links instances _ baseName unicode qual
   = subInstances qual instName links True (map instDecl instances)
   -- force Splice = True to use line URLs
   where
@@ -581,7 +586,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl
                                      (map unLoc (con_names (unLoc c)))) fixities
       ]
 
-    instancesBit = ppInstances links instances docname unicode qual
+    instancesBit = ppInstances links instances Nothing docname unicode qual
 
 
 
-- 
cgit v1.2.3


From 2070c0fa9354365e3e672f5cbee2e04d0ef1fd02 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Tue, 14 Jul 2015 19:59:08 +0200
Subject: Refactor instance head type to record instead of a meaningless tuple.

---
 haddock-api/src/Haddock/Backends/LaTeX.hs          | 14 ++++----
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs     | 21 ++++++++----
 haddock-api/src/Haddock/Convert.hs                 | 38 +++++++++++++---------
 .../src/Haddock/Interface/AttachInstances.hs       |  2 +-
 haddock-api/src/Haddock/Interface/Rename.hs        | 19 +++++++----
 haddock-api/src/Haddock/Types.hs                   |  7 +++-
 6 files changed, 63 insertions(+), 38 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Xhtml/Decl.hs')

diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 2febd5ae..59e5af3e 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -1,4 +1,5 @@
 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+{-# LANGUAGE RecordWildCards #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Haddock.Backends.LaTeX
@@ -560,12 +561,13 @@ ppInstDecl unicode instHead = keyword "instance" <+> ppInstHead unicode instHead
 
 
 ppInstHead :: Bool -> InstHead DocName -> LaTeX
-ppInstHead unicode (n, ks, ts, ClassInst ctx) = ppContextNoLocs ctx unicode <+> ppAppNameTypes n ks ts unicode
-ppInstHead unicode (n, ks, ts, TypeInst rhs) = keyword "type"
-  <+> ppAppNameTypes n ks ts unicode
-  <+> maybe empty (\t -> equals <+> ppType unicode t) rhs
-ppInstHead _unicode (_n, _ks, _ts, DataInst _dd) =
-  error "data instances not supported by --latex yet"
+ppInstHead unicode (InstHead {..}) = case ihdInstType of
+    ClassInst ctx -> ppContextNoLocs ctx unicode <+> typ
+    TypeInst rhs -> keyword "type" <+> typ <+> tibody rhs
+    DataInst _ -> error "data instances not supported by --latex yet"
+  where
+    typ = ppAppNameTypes ihdClsName ihdKinds ihdTypes unicode
+    tibody = maybe empty (\t -> equals <+> ppType unicode t)
 
 lookupAnySubdoc :: (Eq name1) =>
                    name1 -> [(name1, DocForDecl name2)] -> DocForDecl name2
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index a5f3676e..afbbaad1 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE TransformListComp #-}
+{-# LANGUAGE RecordWildCards #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Haddock.Backends.Html.Decl
@@ -507,15 +508,21 @@ ppInstances links instances _ baseName unicode qual
   where
     instName = getOccString $ getName baseName
     instDecl :: DocInstance DocName -> (SubDecl,Located DocName)
-    instDecl (inst, maybeDoc,l) = ((instHead inst, maybeDoc, []),l)
-    instHead (n, ks, ts, ClassInst cs) = ppContextNoLocs cs unicode qual
-        <+> ppAppNameTypes n ks ts unicode qual
-    instHead (n, ks, ts, TypeInst rhs) = keyword "type"
-        <+> ppAppNameTypes n ks ts unicode qual
+    instDecl (inst, maybeDoc,l) =
+        ((ppInstHead links unicode qual inst, maybeDoc, []),l)
+
+ppInstHead :: LinksInfo -> Unicode -> Qualification
+           -> InstHead DocName
+           -> Html
+ppInstHead _ unicode qual (InstHead {..}) = case ihdInstType of
+    ClassInst cs -> ppContextNoLocs cs unicode qual <+> typ
+    TypeInst rhs -> keyword "type" <+> typ
         <+> maybe noHtml (\t -> equals <+> ppType unicode qual t) rhs
-    instHead (n, ks, ts, DataInst dd) = keyword "data"
-        <+> ppAppNameTypes n ks ts unicode qual
+    DataInst dd -> keyword "data" <+> typ
         <+> ppShortDataDecl False True dd unicode qual
+  where
+    typ = ppAppNameTypes ihdClsName ihdKinds ihdTypes unicode qual
+
 
 lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2
 lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 5cbf5f97..e51d9df7 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -390,23 +390,29 @@ synifyKindSig :: Kind -> LHsKind Name
 synifyKindSig k = synifyType WithinType k
 
 synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead Name
-synifyInstHead (_, preds, cls, types) =
-  ( getName cls
-  , map (unLoc . synifyType WithinType) ks
-  , map (unLoc . synifyType WithinType) ts
-  , ClassInst $ map (unLoc . synifyType WithinType) preds
-  )
+synifyInstHead (_, preds, cls, types) = InstHead
+  { ihdClsName = getName cls
+  , ihdKinds = map (unLoc . synifyType WithinType) ks
+  , ihdTypes = map (unLoc . synifyType WithinType) ts
+  , ihdInstType = ClassInst $ map (unLoc . synifyType WithinType) preds
+  }
   where (ks,ts) = break (not . isKind) types
 
 -- Convert a family instance, this could be a type family or data family
 synifyFamInst :: FamInst -> Bool -> Either ErrMsg (InstHead Name)
-synifyFamInst fi opaque =
-  let fff = case fi_flavor fi of
-        SynFamilyInst | opaque -> return $ TypeInst Nothing
-        SynFamilyInst ->
-          return . TypeInst . Just . unLoc . synifyType WithinType $ fi_rhs fi
-        DataFamilyInst c ->
-          synifyTyCon (Just $ famInstAxiom fi) c >>= return . DataInst
-  in fff >>= \f' -> return (fi_fam fi , map (unLoc . synifyType WithinType) ks,
-                            map (unLoc . synifyType WithinType) ts , f')
-  where (ks,ts) = break (not . isKind) $ fi_tys fi
+synifyFamInst fi opaque = do
+    ityp' <- ityp $ fi_flavor fi
+    return InstHead
+        { ihdClsName = fi_fam fi
+        , ihdKinds = synifyTypes ks
+        , ihdTypes = synifyTypes ts
+        , ihdInstType = ityp'
+        }
+  where
+    ityp SynFamilyInst | opaque = return $ TypeInst Nothing
+    ityp SynFamilyInst =
+        return . TypeInst . Just . unLoc . synifyType WithinType $ fi_rhs fi
+    ityp (DataFamilyInst c) =
+        DataInst <$> synifyTyCon (Just $ famInstAxiom fi) c
+    (ks,ts) = break (not . isKind) $ fi_tys fi
+    synifyTypes = map (unLoc. synifyType WithinType)
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index fc530507..e2fd24ee 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -108,7 +108,7 @@ attachToExportItem expInfo iface ifaceMap instIfaceMap export =
 
     attachFixities e = e
     -- spanName: attach the location to the name that is the same file as the instance location
-    spanName s (clsn,_,_,_) (L instL instn) =
+    spanName s (InstHead { ihdClsName = clsn }) (L instL instn) =
         let s1 = getSrcSpan s
             sn = if srcSpanFileName_maybe s1 == srcSpanFileName_maybe instL
                     then instn
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 1a559764..d222c6d2 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RecordWildCards #-}
 ----------------------------------------------------------------------------
 -- |
 -- Module      :  Haddock.Interface.Rename
@@ -261,16 +262,20 @@ renameLContext (L loc context) = do
   return (L loc context')
 
 renameInstHead :: InstHead Name -> RnM (InstHead DocName)
-renameInstHead (className, k, types, rest) = do
-  className' <- rename className
-  k' <- mapM renameType k
-  types' <- mapM renameType types
-  rest' <- case rest of
+renameInstHead InstHead {..} = do
+  cname <- rename ihdClsName
+  kinds <- mapM renameType ihdKinds
+  types <- mapM renameType ihdTypes
+  itype <- case ihdInstType of
     ClassInst cs -> ClassInst <$> mapM renameType cs
     TypeInst  ts -> TypeInst  <$> traverse renameType ts
     DataInst  dd -> DataInst  <$> renameTyClD dd
-  return (className', k', types', rest')
-
+  return InstHead
+    { ihdClsName = cname
+    , ihdKinds = kinds
+    , ihdTypes = types
+    , ihdInstType = itype
+    }
 
 renameLDecl :: LHsDecl Name -> RnM (LHsDecl DocName)
 renameLDecl (L loc d) = return . L loc =<< renameDecl d
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 6dd64506..d9ae6cab 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -308,7 +308,12 @@ type DocInstance name = (InstHead name, Maybe (MDoc name), Located name)
 
 -- | The head of an instance. Consists of a class name, a list of kind
 -- parameters, a list of type parameters and an instance type
-type InstHead name = (name, [HsType name], [HsType name], InstType name)
+data InstHead name = InstHead
+    { ihdClsName :: name
+    , ihdKinds :: [HsType name]
+    , ihdTypes :: [HsType name]
+    , ihdInstType :: InstType name
+    }
 
 -----------------------------------------------------------------------------
 -- * Documentation comments
-- 
cgit v1.2.3


From 05f35d7defbf702e27211628e26a738fa97ecde8 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Wed, 15 Jul 2015 14:27:28 +0200
Subject: Add expandable method section for each class instance declaration.

---
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs   | 52 ++++++++++++++++--------
 haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 16 +++++++-
 2 files changed, 50 insertions(+), 18 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Xhtml/Decl.hs')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index afbbaad1..22b34228 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -269,7 +269,7 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode
       = subEquations qual $ map (ppTyFamEqn . unLoc) eqns
 
       | otherwise
-      = ppInstances links instances Nothing docname unicode qual
+      = ppInstances links instances Nothing docname splice unicode qual
 
     -- Individual equation of a closed type family
     ppTyFamEqn TyFamEqn { tfe_tycon = n, tfe_rhs = rhs
@@ -493,37 +493,54 @@ ppClassDecl summary links instances fixities loc d subdocs
     ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a+++" | "+++b) $ map (ppMinimal False) fs
       where wrap | p = parens | otherwise = id
 
-    instancesBit = ppInstances links instances (Just sigs) nm unicode qual
+    instancesBit = ppInstances links instances (Just sigs) nm splice unicode qual
 
 ppClassDecl _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
 
 
 ppInstances :: LinksInfo
             -> [DocInstance DocName] -> Maybe [Sig DocName] -> DocName
-            -> Unicode -> Qualification
+            -> Splice -> Unicode -> Qualification
             -> Html
-ppInstances links instances _ baseName unicode qual
-  = subInstances qual instName links True (map instDecl instances)
+ppInstances links instances msigs baseName splice unicode qual
+  = subInstances qual instName links True (zipWith instDecl [1..] instances)
   -- force Splice = True to use line URLs
   where
     instName = getOccString $ getName baseName
-    instDecl :: DocInstance DocName -> (SubDecl,Located DocName)
-    instDecl (inst, maybeDoc,l) =
-        ((ppInstHead links unicode qual inst, maybeDoc, []),l)
+    instDecl :: Int -> DocInstance DocName -> (SubDecl,Located DocName)
+    instDecl iid (inst, maybeDoc,l) =
+        ((ppInstHead links splice unicode qual msigs iid inst, maybeDoc, []),l)
 
-ppInstHead :: LinksInfo -> Unicode -> Qualification
-           -> InstHead DocName
+
+ppInstHead :: LinksInfo -> Splice -> Unicode -> Qualification
+           -> Maybe [Sig DocName] -> Int -> InstHead DocName
            -> Html
-ppInstHead _ unicode qual (InstHead {..}) = case ihdInstType of
-    ClassInst cs -> ppContextNoLocs cs unicode qual <+> typ
-    TypeInst rhs -> keyword "type" <+> typ
-        <+> maybe noHtml (\t -> equals <+> ppType unicode qual t) rhs
-    DataInst dd -> keyword "data" <+> typ
-        <+> ppShortDataDecl False True dd unicode qual
+ppInstHead links splice unicode qual msigs iid (InstHead {..}) =
+    case ihdInstType of
+        ClassInst cs | Just sigs <- msigs ->
+            subClsInstance (nameStr ++ "-" ++ show iid) hdr (mets sigs)
+          where
+            hdr = ppContextNoLocs cs unicode qual <+> typ
+            mets = ppInstanceSigs links splice unicode qual
+            nameStr = occNameString . nameOccName $ getName ihdClsName
+        ClassInst cs -> ppContextNoLocs cs unicode qual <+> typ
+        TypeInst rhs -> keyword "type" <+> typ
+            <+> maybe noHtml (\t -> equals <+> ppType unicode qual t) rhs
+        DataInst dd -> keyword "data" <+> typ
+            <+> ppShortDataDecl False True dd unicode qual
   where
     typ = ppAppNameTypes ihdClsName ihdKinds ihdTypes unicode qual
 
 
+ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification
+              -> [Sig DocName]
+              -> [Html]
+ppInstanceSigs links splice unicode qual sigs = do
+    TypeSig lnames (L sspan typ) _ <- sigs
+    let names = map unLoc lnames
+    return $ ppFunSig False links sspan noDocForDecl names typ [] splice unicode qual
+
+
 lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2
 lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n
 
@@ -593,7 +610,8 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl
                                      (map unLoc (con_names (unLoc c)))) fixities
       ]
 
-    instancesBit = ppInstances links instances Nothing docname unicode qual
+    instancesBit = ppInstances links instances Nothing docname
+        splice unicode qual
 
 
 
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
index 4714c1b6..188b4243 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
@@ -31,7 +31,7 @@ module Haddock.Backends.Xhtml.Layout (
   subConstructors,
   subEquations,
   subFields,
-  subInstances,
+  subInstances, subClsInstance,
   subMethods,
   subMinimal,
 
@@ -200,6 +200,20 @@ subInstances qual nm lnks splice = maybe noHtml wrap . instTable
     subCaption = paragraph ! collapseControl id_ True "caption" << "Instances"
     id_ = makeAnchorId $ "i:" ++ nm
 
+
+-- | Generate class instance div with specialized methods.
+subClsInstance :: String -- ^ Section unique id
+               -> Html -- ^ Header contents (instance name and type)
+               -> [Html] -- ^ Method contents (pretty-printed signatures)
+               -> Html
+subClsInstance sid hdr mets =
+    hdrDiv <+> methodDiv
+  where
+    anchorId = makeAnchorId $ "i:" ++ sid
+    hdrDiv = thediv ! collapseControl anchorId False "instance" << hdr
+    methodDiv = thediv ! collapseSection anchorId False [] << subMethods mets
+
+
 subMethods :: [Html] -> Html
 subMethods = divSubDecls "methods" "Methods" . subBlock
 
-- 
cgit v1.2.3


From d6741ee8d407a8ac3c16e5bbddb657cab442a14c Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Wed, 15 Jul 2015 18:28:17 +0200
Subject: Hook type specialization logic with HTML pretty-printer.

---
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 28 +++++++++++++++-----------
 haddock-api/src/Haddock/Types.hs               |  6 ++++++
 2 files changed, 22 insertions(+), 12 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Xhtml/Decl.hs')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 22b34228..2a820531 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -22,6 +22,7 @@ module Haddock.Backends.Xhtml.Decl (
 import Haddock.Backends.Xhtml.DocMarkup
 import Haddock.Backends.Xhtml.Layout
 import Haddock.Backends.Xhtml.Names
+import Haddock.Backends.Xhtml.Specialize
 import Haddock.Backends.Xhtml.Types
 import Haddock.Backends.Xhtml.Utils
 import Haddock.GhcUtils
@@ -493,32 +494,33 @@ ppClassDecl summary links instances fixities loc d subdocs
     ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a+++" | "+++b) $ map (ppMinimal False) fs
       where wrap | p = parens | otherwise = id
 
-    instancesBit = ppInstances links instances (Just sigs) nm splice unicode qual
+    instSpec = Just $ InstSpec { ispecSigs = sigs, ispecTyVars = ltyvars }
+    instancesBit = ppInstances links instances instSpec nm splice unicode qual
 
 ppClassDecl _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
 
 
 ppInstances :: LinksInfo
-            -> [DocInstance DocName] -> Maybe [Sig DocName] -> DocName
+            -> [DocInstance DocName] -> Maybe (InstSpec DocName) -> DocName
             -> Splice -> Unicode -> Qualification
             -> Html
-ppInstances links instances msigs baseName splice unicode qual
+ppInstances links instances mspec baseName splice unicode qual
   = subInstances qual instName links True (zipWith instDecl [1..] instances)
   -- force Splice = True to use line URLs
   where
     instName = getOccString $ getName baseName
     instDecl :: Int -> DocInstance DocName -> (SubDecl,Located DocName)
     instDecl iid (inst, maybeDoc,l) =
-        ((ppInstHead links splice unicode qual msigs iid inst, maybeDoc, []),l)
+        ((ppInstHead links splice unicode qual iid mspec inst, maybeDoc, []),l)
 
 
 ppInstHead :: LinksInfo -> Splice -> Unicode -> Qualification
-           -> Maybe [Sig DocName] -> Int -> InstHead DocName
+           -> Int -> Maybe (InstSpec DocName) -> InstHead DocName
            -> Html
-ppInstHead links splice unicode qual msigs iid (InstHead {..}) =
+ppInstHead links splice unicode qual iid mspec ihead@(InstHead {..}) =
     case ihdInstType of
-        ClassInst cs | Just sigs <- msigs ->
-            subClsInstance (nameStr ++ "-" ++ show iid) hdr (mets sigs)
+        ClassInst cs | Just spec <- mspec ->
+            subClsInstance (nameStr ++ "-" ++ show iid) hdr (mets spec ihead)
           where
             hdr = ppContextNoLocs cs unicode qual <+> typ
             mets = ppInstanceSigs links splice unicode qual
@@ -533,12 +535,14 @@ ppInstHead links splice unicode qual msigs iid (InstHead {..}) =
 
 
 ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification
-              -> [Sig DocName]
+              -> InstSpec DocName -> InstHead DocName
               -> [Html]
-ppInstanceSigs links splice unicode qual sigs = do
-    TypeSig lnames (L sspan typ) _ <- sigs
+ppInstanceSigs links splice unicode qual (InstSpec {..}) (InstHead {..}) = do
+    TypeSig lnames (L sspan typ) _ <- ispecSigs
     let names = map unLoc lnames
-    return $ ppFunSig False links sspan noDocForDecl names typ [] splice unicode qual
+    let typ' = specializeTyVarBndrs ispecTyVars ihdTypes typ
+    return $ ppFunSig False links sspan noDocForDecl names typ' []
+        splice unicode qual
 
 
 lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 5a03af66..76164b5e 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -328,6 +328,12 @@ data InstHead name = InstHead
     , ihdInstType :: InstType name
     }
 
+-- | Instance details used for printing specialized method signatures.
+data InstSpec name = InstSpec
+    { ispecTyVars :: LHsTyVarBndrs name
+    , ispecSigs :: [Sig name]
+    }
+
 -----------------------------------------------------------------------------
 -- * Documentation comments
 -----------------------------------------------------------------------------
-- 
cgit v1.2.3


From 1680145961545a3f2c2e184c2a5a661fb748d5a1 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Wed, 15 Jul 2015 18:42:17 +0200
Subject: Create stub functions for sugaring specialized types.

---
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs       |  2 +-
 haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs | 13 +++++++++++++
 2 files changed, 14 insertions(+), 1 deletion(-)

(limited to 'haddock-api/src/Haddock/Backends/Xhtml/Decl.hs')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 2a820531..f54b7c22 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -540,7 +540,7 @@ ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification
 ppInstanceSigs links splice unicode qual (InstSpec {..}) (InstHead {..}) = do
     TypeSig lnames (L sspan typ) _ <- ispecSigs
     let names = map unLoc lnames
-    let typ' = specializeTyVarBndrs ispecTyVars ihdTypes typ
+    let typ' = sugar $ specializeTyVarBndrs ispecTyVars ihdTypes typ
     return $ ppFunSig False links sspan noDocForDecl names typ' []
         splice unicode qual
 
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
index fa5ba536..c10c7e6e 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
@@ -4,6 +4,7 @@
 module Haddock.Backends.Xhtml.Specialize
     ( specialize, specialize'
     , specializeTyVarBndrs
+    , sugar
     ) where
 
 
@@ -40,3 +41,15 @@ specializeTyVarBndrs bndrs typs =
     bndrs' = map (bname . unLoc) . hsq_tvs $ bndrs
     bname (UserTyVar name) = name
     bname (KindedTyVar (L _ name) _) = name
+
+
+sugar :: HsType name -> HsType name
+sugar = sugarTuples . sugarLists
+
+
+sugarLists :: HsType name -> HsType name
+sugarLists = id
+
+
+sugarTuples :: HsType name -> HsType name
+sugarTuples = id
-- 
cgit v1.2.3


From 70ed9912b5400b1b2afd60cd8bd3585e3d355a5a Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Mon, 20 Jul 2015 13:59:13 +0200
Subject: Hook type renamer with instance method HTML pretty-printer.

---
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs       | 6 +++++-
 haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs | 5 +++--
 2 files changed, 8 insertions(+), 3 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Xhtml/Decl.hs')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index f54b7c22..176180ad 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -31,6 +31,7 @@ import Haddock.Doc (combineDocumentation)
 
 import           Data.List             ( intersperse, sort )
 import qualified Data.Map as Map
+import qualified Data.Set as Set
 import           Data.Maybe
 import           Text.XHtml hiding     ( name, title, p, quote )
 
@@ -540,9 +541,12 @@ ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification
 ppInstanceSigs links splice unicode qual (InstSpec {..}) (InstHead {..}) = do
     TypeSig lnames (L sspan typ) _ <- ispecSigs
     let names = map unLoc lnames
-    let typ' = sugar $ specializeTyVarBndrs ispecTyVars ihdTypes typ
+    let typ' = rename' . sugar $ specializeTyVarBndrs ispecTyVars ihdTypes typ
     return $ ppFunSig False links sspan noDocForDecl names typ' []
         splice unicode qual
+  where
+    fv = foldr Set.union Set.empty . map freeVariables $ ihdTypes
+    rename' = rename fv
 
 
 lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
index 4e68cb7b..3b3d95b9 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
@@ -7,6 +7,7 @@ module Haddock.Backends.Xhtml.Specialize
     ( specialize, specialize'
     , specializeTyVarBndrs
     , sugar, rename
+    , freeVariables
     ) where
 
 
@@ -111,8 +112,8 @@ setInternalOccName occ name =
     nname' = mkInternalName (nameUnique nname) occ (nameSrcSpan nname)
 
 
-rename :: SetName name => HsType name -> HsType name
-rename = fst . evalRWS undefined Map.empty . renameType -- TODO.
+rename :: SetName name => Set OccName -> HsType name -> HsType name
+rename fv typ = fst $ evalRWS (renameType typ) fv Map.empty
 
 
 type Rename name a = RWS (Set OccName) () (Map Name name) a
-- 
cgit v1.2.3


From b4a82b390e3b6d7d5f1c10c42c4e36d5d7cf667b Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Tue, 21 Jul 2015 13:43:48 +0200
Subject: Make specialized signatures refer to original signature declaration.

---
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs   | 11 +++++++++--
 haddock-api/src/Haddock/Backends/Xhtml/Layout.hs |  2 +-
 2 files changed, 10 insertions(+), 3 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Xhtml/Decl.hs')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 176180ad..b3e1db81 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -223,6 +223,14 @@ ppTyName :: Name -> Html
 ppTyName = ppName Prefix
 
 
+ppSimpleSig :: Unicode -> Qualification -> [DocName] -> HsType DocName -> Html
+ppSimpleSig unicode qual names typ =
+    ppTypeSig True occNames ppTyp unicode
+  where
+    ppTyp = ppType unicode qual typ
+    occNames = map getOccName names
+
+
 --------------------------------------------------------------------------------
 -- * Type families
 --------------------------------------------------------------------------------
@@ -542,8 +550,7 @@ ppInstanceSigs links splice unicode qual (InstSpec {..}) (InstHead {..}) = do
     TypeSig lnames (L sspan typ) _ <- ispecSigs
     let names = map unLoc lnames
     let typ' = rename' . sugar $ specializeTyVarBndrs ispecTyVars ihdTypes typ
-    return $ ppFunSig False links sspan noDocForDecl names typ' []
-        splice unicode qual
+    return $ ppSimpleSig unicode qual names typ'
   where
     fv = foldr Set.union Set.empty . map freeVariables $ ihdTypes
     rename' = rename fv
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
index 188b4243..d971b0e5 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
@@ -211,7 +211,7 @@ subClsInstance sid hdr mets =
   where
     anchorId = makeAnchorId $ "i:" ++ sid
     hdrDiv = thediv ! collapseControl anchorId False "instance" << hdr
-    methodDiv = thediv ! collapseSection anchorId False [] << subMethods mets
+    methodDiv = thediv ! collapseSection anchorId False [] << subBlock mets
 
 
 subMethods :: [Html] -> Html
-- 
cgit v1.2.3


From 59d809746c08e3e3e506da5eeaaaed9d04407743 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Tue, 21 Jul 2015 14:36:37 +0200
Subject: Make specialized methods be nicely formatted again.

---
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 12 ++++++++----
 1 file changed, 8 insertions(+), 4 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Xhtml/Decl.hs')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index b3e1db81..4862945a 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -223,10 +223,14 @@ ppTyName :: Name -> Html
 ppTyName = ppName Prefix
 
 
-ppSimpleSig :: Unicode -> Qualification -> [DocName] -> HsType DocName -> Html
-ppSimpleSig unicode qual names typ =
-    ppTypeSig True occNames ppTyp unicode
+ppSimpleSig :: LinksInfo -> Splice -> Unicode -> Qualification
+            -> [DocName] -> HsType DocName
+            -> Html
+ppSimpleSig links splice unicode qual names typ =
+    topDeclElem' names $ ppTypeSig True occNames ppTyp unicode
   where
+    -- TODO: Use *helpful* source span.
+    topDeclElem' = topDeclElem links (UnhelpfulSpan undefined) splice
     ppTyp = ppType unicode qual typ
     occNames = map getOccName names
 
@@ -550,7 +554,7 @@ ppInstanceSigs links splice unicode qual (InstSpec {..}) (InstHead {..}) = do
     TypeSig lnames (L sspan typ) _ <- ispecSigs
     let names = map unLoc lnames
     let typ' = rename' . sugar $ specializeTyVarBndrs ispecTyVars ihdTypes typ
-    return $ ppSimpleSig unicode qual names typ'
+    return $ ppSimpleSig links splice unicode qual names typ'
   where
     fv = foldr Set.union Set.empty . map freeVariables $ ihdTypes
     rename' = rename fv
-- 
cgit v1.2.3


From 42d49d550642aa58696af91bb250487ac42e9095 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Tue, 21 Jul 2015 14:44:22 +0200
Subject: Attach source locations to the specialized class methods.

---
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 11 +++++------
 1 file changed, 5 insertions(+), 6 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Xhtml/Decl.hs')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 4862945a..67405915 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -223,14 +223,13 @@ ppTyName :: Name -> Html
 ppTyName = ppName Prefix
 
 
-ppSimpleSig :: LinksInfo -> Splice -> Unicode -> Qualification
+ppSimpleSig :: LinksInfo -> Splice -> Unicode -> Qualification -> SrcSpan
             -> [DocName] -> HsType DocName
             -> Html
-ppSimpleSig links splice unicode qual names typ =
+ppSimpleSig links splice unicode qual loc names typ =
     topDeclElem' names $ ppTypeSig True occNames ppTyp unicode
   where
-    -- TODO: Use *helpful* source span.
-    topDeclElem' = topDeclElem links (UnhelpfulSpan undefined) splice
+    topDeclElem' = topDeclElem links loc splice
     ppTyp = ppType unicode qual typ
     occNames = map getOccName names
 
@@ -551,10 +550,10 @@ ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification
               -> InstSpec DocName -> InstHead DocName
               -> [Html]
 ppInstanceSigs links splice unicode qual (InstSpec {..}) (InstHead {..}) = do
-    TypeSig lnames (L sspan typ) _ <- ispecSigs
+    TypeSig lnames (L loc typ) _ <- ispecSigs
     let names = map unLoc lnames
     let typ' = rename' . sugar $ specializeTyVarBndrs ispecTyVars ihdTypes typ
-    return $ ppSimpleSig links splice unicode qual names typ'
+    return $ ppSimpleSig links splice unicode qual loc names typ'
   where
     fv = foldr Set.union Set.empty . map freeVariables $ ihdTypes
     rename' = rename fv
-- 
cgit v1.2.3


From 85dab3d6aacf867a381c8810deaf585a43d42d43 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Thu, 23 Jul 2015 19:15:13 +0200
Subject: Integrate instance specification type into class instance definition.

---
 haddock-api/src/Haddock/Backends/LaTeX.hs      |  2 +-
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs |  4 ++--
 haddock-api/src/Haddock/Convert.hs             |  8 ++++++--
 haddock-api/src/Haddock/Interface/Rename.hs    |  5 ++++-
 haddock-api/src/Haddock/Types.hs               | 13 ++++++++++---
 5 files changed, 23 insertions(+), 9 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Xhtml/Decl.hs')

diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 59e5af3e..47087911 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -562,7 +562,7 @@ ppInstDecl unicode instHead = keyword "instance" <+> ppInstHead unicode instHead
 
 ppInstHead :: Bool -> InstHead DocName -> LaTeX
 ppInstHead unicode (InstHead {..}) = case ihdInstType of
-    ClassInst ctx -> ppContextNoLocs ctx unicode <+> typ
+    ClassInst ctx _ _ -> ppContextNoLocs ctx unicode <+> typ
     TypeInst rhs -> keyword "type" <+> typ <+> tibody rhs
     DataInst _ -> error "data instances not supported by --latex yet"
   where
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 67405915..a894972e 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -531,13 +531,13 @@ ppInstHead :: LinksInfo -> Splice -> Unicode -> Qualification
            -> Html
 ppInstHead links splice unicode qual iid mspec ihead@(InstHead {..}) =
     case ihdInstType of
-        ClassInst cs | Just spec <- mspec ->
+        ClassInst cs _ _ | Just spec <- mspec ->
             subClsInstance (nameStr ++ "-" ++ show iid) hdr (mets spec ihead)
           where
             hdr = ppContextNoLocs cs unicode qual <+> typ
             mets = ppInstanceSigs links splice unicode qual
             nameStr = occNameString . nameOccName $ getName ihdClsName
-        ClassInst cs -> ppContextNoLocs cs unicode qual <+> typ
+        ClassInst cs _ _ -> ppContextNoLocs cs unicode qual <+> typ
         TypeInst rhs -> keyword "type" <+> typ
             <+> maybe noHtml (\t -> equals <+> ppType unicode qual t) rhs
         DataInst dd -> keyword "data" <+> typ
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index e51d9df7..3479780a 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -390,11 +390,15 @@ synifyKindSig :: Kind -> LHsKind Name
 synifyKindSig k = synifyType WithinType k
 
 synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead Name
-synifyInstHead (_, preds, cls, types) = InstHead
+synifyInstHead (tyvars, preds, cls, types) = InstHead
   { ihdClsName = getName cls
   , ihdKinds = map (unLoc . synifyType WithinType) ks
   , ihdTypes = map (unLoc . synifyType WithinType) ts
-  , ihdInstType = ClassInst $ map (unLoc . synifyType WithinType) preds
+  , ihdInstType = ClassInst
+      { clsiCtx = map (unLoc . synifyType WithinType) preds
+      , clsiTyVars = synifyTyVars tyvars
+      , clsiSigs = map (synifyIdSig WithinType) $ classMethods cls
+      }
   }
   where (ks,ts) = break (not . isKind) types
 
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 44635318..4e4d3ed9 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -264,7 +264,10 @@ renameInstHead InstHead {..} = do
   kinds <- mapM renameType ihdKinds
   types <- mapM renameType ihdTypes
   itype <- case ihdInstType of
-    ClassInst cs -> ClassInst <$> mapM renameType cs
+    ClassInst ctx bndrs sigs -> ClassInst
+        <$> mapM renameType ctx
+        <*> renameLTyVarBndrs bndrs
+        <*> mapM renameSig sigs
     TypeInst  ts -> TypeInst  <$> traverse renameType ts
     DataInst  dd -> DataInst  <$> renameTyClD dd
   return InstHead
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index c5ca31c0..0c130cb1 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving, TypeFamilies #-}
+{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving, TypeFamilies, RecordWildCards #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 -----------------------------------------------------------------------------
 -- |
@@ -324,12 +324,19 @@ instance SetName DocName where
 
 -- | The three types of instances
 data InstType name
-  = ClassInst [HsType name]         -- ^ Context
+  = ClassInst
+      { clsiCtx :: [HsType name]
+      , clsiTyVars :: LHsTyVarBndrs name
+      , clsiSigs :: [Sig name]
+      }
   | TypeInst  (Maybe (HsType name)) -- ^ Body (right-hand side)
   | DataInst (TyClDecl name)        -- ^ Data constructors
 
 instance OutputableBndr a => Outputable (InstType a) where
-  ppr (ClassInst a) = text "ClassInst" <+> ppr a
+  ppr (ClassInst { .. }) = text "ClassInst"
+      <+> ppr clsiCtx
+      <+> ppr clsiTyVars
+      <+> ppr clsiSigs
   ppr (TypeInst  a) = text "TypeInst"  <+> ppr a
   ppr (DataInst  a) = text "DataInst"  <+> ppr a
 
-- 
cgit v1.2.3


From dc62b95d18c61fc0bf7c8d4c49d23a240af32568 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Thu, 23 Jul 2015 19:27:24 +0200
Subject: Get rid of no longer neccessary instance specification type.

---
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 35 +++++++++++++-------------
 haddock-api/src/Haddock/Types.hs               |  6 -----
 2 files changed, 17 insertions(+), 24 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Xhtml/Decl.hs')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index a894972e..34da4baa 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -282,7 +282,7 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode
       = subEquations qual $ map (ppTyFamEqn . unLoc) eqns
 
       | otherwise
-      = ppInstances links instances Nothing docname splice unicode qual
+      = ppInstances links instances docname splice unicode qual
 
     -- Individual equation of a closed type family
     ppTyFamEqn TyFamEqn { tfe_tycon = n, tfe_rhs = rhs
@@ -506,38 +506,37 @@ ppClassDecl summary links instances fixities loc d subdocs
     ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a+++" | "+++b) $ map (ppMinimal False) fs
       where wrap | p = parens | otherwise = id
 
-    instSpec = Just $ InstSpec { ispecSigs = sigs, ispecTyVars = ltyvars }
-    instancesBit = ppInstances links instances instSpec nm splice unicode qual
+    instancesBit = ppInstances links instances nm splice unicode qual
 
 ppClassDecl _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
 
 
 ppInstances :: LinksInfo
-            -> [DocInstance DocName] -> Maybe (InstSpec DocName) -> DocName
+            -> [DocInstance DocName] -> DocName
             -> Splice -> Unicode -> Qualification
             -> Html
-ppInstances links instances mspec baseName splice unicode qual
+ppInstances links instances baseName splice unicode qual
   = subInstances qual instName links True (zipWith instDecl [1..] instances)
   -- force Splice = True to use line URLs
   where
     instName = getOccString $ getName baseName
     instDecl :: Int -> DocInstance DocName -> (SubDecl,Located DocName)
     instDecl iid (inst, maybeDoc,l) =
-        ((ppInstHead links splice unicode qual iid mspec inst, maybeDoc, []),l)
+        ((ppInstHead links splice unicode qual iid inst, maybeDoc, []),l)
 
 
 ppInstHead :: LinksInfo -> Splice -> Unicode -> Qualification
-           -> Int -> Maybe (InstSpec DocName) -> InstHead DocName
+           -> Int -> InstHead DocName
            -> Html
-ppInstHead links splice unicode qual iid mspec ihead@(InstHead {..}) =
+ppInstHead links splice unicode qual iid (InstHead {..}) =
     case ihdInstType of
-        ClassInst cs _ _ | Just spec <- mspec ->
-            subClsInstance (nameStr ++ "-" ++ show iid) hdr (mets spec ihead)
+        ClassInst { .. } ->
+            subClsInstance (nameStr ++ "-" ++ show iid) hdr mets
           where
-            hdr = ppContextNoLocs cs unicode qual <+> typ
+            hdr = ppContextNoLocs clsiCtx unicode qual <+> typ
             mets = ppInstanceSigs links splice unicode qual
+                clsiTyVars ihdTypes clsiSigs
             nameStr = occNameString . nameOccName $ getName ihdClsName
-        ClassInst cs _ _ -> ppContextNoLocs cs unicode qual <+> typ
         TypeInst rhs -> keyword "type" <+> typ
             <+> maybe noHtml (\t -> equals <+> ppType unicode qual t) rhs
         DataInst dd -> keyword "data" <+> typ
@@ -547,15 +546,15 @@ ppInstHead links splice unicode qual iid mspec ihead@(InstHead {..}) =
 
 
 ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification
-              -> InstSpec DocName -> InstHead DocName
+              -> LHsTyVarBndrs DocName -> [HsType DocName] -> [Sig DocName]
               -> [Html]
-ppInstanceSigs links splice unicode qual (InstSpec {..}) (InstHead {..}) = do
-    TypeSig lnames (L loc typ) _ <- ispecSigs
+ppInstanceSigs links splice unicode qual bndrs tys sigs = do
+    TypeSig lnames (L loc typ) _ <- sigs
     let names = map unLoc lnames
-    let typ' = rename' . sugar $ specializeTyVarBndrs ispecTyVars ihdTypes typ
+    let typ' = rename' . sugar $ specializeTyVarBndrs bndrs tys typ
     return $ ppSimpleSig links splice unicode qual loc names typ'
   where
-    fv = foldr Set.union Set.empty . map freeVariables $ ihdTypes
+    fv = foldr Set.union Set.empty . map freeVariables $ tys
     rename' = rename fv
 
 
@@ -628,7 +627,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl
                                      (map unLoc (con_names (unLoc c)))) fixities
       ]
 
-    instancesBit = ppInstances links instances Nothing docname
+    instancesBit = ppInstances links instances docname
         splice unicode qual
 
 
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 0c130cb1..b4a41020 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -352,12 +352,6 @@ data InstHead name = InstHead
     , ihdInstType :: InstType name
     }
 
--- | Instance details used for printing specialized method signatures.
-data InstSpec name = InstSpec
-    { ispecTyVars :: LHsTyVarBndrs name
-    , ispecSigs :: [Sig name]
-    }
-
 -----------------------------------------------------------------------------
 -- * Documentation comments
 -----------------------------------------------------------------------------
-- 
cgit v1.2.3


From 131e5835425e1e411ceb5cb73f9dee855b702053 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Fri, 24 Jul 2015 15:40:32 +0200
Subject: Fix bug where instance expander was opening wrong section.

---
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 35 ++++++++++++++++++--------
 1 file changed, 24 insertions(+), 11 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Xhtml/Decl.hs')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 34da4baa..a9f38c14 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -282,7 +282,7 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode
       = subEquations qual $ map (ppTyFamEqn . unLoc) eqns
 
       | otherwise
-      = ppInstances links instances docname splice unicode qual
+      = ppInstances links OriginFamily instances docname splice unicode qual
 
     -- Individual equation of a closed type family
     ppTyFamEqn TyFamEqn { tfe_tycon = n, tfe_rhs = rhs
@@ -506,37 +506,41 @@ ppClassDecl summary links instances fixities loc d subdocs
     ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a+++" | "+++b) $ map (ppMinimal False) fs
       where wrap | p = parens | otherwise = id
 
-    instancesBit = ppInstances links instances nm splice unicode qual
+    instancesBit = ppInstances links OriginClass instances nm
+        splice unicode qual
 
 ppClassDecl _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
 
 
+data InstOrigin = OriginClass | OriginData | OriginFamily
+
+
 ppInstances :: LinksInfo
-            -> [DocInstance DocName] -> DocName
+            -> InstOrigin -> [DocInstance DocName] -> DocName
             -> Splice -> Unicode -> Qualification
             -> Html
-ppInstances links instances baseName splice unicode qual
+ppInstances links origin instances baseName splice unicode qual
   = subInstances qual instName links True (zipWith instDecl [1..] instances)
   -- force Splice = True to use line URLs
   where
     instName = getOccString $ getName baseName
     instDecl :: Int -> DocInstance DocName -> (SubDecl,Located DocName)
-    instDecl iid (inst, maybeDoc,l) =
-        ((ppInstHead links splice unicode qual iid inst, maybeDoc, []),l)
+    instDecl no (inst, maybeDoc,l) =
+        ((ppInstHead links splice unicode qual origin no inst, maybeDoc, []),l)
 
 
 ppInstHead :: LinksInfo -> Splice -> Unicode -> Qualification
-           -> Int -> InstHead DocName
+           -> InstOrigin -> Int -> InstHead DocName
            -> Html
-ppInstHead links splice unicode qual iid (InstHead {..}) =
+ppInstHead links splice unicode qual origin no (InstHead {..}) =
     case ihdInstType of
         ClassInst { .. } ->
-            subClsInstance (nameStr ++ "-" ++ show iid) hdr mets
+            subClsInstance iid hdr mets
           where
             hdr = ppContextNoLocs clsiCtx unicode qual <+> typ
             mets = ppInstanceSigs links splice unicode qual
                 clsiTyVars ihdTypes clsiSigs
-            nameStr = occNameString . nameOccName $ getName ihdClsName
+            iid = instanceId origin no ihdClsName
         TypeInst rhs -> keyword "type" <+> typ
             <+> maybe noHtml (\t -> equals <+> ppType unicode qual t) rhs
         DataInst dd -> keyword "data" <+> typ
@@ -562,6 +566,15 @@ lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2
 lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n
 
 
+instanceId :: InstOrigin -> Int -> DocName -> String
+instanceId orgin no name =
+    qual orgin ++ ":" ++ (occNameString . getOccName) name ++ "-" ++ show no
+  where
+    qual OriginClass = "ic"
+    qual OriginData = "id"
+    qual OriginFamily = "if"
+
+
 -------------------------------------------------------------------------------
 -- * Data & newtype declarations
 -------------------------------------------------------------------------------
@@ -627,7 +640,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl
                                      (map unLoc (con_names (unLoc c)))) fixities
       ]
 
-    instancesBit = ppInstances links instances docname
+    instancesBit = ppInstances links OriginData instances docname
         splice unicode qual
 
 
-- 
cgit v1.2.3


From 88df578a8573908d665d4597c4c619c29055a277 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Tue, 28 Jul 2015 23:58:13 +0200
Subject: Rearrange layout of instance methods in generated documentation.

---
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs   | 39 ++++++++++++++++--------
 haddock-api/src/Haddock/Backends/Xhtml/Layout.hs |  2 +-
 2 files changed, 27 insertions(+), 14 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Xhtml/Decl.hs')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index a9f38c14..abcf3eaf 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -525,26 +525,39 @@ ppInstances links origin instances baseName splice unicode qual
   where
     instName = getOccString $ getName baseName
     instDecl :: Int -> DocInstance DocName -> (SubDecl,Located DocName)
-    instDecl no (inst, maybeDoc,l) =
-        ((ppInstHead links splice unicode qual origin no inst, maybeDoc, []),l)
+    instDecl no (inst, mdoc, loc) =
+        ((ppInstHead links splice unicode qual mdoc origin no inst), loc)
 
 
 ppInstHead :: LinksInfo -> Splice -> Unicode -> Qualification
-           -> InstOrigin -> Int -> InstHead DocName
-           -> Html
-ppInstHead links splice unicode qual origin no (InstHead {..}) =
+           -> Maybe (MDoc DocName) -> InstOrigin -> Int -> InstHead DocName
+           -> SubDecl
+ppInstHead links splice unicode qual mdoc origin no (InstHead {..}) =
     case ihdInstType of
         ClassInst { .. } ->
-            subClsInstance iid hdr mets
+            ( subInstHead iid $ ppContextNoLocs clsiCtx unicode qual <+> typ
+            , mdoc
+            , [subInstMethods iid sigs]
+            )
           where
-            hdr = ppContextNoLocs clsiCtx unicode qual <+> typ
-            mets = ppInstanceSigs links splice unicode qual
-                clsiTyVars ihdTypes clsiSigs
             iid = instanceId origin no ihdClsName
-        TypeInst rhs -> keyword "type" <+> typ
-            <+> maybe noHtml (\t -> equals <+> ppType unicode qual t) rhs
-        DataInst dd -> keyword "data" <+> typ
-            <+> ppShortDataDecl False True dd unicode qual
+            sigs = ppInstanceSigs links splice unicode qual
+                clsiTyVars ihdTypes clsiSigs
+        TypeInst rhs ->
+            (ptype, mdoc, [])
+          where
+            ptype = mconcat
+                [ keyword "type"
+                , typ
+                , maybe noHtml (\t -> equals <+> ppType unicode qual t) rhs
+                ]
+        DataInst dd ->
+            (pdata, mdoc, [])
+          where
+            pdata = mconcat
+                [ keyword "data" <+> typ
+                , ppShortDataDecl False True dd unicode qual
+                ]
   where
     typ = ppAppNameTypes ihdClsName ihdKinds ihdTypes unicode qual
 
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
index da03985e..0b09e220 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
@@ -31,7 +31,7 @@ module Haddock.Backends.Xhtml.Layout (
   subConstructors,
   subEquations,
   subFields,
-  subInstances, subClsInstance,
+  subInstances, subClsInstance, subInstHead, subInstMethods,
   subMethods,
   subMinimal,
 
-- 
cgit v1.2.3


From 73f4a18d0b29dd209a5f1172c8ed662be11d5690 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Wed, 29 Jul 2015 12:25:54 +0200
Subject: Make instance details section contain associated types information.

---
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs   | 13 ++++++++++++-
 haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 11 ++++++-----
 2 files changed, 18 insertions(+), 6 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Xhtml/Decl.hs')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index abcf3eaf..6fb36e29 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -537,12 +537,14 @@ ppInstHead links splice unicode qual mdoc origin no (InstHead {..}) =
         ClassInst { .. } ->
             ( subInstHead iid $ ppContextNoLocs clsiCtx unicode qual <+> typ
             , mdoc
-            , [subInstMethods iid sigs]
+            , [subInstDetails iid ats sigs]
             )
           where
             iid = instanceId origin no ihdClsName
             sigs = ppInstanceSigs links splice unicode qual
                 clsiTyVars ihdTypes clsiSigs
+            ats = ppInstanceAssocTys links splice unicode qual
+                clsiAssocTys
         TypeInst rhs ->
             (ptype, mdoc, [])
           where
@@ -562,6 +564,15 @@ ppInstHead links splice unicode qual mdoc origin no (InstHead {..}) =
     typ = ppAppNameTypes ihdClsName ihdKinds ihdTypes unicode qual
 
 
+ppInstanceAssocTys :: LinksInfo -> Splice -> Unicode -> Qualification
+                   -> [FamilyDecl DocName]
+                   -> [Html]
+ppInstanceAssocTys links splice unicode qual =
+    map ppTyFam'
+  where
+    ppTyFam' fam = ppTyFamHeader False True fam unicode qual
+
+
 ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification
               -> LHsTyVarBndrs DocName -> [HsType DocName] -> [Sig DocName]
               -> [Html]
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
index 117f8fc8..074b6801 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
@@ -31,7 +31,7 @@ module Haddock.Backends.Xhtml.Layout (
   subConstructors,
   subEquations,
   subFields,
-  subInstances, subInstHead, subInstMethods,
+  subInstances, subInstHead, subInstDetails,
   subMethods,
   subMinimal,
 
@@ -210,13 +210,14 @@ subInstHead iid hdr =
     expander = thediv ! collapseControl (instAnchorId iid) False "instance"
 
 
-subInstMethods :: String -- ^ Instance unique id (for anchor generation)
+subInstDetails :: String -- ^ Instance unique id (for anchor generation)
+               -> [Html] -- ^ Associated type contents
                -> [Html] -- ^ Method contents (pretty-printed signatures)
                -> Html
-subInstMethods iid mets =
-    section << subMethods mets
+subInstDetails iid ats mets =
+    section << (subAssociatedTypes ats <+> subMethods mets)
   where
-    section = thediv ! collapseSection (instAnchorId iid) False "methods"
+    section = thediv ! collapseSection (instAnchorId iid) False "inst-details"
 
 
 instAnchorId :: String -> String
-- 
cgit v1.2.3


From 3fb4ec56a9e7fc167c8fd970bc15b554ab85a1c9 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Wed, 29 Jul 2015 12:50:51 +0200
Subject: Improve look of rendered associated families in instance details.

---
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 13 +++++++++++--
 1 file changed, 11 insertions(+), 2 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Xhtml/Decl.hs')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 6fb36e29..4b28e4ff 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -302,6 +302,15 @@ ppAssocType summ links doc (L loc decl) fixities splice unicode qual =
    ppTyFam summ True links [] fixities loc (fst doc) decl splice unicode qual
 
 
+ppSimpleAssocTy :: LinksInfo -> Splice -> Unicode -> Qualification
+              -> FamilyDecl DocName
+              -> Html
+ppSimpleAssocTy links splice unicode qual decl =
+    ppAssocType False links noDocForDecl ldecl [] splice unicode qual
+  where
+    ldecl = L (getLoc $ fdLName decl) decl
+
+
 --------------------------------------------------------------------------------
 -- * TyClDecl helpers
 --------------------------------------------------------------------------------
@@ -568,9 +577,9 @@ ppInstanceAssocTys :: LinksInfo -> Splice -> Unicode -> Qualification
                    -> [FamilyDecl DocName]
                    -> [Html]
 ppInstanceAssocTys links splice unicode qual =
-    map ppTyFam'
+    map ppSimpleAssocTy'
   where
-    ppTyFam' fam = ppTyFamHeader False True fam unicode qual
+    ppSimpleAssocTy' = ppSimpleAssocTy links splice unicode qual
 
 
 ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification
-- 
cgit v1.2.3


From 3073526a26d013e8751068fbd526974dcfb8259f Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Wed, 29 Jul 2015 15:37:48 +0200
Subject: Make instance details record use new type for family declarations.

---
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 23 +++++++++++------------
 haddock-api/src/Haddock/Convert.hs             |  2 +-
 haddock-api/src/Haddock/Interface/Rename.hs    | 12 +++++++++++-
 haddock-api/src/Haddock/Types.hs               |  2 +-
 4 files changed, 24 insertions(+), 15 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Xhtml/Decl.hs')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 4b28e4ff..eb4524c2 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -291,6 +291,14 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode
           <+> equals <+> ppType unicode qual (unLoc rhs)
         , Nothing, [] )
 
+
+
+ppPseudoFamilyDecl :: LinksInfo -> Splice -> Unicode -> Qualification
+                   -> PseudoFamilyDecl DocName
+                   -> Html
+ppPseudoFamilyDecl = undefined
+
+
 --------------------------------------------------------------------------------
 -- * Associated Types
 --------------------------------------------------------------------------------
@@ -302,15 +310,6 @@ ppAssocType summ links doc (L loc decl) fixities splice unicode qual =
    ppTyFam summ True links [] fixities loc (fst doc) decl splice unicode qual
 
 
-ppSimpleAssocTy :: LinksInfo -> Splice -> Unicode -> Qualification
-              -> FamilyDecl DocName
-              -> Html
-ppSimpleAssocTy links splice unicode qual decl =
-    ppAssocType False links noDocForDecl ldecl [] splice unicode qual
-  where
-    ldecl = L (getLoc $ fdLName decl) decl
-
-
 --------------------------------------------------------------------------------
 -- * TyClDecl helpers
 --------------------------------------------------------------------------------
@@ -574,12 +573,12 @@ ppInstHead links splice unicode qual mdoc origin no (InstHead {..}) =
 
 
 ppInstanceAssocTys :: LinksInfo -> Splice -> Unicode -> Qualification
-                   -> [FamilyDecl DocName]
+                   -> [PseudoFamilyDecl DocName]
                    -> [Html]
 ppInstanceAssocTys links splice unicode qual =
-    map ppSimpleAssocTy'
+    map ppFamilyDecl'
   where
-    ppSimpleAssocTy' = ppSimpleAssocTy links splice unicode qual
+    ppFamilyDecl' = ppPseudoFamilyDecl links splice unicode qual
 
 
 ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index a2716d92..095bd9e0 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -400,7 +400,7 @@ synifyInstHead (_, preds, cls, types) = InstHead
         , clsiSigs = map synifyClsIdSig $ classMethods cls
         , clsiAssocTys = do
             (Right (FamDecl fam)) <- map (synifyTyCon Nothing) $ classATs cls
-            pure fam
+            pure $ mkPseudoFamilyDecl fam
         }
     }
   where
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 82d14a2c..146a7c0b 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -268,7 +268,7 @@ renameInstHead InstHead {..} = do
         <$> mapM renameType clsiCtx
         <*> renameLTyVarBndrs clsiTyVars
         <*> mapM renameSig clsiSigs
-        <*> mapM renameFamilyDecl clsiAssocTys
+        <*> mapM renamePseudoFamilyDecl clsiAssocTys
     TypeInst  ts -> TypeInst  <$> traverse renameType ts
     DataInst  dd -> DataInst  <$> renameTyClD dd
   return InstHead
@@ -352,6 +352,16 @@ renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname
     return (FamilyDecl { fdInfo = info', fdLName = lname'
                        , fdTyVars = ltyvars', fdKindSig = tckind' })
 
+
+renamePseudoFamilyDecl :: PseudoFamilyDecl Name
+                       -> RnM (PseudoFamilyDecl DocName)
+renamePseudoFamilyDecl (PseudoFamilyDecl { .. }) =  PseudoFamilyDecl
+    <$> renameFamilyInfo pfdInfo
+    <*> renameL pfdLName
+    <*> mapM renameLType pfdTyVars
+    <*> renameMaybeLKind pfdKindSig
+
+
 renameFamilyInfo :: FamilyInfo Name -> RnM (FamilyInfo DocName)
 renameFamilyInfo DataFamily     = return DataFamily
 renameFamilyInfo OpenTypeFamily = return OpenTypeFamily
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 90672c9d..1f074ac3 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -328,7 +328,7 @@ data InstType name
       { clsiCtx :: [HsType name]
       , clsiTyVars :: LHsTyVarBndrs name
       , clsiSigs :: [Sig name]
-      , clsiAssocTys :: [FamilyDecl name]
+      , clsiAssocTys :: [PseudoFamilyDecl name]
       }
   | TypeInst  (Maybe (HsType name)) -- ^ Body (right-hand side)
   | DataInst (TyClDecl name)        -- ^ Data constructors
-- 
cgit v1.2.3


From 5980cfb8eb5bf86e420c2d1b82d6d3b92c0c1fda Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Wed, 29 Jul 2015 16:51:22 +0200
Subject: Split printer of type family header to separate functions.

---
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 37 ++++++++++++++------------
 1 file changed, 20 insertions(+), 17 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Xhtml/Decl.hs')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index eb4524c2..e248dc25 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -239,28 +239,31 @@ ppSimpleSig links splice unicode qual loc names typ =
 --------------------------------------------------------------------------------
 
 
+ppFamilyInfo :: Bool -> FamilyInfo DocName -> Html
+ppFamilyInfo assoc OpenTypeFamily
+    | assoc = keyword "type"
+    | otherwise = keyword "type family"
+ppFamilyInfo assoc DataFamily
+    | assoc = keyword "data"
+    | otherwise = keyword "data family"
+ppFamilyInfo _ (ClosedTypeFamily _) = keyword "type family"
+
+
+ppFamilyKind :: Unicode -> Qualification -> Maybe (LHsKind DocName) -> Html
+ppFamilyKind unicode qual (Just kind) =
+    dcolon unicode <+> ppLKind unicode qual kind
+ppFamilyKind _ _ Nothing = noHtml
+
+
 ppTyFamHeader :: Bool -> Bool -> FamilyDecl DocName
               -> Unicode -> Qualification -> Html
 ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info
                                                , fdKindSig = mkind })
               unicode qual =
-  (case info of
-     OpenTypeFamily
-       | associated -> keyword "type"
-       | otherwise  -> keyword "type family"
-     DataFamily
-       | associated -> keyword "data"
-       | otherwise  -> keyword "data family"
-     ClosedTypeFamily _
-                    -> keyword "type family"
-  ) <+>
-
-  ppFamDeclBinderWithVars summary d <+>
-
-  (case mkind of
-    Just kind -> dcolon unicode  <+> ppLKind unicode qual kind
-    Nothing   -> noHtml
-  )
+    ppFamilyInfo associated info <+>
+    ppFamDeclBinderWithVars summary d <+>
+    ppFamilyKind unicode qual mkind
+
 
 ppTyFam :: Bool -> Bool -> LinksInfo -> [DocInstance DocName] ->
            [(DocName, Fixity)] -> SrcSpan -> Documentation DocName ->
-- 
cgit v1.2.3


From 709ce61f4cf18b2d6a24411670713d7480b8218c Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Wed, 29 Jul 2015 17:45:00 +0200
Subject: Implement HTML renderer for pseudo-family declarations.

---
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 14 +++++++++++++-
 1 file changed, 13 insertions(+), 1 deletion(-)

(limited to 'haddock-api/src/Haddock/Backends/Xhtml/Decl.hs')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index e248dc25..e6869916 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -265,6 +265,14 @@ ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info
     ppFamilyKind unicode qual mkind
 
 
+ppPseudoFamilyHeader :: Unicode -> Qualification -> PseudoFamilyDecl DocName
+                     -> Html
+ppPseudoFamilyHeader unicode qual (PseudoFamilyDecl { .. }) =
+    ppFamilyInfo True pfdInfo <+>
+    ppAppNameTypes (unLoc pfdLName) [] (map unLoc pfdTyVars) unicode qual <+>
+    ppFamilyKind unicode qual pfdKindSig
+
+
 ppTyFam :: Bool -> Bool -> LinksInfo -> [DocInstance DocName] ->
            [(DocName, Fixity)] -> SrcSpan -> Documentation DocName ->
            FamilyDecl DocName -> Splice -> Unicode -> Qualification -> Html
@@ -299,7 +307,11 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode
 ppPseudoFamilyDecl :: LinksInfo -> Splice -> Unicode -> Qualification
                    -> PseudoFamilyDecl DocName
                    -> Html
-ppPseudoFamilyDecl = undefined
+ppPseudoFamilyDecl links splice unicode qual
+                   decl@(PseudoFamilyDecl { pfdLName = L loc name, .. }) =
+    wrapper $ ppPseudoFamilyHeader unicode qual decl
+  where
+    wrapper = topDeclElem links loc splice [name]
 
 
 --------------------------------------------------------------------------------
-- 
cgit v1.2.3


From 00571a39acaa5aaa292b5a4bd5c17f122951f7ae Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Wed, 29 Jul 2015 18:21:04 +0200
Subject: Apply type specializer to associated type family declarations.

---
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs       |  7 ++++---
 haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs | 14 +++++++++++++-
 2 files changed, 17 insertions(+), 4 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Xhtml/Decl.hs')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index e6869916..294af864 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -567,7 +567,7 @@ ppInstHead links splice unicode qual mdoc origin no (InstHead {..}) =
             sigs = ppInstanceSigs links splice unicode qual
                 clsiTyVars ihdTypes clsiSigs
             ats = ppInstanceAssocTys links splice unicode qual
-                clsiAssocTys
+                clsiTyVars ihdTypes clsiAssocTys
         TypeInst rhs ->
             (ptype, mdoc, [])
           where
@@ -588,10 +588,11 @@ ppInstHead links splice unicode qual mdoc origin no (InstHead {..}) =
 
 
 ppInstanceAssocTys :: LinksInfo -> Splice -> Unicode -> Qualification
+                   -> LHsTyVarBndrs DocName -> [HsType DocName]
                    -> [PseudoFamilyDecl DocName]
                    -> [Html]
-ppInstanceAssocTys links splice unicode qual =
-    map ppFamilyDecl'
+ppInstanceAssocTys links splice unicode qual bndrs tys =
+    map ppFamilyDecl' . map (specializePseudoFamilyDecl bndrs tys)
   where
     ppFamilyDecl' = ppPseudoFamilyDecl links splice unicode qual
 
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
index a8a4e8ec..109788fd 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
@@ -7,6 +7,7 @@
 module Haddock.Backends.Xhtml.Specialize
     ( specialize, specialize'
     , specializeTyVarBndrs
+    , specializePseudoFamilyDecl
     , sugar, rename
     , freeVariables
     ) where
@@ -58,8 +59,9 @@ specialize' = flip $ foldr (uncurry specialize)
 -- Again, it is just a convenience function around 'specialize'. Note that
 -- length of type list should be the same as the number of binders.
 specializeTyVarBndrs :: (Eq name, Typeable name, DataId name)
+                     => Data a
                      => LHsTyVarBndrs name -> [HsType name]
-                     -> HsType name -> HsType name
+                     -> a -> a
 specializeTyVarBndrs bndrs typs =
     specialize' $ zip bndrs' typs
   where
@@ -68,6 +70,16 @@ specializeTyVarBndrs bndrs typs =
     bname (KindedTyVar (L _ name) _) = name
 
 
+specializePseudoFamilyDecl :: (Eq name, Typeable name, DataId name)
+                           => LHsTyVarBndrs name -> [HsType name]
+                           -> PseudoFamilyDecl name
+                           -> PseudoFamilyDecl name
+specializePseudoFamilyDecl bndrs typs decl =
+    decl { pfdTyVars = map specializeTyVars (pfdTyVars decl) }
+  where
+    specializeTyVars = specializeTyVarBndrs bndrs typs
+
+
 -- | Make given type use tuple and list literals where appropriate.
 --
 -- After applying 'specialize' function some terms may not use idiomatic list
-- 
cgit v1.2.3


From 730d8b0e76c5e637f2cdd7d980865f6208729366 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Wed, 29 Jul 2015 18:43:39 +0200
Subject: Create helper method for specializing type signatures.

---
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs       |  9 ++-------
 haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs | 18 +++++++++++++-----
 2 files changed, 15 insertions(+), 12 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Xhtml/Decl.hs')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 294af864..7255bf42 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -31,7 +31,6 @@ import Haddock.Doc (combineDocumentation)
 
 import           Data.List             ( intersperse, sort )
 import qualified Data.Map as Map
-import qualified Data.Set as Set
 import           Data.Maybe
 import           Text.XHtml hiding     ( name, title, p, quote )
 
@@ -601,13 +600,9 @@ ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification
               -> LHsTyVarBndrs DocName -> [HsType DocName] -> [Sig DocName]
               -> [Html]
 ppInstanceSigs links splice unicode qual bndrs tys sigs = do
-    TypeSig lnames (L loc typ) _ <- sigs
+    TypeSig lnames (L loc typ) _ <- map (specializeSig bndrs tys) sigs
     let names = map unLoc lnames
-    let typ' = rename' . sugar $ specializeTyVarBndrs bndrs tys typ
-    return $ ppSimpleSig links splice unicode qual loc names typ'
-  where
-    fv = foldr Set.union Set.empty . map freeVariables $ tys
-    rename' = rename fv
+    return $ ppSimpleSig links splice unicode qual loc names typ
 
 
 lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
index 109788fd..2295605b 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
@@ -5,11 +5,7 @@
 
 
 module Haddock.Backends.Xhtml.Specialize
-    ( specialize, specialize'
-    , specializeTyVarBndrs
-    , specializePseudoFamilyDecl
-    , sugar, rename
-    , freeVariables
+    ( specializePseudoFamilyDecl, specializeSig
     ) where
 
 
@@ -80,6 +76,18 @@ specializePseudoFamilyDecl bndrs typs decl =
     specializeTyVars = specializeTyVarBndrs bndrs typs
 
 
+specializeSig :: (Eq name, Typeable name, DataId name, SetName name)
+              => LHsTyVarBndrs name -> [HsType name]
+              -> Sig name
+              -> Sig name
+specializeSig bndrs typs (TypeSig lnames (L loc typ) prn) =
+    TypeSig lnames (L loc typ') prn
+  where
+    typ' = rename fv . sugar $ specializeTyVarBndrs bndrs typs typ
+    fv = foldr Set.union Set.empty . map freeVariables $ typs
+specializeSig _ _ sig = sig
+
+
 -- | Make given type use tuple and list literals where appropriate.
 --
 -- After applying 'specialize' function some terms may not use idiomatic list
-- 
cgit v1.2.3


From f0222eaf888dafb9fdb6dbbac0527fc28223588d Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Wed, 29 Jul 2015 19:32:32 +0200
Subject: Refactor specializer module to be independent from XHTML backend.

---
 haddock-api/haddock-api.cabal                      |   2 +-
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs     |  18 +-
 .../src/Haddock/Backends/Xhtml/Specialize.hs       | 382 --------------------
 haddock-api/src/Haddock/Convert.hs                 |   6 +-
 haddock-api/src/Haddock/Interface/Specialize.hs    | 396 +++++++++++++++++++++
 haddock.cabal                                      |   2 +-
 6 files changed, 409 insertions(+), 397 deletions(-)
 delete mode 100644 haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
 create mode 100644 haddock-api/src/Haddock/Interface/Specialize.hs

(limited to 'haddock-api/src/Haddock/Backends/Xhtml/Decl.hs')

diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal
index 2090c53e..b4ceb1a0 100644
--- a/haddock-api/haddock-api.cabal
+++ b/haddock-api/haddock-api.cabal
@@ -69,6 +69,7 @@ library
     Haddock.Interface.AttachInstances
     Haddock.Interface.LexParseRn
     Haddock.Interface.ParseModuleHeader
+    Haddock.Interface.Specialize
     Haddock.Parser
     Haddock.Utils
     Haddock.Backends.Xhtml
@@ -76,7 +77,6 @@ library
     Haddock.Backends.Xhtml.DocMarkup
     Haddock.Backends.Xhtml.Layout
     Haddock.Backends.Xhtml.Names
-    Haddock.Backends.Xhtml.Specialize
     Haddock.Backends.Xhtml.Themes
     Haddock.Backends.Xhtml.Types
     Haddock.Backends.Xhtml.Utils
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 7255bf42..7da1f08e 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -22,7 +22,6 @@ module Haddock.Backends.Xhtml.Decl (
 import Haddock.Backends.Xhtml.DocMarkup
 import Haddock.Backends.Xhtml.Layout
 import Haddock.Backends.Xhtml.Names
-import Haddock.Backends.Xhtml.Specialize
 import Haddock.Backends.Xhtml.Types
 import Haddock.Backends.Xhtml.Utils
 import Haddock.GhcUtils
@@ -563,10 +562,8 @@ ppInstHead links splice unicode qual mdoc origin no (InstHead {..}) =
             )
           where
             iid = instanceId origin no ihdClsName
-            sigs = ppInstanceSigs links splice unicode qual
-                clsiTyVars ihdTypes clsiSigs
-            ats = ppInstanceAssocTys links splice unicode qual
-                clsiTyVars ihdTypes clsiAssocTys
+            sigs = ppInstanceSigs links splice unicode qual clsiSigs
+            ats = ppInstanceAssocTys links splice unicode qual clsiAssocTys
         TypeInst rhs ->
             (ptype, mdoc, [])
           where
@@ -587,20 +584,19 @@ ppInstHead links splice unicode qual mdoc origin no (InstHead {..}) =
 
 
 ppInstanceAssocTys :: LinksInfo -> Splice -> Unicode -> Qualification
-                   -> LHsTyVarBndrs DocName -> [HsType DocName]
                    -> [PseudoFamilyDecl DocName]
                    -> [Html]
-ppInstanceAssocTys links splice unicode qual bndrs tys =
-    map ppFamilyDecl' . map (specializePseudoFamilyDecl bndrs tys)
+ppInstanceAssocTys links splice unicode qual =
+    map ppFamilyDecl'
   where
     ppFamilyDecl' = ppPseudoFamilyDecl links splice unicode qual
 
 
 ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification
-              -> LHsTyVarBndrs DocName -> [HsType DocName] -> [Sig DocName]
+              -> [Sig DocName]
               -> [Html]
-ppInstanceSigs links splice unicode qual bndrs tys sigs = do
-    TypeSig lnames (L loc typ) _ <- map (specializeSig bndrs tys) sigs
+ppInstanceSigs links splice unicode qual sigs = do
+    TypeSig lnames (L loc typ) _ <- sigs
     let names = map unLoc lnames
     return $ ppSimpleSig links splice unicode qual loc names typ
 
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
deleted file mode 100644
index 2295605b..00000000
--- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
+++ /dev/null
@@ -1,382 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE RecordWildCards #-}
-
-
-module Haddock.Backends.Xhtml.Specialize
-    ( specializePseudoFamilyDecl, specializeSig
-    ) where
-
-
-import Haddock.Syb
-import Haddock.Types
-
-import GHC
-import Name
-import FastString
-
-import Control.Monad
-import Control.Monad.Trans.Reader
-import Control.Monad.Trans.State
-
-import Data.Data
-import qualified Data.List as List
-import Data.Maybe
-import Data.Map (Map)
-import qualified Data.Map as Map
-import Data.Set (Set)
-import qualified Data.Set as Set
-
-
--- | Instantiate all occurrences of given name with particular type.
-specialize :: (Eq name, Typeable name)
-           => Data a
-           => name -> HsType name -> a -> a
-specialize name details =
-    everywhere $ mkT step
-  where
-    step (HsTyVar name') | name == name' = details
-    step typ = typ
-
-
--- | Instantiate all occurrences of given names with corresponding types.
---
--- It is just a convenience function wrapping 'specialize' that supports more
--- that one specialization.
-specialize' :: (Eq name, Typeable name)
-            => Data a
-            => [(name, HsType name)] -> a -> a
-specialize' = flip $ foldr (uncurry specialize)
-
-
--- | Instantiate given binders with corresponding types.
---
--- Again, it is just a convenience function around 'specialize'. Note that
--- length of type list should be the same as the number of binders.
-specializeTyVarBndrs :: (Eq name, Typeable name, DataId name)
-                     => Data a
-                     => LHsTyVarBndrs name -> [HsType name]
-                     -> a -> a
-specializeTyVarBndrs bndrs typs =
-    specialize' $ zip bndrs' typs
-  where
-    bndrs' = map (bname . unLoc) . hsq_tvs $ bndrs
-    bname (UserTyVar name) = name
-    bname (KindedTyVar (L _ name) _) = name
-
-
-specializePseudoFamilyDecl :: (Eq name, Typeable name, DataId name)
-                           => LHsTyVarBndrs name -> [HsType name]
-                           -> PseudoFamilyDecl name
-                           -> PseudoFamilyDecl name
-specializePseudoFamilyDecl bndrs typs decl =
-    decl { pfdTyVars = map specializeTyVars (pfdTyVars decl) }
-  where
-    specializeTyVars = specializeTyVarBndrs bndrs typs
-
-
-specializeSig :: (Eq name, Typeable name, DataId name, SetName name)
-              => LHsTyVarBndrs name -> [HsType name]
-              -> Sig name
-              -> Sig name
-specializeSig bndrs typs (TypeSig lnames (L loc typ) prn) =
-    TypeSig lnames (L loc typ') prn
-  where
-    typ' = rename fv . sugar $ specializeTyVarBndrs bndrs typs typ
-    fv = foldr Set.union Set.empty . map freeVariables $ typs
-specializeSig _ _ sig = sig
-
-
--- | Make given type use tuple and list literals where appropriate.
---
--- After applying 'specialize' function some terms may not use idiomatic list
--- and tuple literals resulting in types like @[] a@ or @(,,) a b c@. This
--- can be fixed using 'sugar' function, that will turn such types into @[a]@
--- and @(a, b, c)@.
-sugar :: forall name. (NamedThing name, DataId name)
-      => HsType name -> HsType name
-sugar =
-    everywhere $ mkT step
-  where
-    step :: HsType name -> HsType name
-    step = sugarTuples . sugarLists
-
-
-sugarLists :: NamedThing name => HsType name -> HsType name
-sugarLists (HsAppTy (L _ (HsTyVar name)) ltyp)
-    | isBuiltInSyntax name' && strName == "[]" = HsListTy ltyp
-  where
-    name' = getName name
-    strName = occNameString . nameOccName $ name'
-sugarLists typ = typ
-
-
-sugarTuples :: NamedThing name => HsType name -> HsType name
-sugarTuples typ =
-    aux [] typ
-  where
-    aux apps (HsAppTy (L _ ftyp) atyp) = aux (atyp:apps) ftyp
-    aux apps (HsParTy (L _ typ')) = aux apps typ'
-    aux apps (HsTyVar name)
-        | isBuiltInSyntax name' && suitable = HsTupleTy HsBoxedTuple apps
-      where
-        name' = getName name
-        strName = occNameString . nameOccName $ name'
-        suitable = case parseTupleArity strName of
-            Just arity -> arity == length apps
-            Nothing -> False
-    aux _ _ = typ
-
-
--- | Compute arity of given tuple operator.
---
--- >>> parseTupleArity "(,,)"
--- Just 3
---
--- >>> parseTupleArity "(,,,,)"
--- Just 5
---
--- >>> parseTupleArity "abc"
--- Nothing
---
--- >>> parseTupleArity "()"
--- Nothing
-parseTupleArity :: String -> Maybe Int
-parseTupleArity ('(':commas) = do
-    n <- parseCommas commas
-    guard $ n /= 0
-    return $ n + 1
-  where
-    parseCommas (',':rest) = (+ 1) <$> parseCommas rest
-    parseCommas ")" = Just 0
-    parseCommas _ = Nothing
-parseTupleArity _ = Nothing
-
-
--- | Haskell AST type representation.
---
--- This type is used for renaming (more below), essentially the ambiguous (!)
--- version of 'Name'. So, why is this 'FastString' instead of 'OccName'? Well,
--- it was 'OccName' before, but turned out that 'OccName' sometimes also
--- contains namespace information, differentiating visually same types.
---
--- And 'FastString' is used because it is /visual/ part of 'OccName' - it is
--- not converted to 'String' or alike to avoid new allocations. Additionally,
--- since it is stored mostly in 'Set', fast comparison of 'FastString' is also
--- quite nice.
-type NameRep = FastString
-
-getNameRep :: NamedThing name => name -> NameRep
-getNameRep = occNameFS . getOccName
-
-nameRepString :: NameRep -> String
-nameRepString = unpackFS
-
-stringNameRep :: String -> NameRep
-stringNameRep = mkFastString
-
-setInternalNameRep :: SetName name => NameRep -> name -> name
-setInternalNameRep = setInternalOccName . mkVarOccFS
-
-setInternalOccName :: SetName name => OccName -> name -> name
-setInternalOccName occ name =
-    setName nname' name
-  where
-    nname = getName name
-    nname' = mkInternalName (nameUnique nname) occ (nameSrcSpan nname)
-
-
--- | Compute set of free variables of given type.
-freeVariables :: forall name. (NamedThing name, DataId name)
-              => HsType name -> Set NameRep
-freeVariables =
-    everythingWithState Set.empty Set.union query
-  where
-    query term ctx = case cast term :: Maybe (HsType name) of
-        Just (HsForAllTy _ _ bndrs _ _) ->
-            (Set.empty, Set.union ctx (bndrsNames bndrs))
-        Just (HsTyVar name)
-            | getName name `Set.member` ctx -> (Set.empty, ctx)
-            | otherwise -> (Set.singleton $ getNameRep name, ctx)
-        _ -> (Set.empty, ctx)
-    bndrsNames = Set.fromList . map (getName . tyVarName . unLoc) . hsq_tvs
-
-
--- | Make given type visually unambiguous.
---
--- After applying 'specialize' method, some free type variables may become
--- visually ambiguous - for example, having @a -> b@ and specializing @a@ to
--- @(a -> b)@ we get @(a -> b) -> b@ where first occurrence of @b@ refers to
--- different type variable than latter one. Applying 'rename' function
--- will fix that type to be visually unambiguous again (making it something
--- like @(a -> c) -> b@).
-rename :: SetName name => Set NameRep -> HsType name -> HsType name
-rename fv typ = runReader (renameType typ) $ RenameEnv
-    { rneFV = fv
-    , rneCtx = Map.empty
-    }
-
-
--- | Renaming monad.
-type Rename name = Reader (RenameEnv name)
-
--- | Binding generation monad.
-type Rebind name = State (RenameEnv name)
-
-data RenameEnv name = RenameEnv
-    { rneFV :: Set NameRep
-    , rneCtx :: Map Name name
-    }
-
-
-renameType :: SetName name => HsType name -> Rename name (HsType name)
-renameType (HsForAllTy ex mspan lbndrs lctx lt) = rebind lbndrs $ \lbndrs' ->
-    HsForAllTy
-        <$> pure ex
-        <*> pure mspan
-        <*> pure lbndrs'
-        <*> located renameContext lctx
-        <*> renameLType lt
-renameType (HsTyVar name) = HsTyVar <$> renameName name
-renameType (HsAppTy lf la) = HsAppTy <$> renameLType lf <*> renameLType la
-renameType (HsFunTy la lr) = HsFunTy <$> renameLType la <*> renameLType lr
-renameType (HsListTy lt) = HsListTy <$> renameLType lt
-renameType (HsPArrTy lt) = HsPArrTy <$> renameLType lt
-renameType (HsTupleTy srt lt) = HsTupleTy srt <$> mapM renameLType lt
-renameType (HsOpTy la lop lb) =
-    HsOpTy <$> renameLType la <*> renameLTyOp lop <*> renameLType lb
-renameType (HsParTy lt) = HsParTy <$> renameLType lt
-renameType (HsIParamTy ip lt) = HsIParamTy ip <$> renameLType lt
-renameType (HsEqTy la lb) = HsEqTy <$> renameLType la <*> renameLType lb
-renameType (HsKindSig lt lk) = HsKindSig <$> renameLType lt <*> pure lk
-renameType t@(HsQuasiQuoteTy _) = pure t
-renameType t@(HsSpliceTy _ _) = pure t
-renameType (HsDocTy lt doc) = HsDocTy <$> renameLType lt <*> pure doc
-renameType (HsBangTy bang lt) = HsBangTy bang <$> renameLType lt
-renameType t@(HsRecTy _) = pure t
-renameType t@(HsCoreTy _) = pure t
-renameType (HsExplicitListTy ph ltys) =
-    HsExplicitListTy ph <$> renameLTypes ltys
-renameType (HsExplicitTupleTy phs ltys) =
-    HsExplicitTupleTy phs <$> renameLTypes ltys
-renameType t@(HsTyLit _) = pure t
-renameType (HsWrapTy wrap t) = HsWrapTy wrap <$> renameType t
-renameType HsWildcardTy = pure HsWildcardTy
-renameType (HsNamedWildcardTy name) = HsNamedWildcardTy <$> renameName name
-
-
-renameLType :: SetName name => LHsType name -> Rename name (LHsType name)
-renameLType = located renameType
-
-
-renameLTypes :: SetName name => [LHsType name] -> Rename name [LHsType name]
-renameLTypes = mapM renameLType
-
-
-renameContext :: SetName name => HsContext name -> Rename name (HsContext name)
-renameContext = renameLTypes
-
-
-renameLTyOp :: SetName name => LHsTyOp name -> Rename name (LHsTyOp name)
-renameLTyOp (wrap, lname) = (,) wrap <$> located renameName lname
-
-
-renameName :: SetName name => name -> Rename name name
-renameName name = do
-    RenameEnv { rneCtx = ctx } <- ask
-    pure $ case Map.lookup (getName name) ctx of
-        Just name' -> name'
-        Nothing -> name
-
-
-rebind :: SetName name
-       => LHsTyVarBndrs name -> (LHsTyVarBndrs name -> Rename name a)
-       -> Rename name a
-rebind lbndrs action = do
-    (lbndrs', env') <- runState (rebindLTyVarBndrs lbndrs) <$> ask
-    local (const env') (action lbndrs')
-
-
-rebindLTyVarBndrs :: SetName name
-                  => LHsTyVarBndrs name -> Rebind name (LHsTyVarBndrs name)
-rebindLTyVarBndrs lbndrs = do
-    tys' <- mapM (located rebindTyVarBndr) $ hsq_tvs lbndrs
-    pure $ lbndrs { hsq_tvs = tys' }
-
-
-rebindTyVarBndr :: SetName name
-                => HsTyVarBndr name -> Rebind name (HsTyVarBndr name)
-rebindTyVarBndr (UserTyVar name) =
-    UserTyVar <$> rebindName name
-rebindTyVarBndr (KindedTyVar name kinds) =
-    KindedTyVar <$> located rebindName name <*> pure kinds
-
-
-rebindName :: SetName name => name -> Rebind name name
-rebindName name = do
-    RenameEnv { .. } <- get
-    taken <- takenNames
-    case Map.lookup (getName name) rneCtx of
-        Just name' -> pure name'
-        Nothing | getNameRep name `Set.member` taken -> freshName name
-        Nothing -> reuseName name
-
-
--- | Generate fresh occurrence name, put it into context and return.
-freshName :: SetName name => name -> Rebind name name
-freshName name = do
-    env@RenameEnv { .. } <- get
-    taken <- takenNames
-    let name' = setInternalNameRep (findFreshName taken rep) name
-    put $ env { rneCtx = Map.insert nname name' rneCtx }
-    return name'
-  where
-    nname = getName name
-    rep = getNameRep nname
-
-
-reuseName :: SetName name => name -> Rebind name name
-reuseName name = do
-    env@RenameEnv { .. } <- get
-    put $ env { rneCtx = Map.insert (getName name) name rneCtx }
-    return name
-
-
-takenNames :: NamedThing name => Rebind name (Set NameRep)
-takenNames = do
-    RenameEnv { .. } <- get
-    return $ Set.union rneFV (ctxElems rneCtx)
-  where
-    ctxElems = Set.fromList . map getNameRep . Map.elems
-
-
-findFreshName :: Set NameRep -> NameRep -> NameRep
-findFreshName taken =
-    fromJust . List.find isFresh . alternativeNames
-  where
-    isFresh = not . flip Set.member taken
-
-
-alternativeNames :: NameRep -> [NameRep]
-alternativeNames name
-    | [_] <- nameRepString name = letterNames ++ alternativeNames' name
-  where
-    letterNames = map (stringNameRep . pure) ['a'..'z']
-alternativeNames name = alternativeNames' name
-
-
-alternativeNames' :: NameRep -> [NameRep]
-alternativeNames' name =
-    [ stringNameRep $ str ++ show i | i :: Int <- [0..] ]
-  where
-    str = nameRepString name
-
-
-located :: Functor f => (a -> f b) -> Located a -> f (Located b)
-located f (L loc e) = L loc <$> f e
-
-
-tyVarName :: HsTyVarBndr name -> name
-tyVarName (UserTyVar name) = name
-tyVarName (KindedTyVar (L _ name) _) = name
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 095bd9e0..c9664652 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -25,7 +25,6 @@ import Data.Either (lefts, rights)
 import Data.List( partition )
 import DataCon
 import FamInstEnv
-import Haddock.Types
 import HsSyn
 import Kind ( splitKindFunTys, synTyConResKind, isKind )
 import Name
@@ -41,6 +40,9 @@ import TysWiredIn ( listTyConName, eqTyCon )
 import Unique ( getUnique )
 import Var
 
+import Haddock.Types
+import Haddock.Interface.Specialize
+
 
 
 -- the main function here! yay!
@@ -390,7 +392,7 @@ synifyKindSig :: Kind -> LHsKind Name
 synifyKindSig k = synifyType WithinType k
 
 synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead Name
-synifyInstHead (_, preds, cls, types) = InstHead
+synifyInstHead (_, preds, cls, types) = specializeInstHead $ InstHead
     { ihdClsName = getName cls
     , ihdKinds = map (unLoc . synifyType WithinType) ks
     , ihdTypes = map (unLoc . synifyType WithinType) ts
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
new file mode 100644
index 00000000..df7f63bc
--- /dev/null
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -0,0 +1,396 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RecordWildCards #-}
+
+
+module Haddock.Interface.Specialize
+    ( specializeInstHead
+    ) where
+
+
+import Haddock.Syb
+import Haddock.Types
+
+import GHC
+import Name
+import FastString
+
+import Control.Monad
+import Control.Monad.Trans.Reader
+import Control.Monad.Trans.State
+
+import Data.Data
+import qualified Data.List as List
+import Data.Maybe
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Set (Set)
+import qualified Data.Set as Set
+
+
+-- | Instantiate all occurrences of given name with particular type.
+specialize :: (Eq name, Typeable name)
+           => Data a
+           => name -> HsType name -> a -> a
+specialize name details =
+    everywhere $ mkT step
+  where
+    step (HsTyVar name') | name == name' = details
+    step typ = typ
+
+
+-- | Instantiate all occurrences of given names with corresponding types.
+--
+-- It is just a convenience function wrapping 'specialize' that supports more
+-- that one specialization.
+specialize' :: (Eq name, Typeable name)
+            => Data a
+            => [(name, HsType name)] -> a -> a
+specialize' = flip $ foldr (uncurry specialize)
+
+
+-- | Instantiate given binders with corresponding types.
+--
+-- Again, it is just a convenience function around 'specialize'. Note that
+-- length of type list should be the same as the number of binders.
+specializeTyVarBndrs :: (Eq name, Typeable name, DataId name)
+                     => Data a
+                     => LHsTyVarBndrs name -> [HsType name]
+                     -> a -> a
+specializeTyVarBndrs bndrs typs =
+    specialize' $ zip bndrs' typs
+  where
+    bndrs' = map (bname . unLoc) . hsq_tvs $ bndrs
+    bname (UserTyVar name) = name
+    bname (KindedTyVar (L _ name) _) = name
+
+
+specializePseudoFamilyDecl :: (Eq name, Typeable name, DataId name)
+                           => LHsTyVarBndrs name -> [HsType name]
+                           -> PseudoFamilyDecl name
+                           -> PseudoFamilyDecl name
+specializePseudoFamilyDecl bndrs typs decl =
+    decl { pfdTyVars = map specializeTyVars (pfdTyVars decl) }
+  where
+    specializeTyVars = specializeTyVarBndrs bndrs typs
+
+
+specializeSig :: (Eq name, Typeable name, DataId name, SetName name)
+              => LHsTyVarBndrs name -> [HsType name]
+              -> Sig name
+              -> Sig name
+specializeSig bndrs typs (TypeSig lnames (L loc typ) prn) =
+    TypeSig lnames (L loc typ') prn
+  where
+    typ' = rename fv . sugar $ specializeTyVarBndrs bndrs typs typ
+    fv = foldr Set.union Set.empty . map freeVariables $ typs
+specializeSig _ _ sig = sig
+
+
+specializeInstHead :: (Eq name, Typeable name, DataId name, SetName name)
+                   => InstHead name -> InstHead name
+specializeInstHead ihd@InstHead { ihdInstType = clsi@ClassInst { .. }, .. } =
+    ihd { ihdInstType = instType' }
+  where
+    instType' = clsi
+        { clsiSigs = map specializeSig' clsiSigs
+        , clsiAssocTys = map specializeFamilyDecl' clsiAssocTys
+        }
+    specializeSig' = specializeSig clsiTyVars ihdTypes
+    specializeFamilyDecl' = specializePseudoFamilyDecl clsiTyVars ihdTypes
+specializeInstHead ihd = ihd
+
+
+-- | Make given type use tuple and list literals where appropriate.
+--
+-- After applying 'specialize' function some terms may not use idiomatic list
+-- and tuple literals resulting in types like @[] a@ or @(,,) a b c@. This
+-- can be fixed using 'sugar' function, that will turn such types into @[a]@
+-- and @(a, b, c)@.
+sugar :: forall name. (NamedThing name, DataId name)
+      => HsType name -> HsType name
+sugar =
+    everywhere $ mkT step
+  where
+    step :: HsType name -> HsType name
+    step = sugarTuples . sugarLists
+
+
+sugarLists :: NamedThing name => HsType name -> HsType name
+sugarLists (HsAppTy (L _ (HsTyVar name)) ltyp)
+    | isBuiltInSyntax name' && strName == "[]" = HsListTy ltyp
+  where
+    name' = getName name
+    strName = occNameString . nameOccName $ name'
+sugarLists typ = typ
+
+
+sugarTuples :: NamedThing name => HsType name -> HsType name
+sugarTuples typ =
+    aux [] typ
+  where
+    aux apps (HsAppTy (L _ ftyp) atyp) = aux (atyp:apps) ftyp
+    aux apps (HsParTy (L _ typ')) = aux apps typ'
+    aux apps (HsTyVar name)
+        | isBuiltInSyntax name' && suitable = HsTupleTy HsBoxedTuple apps
+      where
+        name' = getName name
+        strName = occNameString . nameOccName $ name'
+        suitable = case parseTupleArity strName of
+            Just arity -> arity == length apps
+            Nothing -> False
+    aux _ _ = typ
+
+
+-- | Compute arity of given tuple operator.
+--
+-- >>> parseTupleArity "(,,)"
+-- Just 3
+--
+-- >>> parseTupleArity "(,,,,)"
+-- Just 5
+--
+-- >>> parseTupleArity "abc"
+-- Nothing
+--
+-- >>> parseTupleArity "()"
+-- Nothing
+parseTupleArity :: String -> Maybe Int
+parseTupleArity ('(':commas) = do
+    n <- parseCommas commas
+    guard $ n /= 0
+    return $ n + 1
+  where
+    parseCommas (',':rest) = (+ 1) <$> parseCommas rest
+    parseCommas ")" = Just 0
+    parseCommas _ = Nothing
+parseTupleArity _ = Nothing
+
+
+-- | Haskell AST type representation.
+--
+-- This type is used for renaming (more below), essentially the ambiguous (!)
+-- version of 'Name'. So, why is this 'FastString' instead of 'OccName'? Well,
+-- it was 'OccName' before, but turned out that 'OccName' sometimes also
+-- contains namespace information, differentiating visually same types.
+--
+-- And 'FastString' is used because it is /visual/ part of 'OccName' - it is
+-- not converted to 'String' or alike to avoid new allocations. Additionally,
+-- since it is stored mostly in 'Set', fast comparison of 'FastString' is also
+-- quite nice.
+type NameRep = FastString
+
+getNameRep :: NamedThing name => name -> NameRep
+getNameRep = occNameFS . getOccName
+
+nameRepString :: NameRep -> String
+nameRepString = unpackFS
+
+stringNameRep :: String -> NameRep
+stringNameRep = mkFastString
+
+setInternalNameRep :: SetName name => NameRep -> name -> name
+setInternalNameRep = setInternalOccName . mkVarOccFS
+
+setInternalOccName :: SetName name => OccName -> name -> name
+setInternalOccName occ name =
+    setName nname' name
+  where
+    nname = getName name
+    nname' = mkInternalName (nameUnique nname) occ (nameSrcSpan nname)
+
+
+-- | Compute set of free variables of given type.
+freeVariables :: forall name. (NamedThing name, DataId name)
+              => HsType name -> Set NameRep
+freeVariables =
+    everythingWithState Set.empty Set.union query
+  where
+    query term ctx = case cast term :: Maybe (HsType name) of
+        Just (HsForAllTy _ _ bndrs _ _) ->
+            (Set.empty, Set.union ctx (bndrsNames bndrs))
+        Just (HsTyVar name)
+            | getName name `Set.member` ctx -> (Set.empty, ctx)
+            | otherwise -> (Set.singleton $ getNameRep name, ctx)
+        _ -> (Set.empty, ctx)
+    bndrsNames = Set.fromList . map (getName . tyVarName . unLoc) . hsq_tvs
+
+
+-- | Make given type visually unambiguous.
+--
+-- After applying 'specialize' method, some free type variables may become
+-- visually ambiguous - for example, having @a -> b@ and specializing @a@ to
+-- @(a -> b)@ we get @(a -> b) -> b@ where first occurrence of @b@ refers to
+-- different type variable than latter one. Applying 'rename' function
+-- will fix that type to be visually unambiguous again (making it something
+-- like @(a -> c) -> b@).
+rename :: SetName name => Set NameRep -> HsType name -> HsType name
+rename fv typ = runReader (renameType typ) $ RenameEnv
+    { rneFV = fv
+    , rneCtx = Map.empty
+    }
+
+
+-- | Renaming monad.
+type Rename name = Reader (RenameEnv name)
+
+-- | Binding generation monad.
+type Rebind name = State (RenameEnv name)
+
+data RenameEnv name = RenameEnv
+    { rneFV :: Set NameRep
+    , rneCtx :: Map Name name
+    }
+
+
+renameType :: SetName name => HsType name -> Rename name (HsType name)
+renameType (HsForAllTy ex mspan lbndrs lctx lt) = rebind lbndrs $ \lbndrs' ->
+    HsForAllTy
+        <$> pure ex
+        <*> pure mspan
+        <*> pure lbndrs'
+        <*> located renameContext lctx
+        <*> renameLType lt
+renameType (HsTyVar name) = HsTyVar <$> renameName name
+renameType (HsAppTy lf la) = HsAppTy <$> renameLType lf <*> renameLType la
+renameType (HsFunTy la lr) = HsFunTy <$> renameLType la <*> renameLType lr
+renameType (HsListTy lt) = HsListTy <$> renameLType lt
+renameType (HsPArrTy lt) = HsPArrTy <$> renameLType lt
+renameType (HsTupleTy srt lt) = HsTupleTy srt <$> mapM renameLType lt
+renameType (HsOpTy la lop lb) =
+    HsOpTy <$> renameLType la <*> renameLTyOp lop <*> renameLType lb
+renameType (HsParTy lt) = HsParTy <$> renameLType lt
+renameType (HsIParamTy ip lt) = HsIParamTy ip <$> renameLType lt
+renameType (HsEqTy la lb) = HsEqTy <$> renameLType la <*> renameLType lb
+renameType (HsKindSig lt lk) = HsKindSig <$> renameLType lt <*> pure lk
+renameType t@(HsQuasiQuoteTy _) = pure t
+renameType t@(HsSpliceTy _ _) = pure t
+renameType (HsDocTy lt doc) = HsDocTy <$> renameLType lt <*> pure doc
+renameType (HsBangTy bang lt) = HsBangTy bang <$> renameLType lt
+renameType t@(HsRecTy _) = pure t
+renameType t@(HsCoreTy _) = pure t
+renameType (HsExplicitListTy ph ltys) =
+    HsExplicitListTy ph <$> renameLTypes ltys
+renameType (HsExplicitTupleTy phs ltys) =
+    HsExplicitTupleTy phs <$> renameLTypes ltys
+renameType t@(HsTyLit _) = pure t
+renameType (HsWrapTy wrap t) = HsWrapTy wrap <$> renameType t
+renameType HsWildcardTy = pure HsWildcardTy
+renameType (HsNamedWildcardTy name) = HsNamedWildcardTy <$> renameName name
+
+
+renameLType :: SetName name => LHsType name -> Rename name (LHsType name)
+renameLType = located renameType
+
+
+renameLTypes :: SetName name => [LHsType name] -> Rename name [LHsType name]
+renameLTypes = mapM renameLType
+
+
+renameContext :: SetName name => HsContext name -> Rename name (HsContext name)
+renameContext = renameLTypes
+
+
+renameLTyOp :: SetName name => LHsTyOp name -> Rename name (LHsTyOp name)
+renameLTyOp (wrap, lname) = (,) wrap <$> located renameName lname
+
+
+renameName :: SetName name => name -> Rename name name
+renameName name = do
+    RenameEnv { rneCtx = ctx } <- ask
+    pure $ case Map.lookup (getName name) ctx of
+        Just name' -> name'
+        Nothing -> name
+
+
+rebind :: SetName name
+       => LHsTyVarBndrs name -> (LHsTyVarBndrs name -> Rename name a)
+       -> Rename name a
+rebind lbndrs action = do
+    (lbndrs', env') <- runState (rebindLTyVarBndrs lbndrs) <$> ask
+    local (const env') (action lbndrs')
+
+
+rebindLTyVarBndrs :: SetName name
+                  => LHsTyVarBndrs name -> Rebind name (LHsTyVarBndrs name)
+rebindLTyVarBndrs lbndrs = do
+    tys' <- mapM (located rebindTyVarBndr) $ hsq_tvs lbndrs
+    pure $ lbndrs { hsq_tvs = tys' }
+
+
+rebindTyVarBndr :: SetName name
+                => HsTyVarBndr name -> Rebind name (HsTyVarBndr name)
+rebindTyVarBndr (UserTyVar name) =
+    UserTyVar <$> rebindName name
+rebindTyVarBndr (KindedTyVar name kinds) =
+    KindedTyVar <$> located rebindName name <*> pure kinds
+
+
+rebindName :: SetName name => name -> Rebind name name
+rebindName name = do
+    RenameEnv { .. } <- get
+    taken <- takenNames
+    case Map.lookup (getName name) rneCtx of
+        Just name' -> pure name'
+        Nothing | getNameRep name `Set.member` taken -> freshName name
+        Nothing -> reuseName name
+
+
+-- | Generate fresh occurrence name, put it into context and return.
+freshName :: SetName name => name -> Rebind name name
+freshName name = do
+    env@RenameEnv { .. } <- get
+    taken <- takenNames
+    let name' = setInternalNameRep (findFreshName taken rep) name
+    put $ env { rneCtx = Map.insert nname name' rneCtx }
+    return name'
+  where
+    nname = getName name
+    rep = getNameRep nname
+
+
+reuseName :: SetName name => name -> Rebind name name
+reuseName name = do
+    env@RenameEnv { .. } <- get
+    put $ env { rneCtx = Map.insert (getName name) name rneCtx }
+    return name
+
+
+takenNames :: NamedThing name => Rebind name (Set NameRep)
+takenNames = do
+    RenameEnv { .. } <- get
+    return $ Set.union rneFV (ctxElems rneCtx)
+  where
+    ctxElems = Set.fromList . map getNameRep . Map.elems
+
+
+findFreshName :: Set NameRep -> NameRep -> NameRep
+findFreshName taken =
+    fromJust . List.find isFresh . alternativeNames
+  where
+    isFresh = not . flip Set.member taken
+
+
+alternativeNames :: NameRep -> [NameRep]
+alternativeNames name
+    | [_] <- nameRepString name = letterNames ++ alternativeNames' name
+  where
+    letterNames = map (stringNameRep . pure) ['a'..'z']
+alternativeNames name = alternativeNames' name
+
+
+alternativeNames' :: NameRep -> [NameRep]
+alternativeNames' name =
+    [ stringNameRep $ str ++ show i | i :: Int <- [0..] ]
+  where
+    str = nameRepString name
+
+
+located :: Functor f => (a -> f b) -> Located a -> f (Located b)
+located f (L loc e) = L loc <$> f e
+
+
+tyVarName :: HsTyVarBndr name -> name
+tyVarName (UserTyVar name) = name
+tyVarName (KindedTyVar (L _ name) _) = name
diff --git a/haddock.cabal b/haddock.cabal
index 4ea2a82a..71b78347 100644
--- a/haddock.cabal
+++ b/haddock.cabal
@@ -90,6 +90,7 @@ executable haddock
       Haddock.Interface.AttachInstances
       Haddock.Interface.LexParseRn
       Haddock.Interface.ParseModuleHeader
+      Haddock.Interface.Specialize
       Haddock.Parser
       Haddock.Utils
       Haddock.Backends.Xhtml
@@ -97,7 +98,6 @@ executable haddock
       Haddock.Backends.Xhtml.DocMarkup
       Haddock.Backends.Xhtml.Layout
       Haddock.Backends.Xhtml.Names
-      Haddock.Backends.Xhtml.Specialize
       Haddock.Backends.Xhtml.Themes
       Haddock.Backends.Xhtml.Types
       Haddock.Backends.Xhtml.Utils
-- 
cgit v1.2.3


From ca667e192d0867c9c2a3025918414147f50b7c19 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Fri, 31 Jul 2015 12:38:59 +0200
Subject: Fix bug with missing space in documentation for associated types.

---
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 13 ++++---------
 1 file changed, 4 insertions(+), 9 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Xhtml/Decl.hs')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 7da1f08e..af946f9f 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -567,18 +567,13 @@ ppInstHead links splice unicode qual mdoc origin no (InstHead {..}) =
         TypeInst rhs ->
             (ptype, mdoc, [])
           where
-            ptype = mconcat
-                [ keyword "type"
-                , typ
-                , maybe noHtml (\t -> equals <+> ppType unicode qual t) rhs
-                ]
+            ptype = keyword "type" <+> typ <+> prhs
+            prhs = maybe noHtml (\t -> equals <+> ppType unicode qual t) rhs
         DataInst dd ->
             (pdata, mdoc, [])
           where
-            pdata = mconcat
-                [ keyword "data" <+> typ
-                , ppShortDataDecl False True dd unicode qual
-                ]
+            pdata = keyword "data" <+> typ <+> pdecl
+            pdecl = ppShortDataDecl False True dd unicode qual
   where
     typ = ppAppNameTypes ihdClsName ihdKinds ihdTypes unicode qual
 
-- 
cgit v1.2.3


From a49a3f0840f2880814c35f58d89805b3cd3039d3 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Fri, 31 Jul 2015 16:24:36 +0200
Subject: Fix issue with incorrect instance details sections being expanded.

---
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 39 ++++++++++++++++++++++----
 1 file changed, 34 insertions(+), 5 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Xhtml/Decl.hs')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index af946f9f..35e5c5f6 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE TransformListComp #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE Rank2Types #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Haddock.Backends.Html.Decl
@@ -26,8 +27,11 @@ import Haddock.Backends.Xhtml.Types
 import Haddock.Backends.Xhtml.Utils
 import Haddock.GhcUtils
 import Haddock.Types
+import Haddock.Syb
 import Haddock.Doc (combineDocumentation)
 
+import           Data.Bits
+import           Data.Data (Data, cast)
 import           Data.List             ( intersperse, sort )
 import qualified Data.Map as Map
 import           Data.Maybe
@@ -35,6 +39,7 @@ import           Text.XHtml hiding     ( name, title, p, quote )
 
 import GHC
 import GHC.Exts
+import Unique
 import Name
 import BooleanFormula
 
@@ -553,7 +558,7 @@ ppInstances links origin instances baseName splice unicode qual
 ppInstHead :: LinksInfo -> Splice -> Unicode -> Qualification
            -> Maybe (MDoc DocName) -> InstOrigin -> Int -> InstHead DocName
            -> SubDecl
-ppInstHead links splice unicode qual mdoc origin no (InstHead {..}) =
+ppInstHead links splice unicode qual mdoc origin no ihd@(InstHead {..}) =
     case ihdInstType of
         ClassInst { .. } ->
             ( subInstHead iid $ ppContextNoLocs clsiCtx unicode qual <+> typ
@@ -561,7 +566,7 @@ ppInstHead links splice unicode qual mdoc origin no (InstHead {..}) =
             , [subInstDetails iid ats sigs]
             )
           where
-            iid = instanceId origin no ihdClsName
+            iid = instanceId origin no ihd
             sigs = ppInstanceSigs links splice unicode qual clsiSigs
             ats = ppInstanceAssocTys links splice unicode qual clsiAssocTys
         TypeInst rhs ->
@@ -600,15 +605,39 @@ lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2
 lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n
 
 
-instanceId :: InstOrigin -> Int -> DocName -> String
-instanceId orgin no name =
-    qual orgin ++ ":" ++ (occNameString . getOccName) name ++ "-" ++ show no
+instanceId :: InstOrigin -> Int -> InstHead DocName -> String
+instanceId orgin no ihd = concat
+    [ qual orgin
+    , ":" ++ (occNameString . getOccName . ihdClsName) ihd
+    , "-" ++ show (instHeadId ihd)
+    , "-" ++ show no
+    ]
   where
     qual OriginClass = "ic"
     qual OriginData = "id"
     qual OriginFamily = "if"
 
 
+-- | Compute unique identifier for given instance.
+--
+-- This is rather poor way of doing it. Ideally, we would like to have
+-- everything wrapped in a stateful monad that allows us to generate unique
+-- identifiers as needed. Since introducing such monad would require major
+-- refactoring, for now we just generate naive hash for given instance.
+--
+-- Hashing is very, very trivial and turns a list of 'DocName' to 'Int'. Idea
+-- for such simple hash function is stolen from
+-- <http://stackoverflow.com/questions/9262879/create-a-unique-integer-for-each-string here>.
+instHeadId :: InstHead DocName -> Int
+instHeadId (InstHead { .. }) =
+    djb2 . map key $ [ihdClsName] ++ names ihdTypes ++ names ihdKinds
+  where
+    names = everything (++) $
+        maybeToList . (cast :: forall a. Data a => a -> Maybe DocName)
+    djb2 = foldl (\h c -> h * 33 `xor` c) 5381
+    key = getKey . nameUnique . getName
+
+
 -------------------------------------------------------------------------------
 -- * Data & newtype declarations
 -------------------------------------------------------------------------------
-- 
cgit v1.2.3


From 96a118be9d02cc433f0982ca728e5c80a2c4c8af Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Fri, 31 Jul 2015 18:24:40 +0200
Subject: Make section identifier of instance details more GHC-independent.

---
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 22 ++++++++++++++++------
 1 file changed, 16 insertions(+), 6 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Xhtml/Decl.hs')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 35e5c5f6..c30d0e62 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -39,7 +39,6 @@ import           Text.XHtml hiding     ( name, title, p, quote )
 
 import GHC
 import GHC.Exts
-import Unique
 import Name
 import BooleanFormula
 
@@ -609,8 +608,8 @@ instanceId :: InstOrigin -> Int -> InstHead DocName -> String
 instanceId orgin no ihd = concat
     [ qual orgin
     , ":" ++ (occNameString . getOccName . ihdClsName) ihd
-    , "-" ++ show (instHeadId ihd)
-    , "-" ++ show no
+    , ":" ++ show (instHeadId ihd)
+    , ":" ++ show no
     ]
   where
     qual OriginClass = "ic"
@@ -626,16 +625,27 @@ instanceId orgin no ihd = concat
 -- refactoring, for now we just generate naive hash for given instance.
 --
 -- Hashing is very, very trivial and turns a list of 'DocName' to 'Int'. Idea
--- for such simple hash function is stolen from
+-- for such simple hash function (djb2) is stolen from
 -- <http://stackoverflow.com/questions/9262879/create-a-unique-integer-for-each-string here>.
+--
+-- Hashing is performed on string representation of `Name`. Why string instead
+-- of 'Unique' of that 'Name'? That would be much faster and nicer, yes.
+-- However, 'Unique' is not very deterministic, so running it on different
+-- configurations would yield different HTML documents. This is not very bad,
+-- as nobody cares about these identifiers but it would require us to strip
+-- section anchors in testing framework and that is not only inconvenient but
+-- also makes testing less viable. And it is only temporary solution so we can
+-- live with it.
 instHeadId :: InstHead DocName -> Int
 instHeadId (InstHead { .. }) =
     djb2 . map key $ [ihdClsName] ++ names ihdTypes ++ names ihdKinds
   where
     names = everything (++) $
         maybeToList . (cast :: forall a. Data a => a -> Maybe DocName)
-    djb2 = foldl (\h c -> h * 33 `xor` c) 5381
-    key = getKey . nameUnique . getName
+    key = djb2 . occNameString . nameOccName . getName
+
+    djb2 :: Enum a => [a] -> Int
+    djb2 = foldl (\h c -> h * 33 `xor` fromEnum c) 5381
 
 
 -------------------------------------------------------------------------------
-- 
cgit v1.2.3


From 472440c233fccf662ff41193db66c62e7bc6f6d1 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Fri, 31 Jul 2015 20:16:33 +0200
Subject: Make identifier generation also architecture-independent.

---
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs   | 12 ++++---
 html-test/ref/Bug7.html                          |  8 ++---
 html-test/ref/Hash.html                          |  8 ++---
 html-test/ref/HiddenInstances.html               | 16 +++++-----
 html-test/ref/HiddenInstancesB.html              |  8 ++---
 html-test/ref/QuasiExpr.html                     |  4 +--
 html-test/ref/SpuriousSuperclassConstraints.html |  8 ++---
 html-test/ref/Test.html                          |  4 +--
 html-test/ref/TypeFamilies.html                  | 40 ++++++++++++------------
 9 files changed, 55 insertions(+), 53 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Xhtml/Decl.hs')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index c30d0e62..f1203210 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -31,10 +31,12 @@ import Haddock.Syb
 import Haddock.Doc (combineDocumentation)
 
 import           Data.Bits
+import           Data.Char
 import           Data.Data (Data, cast)
 import           Data.List             ( intersperse, sort )
 import qualified Data.Map as Map
 import           Data.Maybe
+import           Data.Word
 import           Text.XHtml hiding     ( name, title, p, quote )
 
 import GHC
@@ -636,16 +638,16 @@ instanceId orgin no ihd = concat
 -- section anchors in testing framework and that is not only inconvenient but
 -- also makes testing less viable. And it is only temporary solution so we can
 -- live with it.
-instHeadId :: InstHead DocName -> Int
+instHeadId :: InstHead DocName -> Word64
 instHeadId (InstHead { .. }) =
-    djb2 . map key $ [ihdClsName] ++ names ihdTypes ++ names ihdKinds
+    djb2 id . map key $ [ihdClsName] ++ names ihdTypes ++ names ihdKinds
   where
     names = everything (++) $
         maybeToList . (cast :: forall a. Data a => a -> Maybe DocName)
-    key = djb2 . occNameString . nameOccName . getName
+    key = djb2 (fromIntegral . ord) . occNameString . nameOccName . getName
 
-    djb2 :: Enum a => [a] -> Int
-    djb2 = foldl (\h c -> h * 33 `xor` fromEnum c) 5381
+    djb2 :: (a -> Word64) -> [a] -> Word64
+    djb2 conv = foldl (\h c -> h * 33 `xor` conv c) 5381
 
 
 -------------------------------------------------------------------------------
diff --git a/html-test/ref/Bug7.html b/html-test/ref/Bug7.html
index f0fbc44d..4c0ba83b 100644
--- a/html-test/ref/Bug7.html
+++ b/html-test/ref/Bug7.html
@@ -106,7 +106,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Bug7.html");};
 	      ><tr
 		><td class="src clearfix"
 		  ><span class="inst-left"
-		    ><div id="control.i:id:Bar:1707333265:1" class="instance expander" onclick="toggleSection('i:id:Bar:1707333265:1')"
+		    ><div id="control.i:id:Bar:207865763473:1" class="instance expander" onclick="toggleSection('i:id:Bar:207865763473:1')"
 		      ><a href=""
 			>Bar</a
 			> <a href=""
@@ -123,7 +123,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Bug7.html");};
 		  ></tr
 		><tr
 		><td colspan="2"
-		  ><div id="section.i:id:Bar:1707333265:1" class="inst-details hide"
+		  ><div id="section.i:id:Bar:207865763473:1" class="inst-details hide"
 		    ></div
 		    ></td
 		  ></tr
@@ -150,7 +150,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Bug7.html");};
 	      ><tr
 		><td class="src clearfix"
 		  ><span class="inst-left"
-		    ><div id="control.i:ic:Bar:1707333265:1" class="instance expander" onclick="toggleSection('i:ic:Bar:1707333265:1')"
+		    ><div id="control.i:ic:Bar:207865763473:1" class="instance expander" onclick="toggleSection('i:ic:Bar:207865763473:1')"
 		      ><a href=""
 			>Bar</a
 			> <a href=""
@@ -167,7 +167,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Bug7.html");};
 		  ></tr
 		><tr
 		><td colspan="2"
-		  ><div id="section.i:ic:Bar:1707333265:1" class="inst-details hide"
+		  ><div id="section.i:ic:Bar:207865763473:1" class="inst-details hide"
 		    ></div
 		    ></td
 		  ></tr
diff --git a/html-test/ref/Hash.html b/html-test/ref/Hash.html
index 1774097f..23a8a9ef 100644
--- a/html-test/ref/Hash.html
+++ b/html-test/ref/Hash.html
@@ -310,7 +310,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Hash.html");};
 		><tr
 		><td class="src clearfix"
 		  ><span class="inst-left"
-		    ><div id="control.i:ic:Hash:111088708:2" class="instance expander" onclick="toggleSection('i:ic:Hash:111088708:2')"
+		    ><div id="control.i:ic:Hash:210564486212:2" class="instance expander" onclick="toggleSection('i:ic:Hash:210564486212:2')"
 		      ><a href=""
 			>Hash</a
 			> <a href=""
@@ -323,7 +323,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Hash.html");};
 		  ></tr
 		><tr
 		><td colspan="2"
-		  ><div id="section.i:ic:Hash:111088708:2" class="inst-details hide"
+		  ><div id="section.i:ic:Hash:210564486212:2" class="inst-details hide"
 		    ><div class="subs methods"
 		      ><p class="caption"
 			>Methods</p
@@ -342,7 +342,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Hash.html");};
 		><tr
 		><td class="src clearfix"
 		  ><span class="inst-left"
-		    ><div id="control.i:ic:Hash:-45-1335198543:3" class="instance expander" onclick="toggleSection('i:ic:Hash:-45-1335198543:3')"
+		    ><div id="control.i:ic:Hash:6952216853681:3" class="instance expander" onclick="toggleSection('i:ic:Hash:6952216853681:3')"
 		      >(<a href=""
 			>Hash</a
 			> a, <a href=""
@@ -357,7 +357,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Hash.html");};
 		  ></tr
 		><tr
 		><td colspan="2"
-		  ><div id="section.i:ic:Hash:-45-1335198543:3" class="inst-details hide"
+		  ><div id="section.i:ic:Hash:6952216853681:3" class="inst-details hide"
 		    ><div class="subs methods"
 		      ><p class="caption"
 			>Methods</p
diff --git a/html-test/ref/HiddenInstances.html b/html-test/ref/HiddenInstances.html
index a8d63550..cefd33c1 100644
--- a/html-test/ref/HiddenInstances.html
+++ b/html-test/ref/HiddenInstances.html
@@ -81,7 +81,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_HiddenInstances.html")
 	      ><tr
 		><td class="src clearfix"
 		  ><span class="inst-left"
-		    ><div id="control.i:ic:VisibleClass:659775798:1" class="instance expander" onclick="toggleSection('i:ic:VisibleClass:659775798:1')"
+		    ><div id="control.i:ic:VisibleClass:9201309550724210998:1" class="instance expander" onclick="toggleSection('i:ic:VisibleClass:9201309550724210998:1')"
 		      ><a href=""
 			>VisibleClass</a
 			> <a href=""
@@ -96,14 +96,14 @@ window.onload = function () {pageLoad();setSynopsis("mini_HiddenInstances.html")
 		  ></tr
 		><tr
 		><td colspan="2"
-		  ><div id="section.i:ic:VisibleClass:659775798:1" class="inst-details hide"
+		  ><div id="section.i:ic:VisibleClass:9201309550724210998:1" class="inst-details hide"
 		    ></div
 		    ></td
 		  ></tr
 		><tr
 		><td class="src clearfix"
 		  ><span class="inst-left"
-		    ><div id="control.i:ic:VisibleClass:13734107:2" class="instance expander" onclick="toggleSection('i:ic:VisibleClass:13734107:2')"
+		    ><div id="control.i:ic:VisibleClass:13853490573166612699:2" class="instance expander" onclick="toggleSection('i:ic:VisibleClass:13853490573166612699:2')"
 		      ><a href=""
 			>VisibleClass</a
 			> <a href=""
@@ -118,7 +118,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_HiddenInstances.html")
 		  ></tr
 		><tr
 		><td colspan="2"
-		  ><div id="section.i:ic:VisibleClass:13734107:2" class="inst-details hide"
+		  ><div id="section.i:ic:VisibleClass:13853490573166612699:2" class="inst-details hide"
 		    ></div
 		    ></td
 		  ></tr
@@ -145,7 +145,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_HiddenInstances.html")
 	      ><tr
 		><td class="src clearfix"
 		  ><span class="inst-left"
-		    ><div id="control.i:id:Num:1345746733:1" class="instance expander" onclick="toggleSection('i:id:Num:1345746733:1')"
+		    ><div id="control.i:id:Num:13830803011052926765:1" class="instance expander" onclick="toggleSection('i:id:Num:13830803011052926765:1')"
 		      ><a href=""
 			>Num</a
 			> <a href=""
@@ -160,7 +160,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_HiddenInstances.html")
 		  ></tr
 		><tr
 		><td colspan="2"
-		  ><div id="section.i:id:Num:1345746733:1" class="inst-details hide"
+		  ><div id="section.i:id:Num:13830803011052926765:1" class="inst-details hide"
 		    ><div class="subs methods"
 		      ><p class="caption"
 			>Methods</p
@@ -233,7 +233,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_HiddenInstances.html")
 		><tr
 		><td class="src clearfix"
 		  ><span class="inst-left"
-		    ><div id="control.i:id:VisibleClass:13734107:2" class="instance expander" onclick="toggleSection('i:id:VisibleClass:13734107:2')"
+		    ><div id="control.i:id:VisibleClass:13853490573166612699:2" class="instance expander" onclick="toggleSection('i:id:VisibleClass:13853490573166612699:2')"
 		      ><a href=""
 			>VisibleClass</a
 			> <a href=""
@@ -248,7 +248,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_HiddenInstances.html")
 		  ></tr
 		><tr
 		><td colspan="2"
-		  ><div id="section.i:id:VisibleClass:13734107:2" class="inst-details hide"
+		  ><div id="section.i:id:VisibleClass:13853490573166612699:2" class="inst-details hide"
 		    ></div
 		    ></td
 		  ></tr
diff --git a/html-test/ref/HiddenInstancesB.html b/html-test/ref/HiddenInstancesB.html
index 13301ca2..3d64671e 100644
--- a/html-test/ref/HiddenInstancesB.html
+++ b/html-test/ref/HiddenInstancesB.html
@@ -81,7 +81,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_HiddenInstancesB.html"
 	      ><tr
 		><td class="src clearfix"
 		  ><span class="inst-left"
-		    ><div id="control.i:ic:Foo:2007140402:1" class="instance expander" onclick="toggleSection('i:ic:Foo:2007140402:1')"
+		    ><div id="control.i:ic:Foo:6302107698:1" class="instance expander" onclick="toggleSection('i:ic:Foo:6302107698:1')"
 		      ><a href=""
 			>Foo</a
 			> <a href=""
@@ -96,7 +96,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_HiddenInstancesB.html"
 		  ></tr
 		><tr
 		><td colspan="2"
-		  ><div id="section.i:ic:Foo:2007140402:1" class="inst-details hide"
+		  ><div id="section.i:ic:Foo:6302107698:1" class="inst-details hide"
 		    ></div
 		    ></td
 		  ></tr
@@ -123,7 +123,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_HiddenInstancesB.html"
 	      ><tr
 		><td class="src clearfix"
 		  ><span class="inst-left"
-		    ><div id="control.i:id:Foo:2007140402:1" class="instance expander" onclick="toggleSection('i:id:Foo:2007140402:1')"
+		    ><div id="control.i:id:Foo:6302107698:1" class="instance expander" onclick="toggleSection('i:id:Foo:6302107698:1')"
 		      ><a href=""
 			>Foo</a
 			> <a href=""
@@ -138,7 +138,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_HiddenInstancesB.html"
 		  ></tr
 		><tr
 		><td colspan="2"
-		  ><div id="section.i:id:Foo:2007140402:1" class="inst-details hide"
+		  ><div id="section.i:id:Foo:6302107698:1" class="inst-details hide"
 		    ></div
 		    ></td
 		  ></tr
diff --git a/html-test/ref/QuasiExpr.html b/html-test/ref/QuasiExpr.html
index 02f480fc..486ed8de 100644
--- a/html-test/ref/QuasiExpr.html
+++ b/html-test/ref/QuasiExpr.html
@@ -109,7 +109,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_QuasiExpr.html");};
 	      ><tr
 		><td class="src clearfix"
 		  ><span class="inst-left"
-		    ><div id="control.i:id:Show:1911009977:1" class="instance expander" onclick="toggleSection('i:id:Show:1911009977:1')"
+		    ><div id="control.i:id:Show:208069440185:1" class="instance expander" onclick="toggleSection('i:id:Show:208069440185:1')"
 		      ><a href=""
 			>Show</a
 			> <a href=""
@@ -122,7 +122,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_QuasiExpr.html");};
 		  ></tr
 		><tr
 		><td colspan="2"
-		  ><div id="section.i:id:Show:1911009977:1" class="inst-details hide"
+		  ><div id="section.i:id:Show:208069440185:1" class="inst-details hide"
 		    ><div class="subs methods"
 		      ><p class="caption"
 			>Methods</p
diff --git a/html-test/ref/SpuriousSuperclassConstraints.html b/html-test/ref/SpuriousSuperclassConstraints.html
index e4aef67a..7b3c0967 100644
--- a/html-test/ref/SpuriousSuperclassConstraints.html
+++ b/html-test/ref/SpuriousSuperclassConstraints.html
@@ -85,7 +85,7 @@ Fix spurious superclass constraints bug.</pre
 	      ><tr
 		><td class="src clearfix"
 		  ><span class="inst-left"
-		    ><div id="control.i:id:Functor:-45-1648444259:1" class="instance expander" onclick="toggleSection('i:id:Functor:-45-1648444259:1')"
+		    ><div id="control.i:id:Functor:125458641239197:1" class="instance expander" onclick="toggleSection('i:id:Functor:125458641239197:1')"
 		      ><a href=""
 			>Functor</a
 			> (<a href=""
@@ -98,7 +98,7 @@ Fix spurious superclass constraints bug.</pre
 		  ></tr
 		><tr
 		><td colspan="2"
-		  ><div id="section.i:id:Functor:-45-1648444259:1" class="inst-details hide"
+		  ><div id="section.i:id:Functor:125458641239197:1" class="inst-details hide"
 		    ><div class="subs methods"
 		      ><p class="caption"
 			>Methods</p
@@ -125,7 +125,7 @@ Fix spurious superclass constraints bug.</pre
 		><tr
 		><td class="src clearfix"
 		  ><span class="inst-left"
-		    ><div id="control.i:id:Applicative:-45-1896307582:2" class="instance expander" onclick="toggleSection('i:id:Applicative:-45-1896307582:2')"
+		    ><div id="control.i:id:Applicative:18341860631142507650:2" class="instance expander" onclick="toggleSection('i:id:Applicative:18341860631142507650:2')"
 		      ><a href=""
 			>Applicative</a
 			> f =&gt; <a href=""
@@ -140,7 +140,7 @@ Fix spurious superclass constraints bug.</pre
 		  ></tr
 		><tr
 		><td colspan="2"
-		  ><div id="section.i:id:Applicative:-45-1896307582:2" class="inst-details hide"
+		  ><div id="section.i:id:Applicative:18341860631142507650:2" class="inst-details hide"
 		    ><div class="subs methods"
 		      ><p class="caption"
 			>Methods</p
diff --git a/html-test/ref/Test.html b/html-test/ref/Test.html
index 6c972b23..b5b39c61 100644
--- a/html-test/ref/Test.html
+++ b/html-test/ref/Test.html
@@ -1531,7 +1531,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Test.html");};
 	      ><tr
 		><td class="src clearfix"
 		  ><span class="inst-left"
-		    ><div id="control.i:ic:D:207047825:1" class="instance expander" onclick="toggleSection('i:ic:D:207047825:1')"
+		    ><div id="control.i:ic:D:210660445329:1" class="instance expander" onclick="toggleSection('i:ic:D:210660445329:1')"
 		      ><a href=""
 			>D</a
 			> <a href=""
@@ -1544,7 +1544,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Test.html");};
 		  ></tr
 		><tr
 		><td colspan="2"
-		  ><div id="section.i:ic:D:207047825:1" class="inst-details hide"
+		  ><div id="section.i:ic:D:210660445329:1" class="inst-details hide"
 		    ><div class="subs methods"
 		      ><p class="caption"
 			>Methods</p
diff --git a/html-test/ref/TypeFamilies.html b/html-test/ref/TypeFamilies.html
index 10339d97..99f68889 100644
--- a/html-test/ref/TypeFamilies.html
+++ b/html-test/ref/TypeFamilies.html
@@ -213,7 +213,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_TypeFamilies.html");};
 	      ><tr
 		><td class="src clearfix"
 		  ><span class="inst-left"
-		    ><div id="control.i:id:Assoc:784462559:1" class="instance expander" onclick="toggleSection('i:id:Assoc:784462559:1')"
+		    ><div id="control.i:id:Assoc:229407872643807:1" class="instance expander" onclick="toggleSection('i:id:Assoc:229407872643807:1')"
 		      ><a href=""
 			>Assoc</a
 			> * <a href=""
@@ -228,7 +228,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_TypeFamilies.html");};
 		  ></tr
 		><tr
 		><td colspan="2"
-		  ><div id="section.i:id:Assoc:784462559:1" class="inst-details hide"
+		  ><div id="section.i:id:Assoc:229407872643807:1" class="inst-details hide"
 		    ><div class="subs associated-types"
 		      ><p class="caption"
 			>Associated Types</p
@@ -255,7 +255,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_TypeFamilies.html");};
 		><tr
 		><td class="src clearfix"
 		  ><span class="inst-left"
-		    ><div id="control.i:id:Test:-45-897274780:2" class="instance expander" onclick="toggleSection('i:id:Test:-45-897274780:2')"
+		    ><div id="control.i:id:Test:6952654777444:2" class="instance expander" onclick="toggleSection('i:id:Test:6952654777444:2')"
 		      ><a href=""
 			>Test</a
 			> * <a href=""
@@ -270,14 +270,14 @@ window.onload = function () {pageLoad();setSynopsis("mini_TypeFamilies.html");};
 		  ></tr
 		><tr
 		><td colspan="2"
-		  ><div id="section.i:id:Test:-45-897274780:2" class="inst-details hide"
+		  ><div id="section.i:id:Test:6952654777444:2" class="inst-details hide"
 		    ></div
 		    ></td
 		  ></tr
 		><tr
 		><td class="src clearfix"
 		  ><span class="inst-left"
-		    ><div id="control.i:id:-62--60-:1404642119:3" class="instance expander" onclick="toggleSection('i:id:-62--60-:1404642119:3')"
+		    ><div id="control.i:id:-62--60-:207563072327:3" class="instance expander" onclick="toggleSection('i:id:-62--60-:207563072327:3')"
 		      ><a href=""
 			>(&gt;&lt;)</a
 			> <a href=""
@@ -294,7 +294,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_TypeFamilies.html");};
 		  ></tr
 		><tr
 		><td colspan="2"
-		  ><div id="section.i:id:-62--60-:1404642119:3" class="inst-details hide"
+		  ><div id="section.i:id:-62--60-:207563072327:3" class="inst-details hide"
 		    ></div
 		    ></td
 		  ></tr
@@ -469,7 +469,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_TypeFamilies.html");};
 	      ><tr
 		><td class="src clearfix"
 		  ><span class="inst-left"
-		    ><div id="control.i:id:Assoc:784462590:1" class="instance expander" onclick="toggleSection('i:id:Assoc:784462590:1')"
+		    ><div id="control.i:id:Assoc:229407872643838:1" class="instance expander" onclick="toggleSection('i:id:Assoc:229407872643838:1')"
 		      ><a href=""
 			>Assoc</a
 			> * <a href=""
@@ -484,7 +484,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_TypeFamilies.html");};
 		  ></tr
 		><tr
 		><td colspan="2"
-		  ><div id="section.i:id:Assoc:784462590:1" class="inst-details hide"
+		  ><div id="section.i:id:Assoc:229407872643838:1" class="inst-details hide"
 		    ><div class="subs associated-types"
 		      ><p class="caption"
 			>Associated Types</p
@@ -511,7 +511,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_TypeFamilies.html");};
 		><tr
 		><td class="src clearfix"
 		  ><span class="inst-left"
-		    ><div id="control.i:id:Test:-45-897274811:2" class="instance expander" onclick="toggleSection('i:id:Test:-45-897274811:2')"
+		    ><div id="control.i:id:Test:6952654777413:2" class="instance expander" onclick="toggleSection('i:id:Test:6952654777413:2')"
 		      ><a href=""
 			>Test</a
 			> * <a href=""
@@ -526,7 +526,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_TypeFamilies.html");};
 		  ></tr
 		><tr
 		><td colspan="2"
-		  ><div id="section.i:id:Test:-45-897274811:2" class="inst-details hide"
+		  ><div id="section.i:id:Test:6952654777413:2" class="inst-details hide"
 		    ></div
 		    ></td
 		  ></tr
@@ -751,7 +751,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_TypeFamilies.html");};
 	      ><tr
 		><td class="src clearfix"
 		  ><span class="inst-left"
-		    ><div id="control.i:ic:Test:-45-897274811:1" class="instance expander" onclick="toggleSection('i:ic:Test:-45-897274811:1')"
+		    ><div id="control.i:ic:Test:6952654777413:1" class="instance expander" onclick="toggleSection('i:ic:Test:6952654777413:1')"
 		      ><a href=""
 			>Test</a
 			> * <a href=""
@@ -766,14 +766,14 @@ window.onload = function () {pageLoad();setSynopsis("mini_TypeFamilies.html");};
 		  ></tr
 		><tr
 		><td colspan="2"
-		  ><div id="section.i:ic:Test:-45-897274811:1" class="inst-details hide"
+		  ><div id="section.i:ic:Test:6952654777413:1" class="inst-details hide"
 		    ></div
 		    ></td
 		  ></tr
 		><tr
 		><td class="src clearfix"
 		  ><span class="inst-left"
-		    ><div id="control.i:ic:Test:-45-897274780:2" class="instance expander" onclick="toggleSection('i:ic:Test:-45-897274780:2')"
+		    ><div id="control.i:ic:Test:6952654777444:2" class="instance expander" onclick="toggleSection('i:ic:Test:6952654777444:2')"
 		      ><a href=""
 			>Test</a
 			> * <a href=""
@@ -788,7 +788,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_TypeFamilies.html");};
 		  ></tr
 		><tr
 		><td colspan="2"
-		  ><div id="section.i:ic:Test:-45-897274780:2" class="inst-details hide"
+		  ><div id="section.i:ic:Test:6952654777444:2" class="inst-details hide"
 		    ></div
 		    ></td
 		  ></tr
@@ -1033,7 +1033,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_TypeFamilies.html");};
 	      ><tr
 		><td class="src clearfix"
 		  ><span class="inst-left"
-		    ><div id="control.i:ic:Assoc:784462590:1" class="instance expander" onclick="toggleSection('i:ic:Assoc:784462590:1')"
+		    ><div id="control.i:ic:Assoc:229407872643838:1" class="instance expander" onclick="toggleSection('i:ic:Assoc:229407872643838:1')"
 		      ><a href=""
 			>Assoc</a
 			> * <a href=""
@@ -1048,7 +1048,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_TypeFamilies.html");};
 		  ></tr
 		><tr
 		><td colspan="2"
-		  ><div id="section.i:ic:Assoc:784462590:1" class="inst-details hide"
+		  ><div id="section.i:ic:Assoc:229407872643838:1" class="inst-details hide"
 		    ><div class="subs associated-types"
 		      ><p class="caption"
 			>Associated Types</p
@@ -1075,7 +1075,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_TypeFamilies.html");};
 		><tr
 		><td class="src clearfix"
 		  ><span class="inst-left"
-		    ><div id="control.i:ic:Assoc:784462559:2" class="instance expander" onclick="toggleSection('i:ic:Assoc:784462559:2')"
+		    ><div id="control.i:ic:Assoc:229407872643807:2" class="instance expander" onclick="toggleSection('i:ic:Assoc:229407872643807:2')"
 		      ><a href=""
 			>Assoc</a
 			> * <a href=""
@@ -1090,7 +1090,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_TypeFamilies.html");};
 		  ></tr
 		><tr
 		><td colspan="2"
-		  ><div id="section.i:ic:Assoc:784462559:2" class="inst-details hide"
+		  ><div id="section.i:ic:Assoc:229407872643807:2" class="inst-details hide"
 		    ><div class="subs associated-types"
 		      ><p class="caption"
 			>Associated Types</p
@@ -1239,7 +1239,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_TypeFamilies.html");};
 	      ><tr
 		><td class="src clearfix"
 		  ><span class="inst-left"
-		    ><div id="control.i:ic:-62--60-:1404642119:1" class="instance expander" onclick="toggleSection('i:ic:-62--60-:1404642119:1')"
+		    ><div id="control.i:ic:-62--60-:207563072327:1" class="instance expander" onclick="toggleSection('i:ic:-62--60-:207563072327:1')"
 		      ><a href=""
 			>(&gt;&lt;)</a
 			> <a href=""
@@ -1256,7 +1256,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_TypeFamilies.html");};
 		  ></tr
 		><tr
 		><td colspan="2"
-		  ><div id="section.i:ic:-62--60-:1404642119:1" class="inst-details hide"
+		  ><div id="section.i:ic:-62--60-:207563072327:1" class="inst-details hide"
 		    ></div
 		    ></td
 		  ></tr
-- 
cgit v1.2.3


From 2f0d25e3d3f15b05f904fd3ca74e567f2fec4b93 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Mon, 3 Aug 2015 15:47:53 +0200
Subject: Get rid of dreadful hashing function for generating identifiers.

---
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 77 +++++++++-----------------
 1 file changed, 26 insertions(+), 51 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Xhtml/Decl.hs')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index f1203210..20ca8e2b 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -27,16 +27,11 @@ import Haddock.Backends.Xhtml.Types
 import Haddock.Backends.Xhtml.Utils
 import Haddock.GhcUtils
 import Haddock.Types
-import Haddock.Syb
 import Haddock.Doc (combineDocumentation)
 
-import           Data.Bits
-import           Data.Char
-import           Data.Data (Data, cast)
 import           Data.List             ( intersperse, sort )
 import qualified Data.Map as Map
 import           Data.Maybe
-import           Data.Word
 import           Text.XHtml hiding     ( name, title, p, quote )
 
 import GHC
@@ -297,7 +292,7 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode
       = subEquations qual $ map (ppTyFamEqn . unLoc) eqns
 
       | otherwise
-      = ppInstances links OriginFamily instances docname splice unicode qual
+      = ppInstances links (OriginFamily docname) instances splice unicode qual
 
     -- Individual equation of a closed type family
     ppTyFamEqn TyFamEqn { tfe_tycon = n, tfe_rhs = rhs
@@ -533,31 +528,42 @@ ppClassDecl summary links instances fixities loc d subdocs
     ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a+++" | "+++b) $ map (ppMinimal False) fs
       where wrap | p = parens | otherwise = id
 
-    instancesBit = ppInstances links OriginClass instances nm
+    instancesBit = ppInstances links (OriginClass nm) instances
         splice unicode qual
 
 ppClassDecl _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
 
 
-data InstOrigin = OriginClass | OriginData | OriginFamily
+data InstOrigin name
+    = OriginClass name
+    | OriginData name
+    | OriginFamily name
+
+
+instance NamedThing name => NamedThing (InstOrigin name) where
+
+    getName (OriginClass name) = getName name
+    getName (OriginData name) = getName name
+    getName (OriginFamily name) = getName name
 
 
 ppInstances :: LinksInfo
-            -> InstOrigin -> [DocInstance DocName] -> DocName
+            -> InstOrigin DocName -> [DocInstance DocName]
             -> Splice -> Unicode -> Qualification
             -> Html
-ppInstances links origin instances baseName splice unicode qual
+ppInstances links origin instances splice unicode qual
   = subInstances qual instName links True (zipWith instDecl [1..] instances)
   -- force Splice = True to use line URLs
   where
-    instName = getOccString $ getName baseName
+    instName = getOccString origin
     instDecl :: Int -> DocInstance DocName -> (SubDecl,Located DocName)
     instDecl no (inst, mdoc, loc) =
         ((ppInstHead links splice unicode qual mdoc origin no inst), loc)
 
 
 ppInstHead :: LinksInfo -> Splice -> Unicode -> Qualification
-           -> Maybe (MDoc DocName) -> InstOrigin -> Int -> InstHead DocName
+           -> Maybe (MDoc DocName)
+           -> InstOrigin DocName -> Int -> InstHead DocName
            -> SubDecl
 ppInstHead links splice unicode qual mdoc origin no ihd@(InstHead {..}) =
     case ihdInstType of
@@ -606,48 +612,17 @@ lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2
 lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n
 
 
-instanceId :: InstOrigin -> Int -> InstHead DocName -> String
-instanceId orgin no ihd = concat
-    [ qual orgin
+instanceId :: InstOrigin DocName -> Int -> InstHead DocName -> String
+instanceId origin no ihd = concat
+    [ qual origin
+    , ":" ++ getOccString origin
     , ":" ++ (occNameString . getOccName . ihdClsName) ihd
-    , ":" ++ show (instHeadId ihd)
     , ":" ++ show no
     ]
   where
-    qual OriginClass = "ic"
-    qual OriginData = "id"
-    qual OriginFamily = "if"
-
-
--- | Compute unique identifier for given instance.
---
--- This is rather poor way of doing it. Ideally, we would like to have
--- everything wrapped in a stateful monad that allows us to generate unique
--- identifiers as needed. Since introducing such monad would require major
--- refactoring, for now we just generate naive hash for given instance.
---
--- Hashing is very, very trivial and turns a list of 'DocName' to 'Int'. Idea
--- for such simple hash function (djb2) is stolen from
--- <http://stackoverflow.com/questions/9262879/create-a-unique-integer-for-each-string here>.
---
--- Hashing is performed on string representation of `Name`. Why string instead
--- of 'Unique' of that 'Name'? That would be much faster and nicer, yes.
--- However, 'Unique' is not very deterministic, so running it on different
--- configurations would yield different HTML documents. This is not very bad,
--- as nobody cares about these identifiers but it would require us to strip
--- section anchors in testing framework and that is not only inconvenient but
--- also makes testing less viable. And it is only temporary solution so we can
--- live with it.
-instHeadId :: InstHead DocName -> Word64
-instHeadId (InstHead { .. }) =
-    djb2 id . map key $ [ihdClsName] ++ names ihdTypes ++ names ihdKinds
-  where
-    names = everything (++) $
-        maybeToList . (cast :: forall a. Data a => a -> Maybe DocName)
-    key = djb2 (fromIntegral . ord) . occNameString . nameOccName . getName
-
-    djb2 :: (a -> Word64) -> [a] -> Word64
-    djb2 conv = foldl (\h c -> h * 33 `xor` conv c) 5381
+    qual (OriginClass _) = "ic"
+    qual (OriginData _) = "id"
+    qual (OriginFamily _) = "if"
 
 
 -------------------------------------------------------------------------------
@@ -715,7 +690,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl
                                      (map unLoc (con_names (unLoc c)))) fixities
       ]
 
-    instancesBit = ppInstances links OriginData instances docname
+    instancesBit = ppInstances links (OriginData docname) instances
         splice unicode qual
 
 
-- 
cgit v1.2.3


From e46cf071f018a1145ed96c463375c42d40382e35 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Mon, 3 Aug 2015 15:54:18 +0200
Subject: Move `InstOrigin` type declaration to more appropriate module.

---
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 13 -------------
 haddock-api/src/Haddock/Types.hs               | 18 ++++++++++++++++++
 2 files changed, 18 insertions(+), 13 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Xhtml/Decl.hs')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 20ca8e2b..e536ae4b 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -534,19 +534,6 @@ ppClassDecl summary links instances fixities loc d subdocs
 ppClassDecl _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
 
 
-data InstOrigin name
-    = OriginClass name
-    | OriginData name
-    | OriginFamily name
-
-
-instance NamedThing name => NamedThing (InstOrigin name) where
-
-    getName (OriginClass name) = getName name
-    getName (OriginData name) = getName name
-    getName (OriginFamily name) = getName name
-
-
 ppInstances :: LinksInfo
             -> InstOrigin DocName -> [DocInstance DocName]
             -> Splice -> Unicode -> Qualification
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 1f074ac3..106d3544 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -384,6 +384,24 @@ data InstHead name = InstHead
     , ihdInstType :: InstType name
     }
 
+
+-- | An instance origin information.
+--
+-- This is used primarily in HTML backend to generate unique instance
+-- identifiers (for expandable sections).
+data InstOrigin name
+    = OriginClass name
+    | OriginData name
+    | OriginFamily name
+
+
+instance NamedThing name => NamedThing (InstOrigin name) where
+
+    getName (OriginClass name) = getName name
+    getName (OriginData name) = getName name
+    getName (OriginFamily name) = getName name
+
+
 -----------------------------------------------------------------------------
 -- * Documentation comments
 -----------------------------------------------------------------------------
-- 
cgit v1.2.3


From 45ca97d6b02d92924c0aa2a25ba7a940c70cf9aa Mon Sep 17 00:00:00 2001
From: Simon Peyton Jones <simonpj@microsoft.com>
Date: Tue, 10 Feb 2015 12:10:33 +0000
Subject: Track changes in HsSyn for quasi-quotes

---
 haddock-api/src/Haddock/Backends/LaTeX.hs      | 1 -
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 1 -
 haddock-api/src/Haddock/Interface/Rename.hs    | 4 ----
 3 files changed, 6 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Xhtml/Decl.hs')

diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 24779a94..fde12350 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -913,7 +913,6 @@ ppr_mono_ty _         (HsListTy ty)       u = brackets (ppr_mono_lty pREC_TOP ty
 ppr_mono_ty _         (HsPArrTy ty)       u = pabrackets (ppr_mono_lty pREC_TOP ty u)
 ppr_mono_ty _         (HsIParamTy n ty)   u = brackets (ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u)
 ppr_mono_ty _         (HsSpliceTy {})     _ = error "ppr_mono_ty HsSpliceTy"
-ppr_mono_ty _         (HsQuasiQuoteTy {}) _ = error "ppr_mono_ty HsQuasiQuoteTy"
 ppr_mono_ty _         (HsRecTy {})        _ = error "ppr_mono_ty HsRecTy"
 ppr_mono_ty _         (HsCoreTy {})       _ = error "ppr_mono_ty HsCoreTy"
 ppr_mono_ty _         (HsExplicitListTy _ tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index e536ae4b..3ac443a4 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -968,7 +968,6 @@ ppr_mono_ty _         (HsPArrTy ty)       u q = pabrackets (ppr_mono_lty pREC_TO
 ppr_mono_ty ctxt_prec (HsIParamTy n ty)   u q =
     maybeParen ctxt_prec pREC_CTX $ ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q
 ppr_mono_ty _         (HsSpliceTy {})     _ _ = error "ppr_mono_ty HsSpliceTy"
-ppr_mono_ty _         (HsQuasiQuoteTy {}) _ _ = error "ppr_mono_ty HsQuasiQuoteTy"
 ppr_mono_ty _         (HsRecTy {})        _ _ = error "ppr_mono_ty HsRecTy"
 ppr_mono_ty _         (HsCoreTy {})       _ _ = error "ppr_mono_ty HsCoreTy"
 ppr_mono_ty _         (HsExplicitListTy _ tys) u q =
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 146a7c0b..9d848122 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -230,14 +230,10 @@ renameType t = case t of
   HsCoreTy a              -> pure (HsCoreTy a)
   HsExplicitListTy  a b   -> HsExplicitListTy  a <$> mapM renameLType b
   HsExplicitTupleTy a b   -> HsExplicitTupleTy a <$> mapM renameLType b
-  HsQuasiQuoteTy a        -> HsQuasiQuoteTy <$> renameHsQuasiQuote a
   HsSpliceTy _ _          -> error "renameType: HsSpliceTy"
   HsWildcardTy            -> pure HsWildcardTy
   HsNamedWildcardTy a     -> HsNamedWildcardTy <$> rename a
 
-renameHsQuasiQuote :: HsQuasiQuote Name -> RnM (HsQuasiQuote DocName)
-renameHsQuasiQuote (HsQuasiQuote a b c) = HsQuasiQuote <$> rename a <*> pure b <*> pure c
-
 renameLTyVarBndrs :: LHsTyVarBndrs Name -> RnM (LHsTyVarBndrs DocName)
 renameLTyVarBndrs (HsQTvs { hsq_kvs = _, hsq_tvs = tvs })
   = do { tvs' <- mapM renameLTyVarBndr tvs
-- 
cgit v1.2.3


From b731a89153266e29f160a76f3ebaaa3a4621f199 Mon Sep 17 00:00:00 2001
From: Adam Gundry <adam@well-typed.com>
Date: Mon, 4 May 2015 15:32:59 +0100
Subject: Track API changes to support empty closed type familes

---
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs |  4 ++--
 haddock-api/src/Haddock/Convert.hs             | 16 ++++++++++------
 haddock-api/src/Haddock/Interface/Rename.hs    |  2 +-
 3 files changed, 13 insertions(+), 9 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Xhtml/Decl.hs')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 3ac443a4..651060c1 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -287,9 +287,9 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode
        ppTyFamHeader summary associated decl unicode qual <+> ppFixities fixities qual
 
     instancesBit
-      | FamilyDecl { fdInfo = ClosedTypeFamily eqns } <- decl
+      | FamilyDecl { fdInfo = ClosedTypeFamily mb_eqns } <- decl
       , not summary
-      = subEquations qual $ map (ppTyFamEqn . unLoc) eqns
+      = subEquations qual $ map (ppTyFamEqn . unLoc) $ fromMaybe [] mb_eqns
 
       | otherwise
       = ppInstances links (OriginFamily docname) instances splice unicode qual
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 2bd111d6..dd577319 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -132,7 +132,7 @@ synifyAxiom ax@(CoAxiom { co_ax_tc = tc })
                     (TyFamInstDecl { tfid_eqn = noLoc $ synifyAxBranch tc branch
                                    , tfid_fvs = placeHolderNamesTc }))
 
-  | Just ax' <- isClosedSynFamilyTyCon_maybe tc
+  | Just ax' <- isClosedSynFamilyTyConWithAxiom_maybe tc
   , getUnique ax' == getUnique ax   -- without the getUniques, type error
   = synifyTyCon (Just ax) tc >>= return . TyClD
 
@@ -169,11 +169,15 @@ synifyTyCon coax tc
       Just rhs ->
         let info = case rhs of
               OpenSynFamilyTyCon -> return OpenTypeFamily
-              ClosedSynFamilyTyCon (CoAxiom { co_ax_branches = branches }) ->
-                return $ ClosedTypeFamily
-                  (brListMap (noLoc . synifyAxBranch tc) branches)
-              BuiltInSynFamTyCon {} -> return $ ClosedTypeFamily []
-              AbstractClosedSynFamilyTyCon {} -> return $ ClosedTypeFamily []
+              ClosedSynFamilyTyCon mb -> case mb of
+                  Just (CoAxiom { co_ax_branches = branches })
+                          -> return $ ClosedTypeFamily $ Just $
+                               brListMap (noLoc . synifyAxBranch tc) branches
+                  Nothing -> return $ ClosedTypeFamily $ Just []
+              BuiltInSynFamTyCon {}
+                -> return $ ClosedTypeFamily $ Just []
+              AbstractClosedSynFamilyTyCon {}
+                -> return $ ClosedTypeFamily Nothing
         in info >>= \i ->
            return (FamDecl
                    (FamilyDecl { fdInfo = i
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 9d848122..110c9a42 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -362,7 +362,7 @@ renameFamilyInfo :: FamilyInfo Name -> RnM (FamilyInfo DocName)
 renameFamilyInfo DataFamily     = return DataFamily
 renameFamilyInfo OpenTypeFamily = return OpenTypeFamily
 renameFamilyInfo (ClosedTypeFamily eqns)
-  = do { eqns' <- mapM renameLTyFamInstEqn eqns
+  = do { eqns' <- mapM (mapM renameLTyFamInstEqn) eqns
        ; return $ ClosedTypeFamily eqns' }
 
 renameDataDefn :: HsDataDefn Name -> RnM (HsDataDefn DocName)
-- 
cgit v1.2.3


From bf4041f408623536bd9684586f5736d5ca7f12dd Mon Sep 17 00:00:00 2001
From: Thomas Winant <thomas.winant@cs.kuleuven.be>
Date: Mon, 8 Jun 2015 23:47:28 -0500
Subject: Update after wild card renaming refactoring in D613

Summary:
* Move `Post*` type instances to `Haddock.Types` as other modules than
  `Haddock.Interface.Rename` will rely on these type instances.
* Update after wild card renaming refactoring in D613.

Reviewers: simonpj, austin

Reviewed By: austin

Differential Revision: https://phabricator.haskell.org/D954

GHC Trac Issues: #10098
---
 haddock-api/src/Haddock/Backends/LaTeX.hs      | 12 +++++++-----
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 12 +++++++-----
 haddock-api/src/Haddock/Interface/Rename.hs    |  7 +++++--
 haddock-api/src/Haddock/Types.hs               | 16 ++++++++++++++++
 4 files changed, 35 insertions(+), 12 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Xhtml/Decl.hs')

diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index fde12350..7d9ceaec 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -900,9 +900,11 @@ ppr_mono_ty :: Int -> HsType DocName -> Bool -> LaTeX
 ppr_mono_ty ctxt_prec (HsForAllTy expl extra tvs ctxt ty) unicode
   = maybeParen ctxt_prec pREC_FUN $
     hsep [ppForAll expl tvs ctxt' unicode, ppr_mono_lty pREC_TOP ty unicode]
- where ctxt' = case extra of
-                 Just loc -> (++ [L loc HsWildcardTy]) `fmap` ctxt
-                 Nothing  -> ctxt
+ where
+   anonWC = HsWildCardTy (AnonWildCard PlaceHolder)
+   ctxt'
+     | Just loc <- extra = (++ [L loc anonWC]) `fmap` ctxt
+     | otherwise         = ctxt
 
 ppr_mono_ty _         (HsBangTy b ty)     u = ppBang b <> ppLParendType u ty
 ppr_mono_ty _         (HsTyVar name)      _ = ppDocName name
@@ -941,9 +943,9 @@ ppr_mono_ty ctxt_prec (HsParTy ty) unicode
 ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode
   = ppr_mono_lty ctxt_prec ty unicode
 
-ppr_mono_ty _ HsWildcardTy _ = char '_'
+ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ = char '_'
 
-ppr_mono_ty _ (HsNamedWildcardTy name) _ = ppDocName name
+ppr_mono_ty _ (HsWildCardTy (NamedWildCard name)) _ = ppDocName name
 
 ppr_mono_ty _ (HsTyLit t) u = ppr_tylit t u
 
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 651060c1..15bfae08 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -948,9 +948,11 @@ ppr_mono_ty :: Int -> HsType DocName -> Unicode -> Qualification -> Html
 ppr_mono_ty ctxt_prec (HsForAllTy expl extra tvs ctxt ty) unicode qual
   = maybeParen ctxt_prec pREC_FUN $ ppForAllCon expl tvs ctxt' unicode qual
                                     <+> ppr_mono_lty pREC_TOP ty unicode qual
- where ctxt' = case extra of
-                 Just loc -> (++ [L loc HsWildcardTy]) `fmap` ctxt
-                 Nothing  -> ctxt
+ where
+   anonWC = HsWildCardTy (AnonWildCard PlaceHolder)
+   ctxt'
+     | Just loc <- extra = (++ [L loc anonWC]) `fmap` ctxt
+     | otherwise         = ctxt
 
 -- UnicodeSyntax alternatives
 ppr_mono_ty _ (HsTyVar name) True _
@@ -1002,9 +1004,9 @@ ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual
 ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual
   = ppr_mono_lty ctxt_prec ty unicode qual
 
-ppr_mono_ty _ HsWildcardTy _ _ = char '_'
+ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ _ = char '_'
 
-ppr_mono_ty _ (HsNamedWildcardTy name) _ q = ppDocName q Prefix True name
+ppr_mono_ty _ (HsWildCardTy (NamedWildCard name)) _ q = ppDocName q Prefix True name
 
 ppr_mono_ty _ (HsTyLit n) _ _ = ppr_tylit n
 
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 110c9a42..30074e4f 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -231,8 +231,7 @@ renameType t = case t of
   HsExplicitListTy  a b   -> HsExplicitListTy  a <$> mapM renameLType b
   HsExplicitTupleTy a b   -> HsExplicitTupleTy a <$> mapM renameLType b
   HsSpliceTy _ _          -> error "renameType: HsSpliceTy"
-  HsWildcardTy            -> pure HsWildcardTy
-  HsNamedWildcardTy a     -> HsNamedWildcardTy <$> rename a
+  HsWildCardTy a          -> HsWildCardTy <$> renameWildCardInfo a
 
 renameLTyVarBndrs :: LHsTyVarBndrs Name -> RnM (LHsTyVarBndrs DocName)
 renameLTyVarBndrs (HsQTvs { hsq_kvs = _, hsq_tvs = tvs })
@@ -254,6 +253,10 @@ renameLContext (L loc context) = do
   context' <- mapM renameLType context
   return (L loc context')
 
+renameWildCardInfo :: HsWildCardInfo Name -> RnM (HsWildCardInfo DocName)
+renameWildCardInfo (AnonWildCard  _)    = pure (AnonWildCard PlaceHolder)
+renameWildCardInfo (NamedWildCard name) = NamedWildCard <$> rename name
+
 renameInstHead :: InstHead Name -> RnM (InstHead DocName)
 renameInstHead InstHead {..} = do
   cname <- rename ihdClsName
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 106d3544..7e01d88a 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -38,6 +38,7 @@ import Coercion
 import NameSet
 import OccName
 import Outputable
+import Control.Applicative (Applicative(..))
 import Control.Monad (ap)
 
 import Haddock.Backends.Hyperlinker.Types
@@ -646,3 +647,18 @@ instance Monad ErrMsgGhc where
   return a = WriterGhc (return (a, []))
   m >>= k = WriterGhc $ runWriterGhc m >>= \ (a, msgs1) ->
                fmap (second (msgs1 ++)) (runWriterGhc (k a))
+
+
+-----------------------------------------------------------------------------
+-- * Pass sensitive types
+-----------------------------------------------------------------------------
+
+type instance PostRn DocName NameSet  = PlaceHolder
+type instance PostRn DocName Fixity   = PlaceHolder
+type instance PostRn DocName Bool     = PlaceHolder
+type instance PostRn DocName Name     = PlaceHolder
+type instance PostRn DocName [Name]   = PlaceHolder
+
+type instance PostTc DocName Kind     = PlaceHolder
+type instance PostTc DocName Type     = PlaceHolder
+type instance PostTc DocName Coercion = PlaceHolder
-- 
cgit v1.2.3


From f6c317bf8828378549d48d68f118fd9f0f919f82 Mon Sep 17 00:00:00 2001
From: Adam Sandberg Eriksson <adam@sandbergericsson.se>
Date: Fri, 3 Jul 2015 15:57:06 +0200
Subject: StrictData: print correct strictness marks

---
 haddock-api/src/Haddock/Backends/LaTeX.hs      | 7 +++++--
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 8 +++++---
 haddock-api/src/Haddock/Convert.hs             | 8 ++++----
 3 files changed, 14 insertions(+), 9 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Xhtml/Decl.hs')

diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 7d9ceaec..e631acc6 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -825,8 +825,11 @@ pp_hs_context cxt unicode = parenList (map (ppType unicode) cxt)
 
 
 ppBang :: HsBang -> LaTeX
-ppBang HsNoBang = empty
-ppBang _        = char '!' -- Unpacked args is an implementation detail,
+ppBang HsStrict                     = char '!'
+ppBang (HsUnpack {})                = char '!'
+ppBang (HsSrcBang _ _ (Just True))  = char '!'
+ppBang (HsSrcBang _ _ (Just False)) = char '~'
+ppBang _                            = empty
 
 
 tupleParens :: HsTupleSort -> [LaTeX] -> LaTeX
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 15bfae08..f01365e9 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -865,9 +865,11 @@ ppDataHeader _ _ _ _ = error "ppDataHeader: illegal argument"
 
 
 ppBang :: HsBang -> Html
-ppBang HsNoBang = noHtml
-ppBang _        = toHtml "!" -- Unpacked args is an implementation detail,
-                             -- so we just show the strictness annotation
+ppBang HsStrict                     = toHtml "!"
+ppBang (HsUnpack {})                = toHtml "!"
+ppBang (HsSrcBang _ _ (Just True))  = toHtml "!"
+ppBang (HsSrcBang _ _ (Just False)) = toHtml "~"
+ppBang _                            = noHtml
 
 
 tupleParens :: HsTupleSort -> [Html] -> Html
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index dd577319..e8ed148c 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -270,13 +270,13 @@ synifyDataCon use_gadt_syntax dc =
   linear_tys = zipWith (\ty bang ->
             let tySyn = synifyType WithinType ty
                 src_bang = case bang of
-                             HsUnpack {} -> HsSrcBang Nothing (Just True) True
-                             HsStrict    -> HsSrcBang Nothing (Just False) True
+                             HsUnpack {} -> HsSrcBang Nothing (Just True) (Just True)
+                             HsStrict    -> HsSrcBang Nothing (Just False) (Just True)
+                             HsLazy      -> HsSrcBang Nothing Nothing Nothing
                              _           -> bang
             in case src_bang of
-                 HsNoBang -> tySyn
+                 (HsSrcBang _ Nothing Nothing) -> tySyn
                  _        -> noLoc $ HsBangTy bang tySyn
-            -- HsNoBang never appears, it's implied instead.
           )
           arg_tys (dataConSrcBangs dc)
   field_tys = zipWith (\field synTy -> noLoc $ ConDeclField
-- 
cgit v1.2.3


From 2d38f9b34a19b77f4260e8a0291156dace1d63fc Mon Sep 17 00:00:00 2001
From: Adam Sandberg Eriksson <adam@sandbergericsson.se>
Date: Wed, 8 Jul 2015 15:03:04 +0200
Subject: StrictData: changes in HsBang type

---
 haddock-api/src/Haddock/Backends/LaTeX.hs      | 10 +++++-----
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 10 +++++-----
 haddock-api/src/Haddock/Convert.hs             |  8 ++++----
 3 files changed, 14 insertions(+), 14 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Xhtml/Decl.hs')

diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index e631acc6..df2e6b61 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -825,11 +825,11 @@ pp_hs_context cxt unicode = parenList (map (ppType unicode) cxt)
 
 
 ppBang :: HsBang -> LaTeX
-ppBang HsStrict                     = char '!'
-ppBang (HsUnpack {})                = char '!'
-ppBang (HsSrcBang _ _ (Just True))  = char '!'
-ppBang (HsSrcBang _ _ (Just False)) = char '~'
-ppBang _                            = empty
+ppBang HsStrict                  = char '!'
+ppBang (HsUnpack {})             = char '!'
+ppBang (HsSrcBang _ _ SrcStrict) = char '!'
+ppBang (HsSrcBang _ _ SrcLazy)   = char '~'
+ppBang _                         = empty
 
 
 tupleParens :: HsTupleSort -> [LaTeX] -> LaTeX
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index f01365e9..d0e7f890 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -865,11 +865,11 @@ ppDataHeader _ _ _ _ = error "ppDataHeader: illegal argument"
 
 
 ppBang :: HsBang -> Html
-ppBang HsStrict                     = toHtml "!"
-ppBang (HsUnpack {})                = toHtml "!"
-ppBang (HsSrcBang _ _ (Just True))  = toHtml "!"
-ppBang (HsSrcBang _ _ (Just False)) = toHtml "~"
-ppBang _                            = noHtml
+ppBang HsStrict                  = toHtml "!"
+ppBang (HsUnpack {})             = toHtml "!"
+ppBang (HsSrcBang _ _ SrcStrict) = toHtml "!"
+ppBang (HsSrcBang _ _ SrcLazy)   = toHtml "~"
+ppBang _                         = noHtml
 
 
 tupleParens :: HsTupleSort -> [Html] -> Html
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index e8ed148c..e6361ed1 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -270,12 +270,12 @@ synifyDataCon use_gadt_syntax dc =
   linear_tys = zipWith (\ty bang ->
             let tySyn = synifyType WithinType ty
                 src_bang = case bang of
-                             HsUnpack {} -> HsSrcBang Nothing (Just True) (Just True)
-                             HsStrict    -> HsSrcBang Nothing (Just False) (Just True)
-                             HsLazy      -> HsSrcBang Nothing Nothing Nothing
+                             HsUnpack {} -> HsSrcBang Nothing SrcUnpack SrcStrict
+                             HsStrict    -> HsSrcBang Nothing SrcNoUnpack SrcStrict
+                             HsLazy      -> HsSrcBang Nothing NoSrcUnpack NoSrcStrictness
                              _           -> bang
             in case src_bang of
-                 (HsSrcBang _ Nothing Nothing) -> tySyn
+                 (HsSrcBang _ NoSrcUnpack NoSrcStrictness) -> tySyn
                  _        -> noLoc $ HsBangTy bang tySyn
           )
           arg_tys (dataConSrcBangs dc)
-- 
cgit v1.2.3


From ebf0eeb4dc364859016fb6984091ae585c8d3053 Mon Sep 17 00:00:00 2001
From: Adam Sandberg Eriksson <adam@sandbergericsson.se>
Date: Tue, 14 Jul 2015 21:01:01 +0200
Subject: HsBang is split into HsSrcBang and HsImplBang

With recent changes in GHC handling of strictness annotations in Haddock
is simplified.
---
 haddock-api/src/Haddock/Backends/LaTeX.hs      |  4 +---
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs |  4 +---
 haddock-api/src/Haddock/Convert.hs             | 20 ++++++++------------
 3 files changed, 10 insertions(+), 18 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Xhtml/Decl.hs')

diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index df2e6b61..75ad51ab 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -824,9 +824,7 @@ pp_hs_context cxt unicode = parenList (map (ppType unicode) cxt)
 -------------------------------------------------------------------------------
 
 
-ppBang :: HsBang -> LaTeX
-ppBang HsStrict                  = char '!'
-ppBang (HsUnpack {})             = char '!'
+ppBang :: HsSrcBang -> LaTeX
 ppBang (HsSrcBang _ _ SrcStrict) = char '!'
 ppBang (HsSrcBang _ _ SrcLazy)   = char '~'
 ppBang _                         = empty
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index d0e7f890..69393a37 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -864,9 +864,7 @@ ppDataHeader _ _ _ _ = error "ppDataHeader: illegal argument"
 --------------------------------------------------------------------------------
 
 
-ppBang :: HsBang -> Html
-ppBang HsStrict                  = toHtml "!"
-ppBang (HsUnpack {})             = toHtml "!"
+ppBang :: HsSrcBang -> Html
 ppBang (HsSrcBang _ _ SrcStrict) = toHtml "!"
 ppBang (HsSrcBang _ _ SrcLazy)   = toHtml "~"
 ppBang _                         = noHtml
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index e6361ed1..7a8b1acb 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -267,18 +267,14 @@ synifyDataCon use_gadt_syntax dc =
   -- skip any EqTheta, use 'orig'inal syntax
   ctx = synifyCtx theta
 
-  linear_tys = zipWith (\ty bang ->
-            let tySyn = synifyType WithinType ty
-                src_bang = case bang of
-                             HsUnpack {} -> HsSrcBang Nothing SrcUnpack SrcStrict
-                             HsStrict    -> HsSrcBang Nothing SrcNoUnpack SrcStrict
-                             HsLazy      -> HsSrcBang Nothing NoSrcUnpack NoSrcStrictness
-                             _           -> bang
-            in case src_bang of
-                 (HsSrcBang _ NoSrcUnpack NoSrcStrictness) -> tySyn
-                 _        -> noLoc $ HsBangTy bang tySyn
-          )
-          arg_tys (dataConSrcBangs dc)
+  linear_tys =
+    zipWith (\ty bang ->
+               let tySyn = synifyType WithinType ty
+               in case bang of
+                    (HsSrcBang _ NoSrcUnpack NoSrcStrict) -> tySyn
+                    bang' -> noLoc $ HsBangTy bang' tySyn)
+            arg_tys (dataConSrcBangs dc)
+
   field_tys = zipWith (\field synTy -> noLoc $ ConDeclField
                                                [synifyName field] synTy Nothing)
                 (dataConFieldLabels dc) linear_tys
-- 
cgit v1.2.3


From 37a1603cd81a117d107a8468f342a0f56af6f64e Mon Sep 17 00:00:00 2001
From: Jan Stolarek <jan.stolarek@p.lodz.pl>
Date: Fri, 19 Dec 2014 08:16:30 +0100
Subject: Follow changes from #6018

---
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 42 +++++++++++++++++++++++---
 haddock-api/src/Haddock/Convert.hs             | 42 +++++++++++++++++++-------
 haddock-api/src/Haddock/Interface/Rename.hs    | 34 +++++++++++++++++----
 3 files changed, 96 insertions(+), 22 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Xhtml/Decl.hs')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 69393a37..bc16bdcd 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -257,12 +257,32 @@ ppFamilyKind _ _ Nothing = noHtml
 ppTyFamHeader :: Bool -> Bool -> FamilyDecl DocName
               -> Unicode -> Qualification -> Html
 ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info
-                                               , fdKindSig = mkind })
+                                             , fdResultSig = L _ result
+                                             , fdInjectivityAnn = injectivity })
               unicode qual =
-    ppFamilyInfo associated info <+>
-    ppFamDeclBinderWithVars summary d <+>
-    ppFamilyKind unicode qual mkind
-
+  (case info of
+     OpenTypeFamily
+       | associated -> keyword "type"
+       | otherwise  -> keyword "type family"
+     DataFamily
+       | associated -> keyword "data"
+       | otherwise  -> keyword "data family"
+     ClosedTypeFamily _
+                    -> keyword "type family"
+  ) <+>
+
+  ppFamDeclBinderWithVars summary d <+>
+
+  (case result of
+    NoSig               -> noHtml
+    KindSig kind        -> dcolon unicode  <+> ppLKind unicode qual kind
+    TyVarSig (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr
+  ) <+>
+
+  (case injectivity of
+     Nothing                   -> noHtml
+     Just (L _ injectivityAnn) -> ppInjectivityAnn unicode qual injectivityAnn
+  )
 
 ppPseudoFamilyHeader :: Unicode -> Qualification -> PseudoFamilyDecl DocName
                      -> Html
@@ -271,6 +291,11 @@ ppPseudoFamilyHeader unicode qual (PseudoFamilyDecl { .. }) =
     ppAppNameTypes (unLoc pfdLName) [] (map unLoc pfdTyVars) unicode qual <+>
     ppFamilyKind unicode qual pfdKindSig
 
+ppInjectivityAnn :: Bool -> Qualification -> InjectivityAnn DocName -> Html
+ppInjectivityAnn unicode qual (InjectivityAnn lhs rhs) =
+    char '|' <+> ppLDocName qual Raw lhs <+> arrow unicode <+>
+    hsep (map (ppLDocName qual Raw) rhs)
+
 
 ppTyFam :: Bool -> Bool -> LinksInfo -> [DocInstance DocName] ->
            [(DocName, Fixity)] -> SrcSpan -> Documentation DocName ->
@@ -913,6 +938,13 @@ ppCtxType    unicode qual ty = ppr_mono_ty pREC_CTX ty unicode qual
 ppParendType unicode qual ty = ppr_mono_ty pREC_CON ty unicode qual
 ppFunLhType  unicode qual ty = ppr_mono_ty pREC_FUN ty unicode qual
 
+ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr DocName -> Html
+ppHsTyVarBndr _       qual (UserTyVar   name     ) =
+    ppDocName qual Raw False name
+ppHsTyVarBndr unicode qual (KindedTyVar name kind) =
+    parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+>
+            ppLKind unicode qual kind)
+
 ppLKind :: Unicode -> Qualification -> LHsKind DocName -> Html
 ppLKind unicode qual y = ppKind unicode qual (unLoc y)
 
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 24947876..cf8b8243 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -26,7 +26,7 @@ import Data.List( partition )
 import DataCon
 import FamInstEnv
 import HsSyn
-import Kind ( splitKindFunTys, synTyConResKind, isKind )
+import Kind ( splitKindFunTys, tyConResKind, isKind )
 import Name
 import PatSyn
 import SrcLoc ( Located, noLoc, unLoc, noSrcSpan )
@@ -37,6 +37,7 @@ import TypeRep
 import TysPrim ( alphaTyVars )
 import TysWiredIn ( listTyConName, eqTyCon, ipTyCon )
 import Unique ( getUnique )
+import Util ( filterByList )
 import Var
 
 import Haddock.Types
@@ -166,7 +167,8 @@ synifyTyCon coax tc
   | isTypeFamilyTyCon tc
   = case famTyConFlav_maybe tc of
       Just rhs ->
-        let info = case rhs of
+        let resultVar = famTcResVar tc
+            info = case rhs of
               OpenSynFamilyTyCon -> return OpenTypeFamily
               ClosedSynFamilyTyCon mb -> case mb of
                   Just (CoAxiom { co_ax_branches = branches })
@@ -178,21 +180,25 @@ synifyTyCon coax tc
               AbstractClosedSynFamilyTyCon {}
                 -> return $ ClosedTypeFamily Nothing
         in info >>= \i ->
-           return (FamDecl
-                   (FamilyDecl { fdInfo = i
-                               , fdLName = synifyName tc
-                               , fdTyVars = synifyTyVars (tyConTyVars tc)
-                               , fdKindSig =
-                                 Just (synifyKindSig (synTyConResKind tc))
-                               }))
+           return (FamDecl (FamilyDecl { fdInfo = i
+                          , fdLName = synifyName tc
+                          , fdTyVars = synifyTyVars (tyConTyVars tc)
+                          , fdResultSig =
+                              synifyFamilyResultSig resultVar (tyConResKind tc)
+                          , fdInjectivityAnn =
+                              synifyInjectivityAnn  resultVar (tyConTyVars tc)
+                                               (familyTyConInjectivityInfo tc)
+                          }))
       Nothing -> Left "synifyTyCon: impossible open type synonym?"
 
   | isDataFamilyTyCon tc
   = --(why no "isOpenAlgTyCon"?)
     case algTyConRhs tc of
         DataFamilyTyCon -> return $
-          FamDecl (FamilyDecl DataFamily (synifyName tc) (synifyTyVars (tyConTyVars tc))
-                              Nothing) --always kind '*'
+          FamDecl (FamilyDecl DataFamily (synifyName tc)
+                              (synifyTyVars (tyConTyVars tc))
+                              (noLoc NoSig) -- always kind '*'
+                              Nothing)      -- no injectivity
         _ -> Left "synifyTyCon: impossible open data type?"
   | Just ty <- synTyConRhs_maybe tc
   = return $ SynDecl { tcdLName = synifyName tc
@@ -243,6 +249,20 @@ synifyTyCon coax tc
                  , tcdFVs = placeHolderNamesTc }
   dataConErrs -> Left $ unlines dataConErrs
 
+synifyInjectivityAnn :: Maybe Name -> [TyVar] -> Injectivity
+                     -> Maybe (LInjectivityAnn Name)
+synifyInjectivityAnn Nothing _ _            = Nothing
+synifyInjectivityAnn _       _ NotInjective = Nothing
+synifyInjectivityAnn (Just lhs) tvs (Injective inj) =
+    let rhs = map (noLoc . tyVarName) (filterByList inj tvs)
+    in Just $ noLoc $ InjectivityAnn (noLoc lhs) rhs
+
+synifyFamilyResultSig :: Maybe Name -> Kind -> LFamilyResultSig Name
+synifyFamilyResultSig  Nothing    kind =
+   noLoc $ KindSig  (synifyKindSig kind)
+synifyFamilyResultSig (Just name) kind =
+   noLoc $ TyVarSig (noLoc $ KindedTyVar (noLoc name) (synifyKindSig kind))
+
 -- User beware: it is your responsibility to pass True (use_gadt_syntax)
 -- for any constructor that would be misrepresented by omitting its
 -- result-type.
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 30074e4f..6ec1f2c5 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -176,6 +176,25 @@ renameLKind = renameLType
 renameMaybeLKind :: Maybe (LHsKind Name) -> RnM (Maybe (LHsKind DocName))
 renameMaybeLKind = traverse renameLKind
 
+renameFamilyResultSig :: LFamilyResultSig Name -> RnM (LFamilyResultSig DocName)
+renameFamilyResultSig (L loc NoSig)
+    = return (L loc NoSig)
+renameFamilyResultSig (L loc (KindSig ki))
+    = do { ki' <- renameLKind ki
+         ; return (L loc (KindSig ki')) }
+renameFamilyResultSig (L loc (TyVarSig bndr))
+    = do { bndr' <- renameLTyVarBndr bndr
+         ; return (L loc (TyVarSig bndr')) }
+
+renameInjectivityAnn :: LInjectivityAnn Name -> RnM (LInjectivityAnn DocName)
+renameInjectivityAnn (L loc (InjectivityAnn lhs rhs))
+    = do { lhs' <- renameL lhs
+         ; rhs' <- mapM renameL rhs
+         ; return (L loc (InjectivityAnn lhs' rhs')) }
+
+renameMaybeInjectivityAnn :: Maybe (LInjectivityAnn Name)
+                          -> RnM (Maybe (LInjectivityAnn DocName))
+renameMaybeInjectivityAnn = traverse renameInjectivityAnn
 
 renameType :: HsType Name -> RnM (HsType DocName)
 renameType t = case t of
@@ -343,13 +362,16 @@ renameTyClD d = case d of
 
 renameFamilyDecl :: FamilyDecl Name -> RnM (FamilyDecl DocName)
 renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname
-                             , fdTyVars = ltyvars, fdKindSig = tckind }) = do
-    info'    <- renameFamilyInfo info
-    lname'   <- renameL lname
-    ltyvars' <- renameLTyVarBndrs ltyvars
-    tckind'  <- renameMaybeLKind tckind
+                             , fdTyVars = ltyvars, fdResultSig = result
+                             , fdInjectivityAnn = injectivity }) = do
+    info'        <- renameFamilyInfo info
+    lname'       <- renameL lname
+    ltyvars'     <- renameLTyVarBndrs ltyvars
+    result'      <- renameFamilyResultSig result
+    injectivity' <- renameMaybeInjectivityAnn injectivity
     return (FamilyDecl { fdInfo = info', fdLName = lname'
-                       , fdTyVars = ltyvars', fdKindSig = tckind' })
+                       , fdTyVars = ltyvars', fdResultSig = result'
+                       , fdInjectivityAnn = injectivity' })
 
 
 renamePseudoFamilyDecl :: PseudoFamilyDecl Name
-- 
cgit v1.2.3


From 821b1dcfe62bf75711661348ac80a64cc60a0b6a Mon Sep 17 00:00:00 2001
From: Adam Gundry <adam@well-typed.com>
Date: Fri, 16 Oct 2015 16:26:42 +0100
Subject: Roughly fix up haddock for DuplicateRecordFields changes

This compiles, but will probably need more work to produce good
documentation when the DuplicateRecordFields extension is used.
---
 haddock-api/src/Haddock/Backends/Hoogle.hs     |  4 ++--
 haddock-api/src/Haddock/Backends/LaTeX.hs      | 11 +++++++----
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 11 +++++++----
 haddock-api/src/Haddock/Convert.hs             |  8 +++++---
 haddock-api/src/Haddock/GhcUtils.hs            |  3 ++-
 haddock-api/src/Haddock/Interface/Create.hs    | 17 ++++++++++-------
 haddock-api/src/Haddock/Interface/Rename.hs    |  8 ++++++--
 haddock-api/src/Haddock/Types.hs               |  4 ++--
 haddock-api/src/Haddock/Utils.hs               |  5 ++++-
 9 files changed, 45 insertions(+), 26 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Xhtml/Decl.hs')

diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index f6ad9808..42887834 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -245,8 +245,8 @@ ppCtor dflags dat subdocs con
         f (PrefixCon args) = [typeSig name $ args ++ [resType]]
         f (InfixCon a1 a2) = f $ PrefixCon [a1,a2]
         f (RecCon (L _ recs)) = f (PrefixCon $ map cd_fld_type (map unLoc recs)) ++ concat
-                          [(concatMap (lookupCon dflags subdocs) (cd_fld_names r)) ++
-                           [out dflags (map unL $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]]
+                          [(concatMap (lookupCon dflags subdocs . noLoc . selectorFieldOcc . unLoc) (cd_fld_names r)) ++
+                           [out dflags (map (selectorFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]]
                           | r <- map unLoc recs]
 
         funs = foldr1 (\x y -> reL $ HsFunTy (makeExplicitL x) (makeExplicitL y))
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 75ad51ab..eae450a4 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -25,9 +25,10 @@ import qualified Pretty
 import GHC
 import OccName
 import Name                 ( nameOccName )
-import RdrName              ( rdrNameOcc )
+import RdrName              ( rdrNameOcc, mkRdrUnqual )
 import FastString           ( unpackFS, unpackLitString, zString )
 import Outputable           ( panic)
+import PrelNames            ( mkUnboundName )
 
 import qualified Data.Map as Map
 import System.Directory
@@ -688,12 +689,12 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
 
 ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName ->  LaTeX
 ppSideBySideField subdocs unicode (ConDeclField names ltype _) =
-  decltt (cat (punctuate comma (map (ppBinder . nameOccName . getName . unL) names))
+  decltt (cat (punctuate comma (map (ppBinder . rdrNameOcc . rdrNameFieldOcc . unLoc) names))
     <+> dcolon unicode <+> ppLType unicode ltype) <-> rDoc mbDoc
   where
     -- don't use cd_fld_doc for same reason we don't use con_doc above
     -- Where there is more than one name, they all have the same documentation
-    mbDoc = lookup (unL $ head names) subdocs >>= fmap _doc . combineDocumentation . fst
+    mbDoc = lookup (selectorFieldOcc $ unLoc $ head names) subdocs >>= fmap _doc . combineDocumentation . fst
 
 -- {-
 -- ppHsFullConstr :: HsConDecl -> LaTeX
@@ -902,7 +903,9 @@ ppr_mono_ty ctxt_prec (HsForAllTy expl extra tvs ctxt ty) unicode
   = maybeParen ctxt_prec pREC_FUN $
     hsep [ppForAll expl tvs ctxt' unicode, ppr_mono_lty pREC_TOP ty unicode]
  where
-   anonWC = HsWildCardTy (AnonWildCard PlaceHolder)
+   anonWC :: HsType DocName
+   anonWC = HsWildCardTy (AnonWildCard (Undocumented underscore))
+   underscore = mkUnboundName (mkRdrUnqual (mkTyVarOcc "_"))
    ctxt'
      | Just loc <- extra = (++ [L loc anonWC]) `fmap` ctxt
      | otherwise         = ctxt
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index bc16bdcd..89b822d6 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -38,6 +38,8 @@ import GHC
 import GHC.Exts
 import Name
 import BooleanFormula
+import RdrName ( rdrNameOcc, mkRdrUnqual )
+import PrelNames            ( mkUnboundName )
 
 ppDecl :: Bool -> LinksInfo -> LHsDecl DocName
        -> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, Fixity)]
@@ -848,18 +850,18 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, field
 ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification
                   -> ConDeclField DocName -> SubDecl
 ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) =
-  (hsep (punctuate comma (map ((ppBinder False) . nameOccName . getName . unL) names)) <+> dcolon unicode <+> ppLType unicode qual ltype,
+  (hsep (punctuate comma (map ((ppBinder False) . rdrNameOcc . rdrNameFieldOcc . unLoc) names)) <+> dcolon unicode <+> ppLType unicode qual ltype,
     mbDoc,
     [])
   where
     -- don't use cd_fld_doc for same reason we don't use con_doc above
     -- Where there is more than one name, they all have the same documentation
-    mbDoc = lookup (unL $ head names) subdocs >>= combineDocumentation . fst
+    mbDoc = lookup (selectorFieldOcc $ unLoc $ head names) subdocs >>= combineDocumentation . fst
 
 
 ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocName -> Html
 ppShortField summary unicode qual (ConDeclField names ltype _)
-  = hsep (punctuate comma (map ((ppBinder summary) . nameOccName . getName . unL) names))
+  = hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . rdrNameFieldOcc . unLoc) names))
     <+> dcolon unicode <+> ppLType unicode qual ltype
 
 
@@ -981,7 +983,8 @@ ppr_mono_ty ctxt_prec (HsForAllTy expl extra tvs ctxt ty) unicode qual
   = maybeParen ctxt_prec pREC_FUN $ ppForAllCon expl tvs ctxt' unicode qual
                                     <+> ppr_mono_lty pREC_TOP ty unicode qual
  where
-   anonWC = HsWildCardTy (AnonWildCard PlaceHolder)
+   anonWC = HsWildCardTy (AnonWildCard (Undocumented underscore))
+   underscore = mkUnboundName (mkRdrUnqual (mkTyVarOcc "_"))
    ctxt'
      | Just loc <- extra = (++ [L loc anonWC]) `fmap` ctxt
      | otherwise         = ctxt
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index b7aefd09..f12556f8 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -28,6 +28,7 @@ import FamInstEnv
 import HsSyn
 import Kind ( splitKindFunTys, tyConResKind, isKind )
 import Name
+import RdrName ( mkVarUnqual )
 import PatSyn
 import SrcLoc ( Located, noLoc, unLoc, noSrcSpan )
 import TcType ( tcSplitSigmaTy )
@@ -294,9 +295,10 @@ synifyDataCon use_gadt_syntax dc =
                     bang' -> noLoc $ HsBangTy bang' tySyn)
             arg_tys (dataConSrcBangs dc)
 
-  field_tys = zipWith (\field synTy -> noLoc $ ConDeclField
-                                               [synifyName field] synTy Nothing)
-                (dataConFieldLabels dc) linear_tys
+  field_tys = zipWith con_decl_field (dataConFieldLabels dc) linear_tys
+  con_decl_field fl synTy = noLoc $
+    ConDeclField [noLoc $ FieldOcc (mkVarUnqual $ flLabel fl) (flSelector fl)] synTy
+                 Nothing
   hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of
           (True,True) -> Left "synifyDataCon: contradiction!"
           (True,False) -> return $ RecCon (noLoc field_tys)
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index ce4ca38a..0581ceb8 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -188,7 +188,8 @@ class Parent a where
 instance Parent (ConDecl Name) where
   children con =
     case con_details con of
-      RecCon fields -> map unL $ concatMap (cd_fld_names . unL) (unL fields)
+      RecCon fields -> map (selectorFieldOcc . unL) $
+                         concatMap (cd_fld_names . unL) (unL fields)
       _             -> []
 
 instance Parent (TyClDecl Name) where
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index b0a4d621..7a5eb8d7 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -337,15 +337,16 @@ subordinates instMap decl = case decl of
     classSubs dd = [ (name, doc, typeDocs d) | (L _ d, doc) <- classDecls dd
                    , name <- getMainDeclBinder d, not (isValD d)
                    ]
+    dataSubs :: HsDataDefn Name -> [(Name, [HsDocString], Map Int HsDocString)]
     dataSubs dd = constrs ++ fields
       where
         cons = map unL $ (dd_cons dd)
         constrs = [ (unL cname, maybeToList $ fmap unL $ con_doc c, M.empty)
                   | c <- cons, cname <- con_names c ]
-        fields  = [ (unL n, maybeToList $ fmap unL doc, M.empty)
+        fields  = [ (selectorFieldOcc n, maybeToList $ fmap unL doc, M.empty)
                   | RecCon flds <- map con_details cons
                   , L _ (ConDeclField ns _ doc) <- (unLoc flds)
-                  , n <- ns ]
+                  , L _ n <- ns ]
 
 -- | Extract function argument docs from inside types.
 typeDocs :: HsDecl Name -> Map Int HsDocString
@@ -507,7 +508,7 @@ mkExportItems
     lookupExport (IEVar (L _ x))         = declWith x
     lookupExport (IEThingAbs (L _ t))    = declWith t
     lookupExport (IEThingAll (L _ t))    = declWith t
-    lookupExport (IEThingWith (L _ t) _) = declWith t
+    lookupExport (IEThingWith (L _ t) _ _) = declWith t
     lookupExport (IEModuleContents (L _ m)) =
       moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps fixMap splices
     lookupExport (IEGroup lev docStr)  = return $
@@ -802,7 +803,7 @@ extractDecl name mdl decl
                           , L _ ConDecl { con_details = RecCon rec } <- dd_cons (dfid_defn d)
                           , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec)
                           , L _ n <- ns
-                          , n == name
+                          , selectorFieldOcc n == name
                       ]
         in case matches of
           [d0] -> extractDecl name mdl (noLoc . InstD $ DataFamInstD d0)
@@ -833,11 +834,13 @@ extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found"
 
 extractRecSel nm mdl t tvs (L _ con : rest) =
   case con_details con of
-    RecCon (L _ fields) | ((n,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields ->
-      L (getLoc n) (TypeSig [noLoc nm] (noLoc (HsFunTy data_ty (getBangType ty))) [])
+    RecCon (L _ fields) | ((l,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields ->
+      L l (TypeSig [noLoc nm] (noLoc (HsFunTy data_ty (getBangType ty))) [])
     _ -> extractRecSel nm mdl t tvs rest
  where
-  matching_fields flds = [ (n,f) | f@(L _ (ConDeclField ns _ _)) <- flds, n <- ns, unLoc n == nm ]
+  matching_fields :: [LConDeclField Name] -> [(SrcSpan, LConDeclField Name)]
+  matching_fields flds = [ (l,f) | f@(L _ (ConDeclField ns _ _)) <- flds
+                                 , L l n <- ns, selectorFieldOcc n == nm ]
   data_ty
     | ResTyGADT _ ty <- con_res con = ty
     | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) tvs
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 6ec1f2c5..1671a38d 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -273,7 +273,7 @@ renameLContext (L loc context) = do
   return (L loc context')
 
 renameWildCardInfo :: HsWildCardInfo Name -> RnM (HsWildCardInfo DocName)
-renameWildCardInfo (AnonWildCard  _)    = pure (AnonWildCard PlaceHolder)
+renameWildCardInfo (AnonWildCard  name) = AnonWildCard  <$> rename name
 renameWildCardInfo (NamedWildCard name) = NamedWildCard <$> rename name
 
 renameInstHead :: InstHead Name -> RnM (InstHead DocName)
@@ -429,11 +429,15 @@ renameCon decl@(ConDecl { con_names = lnames, con_qvars = ltyvars
 
 renameConDeclFieldField :: LConDeclField Name -> RnM (LConDeclField DocName)
 renameConDeclFieldField (L l (ConDeclField names t doc)) = do
-  names' <- mapM renameL names
+  names' <- mapM renameLFieldOcc names
   t'   <- renameLType t
   doc' <- mapM renameLDocHsSyn doc
   return $ L l (ConDeclField names' t' doc')
 
+renameLFieldOcc :: LFieldOcc Name -> RnM (LFieldOcc DocName)
+renameLFieldOcc (L l (FieldOcc lbl sel)) = do
+  sel' <- rename sel
+  return $ L l (FieldOcc lbl sel')
 
 renameSig :: Sig Name -> RnM (Sig DocName)
 renameSig sig = case sig of
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 7e01d88a..dd41b523 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -296,7 +296,6 @@ type instance PostTc DocName Kind     = PlaceHolder
 type instance PostTc DocName Type     = PlaceHolder
 type instance PostTc DocName Coercion = PlaceHolder
 
-
 instance NamedThing DocName where
   getName (Documented name _) = name
   getName (Undocumented name) = name
@@ -656,8 +655,9 @@ instance Monad ErrMsgGhc where
 type instance PostRn DocName NameSet  = PlaceHolder
 type instance PostRn DocName Fixity   = PlaceHolder
 type instance PostRn DocName Bool     = PlaceHolder
-type instance PostRn DocName Name     = PlaceHolder
+type instance PostRn DocName Name     = DocName
 type instance PostRn DocName [Name]   = PlaceHolder
+type instance PostRn DocName DocName  = DocName
 
 type instance PostTc DocName Kind     = PlaceHolder
 type instance PostTc DocName Type     = PlaceHolder
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index 4fed3a1e..c2e1b09a 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -63,6 +63,7 @@ import Haddock.GhcUtils
 
 import GHC
 import Name
+import HsTypes (selectorFieldOcc)
 
 import Control.Monad ( liftM )
 import Data.Char ( isAlpha, isAlphaNum, isAscii, ord, chr )
@@ -162,7 +163,9 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]
           -- it's the best we can do.
         InfixCon _ _ -> Just d
       where
-        field_avail (L _ (ConDeclField ns _ _)) = all (\n -> unLoc n `elem` names) ns
+        field_avail :: LConDeclField Name -> Bool
+        field_avail (L _ (ConDeclField fs _ _))
+            = all (\f -> selectorFieldOcc (unLoc f) `elem` names) fs
         field_types flds = [ t | ConDeclField _ t _ <- flds ]
 
     keep _ = Nothing
-- 
cgit v1.2.3


From 0b4e5424d1df869cc6eb4bc439c7988f36eeaab4 Mon Sep 17 00:00:00 2001
From: Simon Peyton Jones <simonpj@microsoft.com>
Date: Fri, 30 Oct 2015 13:03:51 +0000
Subject: Work on updating Haddock to wip/spj-wildard-recactor

Still incomplete
---
 haddock-api/src/Haddock/Backends/LaTeX.hs      | 143 ++++++++++---------------
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs |  17 ++-
 haddock-api/src/Haddock/Utils.hs               |   2 +-
 3 files changed, 63 insertions(+), 99 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Xhtml/Decl.hs')

diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index eae450a4..79aa1177 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -214,9 +214,9 @@ processExports (e : es) =
 
 
 isSimpleSig :: ExportItem DocName -> Maybe ([DocName], HsType DocName)
-isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig lnames (L _ t) _))
+isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig lnames t))
                        , expItemMbDoc = (Documentation Nothing Nothing, argDocs) }
-  | Map.null argDocs = Just (map unLoc lnames, t)
+  | Map.null argDocs = Just (map unLoc lnames, unLoc (hsSigWcType t))
 isSimpleSig _ = Nothing
 
 
@@ -251,8 +251,8 @@ ppDocGroup lev doc = sec lev <> braces doc
 declNames :: LHsDecl DocName -> [DocName]
 declNames (L _ decl) = case decl of
   TyClD d  -> [tcdName d]
-  SigD (TypeSig lnames _ _) -> map unLoc lnames
-  SigD (PatSynSig lname _ _ _ _) -> [unLoc lname]
+  SigD (TypeSig lnames _ ) -> map unLoc lnames
+  SigD (PatSynSig lname _) -> [unLoc lname]
   ForD (ForeignImport (L _ n) _ _ _) -> [n]
   ForD (ForeignExport (L _ n) _ _ _) -> [n]
   _ -> error "declaration not supported by declNames"
@@ -294,10 +294,11 @@ ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs _fixities = case decl of
 --  TyClD d@(TySynonym {})
 --    | Just _  <- tcdTyPats d    -> ppTyInst False loc doc d unicode
 -- Family instances happen via FamInst now
-  TyClD d@(ClassDecl {})         -> ppClassDecl instances loc doc subdocs d unicode
-  SigD (TypeSig lnames (L _ t) _) -> ppFunSig loc (doc, fnArgsDoc) (map unLoc lnames) t unicode
-  SigD (PatSynSig lname qtvs prov req ty) ->
-      ppLPatSig loc (doc, fnArgsDoc) lname qtvs prov req ty unicode
+  TyClD d@(ClassDecl {})    -> ppClassDecl instances loc doc subdocs d unicode
+  SigD (TypeSig lnames t)   -> ppFunSig loc (doc, fnArgsDoc) (map unLoc lnames)
+                                        (hsSigWcType t) unicode
+  SigD (PatSynSig lname ty) ->
+      ppLPatSig loc (doc, fnArgsDoc) lname ty unicode
   ForD d                         -> ppFor loc (doc, fnArgsDoc) d unicode
   InstD _                        -> empty
   _                              -> error "declaration not supported by ppDecl"
@@ -312,8 +313,8 @@ ppTyFam _ _ _ _ _ =
 
 
 ppFor :: SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> Bool -> LaTeX
-ppFor loc doc (ForeignImport (L _ name) (L _ typ) _ _) unicode =
-  ppFunSig loc doc [name] typ unicode
+ppFor loc doc (ForeignImport (L _ name) typ _ _) unicode =
+  ppFunSig loc doc [name] (hsSigType typ) unicode
 ppFor _ _ _ _ = error "ppFor error in Haddock.Backends.LaTeX"
 --  error "foreign declarations are currently not supported by --latex"
 
@@ -330,7 +331,9 @@ ppTySyn loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars
                          , tcdRhs = ltype }) unicode
   = ppTypeOrFunSig loc [name] (unLoc ltype) doc (full, hdr, char '=') unicode
   where
-    hdr  = hsep (keyword "type" : ppDocBinder name : ppTyVars ltyvars)
+    hdr  = hsep (keyword "type"
+                 : ppDocBinder name
+                 : map ppSymName (tyvarNames ltyvars))
     full = hdr <+> char '=' <+> ppLType unicode ltype
 
 ppTySyn _ _ _ _ = error "declaration not supported by ppTySyn"
@@ -341,9 +344,9 @@ ppTySyn _ _ _ _ = error "declaration not supported by ppTySyn"
 -------------------------------------------------------------------------------
 
 
-ppFunSig :: SrcSpan -> DocForDecl DocName -> [DocName] -> HsType DocName
+ppFunSig :: SrcSpan -> DocForDecl DocName -> [DocName] -> LHsType DocName
          -> Bool -> LaTeX
-ppFunSig loc doc docnames typ unicode =
+ppFunSig loc doc docnames (L _ typ) unicode =
   ppTypeOrFunSig loc docnames typ doc
     ( ppTypeSig names typ False
     , hsep . punctuate comma $ map ppSymName names
@@ -353,29 +356,17 @@ ppFunSig loc doc docnames typ unicode =
    names = map getName docnames
 
 ppLPatSig :: SrcSpan -> DocForDecl DocName -> Located DocName
-          -> (HsExplicitFlag, LHsTyVarBndrs DocName)
-          -> LHsContext DocName -> LHsContext DocName
-          -> LHsType DocName
+          -> LHsSigType DocName
           -> Bool -> LaTeX
-ppLPatSig _loc (doc, _argDocs) (L _ name) (expl, qtvs) lprov lreq (L _ ty) unicode
+ppLPatSig _loc (doc, _argDocs) (L _ name) ty unicode
   = declWithDoc pref1 (documentationToLaTeX doc)
   where
     pref1 = hsep [ keyword "pattern"
                  , ppDocBinder name
                  , dcolon unicode
-                 , ppLTyVarBndrs expl qtvs unicode
-                 , ctx
-                 , ppType unicode ty
+                 , ppLType unicode (hsSigType ty)
                  ]
 
-    ctx = case (ppLContextMaybe lprov unicode, ppLContextMaybe lreq unicode) of
-        (Nothing,   Nothing)  -> empty
-        (Nothing,   Just req) -> parens empty <+> darr <+> req <+> darr
-        (Just prov, Nothing)  -> prov <+> darr
-        (Just prov, Just req) -> prov <+> darr <+> req <+> darr
-
-    darr = darrow unicode
-
 ppTypeOrFunSig :: SrcSpan -> [DocName] -> HsType DocName
                -> DocForDecl DocName -> (LaTeX, LaTeX, LaTeX)
                -> Bool -> LaTeX
@@ -395,22 +386,14 @@ ppTypeOrFunSig _ _ typ (doc, argDocs) (pref1, pref2, sep0)
      arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs
 
      do_args :: Int -> LaTeX -> (HsType DocName) -> LaTeX
-     do_args n leader (HsForAllTy Explicit _ tvs lctxt ltype)
-       = decltt leader <->
-             decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]) <+>
-                ppLContextNoArrow lctxt unicode) <+> nl $$
-         do_largs n (darrow unicode) ltype
-
-     do_args n leader (HsForAllTy Qualified e a lctxt ltype)
-       = do_args n leader (HsForAllTy Implicit e a lctxt ltype)
-     do_args n leader (HsForAllTy Implicit _ _ lctxt ltype)
-       | not (null (unLoc lctxt))
-       = decltt leader <-> decltt (ppLContextNoArrow lctxt unicode) <+> nl $$
-         do_largs n (darrow unicode) ltype
-         -- if we're not showing any 'forall' or class constraints or
-         -- anything, skip having an empty line for the context.
-       | otherwise
-       = do_largs n leader ltype
+     do_args _n leader (HsForAllTy tvs ltype)
+       = decltt leader
+         <-> decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]))
+         <+> ppLType unicode ltype
+     do_args n leader (HsQualTy lctxt ltype)
+       = decltt leader
+         <-> ppLContextNoArrow lctxt unicode <+> nl $$
+             do_largs n (darrow unicode) ltype
      do_args n leader (HsFunTy lt r)
        = decltt leader <-> decltt (ppLFunLhType unicode lt) <-> arg_doc n <+> nl $$
          do_largs (n+1) (arrow unicode) r
@@ -425,12 +408,12 @@ ppTypeSig nms ty unicode =
     <+> ppType unicode ty
 
 
-ppTyVars :: LHsTyVarBndrs DocName -> [LaTeX]
-ppTyVars tvs = map ppSymName (tyvarNames tvs)
+ppTyVars :: [LHsTyVarBndr DocName] -> [LaTeX]
+ppTyVars = map (ppSymName . getName . hsLTyVarName)
 
 
-tyvarNames :: LHsTyVarBndrs DocName -> [Name]
-tyvarNames = map getName . hsLTyVarNames
+tyvarNames :: LHsQTyVars DocName -> [Name]
+tyvarNames = map (getName . hsLTyVarName) . hsQTvBndrs
 
 
 declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX
@@ -479,12 +462,12 @@ rDoc = maybeDoc . fmap latexStripTrailingWhitespace
 
 
 ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName
-           -> LHsTyVarBndrs DocName -> [Located ([Located DocName], [Located DocName])]
+           -> LHsQTyVars DocName -> [Located ([Located DocName], [Located DocName])]
            -> Bool -> LaTeX
 ppClassHdr summ lctxt n tvs fds unicode =
   keyword "class"
   <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode else empty)
-  <+> ppAppDocNameNames summ n (tyvarNames $ tvs)
+  <+> ppAppDocNameNames summ n (tyvarNames tvs)
   <+> ppFds fds unicode
 
 
@@ -522,8 +505,8 @@ ppClassDecl instances loc doc subdocs
 
     methodTable =
       text "\\haddockpremethods{}\\textbf{Methods}" $$
-      vcat  [ ppFunSig loc doc names typ unicode
-            | L _ (TypeSig lnames (L _ typ) _) <- lsigs
+      vcat  [ ppFunSig loc doc names (hsSigWcType typ) unicode
+            | L _ (TypeSig lnames typ) <- lsigs
             , let doc = lookupAnySubdoc (head names) subdocs
                   names = map unLoc lnames ]
               -- FIXME: is taking just the first name ok? Is it possible that
@@ -615,21 +598,20 @@ ppDataDecl instances subdocs _loc doc dataDecl unicode
 
 
 -- ppConstrHdr is for (non-GADT) existentials constructors' syntax
-ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Bool -> LaTeX
+ppConstrHdr :: Bool -> [Name] -> HsContext DocName -> Bool -> LaTeX
 ppConstrHdr forall tvs ctxt unicode
  = (if null tvs then empty else ppForall)
    <+>
    (if null ctxt then empty else ppContextNoArrow ctxt unicode <+> darrow unicode <+> text " ")
   where
     ppForall = case forall of
-      Explicit -> forallSymbol unicode <+> hsep (map ppName tvs) <+> text ". "
-      Qualified -> empty
-      Implicit -> empty
+      True  -> forallSymbol unicode <+> hsep (map ppName tvs) <+> text ". "
+      False -> empty
 
 
 ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LaTeX
                    -> LConDecl DocName -> LaTeX
-ppSideBySideConstr subdocs unicode leader (L _ con) =
+ppSideBySideConstr subdocs unicode leader (L loc con) =
   leader <->
   case con_res con of
   ResTyH98 -> case con_details con of
@@ -663,13 +645,13 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
     doRecordFields fields =
         vcat (map (ppSideBySideField subdocs unicode) (map unLoc fields))
 
-    doGADTCon args resTy = decltt (ppOcc <+> dcolon unicode <+> hsep [
-                               ppForAll forall ltvs (con_cxt con) unicode,
-                               ppLType unicode (foldr mkFunTy resTy args) ]
+    doGADTCon args resTy = decltt (ppOcc <+> dcolon unicode <+>
+                               ppLType unicode (mk_forall $ mk_phi $
+                                                foldr mkFunTy resTy args)
                             ) <-> rDoc mbDoc
 
 
-    header_ = ppConstrHdr forall tyVars context
+    header_ = ppConstrHdr (con_explicit con) tyVars context
     occ     = map (nameOccName . getName . unLoc) $ con_names con
     ppOcc   = case occ of
       [one] -> ppBinder one
@@ -677,7 +659,12 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
     ltvs    = con_qvars con
     tyVars  = tyvarNames (con_qvars con)
     context = unLoc (con_cxt con)
-    forall  = con_explicit con
+
+    mk_forall ty | con_explicit con = L loc (HsForAllTy (hsQTvBndrs ltvs) ty)
+                 | otherwise        = ty
+    mk_phi ty | null context = ty
+              | otherwise    = L loc (HsQualTy (con_cxt con) ty)
+
     -- don't use "con_doc con", in case it's reconstructed from a .hi file,
     -- or also because we want Haddock to do the doc-parsing, not GHC.
     mbDoc = case con_names con of
@@ -793,9 +780,6 @@ ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Bool -> LaTeX
 ppLContext        = ppContext        . unLoc
 ppLContextNoArrow = ppContextNoArrow . unLoc
 
-ppLContextMaybe :: Located (HsContext DocName) -> Bool -> Maybe LaTeX
-ppLContextMaybe = ppContextNoLocsMaybe . map unLoc . unLoc
-
 ppContextNoLocsMaybe :: [HsType DocName] -> Bool -> Maybe LaTeX
 ppContextNoLocsMaybe [] _ = Nothing
 ppContextNoLocsMaybe cxt unicode = Just $ pp_hs_context cxt unicode
@@ -881,34 +865,19 @@ ppKind unicode ki = ppr_mono_ty pREC_TOP ki unicode
 -- Drop top-level for-all type variables in user style
 -- since they are implicit in Haskell
 
-ppForAll :: HsExplicitFlag -> LHsTyVarBndrs DocName
-         -> Located (HsContext DocName) -> Bool -> LaTeX
-ppForAll expl tvs cxt unicode = ppLTyVarBndrs expl tvs unicode <+> ppLContext cxt unicode
-
-ppLTyVarBndrs :: HsExplicitFlag -> LHsTyVarBndrs DocName
-              -> Bool -> LaTeX
-ppLTyVarBndrs expl tvs unicode
-  | show_forall = hsep (forallSymbol unicode : ppTyVars tvs) <> dot
-  | otherwise   = empty
-  where
-    show_forall = not (null (hsQTvBndrs tvs)) && is_explicit
-    is_explicit = case expl of {Explicit -> True; Implicit -> False; Qualified -> False}
-
 ppr_mono_lty :: Int -> LHsType DocName -> Bool -> LaTeX
 ppr_mono_lty ctxt_prec ty unicode = ppr_mono_ty ctxt_prec (unLoc ty) unicode
 
 
 ppr_mono_ty :: Int -> HsType DocName -> Bool -> LaTeX
-ppr_mono_ty ctxt_prec (HsForAllTy expl extra tvs ctxt ty) unicode
+ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode
   = maybeParen ctxt_prec pREC_FUN $
-    hsep [ppForAll expl tvs ctxt' unicode, ppr_mono_lty pREC_TOP ty unicode]
- where
-   anonWC :: HsType DocName
-   anonWC = HsWildCardTy (AnonWildCard (Undocumented underscore))
-   underscore = mkUnboundName (mkRdrUnqual (mkTyVarOcc "_"))
-   ctxt'
-     | Just loc <- extra = (++ [L loc anonWC]) `fmap` ctxt
-     | otherwise         = ctxt
+    sep [ hsep (forallSymbol unicode : ppTyVars tvs) <> dot
+        , ppr_mono_lty pREC_TOP ty unicode ]
+ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode
+  = maybeParen ctxt_prec pREC_FUN $
+    sep [ ppLContext ctxt unicode
+        , ppr_mono_lty pREC_TOP ty unicode ]
 
 ppr_mono_ty _         (HsBangTy b ty)     u = ppBang b <> ppLParendType u ty
 ppr_mono_ty _         (HsTyVar name)      _ = ppDocName name
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 89b822d6..0461ad41 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -50,8 +50,8 @@ ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances fixities subdocs spl
   TyClD d@(SynDecl {})        -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual
   TyClD d@(ClassDecl {})      -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual
   SigD (TypeSig lnames lty _) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames lty fixities splice unicode qual
-  SigD (PatSynSig lname qtvs prov req ty) ->
-      ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname qtvs prov req ty fixities splice unicode qual
+  SigD (PatSynSig lname ty) ->
+      ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname ty fixities splice unicode qual
   ForD d                         -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual
   InstD _                        -> noHtml
   _                              -> error "declaration not supported by ppDecl"
@@ -74,23 +74,18 @@ ppFunSig summary links loc doc docnames typ fixities splice unicode qual =
     pp_typ = ppType unicode qual typ
 
 ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
-             Located DocName ->
-             (HsExplicitFlag, LHsTyVarBndrs DocName) ->
-             LHsContext DocName -> LHsContext DocName ->
-             LHsType DocName ->
+             Located DocName -> LHsSigType DocName
              [(DocName, Fixity)] ->
              Splice -> Unicode -> Qualification -> Html
-ppLPatSig summary links loc (doc, _argDocs) (L _ name) (expl, qtvs) lprov lreq typ fixities splice unicode qual
+ppLPatSig summary links loc (doc, _argDocs) (L _ name) typ fixities splice unicode qual
   | summary = pref1
   | otherwise = topDeclElem links loc splice [name] (pref1 <+> ppFixities fixities qual)
                 +++ docSection Nothing qual doc
   where
     pref1 = hsep [ keyword "pattern"
-                 , ppBinder summary occname
+                 , ppDocBinder name
                  , dcolon unicode
-                 , ppLTyVarBndrs expl qtvs unicode qual
-                 , cxt
-                 , ppLType unicode qual typ
+                 , ppLType unicode (hsSigType ty)
                  ]
 
     cxt = case (ppLContextMaybe lprov unicode qual, ppLContextMaybe lreq unicode qual) of
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index 6a499f64..f7a32dd3 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -132,7 +132,7 @@ mkEmptySigWcType ty = mkEmptyImplicitBndrs (mkEmptyWildCardBndrs ty)
 
 addClassContext :: Name -> LHsQTyVars Name -> LSig Name -> LSig Name
 -- Add the class context to a class-op signature
-addClassContxt cls tvs0 (L pos (ClassOpSig _ lname ltype))
+addClassContext cls tvs0 (L pos (ClassOpSig _ lname ltype))
   = L pos (TypeSig lname (mkEmptySigWcType (go (hsSigType ltype))))
           -- The mkEmptySigWcType is suspicious
   where
-- 
cgit v1.2.3


From 3fd2ed3213778c090ed5e27bd8a9e5bdee5c5135 Mon Sep 17 00:00:00 2001
From: Simon Peyton Jones <simonpj@microsoft.com>
Date: Sat, 31 Oct 2015 19:08:13 +0000
Subject: More adaption to wildcard-refactor

---
 haddock-api/src/Haddock/Backends/LaTeX.hs      |   2 +-
 haddock-api/src/Haddock/Backends/Xhtml.hs      |   2 +-
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 162 +++++++++++++------------
 3 files changed, 85 insertions(+), 81 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Xhtml/Decl.hs')

diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 79aa1177..b89656d3 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -385,7 +385,7 @@ ppTypeOrFunSig _ _ typ (doc, argDocs) (pref1, pref2, sep0)
 
      arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs
 
-     do_args :: Int -> LaTeX -> (HsType DocName) -> LaTeX
+     do_args :: Int -> LaTeX -> HsType DocName -> LaTeX
      do_args _n leader (HsForAllTy tvs ltype)
        = decltt leader
          <-> decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]))
diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index a1e4f94d..1554a33c 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -583,7 +583,7 @@ processForMiniSynopsis mdl unicode qual ExportDecl { expItemDecl = L _loc decl0
         (DataDecl{})   -> [keyword "data" <+> b]
         (SynDecl{})    -> [keyword "type" <+> b]
         (ClassDecl {}) -> [keyword "class" <+> b]
-    SigD (TypeSig lnames (L _ _) _) ->
+    SigD (TypeSig lnames _) ->
       map (ppNameMini Prefix mdl . nameOccName . getName . unLoc) lnames
     _ -> []
 processForMiniSynopsis _ _ qual (ExportGroup lvl _id txt) =
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 0461ad41..4f0a22ca 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -45,13 +45,14 @@ ppDecl :: Bool -> LinksInfo -> LHsDecl DocName
        -> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, Fixity)]
        -> [(DocName, DocForDecl DocName)] -> Splice -> Unicode -> Qualification -> Html
 ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode qual = case decl of
-  TyClD (FamDecl d)           -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode qual
-  TyClD d@(DataDecl {})       -> ppDataDecl summ links instances fixities subdocs loc mbDoc d splice unicode qual
-  TyClD d@(SynDecl {})        -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual
-  TyClD d@(ClassDecl {})      -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual
-  SigD (TypeSig lnames lty _) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames lty fixities splice unicode qual
-  SigD (PatSynSig lname ty) ->
-      ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname ty fixities splice unicode qual
+  TyClD (FamDecl d)         -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode qual
+  TyClD d@(DataDecl {})     -> ppDataDecl summ links instances fixities subdocs loc mbDoc d splice unicode qual
+  TyClD d@(SynDecl {})      -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual
+  TyClD d@(ClassDecl {})    -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual
+  SigD (TypeSig lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames
+                                         (hsSigWcType lty) fixities splice unicode qual
+  SigD (PatSynSig lname ty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname
+                                         ty fixities splice unicode qual
   ForD d                         -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual
   InstD _                        -> noHtml
   _                              -> error "declaration not supported by ppDecl"
@@ -61,20 +62,20 @@ ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
              [Located DocName] -> LHsType DocName -> [(DocName, Fixity)] ->
              Splice -> Unicode -> Qualification -> Html
 ppLFunSig summary links loc doc lnames lty fixities splice unicode qual =
-  ppFunSig summary links loc doc (map unLoc lnames) (unLoc lty) fixities
+  ppFunSig summary links loc doc (map unLoc lnames) lty fixities
            splice unicode qual
 
 ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
-            [DocName] -> HsType DocName -> [(DocName, Fixity)] ->
+            [DocName] -> LHsType DocName -> [(DocName, Fixity)] ->
             Splice -> Unicode -> Qualification -> Html
 ppFunSig summary links loc doc docnames typ fixities splice unicode qual =
-  ppSigLike summary links loc mempty doc docnames fixities (typ, pp_typ)
+  ppSigLike summary links loc mempty doc docnames fixities (unLoc typ, pp_typ)
             splice unicode qual
   where
-    pp_typ = ppType unicode qual typ
+    pp_typ = ppLType unicode qual typ
 
 ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
-             Located DocName -> LHsSigType DocName
+             Located DocName -> LHsSigType DocName ->
              [(DocName, Fixity)] ->
              Splice -> Unicode -> Qualification -> Html
 ppLPatSig summary links loc (doc, _argDocs) (L _ name) typ fixities splice unicode qual
@@ -83,18 +84,11 @@ ppLPatSig summary links loc (doc, _argDocs) (L _ name) typ fixities splice unico
                 +++ docSection Nothing qual doc
   where
     pref1 = hsep [ keyword "pattern"
-                 , ppDocBinder name
+                 , ppBinder summary occname
                  , dcolon unicode
-                 , ppLType unicode (hsSigType ty)
+                 , ppLType unicode qual (hsSigType typ)
                  ]
 
-    cxt = case (ppLContextMaybe lprov unicode qual, ppLContextMaybe lreq unicode qual) of
-        (Nothing,   Nothing)  -> noHtml
-        (Nothing,   Just req) -> parens noHtml <+> darr <+> req <+> darr
-        (Just prov, Nothing)  -> prov <+> darr
-        (Just prov, Just req) -> prov <+> darr <+> req <+> darr
-
-    darr = darrow unicode
     occname = nameOccName . getName $ name
 
 ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName ->
@@ -128,22 +122,29 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep)
     argDoc n = Map.lookup n argDocs
 
     do_largs n leader (L _ t) = do_args n leader t
+
     do_args :: Int -> Html -> HsType DocName -> [SubDecl]
-    do_args n leader (HsForAllTy _ _ tvs lctxt ltype)
-      = case unLoc lctxt of
-        [] -> do_largs n leader' ltype
-        _  -> (leader' <+> ppLContextNoArrow lctxt unicode qual, Nothing, [])
-              : do_largs n (darrow unicode) ltype
-      where leader' = leader <+> ppForAll tvs unicode qual
+    do_args n leader (HsForAllTy tvs ltype)
+      = do_largs n leader' ltype
+      where
+        leader' = leader <+> ppForAll tvs unicode qual
+
+    do_args n leader (HsQualTy lctxt ltype)
+      | null (unLoc lctxt)
+      = do_largs n leader ltype
+      | otherwise
+      = (leader <+> ppLContextNoArrow lctxt unicode qual, Nothing, [])
+        : do_largs n (darrow unicode) ltype
+
     do_args n leader (HsFunTy lt r)
       = (leader <+> ppLFunLhType unicode qual lt, argDoc n, [])
         : do_largs (n+1) (arrow unicode) r
     do_args n leader t
       = [(leader <+> ppType unicode qual t, argDoc n, [])]
 
-ppForAll :: LHsTyVarBndrs DocName -> Unicode -> Qualification -> Html
+ppForAll :: [LHsTyVarBndr DocName] -> Unicode -> Qualification -> Html
 ppForAll tvs unicode qual =
-  case [ppKTv n k | L _ (KindedTyVar (L _ n) k) <- hsQTvBndrs tvs] of
+  case [ppKTv n k | L _ (KindedTyVar (L _ n) k) <- tvs] of
     [] -> noHtml
     ts -> forallSymbol unicode <+> hsep ts +++ dot
   where ppKTv n k = parens $
@@ -171,20 +172,19 @@ ppFixities fs qual = foldr1 (+++) (map ppFix uniq_fs) +++ rightEdge
     rightEdge = thespan ! [theclass "rightedge"] << noHtml
 
 
-ppTyVars :: LHsTyVarBndrs DocName -> [Html]
-ppTyVars tvs = map ppTyName (tyvarNames tvs)
+ppTyVars :: [LHsTyVarBndr DocName] -> [Html]
+ppTyVars tvs = map (ppTyName . getName . hsLTyVarName) tvs
 
-
-tyvarNames :: LHsTyVarBndrs DocName -> [Name]
-tyvarNames = map getName . hsLTyVarNames
+tyvarNames :: LHsQTyVars DocName -> [Name]
+tyvarNames = map (getName . hsLTyVarName) . hsQTvBndrs
 
 
 ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName
       -> ForeignDecl DocName -> [(DocName, Fixity)]
       -> Splice -> Unicode -> Qualification -> Html
-ppFor summary links loc doc (ForeignImport (L _ name) (L _ typ) _ _) fixities
+ppFor summary links loc doc (ForeignImport (L _ name) typ _ _) fixities
       splice unicode qual
-  = ppFunSig summary links loc doc [name] typ fixities splice unicode qual
+  = ppFunSig summary links loc doc [name] (hsSigType typ) fixities splice unicode qual
 ppFor _ _ _ _ _ _ _ _ _ = error "ppFor"
 
 
@@ -199,7 +199,8 @@ ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars
                    (full <+> fixs, hdr <+> fixs, spaceHtml +++ equals)
                    splice unicode qual
   where
-    hdr  = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars ltyvars)
+    hdr  = hsep ([keyword "type", ppBinder summary occ]
+                 ++ ppTyVars (hsQTvBndrs ltyvars))
     full = hdr <+> equals <+> ppLType unicode qual ltype
     occ  = nameOccName . getName $ name
     fixs
@@ -318,7 +319,7 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode
 
     -- Individual equation of a closed type family
     ppTyFamEqn TyFamEqn { tfe_tycon = n, tfe_rhs = rhs
-                        , tfe_pats = HsWB { hswb_cts = ts }}
+                        , tfe_pats = HsIB { hsib_body = ts }}
       = ( ppAppNameTypes (unLoc n) [] (map unLoc ts) unicode qual
           <+> equals <+> ppType unicode qual (unLoc rhs)
         , Nothing, [] )
@@ -403,10 +404,6 @@ ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Unicode
 ppLContext        = ppContext        . unLoc
 ppLContextNoArrow = ppContextNoArrow . unLoc
 
-
-ppLContextMaybe :: Located (HsContext DocName) -> Unicode -> Qualification -> Maybe Html
-ppLContextMaybe = ppContextNoLocsMaybe . map unLoc . unLoc
-
 ppContextNoArrow :: HsContext DocName -> Unicode -> Qualification -> Html
 ppContextNoArrow cxt unicode qual = fromMaybe noHtml $
                                     ppContextNoLocsMaybe (map unLoc cxt) unicode qual
@@ -437,7 +434,7 @@ ppHsContext cxt unicode qual = parenList (map (ppType unicode qual) cxt)
 
 
 ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName
-           -> LHsTyVarBndrs DocName -> [Located ([Located DocName], [Located DocName])]
+           -> LHsQTyVars DocName -> [Located ([Located DocName], [Located DocName])]
            -> Unicode -> Qualification -> Html
 ppClassHdr summ lctxt n tvs fds unicode qual =
   keyword "class"
@@ -470,8 +467,9 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, t
 
                 -- ToDo: add associated type defaults
 
-            [ ppFunSig summary links loc doc names typ [] splice unicode qual
-              | L _ (TypeSig lnames (L _ typ) _) <- sigs
+            [ ppFunSig summary links loc doc names (hsSigWcType typ)
+                       [] splice unicode qual
+              | L _ (TypeSig lnames typ) <- sigs
               , let doc = lookupAnySubdoc (head names) subdocs
                     names = map unLoc lnames ]
               -- FIXME: is taking just the first name ok? Is it possible that
@@ -517,8 +515,9 @@ ppClassDecl summary links instances fixities loc d subdocs
                             doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs
                             subfixs = [ f | f@(n',_) <- fixities, n == n' ] ]
 
-    methodBit = subMethods [ ppFunSig summary links loc doc names typ subfixs splice unicode qual
-                           | TypeSig lnames (L _ typ) _ <- sigs
+    methodBit = subMethods [ ppFunSig summary links loc doc names (hsSigType typ)
+                                      subfixs splice unicode qual
+                           | L _ (ClassOpSig _ lnames typ) <- lsigs
                            , let doc = lookupAnySubdoc (head names) subdocs
                                  subfixs = [ f | n <- names
                                                , f@(n',_) <- fixities
@@ -531,12 +530,12 @@ ppClassDecl summary links instances fixities loc d subdocs
     minimalBit = case [ s | MinimalSig _ s <- sigs ] of
       -- Miminal complete definition = every shown method
       And xs : _ | sort [getName n | Var (L _ n) <- xs] ==
-                   sort [getName n | TypeSig ns _ _ <- sigs, L _ n <- ns]
+                   sort [getName n | L _ (TypeSig ns _) <- lsigs, L _ n <- ns]
         -> noHtml
 
       -- Minimal complete definition = the only shown method
       Var (L _ n) : _ | [getName n] ==
-                        [getName n' | TypeSig ns _ _ <- sigs, L _ n' <- ns]
+                        [getName n' | L _ (TypeSig ns _) <- lsigs, L _ n' <- ns]
         -> noHtml
 
       -- Minimal complete definition = nothing
@@ -767,23 +766,23 @@ ppShortConstrParts summary dataInst con unicode qual = case con_res con of
 
 
 -- ppConstrHdr is for (non-GADT) existentials constructors' syntax
-ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Unicode
+ppConstrHdr :: Bool -> [Name] -> HsContext DocName -> Unicode
             -> Qualification -> Html
 ppConstrHdr forall_ tvs ctxt unicode qual
  = (if null tvs then noHtml else ppForall)
    +++
-   (if null ctxt then noHtml else ppContextNoArrow ctxt unicode qual
-        <+> darrow unicode +++ toHtml " ")
+   (if null ctxt then noHtml
+    else ppContextNoArrow ctxt unicode qual
+         <+> darrow unicode +++ toHtml " ")
   where
-    ppForall = case forall_ of
-      Explicit -> forallSymbol unicode <+> hsep (map (ppName Prefix) tvs) <+> toHtml ". "
-      Qualified -> noHtml
-      Implicit -> noHtml
-
+    ppForall | forall_   = forallSymbol unicode <+> hsep (map (ppName Prefix) tvs)
+                           <+> toHtml ". "
+             | otherwise = noHtml
 
 ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> [(DocName, Fixity)]
                    -> Unicode -> Qualification -> LConDecl DocName -> SubDecl
-ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, fieldPart)
+ppSideBySideConstr subdocs fixities unicode qual (L loc con)
+ = (decl, mbDoc, fieldPart)
  where
     decl = case con_res con of
       ResTyH98 -> case con_details con of
@@ -813,12 +812,19 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, field
 
     doRecordFields fields = subFields qual
       (map (ppSideBySideField subdocs unicode qual) (map unLoc fields))
+
     doGADTCon :: [LHsType DocName] -> Located (HsType DocName) -> Html
     doGADTCon args resTy = ppOcc <+> dcolon unicode
-        <+> hsep [ppForAllCon forall_ ltvs (con_cxt con) unicode qual,
-                  ppLType unicode qual (foldr mkFunTy resTy args) ]
+        <+> ppLType unicode qual (mk_forall $ mk_phi $
+                                  foldr mkFunTy resTy args)
         <+> fixity
 
+    mk_phi ty | null context = ty
+              | otherwise    = L loc (HsQualTy (con_cxt con) ty)
+
+    mk_forall ty | con_explicit con = L loc (HsForAllTy (hsQTvBndrs ltvs) ty)
+                 | otherwise        = ty
+
     fixity  = ppFixities fixities qual
     header_ = ppConstrHdr forall_ tyVars context unicode qual
     occ       = map (nameOccName . getName . unLoc) $ con_names con
@@ -951,38 +957,36 @@ ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual
 -- Drop top-level for-all type variables in user style
 -- since they are implicit in Haskell
 
-ppForAllCon :: HsExplicitFlag -> LHsTyVarBndrs DocName
-         -> Located (HsContext DocName) -> Unicode -> Qualification -> Html
+ppForAllCon :: Bool -> LHsQTyVars DocName
+            -> Located (HsContext DocName) -> Unicode -> Qualification -> Html
 ppForAllCon expl tvs cxt unicode qual =
   forall_part <+> ppLContext cxt unicode qual
   where
     forall_part = ppLTyVarBndrs expl tvs unicode qual
 
-ppLTyVarBndrs :: HsExplicitFlag -> LHsTyVarBndrs DocName
-              -> Unicode -> Qualification
-              -> Html
-ppLTyVarBndrs expl tvs unicode _qual
-  | show_forall = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot
-  | otherwise   = noHtml
+ppLTyVarBndrs :: Bool -> LHsQTyVars DocName -> Unicode -> Qualification -> Html
+ppLTyVarBndrs show_forall tvs unicode _qual
+  | show_forall
+  , not (null tv_bndrs) = ppForAllPart tv_bndrs unicode
+  | otherwise           = noHtml
   where
-    show_forall = not (null (hsQTvBndrs tvs)) && is_explicit
-    is_explicit = case expl of {Explicit -> True; Implicit -> False; Qualified -> False}
+    tv_bndrs = hsQTvBndrs tvs
 
+ppForAllPart :: [LHsTyVarBndr DocName] -> Unicode -> Html
+ppForAllPart tvs unicode = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot
 
 ppr_mono_lty :: Int -> LHsType DocName -> Unicode -> Qualification -> Html
 ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty)
 
 
 ppr_mono_ty :: Int -> HsType DocName -> Unicode -> Qualification -> Html
-ppr_mono_ty ctxt_prec (HsForAllTy expl extra tvs ctxt ty) unicode qual
-  = maybeParen ctxt_prec pREC_FUN $ ppForAllCon expl tvs ctxt' unicode qual
-                                    <+> ppr_mono_lty pREC_TOP ty unicode qual
- where
-   anonWC = HsWildCardTy (AnonWildCard (Undocumented underscore))
-   underscore = mkUnboundName (mkRdrUnqual (mkTyVarOcc "_"))
-   ctxt'
-     | Just loc <- extra = (++ [L loc anonWC]) `fmap` ctxt
-     | otherwise         = ctxt
+ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode qual
+  = maybeParen ctxt_prec pREC_FUN $
+    ppForAllPart tvs unicode <+> ppr_mono_lty pREC_TOP ty unicode qual
+
+ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode qual
+  = maybeParen ctxt_prec pREC_FUN $
+    ppLContext ctxt unicode qual <+> ppr_mono_lty pREC_TOP ty unicode qual
 
 -- UnicodeSyntax alternatives
 ppr_mono_ty _ (HsTyVar name) True _
-- 
cgit v1.2.3


From e27200a8aa4036727b2dbd454d52ab4d44b144b2 Mon Sep 17 00:00:00 2001
From: Alan Zimmerman <alan.zimm@gmail.com>
Date: Tue, 27 Oct 2015 16:12:50 +0200
Subject: Matching change GHC #11017 BooleanFormula located

---
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 11 ++++++-----
 haddock-api/src/Haddock/Convert.hs             |  2 +-
 haddock-api/src/Haddock/Interface/Create.hs    |  4 ++--
 haddock-api/src/Haddock/Interface/Rename.hs    |  4 +++-
 4 files changed, 12 insertions(+), 9 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Xhtml/Decl.hs')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 4f0a22ca..e6220ff2 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -527,10 +527,10 @@ ppClassDecl summary links instances fixities loc d subdocs
                            -- there are different subdocs for different names in a single
                            -- type signature?
 
-    minimalBit = case [ s | MinimalSig _ s <- sigs ] of
+    minimalBit = case [ s | MinimalSig _ (L _ s) <- sigs ] of
       -- Miminal complete definition = every shown method
-      And xs : _ | sort [getName n | Var (L _ n) <- xs] ==
-                   sort [getName n | L _ (TypeSig ns _) <- lsigs, L _ n <- ns]
+      And xs : _ | sort [getName n | L _ (Var (L _ n)) <- xs] ==
+                   sort [getName n | TypeSig ns _ _ <- sigs, L _ n <- ns]
         -> noHtml
 
       -- Minimal complete definition = the only shown method
@@ -545,9 +545,10 @@ ppClassDecl summary links instances fixities loc d subdocs
       _ -> noHtml
 
     ppMinimal _ (Var (L _ n)) = ppDocName qual Prefix True n
-    ppMinimal _ (And fs) = foldr1 (\a b -> a+++", "+++b) $ map (ppMinimal True) fs
-    ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a+++" | "+++b) $ map (ppMinimal False) fs
+    ppMinimal _ (And fs) = foldr1 (\a b -> a+++", "+++b) $ map (ppMinimal True . unLoc) fs
+    ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a+++" | "+++b) $ map (ppMinimal False . unLoc) fs
       where wrap | p = parens | otherwise = id
+    ppMinimal p (Parens x) = ppMinimal p (unLoc x)
 
     instancesBit = ppInstances links (OriginClass nm) instances
         splice unicode qual
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index e563ac08..b829a5fd 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -79,7 +79,7 @@ tyThingToLHsDecl t = case t of
          , tcdFDs = map (\ (l,r) -> noLoc
                         (map (noLoc . getName) l, map (noLoc . getName) r) ) $
                          snd $ classTvsFds cl
-         , tcdSigs = noLoc (MinimalSig mempty . fmap noLoc $ classMinimalDef cl) :
+         , tcdSigs = noLoc (MinimalSig mempty . noLoc . fmap noLoc $ classMinimalDef cl) :
                       map (noLoc . synifyIdSig DeleteTopLevelQuantification)
                         (classMethods cl)
          , tcdMeths = emptyBag --ignore default method definitions, they don't affect signature
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 11906efa..6f0254c5 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -562,7 +562,7 @@ mkExportItems
 
                   L loc (TyClD cl@ClassDecl{}) -> do
                     mdef <- liftGhcToErrMsgGhc $ minimalDef t
-                    let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . fmap noLoc) mdef
+                    let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . noLoc . fmap noLoc) mdef
                     return [ mkExportDecl t
                       (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_ ]
 
@@ -760,7 +760,7 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap
         return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices))
     mkExportItem (L l (TyClD cl@ClassDecl{ tcdLName = L _ name, tcdSigs = sigs })) = do
       mdef <- liftGhcToErrMsgGhc $ minimalDef name
-      let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . fmap noLoc) mdef
+      let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . noLoc . fmap noLoc) mdef
       expDecl (L l (TyClD cl { tcdSigs = sig ++ sigs })) l name
     mkExportItem decl@(L l d)
       | name:_ <- getMainDeclBinder d = expDecl decl l name
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 3a170f4a..f0ae4cf6 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -462,7 +462,9 @@ renameSig sig = case sig of
   FixSig (FixitySig lnames fixity) -> do
     lnames' <- mapM renameL lnames
     return $ FixSig (FixitySig lnames' fixity)
-  MinimalSig src s -> MinimalSig src <$> traverse renameL s
+  MinimalSig src (L l s) -> do
+    s' <- traverse renameL s
+    return $ MinimalSig src (L l s')
   -- we have filtered out all other kinds of signatures in Interface.Create
   _ -> error "expected TypeSig"
 
-- 
cgit v1.2.3


From d74b8d0e5ab3589d3ab8cf82e22ab6ac6813ae40 Mon Sep 17 00:00:00 2001
From: Alan Zimmerman <alan.zimm@gmail.com>
Date: Sat, 21 Nov 2015 21:16:12 +0200
Subject: Update to match GHC wip/T11019

---
 haddock-api/src/Haddock/Backends/Hoogle.hs     |  2 +-
 haddock-api/src/Haddock/Backends/LaTeX.hs      |  4 ++--
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs |  8 ++++----
 haddock-api/src/Haddock/Convert.hs             |  6 +++---
 haddock-api/src/Haddock/Interface/Create.hs    |  2 +-
 haddock-api/src/Haddock/Interface/Rename.hs    | 10 +++++-----
 haddock-api/src/Haddock/Types.hs               | 13 +++++++------
 7 files changed, 23 insertions(+), 22 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Xhtml/Decl.hs')

diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 1d85b474..5800736f 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -241,7 +241,7 @@ ppCtor dflags dat subdocs con
         name = commaSeparate dflags . map unL $ con_names con
 
         resType = case con_res con of
-            ResTyH98 -> apps $ map (reL . HsTyVar) $
+            ResTyH98 -> apps $ map (reL . HsTyVar . reL) $
                         (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvBndrs $ tyClDeclTyVars dat]
             ResTyGADT _ x -> x
 
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index b89656d3..a71ae784 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -880,7 +880,7 @@ ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode
         , ppr_mono_lty pREC_TOP ty unicode ]
 
 ppr_mono_ty _         (HsBangTy b ty)     u = ppBang b <> ppLParendType u ty
-ppr_mono_ty _         (HsTyVar name)      _ = ppDocName name
+ppr_mono_ty _         (HsTyVar (L _ name)) _ = ppDocName name
 ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2)   u = ppr_fun_ty ctxt_prec ty1 ty2 u
 ppr_mono_ty _         (HsTupleTy con tys) u = tupleParens con (map (ppLType u) tys)
 ppr_mono_ty _         (HsKindSig ty kind) u = parens (ppr_mono_lty pREC_TOP ty u <+> dcolon u <+> ppLKind u kind)
@@ -918,7 +918,7 @@ ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode
 
 ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ = char '_'
 
-ppr_mono_ty _ (HsWildCardTy (NamedWildCard name)) _ = ppDocName name
+ppr_mono_ty _ (HsWildCardTy (NamedWildCard (L _ name))) _ = ppDocName name
 
 ppr_mono_ty _ (HsTyLit t) u = ppr_tylit t u
 
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index e6220ff2..5f5a9e61 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -943,7 +943,7 @@ ppParendType unicode qual ty = ppr_mono_ty pREC_CON ty unicode qual
 ppFunLhType  unicode qual ty = ppr_mono_ty pREC_FUN ty unicode qual
 
 ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr DocName -> Html
-ppHsTyVarBndr _       qual (UserTyVar   name     ) =
+ppHsTyVarBndr _       qual (UserTyVar (L _ name)) =
     ppDocName qual Raw False name
 ppHsTyVarBndr unicode qual (KindedTyVar name kind) =
     parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+>
@@ -990,12 +990,12 @@ ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode qual
     ppLContext ctxt unicode qual <+> ppr_mono_lty pREC_TOP ty unicode qual
 
 -- UnicodeSyntax alternatives
-ppr_mono_ty _ (HsTyVar name) True _
+ppr_mono_ty _ (HsTyVar (L _ name)) True _
   | getOccString (getName name) == "*"    = toHtml "★"
   | getOccString (getName name) == "(->)" = toHtml "(→)"
 
 ppr_mono_ty _         (HsBangTy b ty)     u q = ppBang b +++ ppLParendType u q ty
-ppr_mono_ty _         (HsTyVar name)      _ q = ppDocName q Prefix True name
+ppr_mono_ty _         (HsTyVar (L _ name)) _ q = ppDocName q Prefix True name
 ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2)   u q = ppr_fun_ty ctxt_prec ty1 ty2 u q
 ppr_mono_ty _         (HsTupleTy con tys) u q = tupleParens con (map (ppLType u q) tys)
 ppr_mono_ty _         (HsKindSig ty kind) u q =
@@ -1041,7 +1041,7 @@ ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual
 
 ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ _ = char '_'
 
-ppr_mono_ty _ (HsWildCardTy (NamedWildCard name)) _ q = ppDocName q Prefix True name
+ppr_mono_ty _ (HsWildCardTy (NamedWildCard (L _ name))) _ q = ppDocName q Prefix True name
 
 ppr_mono_ty _ (HsTyLit n) _ _ = ppr_tylit n
 
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index ddf8f6b3..3b6657c2 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -334,7 +334,7 @@ synifyTyVars ktvs = HsQTvs { hsq_kvs = map tyVarName kvs
 
 synifyTyVar :: TyVar -> LHsTyVarBndr Name
 synifyTyVar tv
-  | isLiftedTypeKind kind = noLoc (UserTyVar name)
+  | isLiftedTypeKind kind = noLoc (UserTyVar (noLoc name))
   | otherwise             = noLoc (KindedTyVar (noLoc name) (synifyKindSig kind))
   where
     kind = tyVarKind tv
@@ -366,7 +366,7 @@ synifySigWcType :: SynifyTypeState -> Type -> LHsSigWcType Name
 synifySigWcType s ty = mkEmptyImplicitBndrs (mkEmptyWildCardBndrs (synifyType s ty))
 
 synifyType :: SynifyTypeState -> Type -> LHsType Name
-synifyType _ (TyVarTy tv) = noLoc $ HsTyVar (getName tv)
+synifyType _ (TyVarTy tv) = noLoc $ HsTyVar $ noLoc (getName tv)
 synifyType _ (TyConApp tc tys)
   -- Use non-prefix tuple syntax where possible, because it looks nicer.
   | Just sort <- tyConTuple_maybe tc
@@ -391,7 +391,7 @@ synifyType _ (TyConApp tc tys)
   -- Most TyCons:
   | otherwise =
     foldl (\t1 t2 -> noLoc (HsAppTy t1 t2))
-      (noLoc $ HsTyVar (getName tc))
+      (noLoc $ HsTyVar $ noLoc (getName tc))
       (map (synifyType WithinType) tys)
 synifyType _ (AppTy t1 t2) = let
   s1 = synifyType WithinType t1
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 1c2cf5c9..5ce4e6e6 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -822,7 +822,7 @@ extractRecSel nm mdl t tvs (L _ con : rest) =
                                  , L l n <- ns, selectorFieldOcc n == nm ]
   data_ty
     | ResTyGADT _ ty <- con_res con = ty
-    | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) tvs
+    | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar (noLoc t))) tvs
 
 -- | Keep export items with docs.
 pruneExportItems :: [ExportItem Name] -> [ExportItem Name]
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index f0ae4cf6..4804faff 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -214,7 +214,7 @@ renameType t = case t of
     ltype'    <- renameLType ltype
     return (HsQualTy { hst_ctxt = lcontext', hst_body = ltype' })
 
-  HsTyVar n -> return . HsTyVar =<< rename n
+  HsTyVar (L l n) -> return . HsTyVar . L l =<< rename n
   HsBangTy b ltype -> return . HsBangTy b =<< renameLType ltype
 
   HsAppTy a b -> do
@@ -269,9 +269,9 @@ renameLHsQTyVars (HsQTvs { hsq_kvs = _, hsq_tvs = tvs })
                 -- This is rather bogus, but I'm not sure what else to do
 
 renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName)
-renameLTyVarBndr (L loc (UserTyVar n))
+renameLTyVarBndr (L loc (UserTyVar (L l n)))
   = do { n' <- rename n
-       ; return (L loc (UserTyVar n')) }
+       ; return (L loc (UserTyVar (L l n'))) }
 renameLTyVarBndr (L loc (KindedTyVar (L lv n) kind))
   = do { n' <- rename n
        ; kind' <- renameLKind kind
@@ -283,8 +283,8 @@ renameLContext (L loc context) = do
   return (L loc context')
 
 renameWildCardInfo :: HsWildCardInfo Name -> RnM (HsWildCardInfo DocName)
-renameWildCardInfo (AnonWildCard  name) = AnonWildCard  <$> rename name
-renameWildCardInfo (NamedWildCard name) = NamedWildCard <$> rename name
+renameWildCardInfo (AnonWildCard  (L l name)) = AnonWildCard . L l <$> rename name
+renameWildCardInfo (NamedWildCard (L l name)) = NamedWildCard . L l <$> rename name
 
 renameInstHead :: InstHead Name -> RnM (InstHead DocName)
 renameInstHead InstHead {..} = do
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index dd41b523..9db11be6 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -652,12 +652,13 @@ instance Monad ErrMsgGhc where
 -- * Pass sensitive types
 -----------------------------------------------------------------------------
 
-type instance PostRn DocName NameSet  = PlaceHolder
-type instance PostRn DocName Fixity   = PlaceHolder
-type instance PostRn DocName Bool     = PlaceHolder
-type instance PostRn DocName Name     = DocName
-type instance PostRn DocName [Name]   = PlaceHolder
-type instance PostRn DocName DocName  = DocName
+type instance PostRn DocName NameSet        = PlaceHolder
+type instance PostRn DocName Fixity         = PlaceHolder
+type instance PostRn DocName Bool           = PlaceHolder
+type instance PostRn DocName Name           = DocName
+type instance PostRn DocName (Located Name) = Located DocName
+type instance PostRn DocName [Name]         = PlaceHolder
+type instance PostRn DocName DocName        = DocName
 
 type instance PostTc DocName Kind     = PlaceHolder
 type instance PostTc DocName Type     = PlaceHolder
-- 
cgit v1.2.3


From 5b07e7132ede1eefd2bc52604517434e960c87cb Mon Sep 17 00:00:00 2001
From: Alan Zimmerman <alan.zimm@gmail.com>
Date: Sat, 5 Dec 2015 17:33:52 +0200
Subject: Matching changes for #11028

---
 haddock-api/src/Haddock/Backends/Hoogle.hs     |  19 ++--
 haddock-api/src/Haddock/Backends/LaTeX.hs      |  71 ++++++++++++++-
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 116 ++++++++-----------------
 haddock-api/src/Haddock/Convert.hs             |  24 ++---
 haddock-api/src/Haddock/GhcUtils.hs            |   6 +-
 haddock-api/src/Haddock/Interface/Create.hs    |  13 +--
 haddock-api/src/Haddock/Interface/Rename.hs    |  28 +++---
 haddock-api/src/Haddock/Utils.hs               |  20 ++++-
 8 files changed, 176 insertions(+), 121 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Xhtml/Decl.hs')

diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 5800736f..cef0da20 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -221,8 +221,9 @@ lookupCon dflags subdocs (L _ name) = case lookup name subdocs of
   _ -> []
 
 ppCtor :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> ConDecl Name -> [String]
-ppCtor dflags dat subdocs con
-   = concatMap (lookupCon dflags subdocs) (con_names con) ++ f (con_details con)
+ppCtor dflags dat subdocs con@ConDeclH98 {}
+  -- AZ:TODO get rid of the concatMap
+   = concatMap (lookupCon dflags subdocs) [con_name con] ++ f (getConDetails con)
     where
         f (PrefixCon args) = [typeSig name $ args ++ [resType]]
         f (InfixCon a1 a2) = f $ PrefixCon [a1,a2]
@@ -238,12 +239,18 @@ ppCtor dflags dat subdocs con
 
         -- We print the constructors as comma-separated list. See GHC
         -- docs for con_names on why it is a list to begin with.
-        name = commaSeparate dflags . map unL $ con_names con
+        name = commaSeparate dflags . map unL $ getConNames con
 
-        resType = case con_res con of
-            ResTyH98 -> apps $ map (reL . HsTyVar . reL) $
+        resType = apps $ map (reL . HsTyVar . reL) $
                         (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvBndrs $ tyClDeclTyVars dat]
-            ResTyGADT _ x -> x
+
+ppCtor dflags _dat subdocs con@ConDeclGADT {}
+   = concatMap (lookupCon dflags subdocs) (getConNames con) ++ f
+    where
+        f = [typeSig name (hsib_body $ con_type con)]
+
+        typeSig nm ty = operator nm ++ " :: " ++ outHsType dflags (unL ty)
+        name = out dflags $ map unL $ getConNames con
 
 
 ppFixity :: DynFlags -> (Name, Fixity) -> [String]
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index a71ae784..e7780d6e 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -577,14 +577,14 @@ ppDataDecl instances subdocs _loc doc dataDecl unicode
 
   where
     cons      = dd_cons (tcdDataDefn dataDecl)
-    resTy     = (con_res . unLoc . head) cons
+    resTy     = (unLoc . head) cons
 
     body = catMaybes [constrBit, doc >>= documentationToLaTeX]
 
     (whereBit, leaders)
       | null cons = (empty,[])
       | otherwise = case resTy of
-        ResTyGADT _ _ -> (decltt (keyword "where"), repeat empty)
+        ConDeclGADT{} -> (decltt (keyword "where"), repeat empty)
         _             -> (empty, (decltt (text "=") : repeat (decltt (text "|"))))
 
     constrBit
@@ -609,6 +609,71 @@ ppConstrHdr forall tvs ctxt unicode
       False -> empty
 
 
+ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LaTeX
+                   -> LConDecl DocName -> LaTeX
+ppSideBySideConstr subdocs unicode leader (L _ con@(ConDeclH98 {})) =
+  leader <->
+  case con_details con of
+
+    PrefixCon args ->
+      decltt (hsep ((header_ unicode <+> ppOcc) :
+                 map (ppLParendType unicode) args))
+      <-> rDoc mbDoc <+> nl
+
+    RecCon (L _ fields) ->
+      (decltt (header_ unicode <+> ppOcc)
+        <-> rDoc mbDoc <+> nl)
+      $$
+      doRecordFields fields
+
+    InfixCon arg1 arg2 ->
+      decltt (hsep [ header_ unicode <+> ppLParendType unicode arg1,
+                 ppOcc,
+                 ppLParendType unicode arg2 ])
+      <-> rDoc mbDoc <+> nl
+
+ where
+    doRecordFields fields =
+        vcat (map (ppSideBySideField subdocs unicode) (map unLoc fields))
+
+
+    header_ = ppConstrHdr False tyVars context
+    occ     = map (nameOccName . getName . unLoc) $ getConNames con
+    ppOcc   = case occ of
+      [one] -> ppBinder one
+      _     -> cat (punctuate comma (map ppBinder occ))
+    tyVars  = tyvarNames (fromMaybe (HsQTvs PlaceHolder []) (con_qvars con))
+    context = unLoc (fromMaybe (noLoc []) (con_cxt con))
+
+    -- don't use "con_doc con", in case it's reconstructed from a .hi file,
+    -- or also because we want Haddock to do the doc-parsing, not GHC.
+    mbDoc = case getConNames con of
+              [] -> panic "empty con_names"
+              (cn:_) -> lookup (unLoc cn) subdocs >>=
+                        fmap _doc . combineDocumentation . fst
+
+ppSideBySideConstr subdocs unicode leader (L _ con@(ConDeclGADT {})) =
+  leader <->
+  doGADTCon (hsib_body $ con_type con)
+
+ where
+    doGADTCon resTy = decltt (ppOcc <+> dcolon unicode <+>
+                               ppLType unicode resTy
+                            ) <-> rDoc mbDoc
+
+    occ     = map (nameOccName . getName . unLoc) $ getConNames con
+    ppOcc   = case occ of
+      [one] -> ppBinder one
+      _     -> cat (punctuate comma (map ppBinder occ))
+
+    -- don't use "con_doc con", in case it's reconstructed from a .hi file,
+    -- or also because we want Haddock to do the doc-parsing, not GHC.
+    mbDoc = case getConNames con of
+              [] -> panic "empty con_names"
+              (cn:_) -> lookup (unLoc cn) subdocs >>=
+                        fmap _doc . combineDocumentation . fst
+{- old
+
 ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LaTeX
                    -> LConDecl DocName -> LaTeX
 ppSideBySideConstr subdocs unicode leader (L loc con) =
@@ -672,7 +737,7 @@ ppSideBySideConstr subdocs unicode leader (L loc con) =
               (cn:_) -> lookup (unLoc cn) subdocs >>=
                         fmap _doc . combineDocumentation . fst
     mkFunTy a b = noLoc (HsFunTy a b)
-
+-}
 
 ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName ->  LaTeX
 ppSideBySideField subdocs unicode (ConDeclField names ltype _) =
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 5f5a9e61..af672ff7 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -645,11 +645,11 @@ ppShortDataDecl summary dataInst dataDecl unicode qual
 
   | [] <- cons = dataHeader
 
-  | [lcon] <- cons, ResTyH98 <- resTy,
+  | [lcon] <- cons, isH98,
     (cHead,cBody,cFoot) <- ppShortConstrParts summary dataInst (unLoc lcon) unicode qual
        = (dataHeader <+> equals <+> cHead) +++ cBody +++ cFoot
 
-  | ResTyH98 <- resTy = dataHeader
+  | isH98 = dataHeader
       +++ shortSubDecls dataInst (zipWith doConstr ('=':repeat '|') cons)
 
   | otherwise = (dataHeader <+> keyword "where")
@@ -663,7 +663,9 @@ ppShortDataDecl summary dataInst dataDecl unicode qual
     doGADTConstr con = ppShortConstr summary (unLoc con) unicode qual
 
     cons      = dd_cons (tcdDataDefn dataDecl)
-    resTy     = (con_res . unLoc . head) cons
+    isH98     = case unLoc (head cons) of
+                  ConDeclH98 {} -> True
+                  ConDeclGADT{} -> False
 
 
 ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)] ->
@@ -679,7 +681,9 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl
   where
     docname   = tcdName dataDecl
     cons      = dd_cons (tcdDataDefn dataDecl)
-    resTy     = (con_res . unLoc . head) cons
+    isH98     = case unLoc (head cons) of
+                  ConDeclH98 {} -> True
+                  ConDeclGADT{} -> False
 
     header_ = topDeclElem links loc splice [docname] $
              ppDataHeader summary dataDecl unicode qual <+> whereBit <+> fix
@@ -688,15 +692,13 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl
 
     whereBit
       | null cons = noHtml
-      | otherwise = case resTy of
-        ResTyGADT _ _ -> keyword "where"
-        _ -> noHtml
+      | otherwise = if isH98 then noHtml else keyword "where"
 
     constrBit = subConstructors qual
       [ ppSideBySideConstr subdocs subfixs unicode qual c
       | c <- cons
       , let subfixs = filter (\(n,_) -> any (\cn -> cn == n)
-                                     (map unLoc (con_names (unLoc c)))) fixities
+                                     (map unLoc (getConNames (unLoc c)))) fixities
       ]
 
     instancesBit = ppInstances links (OriginData docname) instances
@@ -713,8 +715,8 @@ ppShortConstr summary con unicode qual = cHead <+> cBody <+> cFoot
 -- returns three pieces: header, body, footer so that header & footer can be
 -- incorporated into the declaration
 ppShortConstrParts :: Bool -> Bool -> ConDecl DocName -> Unicode -> Qualification -> (Html, Html, Html)
-ppShortConstrParts summary dataInst con unicode qual = case con_res con of
-  ResTyH98 -> case con_details con of
+ppShortConstrParts summary dataInst con unicode qual = case con of
+  ConDeclH98{} -> case con_details con of
     PrefixCon args ->
       (header_ unicode qual +++ hsep (ppOcc
             : map (ppLParendType unicode qual) args), noHtml, noHtml)
@@ -727,28 +729,15 @@ ppShortConstrParts summary dataInst con unicode qual = case con_res con of
             ppOccInfix, ppLParendType unicode qual arg2],
        noHtml, noHtml)
 
-  ResTyGADT _ resTy -> case con_details con of
-    -- prefix & infix could use hsConDeclArgTys if it seemed to
-    -- simplify the code.
-    PrefixCon args -> (doGADTCon args resTy, noHtml, noHtml)
-    -- display GADT records with the new syntax,
-    -- Constr :: (Context) => { field :: a, field2 :: b } -> Ty (a, b)
-    -- (except each field gets its own line in docs, to match
-    -- non-GADT records)
-    RecCon (L _ fields) -> (ppOcc <+> dcolon unicode <+>
-                            ppForAllCon forall_ ltvs lcontext unicode qual <+> char '{',
-                            doRecordFields fields,
-                            char '}' <+> arrow unicode <+> ppLType unicode qual resTy)
-    InfixCon arg1 arg2 -> (doGADTCon [arg1, arg2] resTy, noHtml, noHtml)
+  ConDeclGADT {} -> (ppOcc <+> dcolon unicode <+> ppLType unicode qual resTy,noHtml,noHtml)
 
   where
+    resTy = hsib_body (con_type con)
+
     doRecordFields fields = shortSubDecls dataInst (map (ppShortField summary unicode qual) (map unLoc fields))
-    doGADTCon args resTy = ppOcc <+> dcolon unicode <+> hsep [
-                             ppForAllCon forall_ ltvs lcontext unicode qual,
-                             ppLType unicode qual (foldr mkFunTy resTy args) ]
 
     header_  = ppConstrHdr forall_ tyVars context
-    occ        = map (nameOccName . getName . unLoc) $ con_names con
+    occ        = map (nameOccName . getName . unLoc) $ getConNames con
 
     ppOcc      = case occ of
       [one] -> ppBinder summary one
@@ -758,12 +747,11 @@ ppShortConstrParts summary dataInst con unicode qual = case con_res con of
       [one] -> ppBinderInfix summary one
       _     -> hsep (punctuate comma (map (ppBinderInfix summary) occ))
 
-    ltvs     = con_qvars con
+    ltvs     = fromMaybe (HsQTvs PlaceHolder []) (con_qvars con)
     tyVars   = tyvarNames ltvs
-    lcontext = con_cxt con
-    context  = unLoc (con_cxt con)
-    forall_  = con_explicit con
-    mkFunTy a b = noLoc (HsFunTy a b)
+    lcontext = fromMaybe (noLoc []) (con_cxt con)
+    context  = unLoc lcontext
+    forall_  = False
 
 
 -- ppConstrHdr is for (non-GADT) existentials constructors' syntax
@@ -782,11 +770,11 @@ ppConstrHdr forall_ tvs ctxt unicode qual
 
 ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> [(DocName, Fixity)]
                    -> Unicode -> Qualification -> LConDecl DocName -> SubDecl
-ppSideBySideConstr subdocs fixities unicode qual (L loc con)
+ppSideBySideConstr subdocs fixities unicode qual (L _ con)
  = (decl, mbDoc, fieldPart)
  where
-    decl = case con_res con of
-      ResTyH98 -> case con_details con of
+    decl = case con of
+      ConDeclH98{} -> case con_details con of
         PrefixCon args ->
           hsep ((header_ +++ ppOcc)
             : map (ppLParendType unicode qual) args)
@@ -800,35 +788,25 @@ ppSideBySideConstr subdocs fixities unicode qual (L loc con)
             ppLParendType unicode qual arg2]
           <+> fixity
 
-      ResTyGADT _ resTy -> case con_details con of
-        -- prefix & infix could also use hsConDeclArgTys if it seemed to
-        -- simplify the code.
-        PrefixCon args -> doGADTCon args resTy
-        cd@(RecCon _) -> doGADTCon (hsConDeclArgTys cd) resTy
-        InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy
+      ConDeclGADT{} -> doGADTCon resTy
+
+    resTy = hsib_body (con_type con)
 
-    fieldPart = case con_details con of
+    fieldPart = case getConDetails con of
         RecCon (L _ fields) -> [doRecordFields fields]
         _ -> []
 
     doRecordFields fields = subFields qual
       (map (ppSideBySideField subdocs unicode qual) (map unLoc fields))
 
-    doGADTCon :: [LHsType DocName] -> Located (HsType DocName) -> Html
-    doGADTCon args resTy = ppOcc <+> dcolon unicode
-        <+> ppLType unicode qual (mk_forall $ mk_phi $
-                                  foldr mkFunTy resTy args)
+    doGADTCon :: Located (HsType DocName) -> Html
+    doGADTCon ty = ppOcc <+> dcolon unicode
+        <+> ppLType unicode qual ty
         <+> fixity
 
-    mk_phi ty | null context = ty
-              | otherwise    = L loc (HsQualTy (con_cxt con) ty)
-
-    mk_forall ty | con_explicit con = L loc (HsForAllTy (hsQTvBndrs ltvs) ty)
-                 | otherwise        = ty
-
     fixity  = ppFixities fixities qual
     header_ = ppConstrHdr forall_ tyVars context unicode qual
-    occ       = map (nameOccName . getName . unLoc) $ con_names con
+    occ       = map (nameOccName . getName . unLoc) $ getConNames con
 
     ppOcc     = case occ of
       [one] -> ppBinder False one
@@ -838,15 +816,13 @@ ppSideBySideConstr subdocs fixities unicode qual (L loc con)
       [one] -> ppBinderInfix False one
       _     -> hsep (punctuate comma (map (ppBinderInfix False) occ))
 
-    ltvs    = con_qvars con
-    tyVars  = tyvarNames (con_qvars con)
-    context = unLoc (con_cxt con)
-    forall_ = con_explicit con
+    tyVars  = tyvarNames (fromMaybe (HsQTvs PlaceHolder []) (con_qvars con))
+    context = unLoc (fromMaybe (noLoc []) (con_cxt con))
+    forall_ = False
     -- don't use "con_doc con", in case it's reconstructed from a .hi file,
     -- or also because we want Haddock to do the doc-parsing, not GHC.
-    mbDoc = lookup (unLoc $ head $ con_names con) subdocs >>=
+    mbDoc = lookup (unLoc $ head $ getConNames con) subdocs >>=
             combineDocumentation . fst
-    mkFunTy a b = noLoc (HsFunTy a b)
 
 
 ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification
@@ -955,24 +931,6 @@ ppLKind unicode qual y = ppKind unicode qual (unLoc y)
 ppKind :: Unicode -> Qualification -> HsKind DocName -> Html
 ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual
 
--- Drop top-level for-all type variables in user style
--- since they are implicit in Haskell
-
-ppForAllCon :: Bool -> LHsQTyVars DocName
-            -> Located (HsContext DocName) -> Unicode -> Qualification -> Html
-ppForAllCon expl tvs cxt unicode qual =
-  forall_part <+> ppLContext cxt unicode qual
-  where
-    forall_part = ppLTyVarBndrs expl tvs unicode qual
-
-ppLTyVarBndrs :: Bool -> LHsQTyVars DocName -> Unicode -> Qualification -> Html
-ppLTyVarBndrs show_forall tvs unicode _qual
-  | show_forall
-  , not (null tv_bndrs) = ppForAllPart tv_bndrs unicode
-  | otherwise           = noHtml
-  where
-    tv_bndrs = hsQTvBndrs tvs
-
 ppForAllPart :: [LHsTyVarBndr DocName] -> Unicode -> Html
 ppForAllPart tvs unicode = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot
 
@@ -1005,7 +963,9 @@ ppr_mono_ty _         (HsPArrTy ty)       u q = pabrackets (ppr_mono_lty pREC_TO
 ppr_mono_ty ctxt_prec (HsIParamTy n ty)   u q =
     maybeParen ctxt_prec pREC_CTX $ ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q
 ppr_mono_ty _         (HsSpliceTy {})     _ _ = error "ppr_mono_ty HsSpliceTy"
-ppr_mono_ty _         (HsRecTy {})        _ _ = error "ppr_mono_ty HsRecTy"
+ppr_mono_ty _         (HsRecTy {})        _ _ = mempty -- Can now legally occur
+                                                       -- un ConDeclGADT, but is
+                                                       -- output elsewhere
 ppr_mono_ty _         (HsCoreTy {})       _ _ = error "ppr_mono_ty HsCoreTy"
 ppr_mono_ty _         (HsExplicitListTy _ tys) u q =
     promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 3b6657c2..f68db9bc 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -300,19 +300,21 @@ synifyDataCon use_gadt_syntax dc =
           (False,True) -> case linear_tys of
                            [a,b] -> return $ InfixCon a b
                            _ -> Left "synifyDataCon: infix with non-2 args?"
-  hs_res_ty = if use_gadt_syntax
-              then ResTyGADT noSrcSpan (synifyType WithinType res_ty)
-              else ResTyH98
+  gadt_ty = HsIB [] [] (synifyType WithinType res_ty)
  -- finally we get synifyDataCon's result!
  in hs_arg_tys >>=
-      \hat -> return $ noLoc $
-              ConDecl { con_names = [name]
-                      , con_explicit = Implicit   -- we don't know nor care
-                      , con_qvars = qvars
-                      , con_cxt   = ctx
-                      , con_details =  hat
-                      , con_res = hs_res_ty
-                      , con_doc =  Nothing }
+      \hat ->
+        if use_gadt_syntax
+           then return $ noLoc $
+              ConDeclGADT { con_names = [name]
+                          , con_type = gadt_ty
+                          , con_doc =  Nothing }
+           else return $ noLoc $
+              ConDeclH98 { con_name = name
+                         , con_qvars = Just qvars
+                         , con_cxt   = Just ctx
+                         , con_details =  hat
+                         , con_doc =  Nothing }
 
 synifyName :: NamedThing n => n -> Located Name
 synifyName = noLoc . getName
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index e2aa8f06..2a9fba2e 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -187,14 +187,14 @@ class Parent a where
 
 instance Parent (ConDecl Name) where
   children con =
-    case con_details con of
+    case getConDetails con of
       RecCon fields -> map (selectorFieldOcc . unL) $
                          concatMap (cd_fld_names . unL) (unL fields)
       _             -> []
 
 instance Parent (TyClDecl Name) where
   children d
-    | isDataDecl  d = map unL $ concatMap (con_names . unL)
+    | isDataDecl  d = map unL $ concatMap (getConNames . unL)
                               $ (dd_cons . tcdDataDefn) $ d
     | isClassDecl d =
         map (unL . fdLName . unL) (tcdATs d) ++
@@ -208,7 +208,7 @@ family = getName &&& children
 
 
 familyConDecl :: ConDecl Name -> [(Name, [Name])]
-familyConDecl d = zip (map unL (con_names d)) (repeat $ children d)
+familyConDecl d = zip (map unL (getConNames d)) (repeat $ children d)
 
 -- | A mapping from the parent (main-binder) to its children and from each
 -- child to its grand-children, recursively.
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 5ce4e6e6..d427be6c 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -50,6 +50,7 @@ import TcRnTypes
 import FastString (concatFS)
 import BasicTypes ( StringLiteral(..) )
 import qualified Outputable as O
+import HsDecls ( gadtDeclDetails,getConDetails )
 
 -- | Use a 'TypecheckedModule' to produce an 'Interface'.
 -- To do this, we need access to already processed modules in the topological
@@ -340,9 +341,9 @@ subordinates instMap decl = case decl of
       where
         cons = map unL $ (dd_cons dd)
         constrs = [ (unL cname, maybeToList $ fmap unL $ con_doc c, M.empty)
-                  | c <- cons, cname <- con_names c ]
+                  | c <- cons, cname <- getConNames c ]
         fields  = [ (selectorFieldOcc n, maybeToList $ fmap unL doc, M.empty)
-                  | RecCon flds <- map con_details cons
+                  | RecCon flds <- map getConDetails cons
                   , L _ (ConDeclField ns _ doc) <- (unLoc flds)
                   , L _ n <- ns ]
 
@@ -797,7 +798,8 @@ extractDecl name mdl decl
         SigD <$> extractRecSel name mdl n tys (dd_cons defn)
       InstD (ClsInstD ClsInstDecl { cid_datafam_insts = insts }) ->
         let matches = [ d | L _ d <- insts
-                          , L _ ConDecl { con_details = RecCon rec } <- dd_cons (dfid_defn d)
+                          -- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (dfid_defn d)
+                          , RecCon rec <- map (getConDetails . unLoc) (dd_cons (dfid_defn d))
                           , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec)
                           , L _ n <- ns
                           , selectorFieldOcc n == name
@@ -812,7 +814,7 @@ extractRecSel :: Name -> Module -> Name -> [LHsType Name] -> [LConDecl Name]
 extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found"
 
 extractRecSel nm mdl t tvs (L _ con : rest) =
-  case con_details con of
+  case getConDetails con of
     RecCon (L _ fields) | ((l,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields ->
       L l (TypeSig [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy data_ty (getBangType ty)))))
     _ -> extractRecSel nm mdl t tvs rest
@@ -821,7 +823,8 @@ extractRecSel nm mdl t tvs (L _ con : rest) =
   matching_fields flds = [ (l,f) | f@(L _ (ConDeclField ns _ _)) <- flds
                                  , L l n <- ns, selectorFieldOcc n == nm ]
   data_ty
-    | ResTyGADT _ ty <- con_res con = ty
+    -- | ResTyGADT _ ty <- con_res con = ty
+    | ConDeclGADT{} <- con = hsib_body $ con_type con
     | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar (noLoc t))) tvs
 
 -- | Keep export items with docs.
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 2183d8f2..378dcf61 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -411,17 +411,16 @@ renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType
                        , dd_kindSig = k', dd_cons = cons', dd_derivs = Nothing })
 
 renameCon :: ConDecl Name -> RnM (ConDecl DocName)
-renameCon decl@(ConDecl { con_names = lnames, con_qvars = ltyvars
-                        , con_cxt = lcontext, con_details = details
-                        , con_res = restype, con_doc = mbldoc }) = do
-      lnames'   <- mapM renameL lnames
-      ltyvars'  <- renameLHsQTyVars ltyvars
-      lcontext' <- renameLContext lcontext
+renameCon decl@(ConDeclH98 { con_name = lname, con_qvars = ltyvars
+                           , con_cxt = lcontext, con_details = details
+                           , con_doc = mbldoc }) = do
+      lname'    <- renameL lname
+      ltyvars'  <- traverse renameLHsQTyVars ltyvars
+      lcontext' <- traverse renameLContext lcontext
       details'  <- renameDetails details
-      restype'  <- renameResType restype
       mbldoc'   <- mapM renameLDocHsSyn mbldoc
-      return (decl { con_names = lnames', con_qvars = ltyvars', con_cxt = lcontext'
-                   , con_details = details', con_res = restype', con_doc = mbldoc' })
+      return (decl { con_name = lname', con_qvars = ltyvars', con_cxt = lcontext'
+                   , con_details = details', con_doc = mbldoc' })
 
   where
     renameDetails (RecCon (L l fields)) = do
@@ -433,9 +432,14 @@ renameCon decl@(ConDecl { con_names = lnames, con_qvars = ltyvars
       b' <- renameLType b
       return (InfixCon a' b')
 
-    renameResType (ResTyH98) = return ResTyH98
-    renameResType (ResTyGADT l t) = return . ResTyGADT l =<< renameLType t
-
+renameCon decl@(ConDeclGADT { con_names = lnames
+                            , con_type = lty
+                            , con_doc = mbldoc }) = do
+      lnames'   <- mapM renameL lnames
+      lty'      <- renameLSigType lty
+      mbldoc'   <- mapM renameLDocHsSyn mbldoc
+      return (decl { con_names = lnames'
+                   , con_type = lty', con_doc = mbldoc' })
 
 renameConDeclFieldField :: LConDeclField Name -> RnM (LConDeclField DocName)
 renameConDeclFieldField (L l (ConDeclField names t doc)) = do
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index 658007ba..45deca9c 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -180,18 +180,32 @@ restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons })
 restrictCons :: [Name] -> [LConDecl Name] -> [LConDecl Name]
 restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]
   where
-    keep d | any (\n -> n `elem` names) (map unLoc $ con_names d) =
-      case con_details d of
+    keep d | any (\n -> n `elem` names) (map unLoc $ getConNames d) =
+      case getConDetails h98d of
         PrefixCon _ -> Just d
         RecCon fields
           | all field_avail (unL fields) -> Just d
-          | otherwise -> Just (d { con_details = PrefixCon (field_types (map unL (unL fields))) })
+          | otherwise -> Just (h98d { con_details = PrefixCon (field_types (map unL (unL fields))) })
           -- if we have *all* the field names available, then
           -- keep the record declaration.  Otherwise degrade to
           -- a constructor declaration.  This isn't quite right, but
           -- it's the best we can do.
         InfixCon _ _ -> Just d
       where
+        h98d = h98ConDecl d
+        h98ConDecl c@ConDeclH98{} = c
+        h98ConDecl c@ConDeclGADT{} = c'
+          where
+            (details,_res_ty,cxt,tvs) = gadtDeclDetails (con_type c)
+            c' :: ConDecl Name
+            c' = ConDeclH98
+                   { con_name = head (con_names c)
+                   , con_qvars = Just $ HsQTvs { hsq_kvs = mempty, hsq_tvs = tvs }
+                   , con_cxt = Just cxt
+                   , con_details = details
+                   , con_doc = con_doc c
+                   }
+
         field_avail :: LConDeclField Name -> Bool
         field_avail (L _ (ConDeclField fs _ _))
             = all (\f -> selectorFieldOcc (unLoc f) `elem` names) fs
-- 
cgit v1.2.3


From cc20c0da2a9d8065e9d2f2470725e41353767214 Mon Sep 17 00:00:00 2001
From: Alan Zimmerman <alan.zimm@gmail.com>
Date: Sat, 5 Dec 2015 19:45:33 +0200
Subject: Placeholder for record style GADT declaration

A GADT Declaration is now presented as

    CmmCondBranch :: {..} -> CmmNode O C
        cml_pred :: CmmExpr
        cml_true, cml_false :: !Label
        cml_likely :: Maybe Bool
for

    CmmCondBranch :: {              -- conditional branch
        cml_pred :: CmmExpr,
        cml_true, cml_false :: ULabel,
        cml_likely :: Maybe Bool    -- likely result of the conditional,
                                    -- if known
    } -> CmmNode O C
---
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 8 +++++---
 1 file changed, 5 insertions(+), 3 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Xhtml/Decl.hs')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index af672ff7..0e5e381a 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -801,6 +801,7 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con)
 
     doGADTCon :: Located (HsType DocName) -> Html
     doGADTCon ty = ppOcc <+> dcolon unicode
+        -- ++AZ++ make this prepend "{..}" when it is a record style GADT
         <+> ppLType unicode qual ty
         <+> fixity
 
@@ -963,9 +964,10 @@ ppr_mono_ty _         (HsPArrTy ty)       u q = pabrackets (ppr_mono_lty pREC_TO
 ppr_mono_ty ctxt_prec (HsIParamTy n ty)   u q =
     maybeParen ctxt_prec pREC_CTX $ ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q
 ppr_mono_ty _         (HsSpliceTy {})     _ _ = error "ppr_mono_ty HsSpliceTy"
-ppr_mono_ty _         (HsRecTy {})        _ _ = mempty -- Can now legally occur
-                                                       -- un ConDeclGADT, but is
-                                                       -- output elsewhere
+ppr_mono_ty _         (HsRecTy {})        _ _ = toHtml "{..}"
+       -- Can now legally occur in ConDeclGADT, the output here is to provide a
+       -- placeholder in the signature, which is followed by the field
+       -- declarations.
 ppr_mono_ty _         (HsCoreTy {})       _ _ = error "ppr_mono_ty HsCoreTy"
 ppr_mono_ty _         (HsExplicitListTy _ tys) u q =
     promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys
-- 
cgit v1.2.3


From 50c0faf18a5c963c0df874aa94b034430280856a Mon Sep 17 00:00:00 2001
From: Richard Eisenberg <eir@cis.upenn.edu>
Date: Tue, 8 Dec 2015 23:54:34 -0500
Subject: Update for type=kinds

---
 haddock-api/src/Haddock/Backends/Hoogle.hs         |  2 +-
 haddock-api/src/Haddock/Backends/LaTeX.hs          |  9 +++--
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs     | 14 +++----
 haddock-api/src/Haddock/Convert.hs                 | 43 +++++++++++-----------
 .../src/Haddock/Interface/AttachInstances.hs       | 24 ++++++++----
 haddock-api/src/Haddock/Interface/Rename.hs        | 12 +++---
 haddock-api/src/Haddock/Utils.hs                   |  8 ++--
 7 files changed, 62 insertions(+), 50 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Xhtml/Decl.hs')

diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index cef0da20..a8882fe2 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -242,7 +242,7 @@ ppCtor dflags dat subdocs con@ConDeclH98 {}
         name = commaSeparate dflags . map unL $ getConNames con
 
         resType = apps $ map (reL . HsTyVar . reL) $
-                        (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvBndrs $ tyClDeclTyVars dat]
+                        (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvExplicit $ tyClDeclTyVars dat]
 
 ppCtor dflags _dat subdocs con@ConDeclGADT {}
    = concatMap (lookupCon dflags subdocs) (getConNames con) ++ f
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index e7780d6e..75a4edba 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -413,7 +413,7 @@ ppTyVars = map (ppSymName . getName . hsLTyVarName)
 
 
 tyvarNames :: LHsQTyVars DocName -> [Name]
-tyvarNames = map (getName . hsLTyVarName) . hsQTvBndrs
+tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit
 
 
 declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX
@@ -725,7 +725,7 @@ ppSideBySideConstr subdocs unicode leader (L loc con) =
     tyVars  = tyvarNames (con_qvars con)
     context = unLoc (con_cxt con)
 
-    mk_forall ty | con_explicit con = L loc (HsForAllTy (hsQTvBndrs ltvs) ty)
+    mk_forall ty | con_explicit con = L loc (HsForAllTy (hsQTvExplicit ltvs) ty)
                  | otherwise        = ty
     mk_phi ty | null context = ty
               | otherwise    = L loc (HsQualTy (con_cxt con) ty)
@@ -957,7 +957,6 @@ ppr_mono_ty _         (HsRecTy {})        _ = error "ppr_mono_ty HsRecTy"
 ppr_mono_ty _         (HsCoreTy {})       _ = error "ppr_mono_ty HsCoreTy"
 ppr_mono_ty _         (HsExplicitListTy _ tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys
 ppr_mono_ty _         (HsExplicitTupleTy _ tys) u = Pretty.quote $ parenList $ map (ppLType u) tys
-ppr_mono_ty _         (HsWrapTy {})       _ = error "ppr_mono_ty HsWrapTy"
 
 ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode
   = maybeParen ctxt_prec pREC_OP $
@@ -967,7 +966,7 @@ ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode
   = maybeParen ctxt_prec pREC_CON $
     hsep [ppr_mono_lty pREC_FUN fun_ty unicode, ppr_mono_lty pREC_CON arg_ty unicode]
 
-ppr_mono_ty ctxt_prec (HsOpTy ty1 (_, op) ty2) unicode
+ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode
   = maybeParen ctxt_prec pREC_FUN $
     ppr_mono_lty pREC_OP ty1 unicode <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode
   where
@@ -987,6 +986,8 @@ ppr_mono_ty _ (HsWildCardTy (NamedWildCard (L _ name))) _ = ppDocName name
 
 ppr_mono_ty _ (HsTyLit t) u = ppr_tylit t u
 
+ppr_mono_ty _ (HsAppsTy {}) _ = panic "ppr_mono_ty:HsAppsTy"
+
 
 ppr_tylit :: HsTyLit -> Bool -> LaTeX
 ppr_tylit (HsNumTy _ n) _ = integer n
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 0e5e381a..124debfb 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -176,7 +176,7 @@ ppTyVars :: [LHsTyVarBndr DocName] -> [Html]
 ppTyVars tvs = map (ppTyName . getName . hsLTyVarName) tvs
 
 tyvarNames :: LHsQTyVars DocName -> [Name]
-tyvarNames = map (getName . hsLTyVarName) . hsQTvBndrs
+tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit
 
 
 ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName
@@ -200,7 +200,7 @@ ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars
                    splice unicode qual
   where
     hdr  = hsep ([keyword "type", ppBinder summary occ]
-                 ++ ppTyVars (hsQTvBndrs ltyvars))
+                 ++ ppTyVars (hsQTvExplicit ltyvars))
     full = hdr <+> equals <+> ppLType unicode qual ltype
     occ  = nameOccName . getName $ name
     fixs
@@ -969,11 +969,9 @@ ppr_mono_ty _         (HsRecTy {})        _ _ = toHtml "{..}"
        -- placeholder in the signature, which is followed by the field
        -- declarations.
 ppr_mono_ty _         (HsCoreTy {})       _ _ = error "ppr_mono_ty HsCoreTy"
-ppr_mono_ty _         (HsExplicitListTy _ tys) u q =
-    promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys
-ppr_mono_ty _         (HsExplicitTupleTy _ tys) u q =
-    promoQuote $ parenList $ map (ppLType u q) tys
-ppr_mono_ty _         (HsWrapTy {})       _ _ = error "ppr_mono_ty HsWrapTy"
+ppr_mono_ty _         (HsExplicitListTy _ tys) u q = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys
+ppr_mono_ty _         (HsExplicitTupleTy _ tys) u q = promoQuote $ parenList $ map (ppLType u q) tys
+ppr_mono_ty _         (HsAppsTy {})       _ _ = error "ppr_mono_ty HsAppsTy"
 
 ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode qual
   = maybeParen ctxt_prec pREC_CTX $
@@ -983,7 +981,7 @@ ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode qual
   = maybeParen ctxt_prec pREC_CON $
     hsep [ppr_mono_lty pREC_FUN fun_ty unicode qual, ppr_mono_lty pREC_CON arg_ty unicode qual]
 
-ppr_mono_ty ctxt_prec (HsOpTy ty1 (_, op) ty2) unicode qual
+ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode qual
   = maybeParen ctxt_prec pREC_FUN $
     ppr_mono_lty pREC_OP ty1 unicode qual <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual
   where
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index f68db9bc..664598ab 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -26,19 +26,19 @@ import Data.List( partition )
 import DataCon
 import FamInstEnv
 import HsSyn
-import Kind ( splitKindFunTys, tyConResKind, isKind )
 import Name
 import RdrName ( mkVarUnqual )
 import PatSyn
 import SrcLoc ( Located, noLoc, unLoc, noSrcSpan )
 import TcType ( tcSplitSigmaTy )
 import TyCon
-import Type (isStrLitTy, mkFunTys)
-import TypeRep
+import Type
+import TyCoRep
 import TysPrim ( alphaTyVars )
-import TysWiredIn ( listTyConName, eqTyCon, ipTyCon )
+import TysWiredIn ( listTyConName, ipTyCon )
+import PrelNames ( hasKey, eqTyConKey )
 import Unique ( getUnique )
-import Util ( filterByList )
+import Util ( filterByList, filterOut )
 import Var
 
 import Haddock.Types
@@ -117,11 +117,9 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs })
   = let name       = synifyName tc
         typats     = map (synifyType WithinType) args
         hs_rhs     = synifyType WithinType rhs
-        (kvs, tvs) = partition isKindVar tkvs
     in TyFamEqn { tfe_tycon = name
                 , tfe_pats  = HsIB { hsib_body = typats
-                                   , hsib_kvs = map tyVarName kvs
-                                   , hsib_tvs = map tyVarName tvs }
+                                   , hsib_vars = map tyVarName tkvs }
                 , tfe_rhs   = hs_rhs }
 
 synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl Name)
@@ -149,8 +147,8 @@ synifyTyCon _coax tc
                          let mk_hs_tv realKind fakeTyVar
                                 = noLoc $ KindedTyVar (noLoc (getName fakeTyVar))
                                                       (synifyKindSig realKind)
-                         in HsQTvs { hsq_kvs = []   -- No kind polymorphism
-                                   , hsq_tvs = zipWith mk_hs_tv (fst (splitKindFunTys (tyConKind tc)))
+                         in HsQTvs { hsq_implicit = []   -- No kind polymorphism
+                                   , hsq_explicit = zipWith mk_hs_tv (fst (splitFunTys (tyConKind tc)))
                                                                 alphaTyVars --a, b, c... which are unfortunately all kind *
                                    }
 
@@ -188,11 +186,12 @@ synifyTyCon _coax tc
                  , fdLName = synifyName tc
                  , fdTyVars = synifyTyVars (tyConTyVars tc)
                  , fdResultSig =
-                       synifyFamilyResultSig resultVar (tyConResKind tc)
+                       synifyFamilyResultSig resultVar tyConResKind
                  , fdInjectivityAnn =
                        synifyInjectivityAnn  resultVar (tyConTyVars tc)
                                        (familyTyConInjectivityInfo tc)
                  }
+    tyConResKind = piResultTys (tyConKind tc) (mkTyVarTys (tyConTyVars tc))
 
 synifyTyCon coax tc
   | Just ty <- synTyConRhs_maybe tc
@@ -300,7 +299,7 @@ synifyDataCon use_gadt_syntax dc =
           (False,True) -> case linear_tys of
                            [a,b] -> return $ InfixCon a b
                            _ -> Left "synifyDataCon: infix with non-2 args?"
-  gadt_ty = HsIB [] [] (synifyType WithinType res_ty)
+  gadt_ty = HsIB [] (synifyType WithinType res_ty)
  -- finally we get synifyDataCon's result!
  in hs_arg_tys >>=
       \hat ->
@@ -329,10 +328,8 @@ synifyCtx = noLoc . map (synifyType WithinType)
 
 
 synifyTyVars :: [TyVar] -> LHsQTyVars Name
-synifyTyVars ktvs = HsQTvs { hsq_kvs = map tyVarName kvs
-                           , hsq_tvs = map synifyTyVar tvs }
-  where
-    (kvs, tvs) = partition isKindVar ktvs
+synifyTyVars ktvs = HsQTvs { hsq_implicit = []
+                           , hsq_explicit = map synifyTyVar ktvs }
 
 synifyTyVar :: TyVar -> LHsTyVarBndr Name
 synifyTyVar tv
@@ -387,19 +384,21 @@ synifyType _ (TyConApp tc tys)
   , Just x <- isStrLitTy name
   = noLoc $ HsIParamTy (HsIPName x) (synifyType WithinType ty)
   -- and equalities
-  | tc == eqTyCon
+  | tc `hasKey` eqTyConKey
   , [ty1, ty2] <- tys
   = noLoc $ HsEqTy (synifyType WithinType ty1) (synifyType WithinType ty2)
   -- Most TyCons:
   | otherwise =
     foldl (\t1 t2 -> noLoc (HsAppTy t1 t2))
       (noLoc $ HsTyVar $ noLoc (getName tc))
-      (map (synifyType WithinType) tys)
+      (map (synifyType WithinType) $
+       filterOut isCoercionTy tys)
+synifyType s (AppTy t1 (CoercionTy {})) = synifyType s t1
 synifyType _ (AppTy t1 t2) = let
   s1 = synifyType WithinType t1
   s2 = synifyType WithinType t2
   in noLoc $ HsAppTy s1 s2
-synifyType _ (FunTy t1 t2) = let
+synifyType _ (ForAllTy (Anon t1) t2) = let
   s1 = synifyType WithinType t1
   s2 = synifyType WithinType t2
   in noLoc $ HsFunTy s1 s2
@@ -414,6 +413,8 @@ synifyType s forallty@(ForAllTy _tv _ty) =
     ImplicitizeForAll -> noLoc sPhi
 
 synifyType _ (LitTy t) = noLoc $ HsTyLit $ synifyTyLit t
+synifyType s (CastTy t _) = synifyType s t
+synifyType _ (CoercionTy {}) = error "synifyType:Coercion"
 
 synifyTyLit :: TyLit -> HsTyLit
 synifyTyLit (NumTyLit n) = HsNumTy mempty n
@@ -437,7 +438,7 @@ synifyInstHead (_, preds, cls, types) = specializeInstHead $ InstHead
         }
     }
   where
-    (ks,ts) = break (not . isKind) types
+    (ks,ts) = partitionInvisibles (classTyCon cls) id types
     synifyClsIdSig = synifyIdSig DeleteTopLevelQuantification
 
 -- Convert a family instance, this could be a type family or data family
@@ -456,5 +457,5 @@ synifyFamInst fi opaque = do
         return . TypeInst . Just . unLoc . synifyType WithinType $ fi_rhs fi
     ityp (DataFamilyInst c) =
         DataInst <$> synifyTyCon (Just $ famInstAxiom fi) c
-    (ks,ts) = break (not . isKind) $ fi_tys fi
+    (ks,ts) = partitionInvisibles (classTyCon cls) id $ fi_tys fi
     synifyTypes = map (unLoc. synifyType WithinType)
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index 21569374..56382341 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -22,6 +22,7 @@ import Control.Arrow hiding ((<+>))
 import Data.List
 import Data.Ord (comparing)
 import Data.Function (on)
+import Data.Maybe ( maybeToList, mapMaybe )
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 
@@ -42,7 +43,7 @@ import SrcLoc
 import TcRnDriver (tcRnGetInfo)
 import TcType (tcSplitSigmaTy)
 import TyCon
-import TypeRep
+import TyCoRep
 import TysPrim( funTyCon )
 import Var hiding (varName)
 #define FSLIT(x) (mkFastString# (x#))
@@ -160,18 +161,26 @@ instHead (_, _, cls, args)
 argCount :: Type -> Int
 argCount (AppTy t _) = argCount t + 1
 argCount (TyConApp _ ts) = length ts
-argCount (FunTy _ _ ) = 2
+argCount (ForAllTy (Anon _) _ ) = 2
 argCount (ForAllTy _ t) = argCount t
+argCount (CastTy t _) = argCount t
 argCount _ = 0
 
 simplify :: Type -> SimpleType
+simplify (ForAllTy (Anon t1) t2) = SimpleType funTyConName [simplify t1, simplify t2]
 simplify (ForAllTy _ t) = simplify t
-simplify (FunTy t1 t2) = SimpleType funTyConName [simplify t1, simplify t2]
-simplify (AppTy t1 t2) = SimpleType s (ts ++ [simplify t2])
+simplify (AppTy t1 t2) = SimpleType s (ts ++ maybeToList (simplify_maybe t2))
   where (SimpleType s ts) = simplify t1
 simplify (TyVarTy v) = SimpleType (tyVarName v) []
-simplify (TyConApp tc ts) = SimpleType (tyConName tc) (map simplify ts)
+simplify (TyConApp tc ts) = SimpleType (tyConName tc)
+                                       (mapMaybe simplify_maybe ts)
 simplify (LitTy l) = SimpleTyLit l
+simplify (CastTy ty _) = simplify ty
+simplify (CoercionTy _) = error "simplify:Coercion"
+
+simplify_maybe :: Type -> Maybe SimpleType
+simplify_maybe (CoercionTy {}) = Nothing
+simplify_maybe ty              = Just (simplify ty)
 
 -- Used for sorting
 instFam :: FamInst -> ([Int], Name, [SimpleType], Int, SimpleType)
@@ -221,9 +230,10 @@ isTypeHidden expInfo = typeHidden
         TyVarTy {} -> False
         AppTy t1 t2 -> typeHidden t1 || typeHidden t2
         TyConApp tcon args -> nameHidden (getName tcon) || any typeHidden args
-        FunTy t1 t2 -> typeHidden t1 || typeHidden t2
-        ForAllTy _ ty -> typeHidden ty
+        ForAllTy bndr ty -> typeHidden (binderType bndr) || typeHidden ty
         LitTy _ -> False
+        CastTy ty _ -> typeHidden ty
+        CoercionTy {} -> False
 
     nameHidden :: Name -> Bool
     nameHidden = isNameHidden expInfo
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 378dcf61..e3a5a7d5 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -234,11 +234,11 @@ renameType t = case t of
 
   HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts
 
-  HsOpTy a (w, L loc op) b -> do
+  HsOpTy a (L loc op) b -> do
     op' <- rename op
     a'  <- renameLType a
     b'  <- renameLType b
-    return (HsOpTy a' (w, L loc op') b')
+    return (HsOpTy a' (L loc op') b')
 
   HsParTy ty -> return . HsParTy =<< renameLType ty
 
@@ -254,18 +254,18 @@ renameType t = case t of
 
   HsTyLit x -> return (HsTyLit x)
 
-  HsWrapTy a b            -> HsWrapTy a <$> renameType b
   HsRecTy a               -> HsRecTy <$> mapM renameConDeclFieldField a
   HsCoreTy a              -> pure (HsCoreTy a)
   HsExplicitListTy  a b   -> HsExplicitListTy  a <$> mapM renameLType b
   HsExplicitTupleTy a b   -> HsExplicitTupleTy a <$> mapM renameLType b
   HsSpliceTy _ _          -> error "renameType: HsSpliceTy"
   HsWildCardTy a          -> HsWildCardTy <$> renameWildCardInfo a
+  HsAppsTy _              -> error "renameType: HsAppsTy"
 
 renameLHsQTyVars :: LHsQTyVars Name -> RnM (LHsQTyVars DocName)
-renameLHsQTyVars (HsQTvs { hsq_kvs = _, hsq_tvs = tvs })
+renameLHsQTyVars (HsQTvs { hsq_implicit = _, hsq_explicit = tvs })
   = do { tvs' <- mapM renameLTyVarBndr tvs
-       ; return (HsQTvs { hsq_kvs = error "haddock:renameLHsQTyVars", hsq_tvs = tvs' }) }
+       ; return (HsQTvs { hsq_implicit = error "haddock:renameLHsQTyVars", hsq_explicit = tvs' }) }
                 -- This is rather bogus, but I'm not sure what else to do
 
 renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName)
@@ -547,7 +547,7 @@ renameImplicit :: (in_thing -> RnM out_thing)
 renameImplicit rn_thing (HsIB { hsib_body = thing })
   = do { thing' <- rn_thing thing
        ; return (HsIB { hsib_body = thing'
-                      , hsib_kvs = PlaceHolder, hsib_tvs = PlaceHolder }) }
+                      , hsib_vars = PlaceHolder }) }
 
 renameWc :: (in_thing -> RnM out_thing)
          -> HsWildCardBndrs Name in_thing
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index 45deca9c..3510d908 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -151,7 +151,7 @@ addClassContext _ _ sig = sig   -- E.g. a MinimalSig is fine
 lHsQTyVarsToTypes :: LHsQTyVars Name -> [LHsType Name]
 lHsQTyVarsToTypes tvs
   = [ noLoc (HsTyVar (noLoc (hsLTyVarName tv)))
-    | tv <- hsQTvBndrs tvs ]
+    | tv <- hsQTvExplicit tvs ]
 
 --------------------------------------------------------------------------------
 -- * Making abstract declarations
@@ -200,7 +200,8 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]
             c' :: ConDecl Name
             c' = ConDeclH98
                    { con_name = head (con_names c)
-                   , con_qvars = Just $ HsQTvs { hsq_kvs = mempty, hsq_tvs = tvs }
+                   , con_qvars = Just $ HsQTvs { hsq_implicit = mempty
+                                               , hsq_explicit = tvs }
                    , con_cxt = Just cxt
                    , con_details = details
                    , con_doc = con_doc c
@@ -224,7 +225,8 @@ emptyHsQTvs :: LHsQTyVars Name
 -- This function is here, rather than in HsTypes, because it *renamed*, but
 -- does not necessarily have all the rigt kind variables.  It is used
 -- in Haddock just for printing, so it doesn't matter
-emptyHsQTvs = HsQTvs { hsq_kvs = error "haddock:emptyHsQTvs", hsq_tvs = [] }
+emptyHsQTvs = HsQTvs { hsq_implicit = error "haddock:emptyHsQTvs"
+                     , hsq_explicit = [] }
 
 
 --------------------------------------------------------------------------------
-- 
cgit v1.2.3


From cb89336401b74b274b81b28079e6906e926409c4 Mon Sep 17 00:00:00 2001
From: Matthew Pickering <matthewtpickering@gmail.com>
Date: Mon, 14 Dec 2015 18:17:00 +0000
Subject: Changes to compile with 8.0

---
 haddock-api/src/Haddock.hs                         |  2 +-
 haddock-api/src/Haddock/Backends/Hoogle.hs         | 10 +--
 .../src/Haddock/Backends/Hyperlinker/Ast.hs        | 24 ++++---
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs     | 24 ++++---
 haddock-api/src/Haddock/Convert.hs                 | 12 +---
 haddock-api/src/Haddock/Interface/Rename.hs        |  4 +-
 haddock-api/src/Haddock/Interface/Specialize.hs    | 78 +++++++++++-----------
 haddock-api/src/Haddock/Types.hs                   | 10 +--
 8 files changed, 82 insertions(+), 82 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Xhtml/Decl.hs')

diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index ef873500..70cdf8a3 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -269,7 +269,7 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do
       (Map.map SrcExternal extSrcMap)
       (Map.fromList [ (ifaceMod iface, SrcLocal) | iface <- ifaces ])
 
-    pkgSrcMap = Map.mapKeys modulePackageKey extSrcMap
+    pkgSrcMap = Map.mapKeys moduleUnitId extSrcMap
     pkgSrcMap'
       | Flag_HyperlinkedSource `elem` flags =
           Map.insert pkgKey hypSrcModuleNameUrlFormat pkgSrcMap
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index a8882fe2..1adcddfc 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -122,8 +122,8 @@ ppExport dflags ExportDecl { expItemDecl    = L _ decl
         f (TyClD d@DataDecl{})  = ppData dflags d subdocs
         f (TyClD d@SynDecl{})   = ppSynonym dflags d
         f (TyClD d@ClassDecl{}) = ppClass dflags d subdocs
-        f (ForD (ForeignImport name typ _ _)) = pp_sig dflags [name] (hsSigType typ)
-        f (ForD (ForeignExport name typ _ _)) = pp_sig dflags [name] (hsSigType typ)
+        f (ForD (ForeignImport name typ _ _)) = [pp_sig dflags [name] (hsSigType typ)]
+        f (ForD (ForeignExport name typ _ _)) = [pp_sig dflags [name] (hsSigType typ)]
         f (SigD sig) = ppSig dflags sig ++ ppFixities
         f _ = []
 
@@ -157,10 +157,10 @@ ppClass :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String]
 ppClass dflags decl subdocs = (out dflags decl{tcdSigs=[]} ++ ppTyFams) :  ppMethods
     where
 
-        ppMethods = concat . map (ppSig' . unL . add_ctxt) $ tcdSigs decl
-        ppSig' = flip (ppSigWithDoc dflags) subdocs . addContext
+        ppMethods = concat . map (ppSig' . unLoc . add_ctxt) $ tcdSigs decl
+        ppSig' = flip (ppSigWithDoc dflags) subdocs
 
-        add_ctxt = addClassContext (tcdName x) (tyClDeclTyVars x)
+        add_ctxt = addClassContext (tcdName decl) (tyClDeclTyVars decl)
 
         ppTyFams
             | null $ tcdATs decl = ""
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index 5eca973e..060534bf 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeFamilies #-}
 
 
 module Haddock.Backends.Hyperlinker.Ast (enrich) where
@@ -10,6 +11,7 @@ import Haddock.Syb
 import Haddock.Backends.Hyperlinker.Types
 
 import qualified GHC
+import qualified FieldLabel as GHC
 
 import Control.Applicative
 import Data.Data
@@ -56,8 +58,8 @@ variables =
   where
     var term = case cast term of
         (Just (GHC.L sspan (GHC.HsVar name))) ->
-            pure (sspan, RtkVar name)
-        (Just (GHC.L _ (GHC.RecordCon (GHC.L sspan name) _ _))) ->
+            pure (sspan, RtkVar (GHC.unLoc name))
+        (Just (GHC.L _ (GHC.RecordCon (GHC.L sspan name) _ _ _))) ->
             pure (sspan, RtkVar name)
         _ -> empty
     rec term = case cast term of
@@ -72,7 +74,7 @@ types =
   where
     ty term = case cast term of
         (Just (GHC.L sspan (GHC.HsTyVar name))) ->
-            pure (sspan, RtkType name)
+            pure (sspan, RtkType (GHC.unLoc name))
         _ -> empty
 
 -- | Obtain details map for identifier bindings.
@@ -85,12 +87,12 @@ binds =
     everything (<|>) (fun `combine` pat `combine` tvar)
   where
     fun term = case cast term of
-        (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name)) ->
+        (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.Name)) ->
             pure (sspan, RtkBind name)
         _ -> empty
     pat term = case cast term of
         (Just (GHC.L sspan (GHC.VarPat name))) ->
-            pure (sspan, RtkBind name)
+            pure (sspan, RtkBind (GHC.unLoc name))
         (Just (GHC.L _ (GHC.ConPatIn (GHC.L sspan name) recs))) ->
             [(sspan, RtkVar name)] ++ everything (<|>) rec recs
         (Just (GHC.L _ (GHC.AsPat (GHC.L sspan name) _))) ->
@@ -102,7 +104,7 @@ binds =
         _ -> empty
     tvar term = case cast term of
         (Just (GHC.L sspan (GHC.UserTyVar name))) ->
-            pure (sspan, RtkBind name)
+            pure (sspan, RtkBind (GHC.unLoc name))
         (Just (GHC.L _ (GHC.KindedTyVar (GHC.L sspan name) _))) ->
             pure (sspan, RtkBind name)
         _ -> empty
@@ -121,7 +123,7 @@ decls (group, _, _, _) = concatMap ($ group)
         GHC.FamDecl fam -> pure . decl $ GHC.fdLName fam
         GHC.ClassDecl{..} -> [decl tcdLName] ++ concatMap sig tcdSigs
     fun term = case cast term of
-        (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name))
+        (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.Name))
             | GHC.isExternalName name -> pure (sspan, RtkDecl name)
         _ -> empty
     con term = case cast term of
@@ -134,9 +136,10 @@ decls (group, _, _, _) = concatMap ($ group)
             pure . tyref $ GHC.tfe_tycon eqn
         _ -> empty
     fld term = case cast term of
-        Just field -> map decl $ GHC.cd_fld_names field
+        Just (field :: GHC.ConDeclField GHC.Name)
+          -> map (decl . fmap GHC.selectorFieldOcc) $ GHC.cd_fld_names field
         Nothing -> empty
-    sig (GHC.L _ (GHC.TypeSig names _ _)) = map decl names
+    sig (GHC.L _ (GHC.TypeSig names _)) = map decl names
     sig _ = []
     decl (GHC.L sspan name) = (sspan, RtkDecl name)
     tyref (GHC.L sspan name) = (sspan, RtkType name)
@@ -153,7 +156,8 @@ imports src@(_, imps, _, _) =
         (Just (GHC.IEVar v)) -> pure $ var v
         (Just (GHC.IEThingAbs t)) -> pure $ typ t
         (Just (GHC.IEThingAll t)) -> pure $ typ t
-        (Just (GHC.IEThingWith t vs)) -> [typ t] ++ map var vs
+        (Just (GHC.IEThingWith t _ vs _fls)) ->
+          [typ t] ++ map var vs
         _ -> empty
     typ (GHC.L sspan name) = (sspan, RtkType name)
     var (GHC.L sspan name) = (sspan, RtkVar name)
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 124debfb..ae1905bf 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -270,24 +270,25 @@ ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info
   ) <+>
 
   ppFamDeclBinderWithVars summary d <+>
-
-  (case result of
-    NoSig               -> noHtml
-    KindSig kind        -> dcolon unicode  <+> ppLKind unicode qual kind
-    TyVarSig (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr
-  ) <+>
+  ppResultSig result unicode qual <+>
 
   (case injectivity of
      Nothing                   -> noHtml
      Just (L _ injectivityAnn) -> ppInjectivityAnn unicode qual injectivityAnn
   )
 
+ppResultSig :: FamilyResultSig DocName -> Unicode -> Qualification -> Html
+ppResultSig result unicode qual = case result of
+    NoSig               -> noHtml
+    KindSig kind        -> dcolon unicode  <+> ppLKind unicode qual kind
+    TyVarSig (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr
+
 ppPseudoFamilyHeader :: Unicode -> Qualification -> PseudoFamilyDecl DocName
                      -> Html
 ppPseudoFamilyHeader unicode qual (PseudoFamilyDecl { .. }) =
     ppFamilyInfo True pfdInfo <+>
     ppAppNameTypes (unLoc pfdLName) [] (map unLoc pfdTyVars) unicode qual <+>
-    ppFamilyKind unicode qual pfdKindSig
+    ppResultSig (unLoc pfdKindSig) unicode qual
 
 ppInjectivityAnn :: Bool -> Qualification -> InjectivityAnn DocName -> Html
 ppInjectivityAnn unicode qual (InjectivityAnn lhs rhs) =
@@ -530,7 +531,7 @@ ppClassDecl summary links instances fixities loc d subdocs
     minimalBit = case [ s | MinimalSig _ (L _ s) <- sigs ] of
       -- Miminal complete definition = every shown method
       And xs : _ | sort [getName n | L _ (Var (L _ n)) <- xs] ==
-                   sort [getName n | TypeSig ns _ _ <- sigs, L _ n <- ns]
+                   sort [getName n | TypeSig ns _ <- sigs, L _ n <- ns]
         -> noHtml
 
       -- Minimal complete definition = the only shown method
@@ -612,9 +613,12 @@ ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification
               -> [Sig DocName]
               -> [Html]
 ppInstanceSigs links splice unicode qual sigs = do
-    TypeSig lnames (L loc typ) _ <- sigs
+    TypeSig lnames typ <- sigs
     let names = map unLoc lnames
-    return $ ppSimpleSig links splice unicode qual loc names typ
+        L loc rtyp = get_type typ
+    return $ ppSimpleSig links splice unicode qual loc names rtyp
+    where
+      get_type = hswc_body . hsib_body
 
 
 lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 664598ab..4a7ad162 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -100,14 +100,8 @@ tyThingToLHsDecl t = case t of
     (synifySigWcType ImplicitizeForAll (dataConUserType dc)))
 
   AConLike (PatSynCon ps) ->
-      let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, res_ty) = patSynSig ps
-          qtvs = univ_tvs ++ ex_tvs
-          ty = mkFunTys arg_tys res_ty
-      in allOK . SigD $ PatSynSig (synifyName ps)
-                          (Implicit, synifyTyVars qtvs)
-                          (synifyCtx req_theta)
-                          (synifyCtx prov_theta)
-                          (synifyType WithinType ty)
+    allOK . SigD $ PatSynSig (synifyName ps) (synifySigType WithinType
+                                  (patSynType ps))
   where
     withErrs e x = return (e, x)
     allOK x = return (mempty, x)
@@ -457,5 +451,5 @@ synifyFamInst fi opaque = do
         return . TypeInst . Just . unLoc . synifyType WithinType $ fi_rhs fi
     ityp (DataFamilyInst c) =
         DataInst <$> synifyTyCon (Just $ famInstAxiom fi) c
-    (ks,ts) = partitionInvisibles (classTyCon cls) id $ fi_tys fi
+    (ks,ts) = partitionInvisibles (famInstTyCon fi) id $ fi_tys fi
     synifyTypes = map (unLoc. synifyType WithinType)
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index e3a5a7d5..859afe6e 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -294,7 +294,7 @@ renameInstHead InstHead {..} = do
   itype <- case ihdInstType of
     ClassInst { .. } -> ClassInst
         <$> mapM renameType clsiCtx
-        <*> renameLTyVarBndrs clsiTyVars
+        <*> renameLHsQTyVars clsiTyVars
         <*> mapM renameSig clsiSigs
         <*> mapM renamePseudoFamilyDecl clsiAssocTys
     TypeInst  ts -> TypeInst  <$> traverse renameType ts
@@ -390,7 +390,7 @@ renamePseudoFamilyDecl (PseudoFamilyDecl { .. }) =  PseudoFamilyDecl
     <$> renameFamilyInfo pfdInfo
     <*> renameL pfdLName
     <*> mapM renameLType pfdTyVars
-    <*> renameMaybeLKind pfdKindSig
+    <*> renameFamilyResultSig pfdKindSig
 
 
 renameFamilyInfo :: FamilyInfo Name -> RnM (FamilyInfo DocName)
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index d6466570..e9b9c60a 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -36,7 +36,7 @@ specialize :: (Eq name, Typeable name)
 specialize name details =
     everywhere $ mkT step
   where
-    step (HsTyVar name') | name == name' = details
+    step (HsTyVar (L _ name')) | name == name' = details
     step typ = typ
 
 
@@ -56,18 +56,18 @@ specialize' = flip $ foldr (uncurry specialize)
 -- length of type list should be the same as the number of binders.
 specializeTyVarBndrs :: (Eq name, Typeable name, DataId name)
                      => Data a
-                     => LHsTyVarBndrs name -> [HsType name]
+                     => LHsQTyVars name -> [HsType name]
                      -> a -> a
 specializeTyVarBndrs bndrs typs =
     specialize' $ zip bndrs' typs
   where
-    bndrs' = map (bname . unLoc) . hsq_tvs $ bndrs
-    bname (UserTyVar name) = name
+    bndrs' = map (bname . unLoc) . hsq_explicit $ bndrs
+    bname (UserTyVar (L _ name)) = name
     bname (KindedTyVar (L _ name) _) = name
 
 
 specializePseudoFamilyDecl :: (Eq name, Typeable name, DataId name)
-                           => LHsTyVarBndrs name -> [HsType name]
+                           => LHsQTyVars name -> [HsType name]
                            -> PseudoFamilyDecl name
                            -> PseudoFamilyDecl name
 specializePseudoFamilyDecl bndrs typs decl =
@@ -76,14 +76,17 @@ specializePseudoFamilyDecl bndrs typs decl =
     specializeTyVars = specializeTyVarBndrs bndrs typs
 
 
-specializeSig :: (Eq name, Typeable name, DataId name, SetName name)
-              => LHsTyVarBndrs name -> [HsType name]
+specializeSig :: forall name . (Eq name, Typeable name, DataId name, SetName name)
+              => LHsQTyVars name -> [HsType name]
               -> Sig name
               -> Sig name
-specializeSig bndrs typs (TypeSig lnames (L loc typ) prn) =
-    TypeSig lnames (L loc typ') prn
+specializeSig bndrs typs (TypeSig lnames typ) =
+    TypeSig lnames (typ { hsib_body = (hsib_body typ) { hswc_body = noLoc typ'}})
   where
-    typ' = rename fv . sugar $ specializeTyVarBndrs bndrs typs typ
+    true_type :: HsType name
+    true_type = unLoc (hswc_body (hsib_body typ))
+    typ' :: HsType name
+    typ' = rename fv . sugar $ specializeTyVarBndrs bndrs typs true_type
     fv = foldr Set.union Set.empty . map freeVariables $ typs
 specializeSig _ _ sig = sig
 
@@ -120,7 +123,7 @@ sugar =
 
 
 sugarLists :: NamedThing name => HsType name -> HsType name
-sugarLists (HsAppTy (L _ (HsTyVar name)) ltyp)
+sugarLists (HsAppTy (L _ (HsTyVar (L _ name))) ltyp)
     | isBuiltInSyntax name' && strName == "[]" = HsListTy ltyp
   where
     name' = getName name
@@ -134,7 +137,7 @@ sugarTuples typ =
   where
     aux apps (HsAppTy (L _ ftyp) atyp) = aux (atyp:apps) ftyp
     aux apps (HsParTy (L _ typ')) = aux apps typ'
-    aux apps (HsTyVar name)
+    aux apps (HsTyVar (L _ name))
         | isBuiltInSyntax name' && suitable = HsTupleTy HsBoxedTuple apps
       where
         name' = getName name
@@ -146,8 +149,8 @@ sugarTuples typ =
 
 
 sugarOperators :: NamedThing name => HsType name -> HsType name
-sugarOperators (HsAppTy (L _ (HsAppTy (L loc (HsTyVar name)) la)) lb)
-    | isSymOcc $ getOccName name' = mkHsOpTy la (L loc name) lb
+sugarOperators (HsAppTy (L _ (HsAppTy (L loc (HsTyVar (L l name))) la)) lb)
+    | isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb
     | isBuiltInSyntax name' && getOccString name == "(->)" = HsFunTy la lb
   where
     name' = getName name
@@ -219,13 +222,13 @@ freeVariables =
     everythingWithState Set.empty Set.union query
   where
     query term ctx = case cast term :: Maybe (HsType name) of
-        Just (HsForAllTy _ _ bndrs _ _) ->
+        Just (HsForAllTy bndrs _) ->
             (Set.empty, Set.union ctx (bndrsNames bndrs))
-        Just (HsTyVar name)
+        Just (HsTyVar (L _ name))
             | getName name `Set.member` ctx -> (Set.empty, ctx)
             | otherwise -> (Set.singleton $ getNameRep name, ctx)
         _ -> (Set.empty, ctx)
-    bndrsNames = Set.fromList . map (getName . tyVarName . unLoc) . hsq_tvs
+    bndrsNames = Set.fromList . map (getName . tyVarName . unLoc)
 
 
 -- | Make given type visually unambiguous.
@@ -256,26 +259,26 @@ data RenameEnv name = RenameEnv
 
 
 renameType :: SetName name => HsType name -> Rename name (HsType name)
-renameType (HsForAllTy ex mspan lbndrs lctx lt) = rebind lbndrs $ \lbndrs' ->
+renameType (HsForAllTy bndrs lt) = rebind bndrs $ \bndrs' ->
     HsForAllTy
-        <$> pure ex
-        <*> pure mspan
-        <*> pure lbndrs'
-        <*> located renameContext lctx
+        <$> pure bndrs'
         <*> renameLType lt
-renameType (HsTyVar name) = HsTyVar <$> renameName name
+renameType (HsQualTy lctxt lt) =
+  HsQualTy
+        <$> located renameContext lctxt
+        <*> renameLType lt
+renameType (HsTyVar name) = HsTyVar <$> located renameName name
 renameType (HsAppTy lf la) = HsAppTy <$> renameLType lf <*> renameLType la
 renameType (HsFunTy la lr) = HsFunTy <$> renameLType la <*> renameLType lr
 renameType (HsListTy lt) = HsListTy <$> renameLType lt
 renameType (HsPArrTy lt) = HsPArrTy <$> renameLType lt
 renameType (HsTupleTy srt lt) = HsTupleTy srt <$> mapM renameLType lt
 renameType (HsOpTy la lop lb) =
-    HsOpTy <$> renameLType la <*> renameLTyOp lop <*> renameLType lb
+    HsOpTy <$> renameLType la <*> located renameName lop <*> renameLType lb
 renameType (HsParTy lt) = HsParTy <$> renameLType lt
 renameType (HsIParamTy ip lt) = HsIParamTy ip <$> renameLType lt
 renameType (HsEqTy la lb) = HsEqTy <$> renameLType la <*> renameLType lb
 renameType (HsKindSig lt lk) = HsKindSig <$> renameLType lt <*> pure lk
-renameType t@(HsQuasiQuoteTy _) = pure t
 renameType t@(HsSpliceTy _ _) = pure t
 renameType (HsDocTy lt doc) = HsDocTy <$> renameLType lt <*> pure doc
 renameType (HsBangTy bang lt) = HsBangTy bang <$> renameLType lt
@@ -286,9 +289,7 @@ renameType (HsExplicitListTy ph ltys) =
 renameType (HsExplicitTupleTy phs ltys) =
     HsExplicitTupleTy phs <$> renameLTypes ltys
 renameType t@(HsTyLit _) = pure t
-renameType (HsWrapTy wrap t) = HsWrapTy wrap <$> renameType t
-renameType HsWildcardTy = pure HsWildcardTy
-renameType (HsNamedWildcardTy name) = HsNamedWildcardTy <$> renameName name
+renameType (HsWildCardTy wc) = pure (HsWildCardTy wc)
 
 
 renameLType :: SetName name => LHsType name -> Rename name (LHsType name)
@@ -302,21 +303,20 @@ renameLTypes = mapM renameLType
 renameContext :: SetName name => HsContext name -> Rename name (HsContext name)
 renameContext = renameLTypes
 
-
+{-
 renameLTyOp :: SetName name => LHsTyOp name -> Rename name (LHsTyOp name)
 renameLTyOp (wrap, lname) = (,) wrap <$> located renameName lname
+-}
 
 
 renameName :: SetName name => name -> Rename name name
 renameName name = do
     RenameEnv { rneCtx = ctx } <- ask
-    pure $ case Map.lookup (getName name) ctx of
-        Just name' -> name'
-        Nothing -> name
+    pure $ fromMaybe name (Map.lookup (getName name) ctx)
 
 
 rebind :: SetName name
-       => LHsTyVarBndrs name -> (LHsTyVarBndrs name -> Rename name a)
+       => [LHsTyVarBndr name] -> ([LHsTyVarBndr name] -> Rename name a)
        -> Rename name a
 rebind lbndrs action = do
     (lbndrs', env') <- runState (rebindLTyVarBndrs lbndrs) <$> ask
@@ -324,16 +324,14 @@ rebind lbndrs action = do
 
 
 rebindLTyVarBndrs :: SetName name
-                  => LHsTyVarBndrs name -> Rebind name (LHsTyVarBndrs name)
-rebindLTyVarBndrs lbndrs = do
-    tys' <- mapM (located rebindTyVarBndr) $ hsq_tvs lbndrs
-    pure $ lbndrs { hsq_tvs = tys' }
+                  => [LHsTyVarBndr name] -> Rebind name [LHsTyVarBndr name]
+rebindLTyVarBndrs lbndrs = mapM (located rebindTyVarBndr) lbndrs
 
 
 rebindTyVarBndr :: SetName name
                 => HsTyVarBndr name -> Rebind name (HsTyVarBndr name)
-rebindTyVarBndr (UserTyVar name) =
-    UserTyVar <$> rebindName name
+rebindTyVarBndr (UserTyVar (L l name)) =
+    UserTyVar . L l <$> rebindName name
 rebindTyVarBndr (KindedTyVar name kinds) =
     KindedTyVar <$> located rebindName name <*> pure kinds
 
@@ -403,5 +401,5 @@ located f (L loc e) = L loc <$> f e
 
 
 tyVarName :: HsTyVarBndr name -> name
-tyVarName (UserTyVar name) = name
+tyVarName (UserTyVar name) = unLoc name
 tyVarName (KindedTyVar (L _ name) _) = name
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index e07f55f1..6bc00f63 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -326,7 +326,7 @@ instance SetName DocName where
 data InstType name
   = ClassInst
       { clsiCtx :: [HsType name]
-      , clsiTyVars :: LHsTyVarBndrs name
+      , clsiTyVars :: LHsQTyVars name
       , clsiSigs :: [Sig name]
       , clsiAssocTys :: [PseudoFamilyDecl name]
       }
@@ -353,7 +353,7 @@ data PseudoFamilyDecl name = PseudoFamilyDecl
     { pfdInfo :: FamilyInfo name
     , pfdLName :: Located name
     , pfdTyVars :: [LHsType name]
-    , pfdKindSig :: Maybe (LHsKind name)
+    , pfdKindSig :: LFamilyResultSig name
     }
 
 
@@ -361,14 +361,14 @@ mkPseudoFamilyDecl :: FamilyDecl name -> PseudoFamilyDecl name
 mkPseudoFamilyDecl (FamilyDecl { .. }) = PseudoFamilyDecl
     { pfdInfo = fdInfo
     , pfdLName = fdLName
-    , pfdTyVars = [ L loc (mkType bndr) | L loc bndr <- hsq_tvs fdTyVars ]
-    , pfdKindSig = fdKindSig
+    , pfdTyVars = [ L loc (mkType bndr) | L loc bndr <- hsq_explicit fdTyVars ]
+    , pfdKindSig = fdResultSig
     }
   where
     mkType (KindedTyVar (L loc name) lkind) =
         HsKindSig tvar lkind
       where
-        tvar = L loc (HsTyVar name)
+        tvar = L loc (HsTyVar (L loc name))
     mkType (UserTyVar name) = HsTyVar name
 
 
-- 
cgit v1.2.3


From a89c8083c2c08d9cd9607a91d6ea11420bd72a70 Mon Sep 17 00:00:00 2001
From: Matthew Pickering <matthewtpickering@gmail.com>
Date: Mon, 14 Dec 2015 18:47:12 +0000
Subject: Warnings

---
 haddock-api/src/Haddock/Backends/Hoogle.hs           |  2 --
 haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs  |  1 -
 haddock-api/src/Haddock/Backends/LaTeX.hs            |  3 +--
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs       |  9 +--------
 haddock-api/src/Haddock/Convert.hs                   |  3 +--
 haddock-api/src/Haddock/Interface/AttachInstances.hs |  2 --
 haddock-api/src/Haddock/Interface/LexParseRn.hs      |  1 -
 haddock-api/src/Haddock/Interface/Specialize.hs      | 11 ++++++-----
 8 files changed, 9 insertions(+), 23 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Xhtml/Decl.hs')

diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 1adcddfc..a9bc9a8b 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -21,7 +21,6 @@ import Haddock.GhcUtils
 import Haddock.Types hiding (Version)
 import Haddock.Utils hiding (out)
 
-import Bag
 import GHC
 import Outputable
 import NameSet
@@ -140,7 +139,6 @@ ppSigWithDoc dflags (TypeSig names sig) subdocs
         getDoc :: Located Name -> [Documentation Name]
         getDoc n = maybe [] (return . fst) (lookup (unL n) subdocs)
 
-        typ = unL (hsSigWcType sig)
 ppSigWithDoc _ _ _ = []
 
 ppSig :: DynFlags -> Sig Name -> [String]
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index 060534bf..1f396df5 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -11,7 +11,6 @@ import Haddock.Syb
 import Haddock.Backends.Hyperlinker.Types
 
 import qualified GHC
-import qualified FieldLabel as GHC
 
 import Control.Applicative
 import Data.Data
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 75a4edba..ab6bb41c 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -25,10 +25,9 @@ import qualified Pretty
 import GHC
 import OccName
 import Name                 ( nameOccName )
-import RdrName              ( rdrNameOcc, mkRdrUnqual )
+import RdrName              ( rdrNameOcc )
 import FastString           ( unpackFS, unpackLitString, zString )
 import Outputable           ( panic)
-import PrelNames            ( mkUnboundName )
 
 import qualified Data.Map as Map
 import System.Directory
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index ae1905bf..d27cb2bc 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -38,8 +38,7 @@ import GHC
 import GHC.Exts
 import Name
 import BooleanFormula
-import RdrName ( rdrNameOcc, mkRdrUnqual )
-import PrelNames            ( mkUnboundName )
+import RdrName ( rdrNameOcc )
 
 ppDecl :: Bool -> LinksInfo -> LHsDecl DocName
        -> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, Fixity)]
@@ -246,12 +245,6 @@ ppFamilyInfo assoc DataFamily
 ppFamilyInfo _ (ClosedTypeFamily _) = keyword "type family"
 
 
-ppFamilyKind :: Unicode -> Qualification -> Maybe (LHsKind DocName) -> Html
-ppFamilyKind unicode qual (Just kind) =
-    dcolon unicode <+> ppLKind unicode qual kind
-ppFamilyKind _ _ Nothing = noHtml
-
-
 ppTyFamHeader :: Bool -> Bool -> FamilyDecl DocName
               -> Unicode -> Qualification -> Html
 ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 4a7ad162..bc293731 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -22,14 +22,13 @@ import Class
 import CoAxiom
 import ConLike
 import Data.Either (lefts, rights)
-import Data.List( partition )
 import DataCon
 import FamInstEnv
 import HsSyn
 import Name
 import RdrName ( mkVarUnqual )
 import PatSyn
-import SrcLoc ( Located, noLoc, unLoc, noSrcSpan )
+import SrcLoc ( Located, noLoc, unLoc )
 import TcType ( tcSplitSigmaTy )
 import TyCon
 import Type
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index 56382341..faf043aa 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -33,7 +33,6 @@ import FamInstEnv
 import FastString
 import GHC
 import GhcMonad (withSession)
-import Id
 import InstEnv
 import MonadUtils (liftIO)
 import Name
@@ -41,7 +40,6 @@ import Outputable (text, sep, (<+>))
 import PrelNames
 import SrcLoc
 import TcRnDriver (tcRnGetInfo)
-import TcType (tcSplitSigmaTy)
 import TyCon
 import TyCoRep
 import TysPrim( funTyCon )
diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs
index 0f6add36..661bd6be 100644
--- a/haddock-api/src/Haddock/Interface/LexParseRn.hs
+++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs
@@ -28,7 +28,6 @@ import Haddock.Interface.ParseModuleHeader
 import Haddock.Parser
 import Haddock.Types
 import Name
-import RdrHsSyn   ( setRdrNameSpace )
 import Outputable ( showPpr )
 import RdrName
 import RnEnv (dataTcOccs)
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index e9b9c60a..ab719fe8 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -54,7 +54,7 @@ specialize' = flip $ foldr (uncurry specialize)
 --
 -- Again, it is just a convenience function around 'specialize'. Note that
 -- length of type list should be the same as the number of binders.
-specializeTyVarBndrs :: (Eq name, Typeable name, DataId name)
+specializeTyVarBndrs :: (Eq name, DataId name)
                      => Data a
                      => LHsQTyVars name -> [HsType name]
                      -> a -> a
@@ -66,7 +66,7 @@ specializeTyVarBndrs bndrs typs =
     bname (KindedTyVar (L _ name) _) = name
 
 
-specializePseudoFamilyDecl :: (Eq name, Typeable name, DataId name)
+specializePseudoFamilyDecl :: (Eq name, DataId name)
                            => LHsQTyVars name -> [HsType name]
                            -> PseudoFamilyDecl name
                            -> PseudoFamilyDecl name
@@ -76,7 +76,7 @@ specializePseudoFamilyDecl bndrs typs decl =
     specializeTyVars = specializeTyVarBndrs bndrs typs
 
 
-specializeSig :: forall name . (Eq name, Typeable name, DataId name, SetName name)
+specializeSig :: forall name . (Eq name, DataId name, SetName name)
               => LHsQTyVars name -> [HsType name]
               -> Sig name
               -> Sig name
@@ -93,7 +93,7 @@ specializeSig _ _ sig = sig
 
 -- | Make all details of instance head (signatures, associated types)
 -- specialized to that particular instance type.
-specializeInstHead :: (Eq name, Typeable name, DataId name, SetName name)
+specializeInstHead :: (Eq name, DataId name, SetName name)
                    => InstHead name -> InstHead name
 specializeInstHead ihd@InstHead { ihdInstType = clsi@ClassInst { .. }, .. } =
     ihd { ihdInstType = instType' }
@@ -149,7 +149,7 @@ sugarTuples typ =
 
 
 sugarOperators :: NamedThing name => HsType name -> HsType name
-sugarOperators (HsAppTy (L _ (HsAppTy (L loc (HsTyVar (L l name))) la)) lb)
+sugarOperators (HsAppTy (L _ (HsAppTy (L _ (HsTyVar (L l name))) la)) lb)
     | isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb
     | isBuiltInSyntax name' && getOccString name == "(->)" = HsFunTy la lb
   where
@@ -290,6 +290,7 @@ renameType (HsExplicitTupleTy phs ltys) =
     HsExplicitTupleTy phs <$> renameLTypes ltys
 renameType t@(HsTyLit _) = pure t
 renameType (HsWildCardTy wc) = pure (HsWildCardTy wc)
+renameType (HsAppsTy _) = error "HsAppsTy: Only used before renaming"
 
 
 renameLType :: SetName name => LHsType name -> Rename name (LHsType name)
-- 
cgit v1.2.3


From 3de72a80fff18aa71873ace86d1aeb5171b09b41 Mon Sep 17 00:00:00 2001
From: Ben Gamari <ben@smart-cactus.org>
Date: Wed, 16 Dec 2015 06:05:25 -0500
Subject: Fix fallout from wildcards refactoring

The wildcard refactoring was introduced a new type of signature,
`ClassOpSig`, which is carried by typeclasses. The original patch
adapting Haddock for this change missed a few places where this
constructor needed to be handled, resulting in no class methods
in documentation produced by Haddock.

Additionally, this moves and renames the `isVanillaLSig` helper from
GHC's HsBinds module into GhcUtils, since it is only used by Haddock.
---
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs |  4 ++--
 haddock-api/src/Haddock/GhcUtils.hs            | 18 ++++++++++++++----
 haddock-api/src/Haddock/Interface/Create.hs    |  6 +++---
 haddock-api/src/Haddock/Interface/Rename.hs    |  4 ++++
 4 files changed, 23 insertions(+), 9 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Xhtml/Decl.hs')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index d27cb2bc..49149b8c 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -451,7 +451,7 @@ ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan
 ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = tvs
                                           , tcdFDs = fds, tcdSigs = sigs, tcdATs = ats }) loc
     subdocs splice unicode qual =
-  if not (any isVanillaLSig sigs) && null ats
+  if not (any isUserLSig sigs) && null ats
     then (if summary then id else topDeclElem links loc splice [nm]) hdr
     else (if summary then id else topDeclElem links loc splice [nm]) (hdr <+> keyword "where")
       +++ shortSubDecls False
@@ -492,7 +492,7 @@ ppClassDecl summary links instances fixities loc d subdocs
     sigs = map unLoc lsigs
 
     classheader
-      | any isVanillaLSig lsigs = topDeclElem links loc splice [nm] (hdr unicode qual <+> keyword "where" <+> fixs)
+      | any isUserLSig lsigs = topDeclElem links loc splice [nm] (hdr unicode qual <+> keyword "where" <+> fixs)
       | otherwise = topDeclElem links loc splice [nm] (hdr unicode qual <+> fixs)
 
     -- Only the fixity relevant to the class header
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 2a9fba2e..4e5e008b 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -95,6 +95,10 @@ filterSigNames p (TypeSig ns ty) =
   case filter (p . unLoc) ns of
     []       -> Nothing
     filtered -> Just (TypeSig filtered ty)
+filterSigNames p (ClassOpSig is_default ns ty) =
+  case filter (p . unLoc) ns of
+    []       -> Nothing
+    filtered -> Just (ClassOpSig is_default filtered ty)
 filterSigNames _ _                           = Nothing
 
 ifTrueJust :: Bool -> name -> Maybe name
@@ -105,13 +109,19 @@ sigName :: LSig name -> [name]
 sigName (L _ sig) = sigNameNoLoc sig
 
 sigNameNoLoc :: Sig name -> [name]
-sigNameNoLoc (TypeSig   ns _)          = map unLoc ns
-sigNameNoLoc (PatSynSig n _)           = [unLoc n]
-sigNameNoLoc (SpecSig   n _ _)         = [unLoc n]
-sigNameNoLoc (InlineSig n _)           = [unLoc n]
+sigNameNoLoc (TypeSig      ns _)       = map unLoc ns
+sigNameNoLoc (ClassOpSig _ ns _)       = map unLoc ns
+sigNameNoLoc (PatSynSig    n _)        = [unLoc n]
+sigNameNoLoc (SpecSig      n _ _)      = [unLoc n]
+sigNameNoLoc (InlineSig    n _)        = [unLoc n]
 sigNameNoLoc (FixSig (FixitySig ns _)) = map unLoc ns
 sigNameNoLoc _                         = []
 
+-- | Was this signature given by the user?
+isUserLSig :: LSig name -> Bool
+isUserLSig (L _(TypeSig {}))    = True
+isUserLSig (L _(ClassOpSig {})) = True
+isUserLSig _                    = False
 
 isTyClD :: HsDecl a -> Bool
 isTyClD (TyClD _) = True
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index d427be6c..c41946f5 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -402,7 +402,7 @@ ungroup group_ =
   mkDecls (typesigs . hs_valds)  SigD   group_ ++
   mkDecls (valbinds . hs_valds)  ValD   group_
   where
-    typesigs (ValBindsOut _ sigs) = filter isVanillaLSig sigs
+    typesigs (ValBindsOut _ sigs) = filter isUserLSig sigs
     typesigs _ = error "expected ValBindsOut"
 
     valbinds (ValBindsOut binds _) = concatMap bagToList . snd . unzip $ binds
@@ -434,7 +434,7 @@ filterDecls = filter (isHandled . unL . fst)
     isHandled (ForD (ForeignImport {})) = True
     isHandled (TyClD {}) = True
     isHandled (InstD {}) = True
-    isHandled (SigD d) = isVanillaLSig (reL d)
+    isHandled (SigD d) = isUserLSig (reL d)
     isHandled (ValD _) = True
     -- we keep doc declarations to be able to get at named docs
     isHandled (DocD _) = True
@@ -447,7 +447,7 @@ filterClasses decls = [ if isClassD d then (L loc (filterClass d), doc) else x
                       | x@(L loc d, doc) <- decls ]
   where
     filterClass (TyClD c) =
-      TyClD $ c { tcdSigs = filter (liftA2 (||) isVanillaLSig isMinimalLSig) $ tcdSigs c }
+      TyClD $ c { tcdSigs = filter (liftA2 (||) isUserLSig isMinimalLSig) $ tcdSigs c }
     filterClass _ = error "expected TyClD"
 
 
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 859afe6e..2478ce23 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -459,6 +459,10 @@ renameSig sig = case sig of
     lnames' <- mapM renameL lnames
     ltype' <- renameLSigWcType ltype
     return (TypeSig lnames' ltype')
+  ClassOpSig is_default lnames sig_ty -> do
+    lnames' <- mapM renameL lnames
+    ltype' <- renameLSigType sig_ty
+    return (ClassOpSig is_default lnames' ltype')
   PatSynSig lname sig_ty -> do
     lname' <- renameL lname
     sig_ty' <- renameLSigType sig_ty
-- 
cgit v1.2.3