From b383b17cd1c4aebe73481dba0df13640e7bfc50a Mon Sep 17 00:00:00 2001
From: Justus Adam <dev@justus.science>
Date: Thu, 2 Mar 2017 15:33:34 +0100
Subject: Adding MDoc to exports of Documentation.Haddock

---
 haddock-api/src/Documentation/Haddock.hs | 1 +
 1 file changed, 1 insertion(+)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Documentation/Haddock.hs b/haddock-api/src/Documentation/Haddock.hs
index 1ff5cf75..4203a564 100644
--- a/haddock-api/src/Documentation/Haddock.hs
+++ b/haddock-api/src/Documentation/Haddock.hs
@@ -34,6 +34,7 @@ module Documentation.Haddock (
 
   -- * Documentation comments
   Doc,
+  MDoc,
   DocH(..),
   Example(..),
   Hyperlink(..),
-- 
cgit v1.2.3


From ef99ed85007636a866fbdeed154d89612d68f824 Mon Sep 17 00:00:00 2001
From: Justus Adam <dev@justus.science>
Date: Thu, 9 Mar 2017 11:41:44 +0100
Subject: Also exposing toInstalledIface

---
 haddock-api/src/Documentation/Haddock.hs | 1 +
 1 file changed, 1 insertion(+)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Documentation/Haddock.hs b/haddock-api/src/Documentation/Haddock.hs
index 4203a564..14605e92 100644
--- a/haddock-api/src/Documentation/Haddock.hs
+++ b/haddock-api/src/Documentation/Haddock.hs
@@ -16,6 +16,7 @@ module Documentation.Haddock (
   -- * Interface
   Interface(..),
   InstalledInterface(..),
+  toInstalledIface,
   createInterfaces,
   processModules,
 
-- 
cgit v1.2.3


From d2be5e88281d8e3148bc55830c27c75844b86f38 Mon Sep 17 00:00:00 2001
From: Ben Gamari <ben@smart-cactus.org>
Date: Thu, 9 Mar 2017 22:13:43 -0500
Subject: Bump for GHC 8.2

---
 haddock-api/src/Haddock/InterfaceFile.hs | 4 ++--
 haddock.cabal                            | 4 ++--
 2 files changed, 4 insertions(+), 4 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs
index 63419102..0d000029 100644
--- a/haddock-api/src/Haddock/InterfaceFile.hs
+++ b/haddock-api/src/Haddock/InterfaceFile.hs
@@ -82,8 +82,8 @@ binaryInterfaceMagic = 0xD0Cface
 -- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion]
 --
 binaryInterfaceVersion :: Word16
-#if (__GLASGOW_HASKELL__ >= 801) && (__GLASGOW_HASKELL__ < 803)
-binaryInterfaceVersion = 28
+#if (__GLASGOW_HASKELL__ >= 802) && (__GLASGOW_HASKELL__ < 804)
+binaryInterfaceVersion = 29
 
 binaryInterfaceVersionCompatibility :: [Word16]
 binaryInterfaceVersionCompatibility = [binaryInterfaceVersion]
diff --git a/haddock.cabal b/haddock.cabal
index 7103a459..10460526 100644
--- a/haddock.cabal
+++ b/haddock.cabal
@@ -55,8 +55,8 @@ executable haddock
       array,
       xhtml >= 3000.2 && < 3000.3,
       Cabal >= 1.10,
-      ghc-boot == 8.1,
-      ghc == 8.1,
+      ghc-boot,
+      ghc == 8.2.*,
       bytestring,
       transformers
 
-- 
cgit v1.2.3


From 4f249c9b64d50d79e7ba703289cd67293a76821a Mon Sep 17 00:00:00 2001
From: Richard Eisenberg <rae@cs.brynmawr.edu>
Date: Fri, 10 Mar 2017 11:31:33 -0500
Subject: Update Haddock w.r.t. new HsImplicitBndrs

---
 haddock-api/src/Haddock/Convert.hs          | 5 +++--
 haddock-api/src/Haddock/Interface/Rename.hs | 3 ++-
 2 files changed, 5 insertions(+), 3 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index b5966291..577b1a3c 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -114,7 +114,8 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs })
         hs_rhs     = synifyType WithinType rhs
     in TyFamEqn { tfe_tycon = name
                 , tfe_pats  = HsIB { hsib_body = typats
-                                   , hsib_vars = map tyVarName tkvs }
+                                   , hsib_vars = map tyVarName tkvs
+                                   , hsib_closed = True }
                 , tfe_fixity = Prefix
                 , tfe_rhs   = hs_rhs }
 
@@ -300,7 +301,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) False
  -- finally we get synifyDataCon's result!
  in hs_arg_tys >>=
       \hat ->
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index f88d9f4e..b43860fb 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -577,7 +577,8 @@ renameImplicit :: (in_thing -> RnM out_thing)
 renameImplicit rn_thing (HsIB { hsib_body = thing })
   = do { thing' <- rn_thing thing
        ; return (HsIB { hsib_body = thing'
-                      , hsib_vars = PlaceHolder }) }
+                      , hsib_vars = PlaceHolder
+                      , hsib_closed = PlaceHolder }) }
 
 renameWc :: (in_thing -> RnM out_thing)
          -> HsWildCardBndrs Name in_thing
-- 
cgit v1.2.3


From f6f9bca1416f6cee48f2d4731a6c38db92e87300 Mon Sep 17 00:00:00 2001
From: Brian Huffman <huffman@galois.com>
Date: Fri, 17 Mar 2017 14:57:39 -0700
Subject: Print any user-supplied kind signatures on type parameters.

This applies to type parameters on data, newtype, type, and class
declarations, and also to forall-bound type vars in type signatures.
---
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 37 ++++++++++----------------
 1 file changed, 14 insertions(+), 23 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 2aec5272..ffe42c4f 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -171,8 +171,8 @@ ppFixities fs qual = foldr1 (+++) (map ppFix uniq_fs) +++ rightEdge
 
 
 -- | Pretty-print type variables.
-ppTyVars :: [LHsTyVarBndr DocName] -> [Html]
-ppTyVars tvs = map (ppTyName . getName . hsLTyVarName) tvs
+ppTyVars :: Unicode -> Qualification -> [LHsTyVarBndr DocName] -> [Html]
+ppTyVars unicode qual tvs = map (ppHsTyVarBndr unicode qual . unLoc) tvs
 
 tyvarNames :: LHsQTyVars DocName -> [Name]
 tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit
@@ -199,7 +199,7 @@ ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars
                    splice unicode qual
   where
     hdr  = hsep ([keyword "type", ppBinder summary occ]
-                 ++ ppTyVars (hsQTvExplicit ltyvars))
+                 ++ ppTyVars unicode qual (hsQTvExplicit ltyvars))
     full = hdr <+> equals <+> ppLType unicode qual ltype
     occ  = nameOccName . getName $ name
     fixs
@@ -353,20 +353,20 @@ ppAssocType summ links doc (L loc decl) fixities splice unicode qual =
 -- | Print a type family and its variables
 ppFamDeclBinderWithVars :: Bool -> Unicode -> Qualification -> FamilyDecl DocName -> Html
 ppFamDeclBinderWithVars summ unicode qual (FamilyDecl { fdLName = lname, fdTyVars = tvs }) =
-  ppAppDocNameTyVarBndrs summ unicode qual (unLoc lname) (map unLoc $ hsq_explicit tvs)
+  ppAppDocNameTyVarBndrs summ unicode qual (unLoc lname) (hsq_explicit tvs)
 
 -- | Print a newtype / data binder and its variables
-ppDataBinderWithVars :: Bool -> TyClDecl DocName -> Html
-ppDataBinderWithVars summ decl =
-  ppAppDocNameNames summ (tcdName decl) (tyvarNames $ tcdTyVars decl)
+ppDataBinderWithVars :: Bool -> Unicode -> Qualification -> TyClDecl DocName -> Html
+ppDataBinderWithVars summ unicode qual decl =
+  ppAppDocNameTyVarBndrs summ unicode qual (tcdName decl) (hsQTvExplicit $ tcdTyVars decl)
 
 --------------------------------------------------------------------------------
 -- * Type applications
 --------------------------------------------------------------------------------
 
-ppAppDocNameTyVarBndrs :: Bool -> Unicode -> Qualification -> DocName -> [HsTyVarBndr DocName] -> Html
+ppAppDocNameTyVarBndrs :: Bool -> Unicode -> Qualification -> DocName -> [LHsTyVarBndr DocName] -> Html
 ppAppDocNameTyVarBndrs summ unicode qual n vs =
-    ppTypeApp n [] vs ppDN (ppHsTyVarBndr unicode qual)
+    ppTypeApp n [] vs ppDN (ppHsTyVarBndr unicode qual . unLoc)
   where
     ppDN notation = ppBinderFixity notation summ . nameOccName . getName
     ppBinderFixity Infix = ppBinderInfix
@@ -379,15 +379,6 @@ ppAppNameTypes n ks ts unicode qual =
     ppTypeApp n ks ts (\p -> ppDocName qual p True) (ppParendType unicode qual)
 
 
--- | Print an application of a 'DocName' and a list of 'Names'
-ppAppDocNameNames :: Bool -> DocName -> [Name] -> Html
-ppAppDocNameNames summ n ns =
-    ppTypeApp n [] ns ppDN ppTyName
-  where
-    ppDN notation = ppBinderFixity notation summ . nameOccName . getName
-    ppBinderFixity Infix = ppBinderInfix
-    ppBinderFixity _ = ppBinder
-
 -- | General printing of type applications
 ppTypeApp :: DocName -> [a] -> [a] -> (Notation -> DocName -> Html) -> (a -> Html) -> Html
 ppTypeApp n [] (t1:t2:rest) ppDN ppT
@@ -445,7 +436,7 @@ ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName
 ppClassHdr summ lctxt n tvs fds unicode qual =
   keyword "class"
   <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode qual else noHtml)
-  <+> ppAppDocNameNames summ n (tyvarNames tvs)
+  <+> ppAppDocNameTyVarBndrs summ unicode qual n (hsQTvExplicit tvs)
   <+> ppFds fds unicode qual
 
 
@@ -890,7 +881,7 @@ ppDataHeader summary decl@(DataDecl { tcdDataDefn =
     -- context
     ppLContext ctxt unicode qual <+>
     -- T a b c ..., or a :+: b
-    ppDataBinderWithVars summary decl
+    ppDataBinderWithVars summary unicode qual decl
     <+> case ks of
       Nothing -> mempty
       Just (L _ x) -> dcolon unicode <+> ppKind unicode qual x
@@ -967,8 +958,8 @@ 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
 
-ppForAllPart :: [LHsTyVarBndr DocName] -> Unicode -> Html
-ppForAllPart tvs unicode = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot
+ppForAllPart :: Unicode -> Qualification -> [LHsTyVarBndr DocName] -> Html
+ppForAllPart unicode qual tvs = hsep (forallSymbol unicode : ppTyVars unicode qual tvs) +++ dot
 
 ppr_mono_lty :: Int -> LHsType DocName -> Unicode -> Qualification -> Html
 ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty)
@@ -977,7 +968,7 @@ 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 tvs ty) unicode qual
   = maybeParen ctxt_prec pREC_FUN $
-    ppForAllPart tvs unicode <+> ppr_mono_lty pREC_TOP ty unicode qual
+    ppForAllPart unicode qual tvs <+> ppr_mono_lty pREC_TOP ty unicode qual
 
 ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode qual
   = maybeParen ctxt_prec pREC_FUN $
-- 
cgit v1.2.3


From 68e531baa35e698d947686b83525871eb33c3730 Mon Sep 17 00:00:00 2001
From: "Edward Z. Yang" <ezyang@cs.stanford.edu>
Date: Mon, 13 Mar 2017 02:53:36 -0700
Subject: Correctly handle Backpack identity/semantic modules.

Signed-off-by: Edward Z. Yang <ezyang@cs.stanford.edu>
(cherry picked from commit 26d6c150b31bc4580ab17cfd07b6e7f9afe10737)
---
 haddock-api/src/Haddock/Interface/Create.hs | 75 +++++++++++++++++++++--------
 1 file changed, 54 insertions(+), 21 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index c8e6b982..ff53fd3c 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -62,6 +62,7 @@ createInterface tm flags modMap instIfaceMap = do
       L _ hsm        = parsedSource tm
       !safety        = modInfoSafe mi
       mdl            = ms_mod ms
+      sem_mdl        = tcg_semantic_mod (fst (tm_internals_ tm))
       dflags         = ms_hspp_opts ms
       !instances     = modInfoInstances mi
       !fam_instances = md_fam_insts md
@@ -88,8 +89,9 @@ createInterface tm flags modMap instIfaceMap = do
   let declsWithDocs = topDecls group_
       fixMap = mkFixMap group_
       (decls, _) = unzip declsWithDocs
-      localInsts = filter (nameIsLocalOrFrom mdl) $  map getName instances
-                                                  ++ map getName fam_instances
+      localInsts = filter (nameIsLocalOrFrom sem_mdl)
+                        $  map getName instances
+                        ++ map getName fam_instances
       -- Locations of all TH splices
       splices = [ l | L l (SpliceD _) <- hsmodDecls hsm ]
 
@@ -104,7 +106,7 @@ createInterface tm flags modMap instIfaceMap = do
 
   let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap))
 
-  exportItems <- mkExportItems modMap mdl allWarnings gre exportedNames decls
+  exportItems <- mkExportItems modMap mdl sem_mdl allWarnings gre exportedNames decls
                    maps fixMap splices exports instIfaceMap dflags
 
   let !visibleNames = mkVisibleNames maps exportItems opts
@@ -156,6 +158,10 @@ createInterface tm flags modMap instIfaceMap = do
   , ifaceTokenizedSrc    = tokenizedSrc
   }
 
+-- | Given all of the @import M as N@ declarations in a package,
+-- create a mapping from the module identity of M, to an alias N
+-- (if there are multiple aliases, we pick the last one.)  This
+-- will go in 'ifaceModuleAliases'.
 mkAliasMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName
 mkAliasMap dflags mRenamedSource =
   case mRenamedSource of
@@ -166,13 +172,28 @@ mkAliasMap dflags mRenamedSource =
         SrcLoc.L _ alias <- ideclAs impDecl
         return $
           (lookupModuleDyn dflags
+             -- TODO: This is supremely dodgy, because in general the
+             -- UnitId isn't going to look anything like the package
+             -- qualifier (even with old versions of GHC, the
+             -- IPID would be p-0.1, but a package qualifier never
+             -- has a version number it.  (Is it possible that in
+             -- Haddock-land, the UnitIds never have version numbers?
+             -- I, ezyang, have not quite understand Haddock's package
+             -- identifier model.)
+             --
+             -- Additionally, this is simulating some logic GHC already
+             -- has for deciding how to qualify names when it outputs
+             -- them to the user.  We should reuse that information;
+             -- or at least reuse the renamed imports, which know what
+             -- they import!
              (fmap Module.fsToUnitId $
               fmap sl_fs $ ideclPkgQual impDecl)
              (case ideclName impDecl of SrcLoc.L _ name -> name),
            alias))
         impDecls
 
--- similar to GHC.lookupModule
+-- Similar to GHC.lookupModule
+-- ezyang: Not really...
 lookupModuleDyn ::
   DynFlags -> Maybe UnitId -> ModuleName -> Module
 lookupModuleDyn _ (Just pkgId) mdlName =
@@ -492,6 +513,7 @@ collectDocs = go Nothing []
 mkExportItems
   :: IfaceMap
   -> Module             -- this module
+  -> Module             -- semantic module
   -> WarningMap
   -> GlobalRdrEnv
   -> [Name]             -- exported names (orig)
@@ -504,7 +526,7 @@ mkExportItems
   -> DynFlags
   -> ErrMsgGhc [ExportItem Name]
 mkExportItems
-  modMap thisMod warnings gre exportedNames decls
+  modMap thisMod semMod warnings gre exportedNames decls
   maps@(docMap, argMap, subMap, declMap, instMap) fixMap splices optExports instIfaceMap dflags =
   case optExports of
     Nothing -> fullModuleContents dflags warnings gre maps fixMap splices decls
@@ -515,6 +537,7 @@ mkExportItems
     lookupExport (IEThingAll (L _ t))    = declWith $ ieWrappedName t
     lookupExport (IEThingWith (L _ t) _ _ _) = declWith $ ieWrappedName t
     lookupExport (IEModuleContents (L _ m)) =
+      -- Pass in identity module, so we can look it up in index correctly
       moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps fixMap splices
     lookupExport (IEGroup lev docStr)  = return $
       return . ExportGroup lev "" $ processDocString dflags gre docStr
@@ -582,6 +605,8 @@ mkExportItems
             Just decl ->
               -- We try to get the subs and docs
               -- from the installed .haddock file for that package.
+              -- TODO: This needs to be more sophisticated to deal
+              -- with signature inheritance
               case M.lookup (nameModule t) instIfaceMap of
                 Nothing -> do
                    liftErrMsg $ tell
@@ -597,8 +622,7 @@ mkExportItems
     mkExportDecl :: Name -> LHsDecl Name -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ExportItem Name
     mkExportDecl name decl (doc, subs) = decl'
       where
-        decl' = ExportDecl (restrictTo sub_names (extractDecl name mdl decl)) doc subs' [] fixities False
-        mdl = nameModule name
+        decl' = ExportDecl (restrictTo sub_names (extractDecl name decl)) doc subs' [] fixities False
         subs' = filter (isExported . fst) subs
         sub_names = map fst subs'
         fixities = [ (n, f) | n <- name:sub_names, Just f <- [M.lookup n fixMap] ]
@@ -609,14 +633,20 @@ mkExportItems
 
     findDecl :: Name -> ([LHsDecl Name], (DocForDecl Name, [(Name, DocForDecl Name)]))
     findDecl n
-      | m == thisMod, Just ds <- M.lookup n declMap =
+      | m == semMod, Just ds <- M.lookup n declMap =
           (ds, lookupDocs n warnings docMap argMap subMap)
-      | Just iface <- M.lookup m modMap, Just ds <- M.lookup n (ifaceDeclMap iface) =
+      | Just iface <- M.lookup (semToIdMod (moduleUnitId thisMod) m) modMap, Just ds <- M.lookup n (ifaceDeclMap iface) =
           (ds, lookupDocs n warnings (ifaceDocMap iface) (ifaceArgMap iface) (ifaceSubMap iface))
       | otherwise = ([], (noDocForDecl, []))
       where
         m = nameModule n
 
+-- | Given a 'Module' from a 'Name', convert it into a 'Module' that
+-- we can actually find in the 'IfaceMap'.
+semToIdMod :: UnitId -> Module -> Module
+semToIdMod this_uid m
+    | Module.isHoleModule m = mkModule this_uid (moduleName m)
+    | otherwise      = m
 
 hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl Name))
 hiDecl dflags t = do
@@ -679,7 +709,7 @@ lookupDocs n warnings docMap argMap subMap =
 --    only return those that are.
 -- 3) B is visible and all its exports are in scope, in which case we return
 --    a single 'ExportModule' item.
-moduleExports :: Module           -- ^ Module A
+moduleExports :: Module           -- ^ Module A (identity, NOT semantic)
               -> ModuleName       -- ^ The real name of B, the exported module
               -> DynFlags         -- ^ The flags used when typechecking A
               -> WarningMap
@@ -693,8 +723,11 @@ moduleExports :: Module           -- ^ Module A
               -> [SrcSpan]        -- ^ Locations of all TH splices
               -> ErrMsgGhc [ExportItem Name] -- ^ Resulting export items
 moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfaceMap maps fixMap splices
-  | m == thisMod = fullModuleContents dflags warnings gre maps fixMap splices decls
+  | expMod == moduleName thisMod
+  = fullModuleContents dflags warnings gre maps fixMap splices decls
   | otherwise =
+    -- NB: we constructed the identity module when looking up in
+    -- the IfaceMap.
     case M.lookup m ifaceMap of
       Just iface
         | OptHide `elem` ifaceOptions iface -> return (ifaceExportItems iface)
@@ -710,7 +743,7 @@ moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfa
                     "documentation for exported module: " ++ pretty dflags expMod]
             return []
   where
-    m = mkModule unitId expMod
+    m = mkModule unitId expMod -- Identity module!
     unitId = moduleUnitId thisMod
 
 
@@ -789,8 +822,8 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap
 -- it might be an individual record selector or a class method.  In these
 -- cases we have to extract the required declaration (and somehow cobble
 -- together a type signature for it...).
-extractDecl :: Name -> Module -> LHsDecl Name -> LHsDecl Name
-extractDecl name mdl decl
+extractDecl :: Name -> LHsDecl Name -> LHsDecl Name
+extractDecl name decl
   | name `elem` getMainDeclBinder (unLoc decl) = decl
   | otherwise  =
     case unLoc decl of
@@ -812,11 +845,11 @@ extractDecl name mdl decl
                                          O.$$ O.nest 4 (O.ppr matches))
       TyClD d@DataDecl {} ->
         let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars d))
-        in SigD <$> extractRecSel name mdl n tyvar_tys (dd_cons (tcdDataDefn d))
+        in SigD <$> extractRecSel name n tyvar_tys (dd_cons (tcdDataDefn d))
       InstD (DataFamInstD DataFamInstDecl { dfid_tycon = L _ n
                                           , dfid_pats = HsIB { hsib_body = tys }
                                           , dfid_defn = defn }) ->
-        SigD <$> extractRecSel name mdl n tys (dd_cons defn)
+        SigD <$> extractRecSel name 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)
@@ -826,19 +859,19 @@ extractDecl name mdl decl
                           , selectorFieldOcc n == name
                       ]
         in case matches of
-          [d0] -> extractDecl name mdl (noLoc . InstD $ DataFamInstD d0)
+          [d0] -> extractDecl name (noLoc . InstD $ DataFamInstD d0)
           _ -> error "internal: extractDecl (ClsInstD)"
       _ -> error "internal: extractDecl"
 
-extractRecSel :: Name -> Module -> Name -> [LHsType Name] -> [LConDecl Name]
+extractRecSel :: Name -> Name -> [LHsType Name] -> [LConDecl Name]
               -> LSig Name
-extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found"
+extractRecSel _ _ _ [] = error "extractRecSel: selector not found"
 
-extractRecSel nm mdl t tvs (L _ con : rest) =
+extractRecSel nm t tvs (L _ con : rest) =
   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
+    _ -> extractRecSel nm t tvs rest
  where
   matching_fields :: [LConDeclField Name] -> [(SrcSpan, LConDeclField Name)]
   matching_fields flds = [ (l,f) | f@(L _ (ConDeclField ns _ _)) <- flds
-- 
cgit v1.2.3


From 26879d9b4a2aba264a10812f2738d4db685d61d1 Mon Sep 17 00:00:00 2001
From: "Edward Z. Yang" <ezyang@cs.stanford.edu>
Date: Mon, 13 Mar 2017 03:03:20 -0700
Subject: Add a field marking if interface is a signature or not.

Signed-off-by: Edward Z. Yang <ezyang@cs.stanford.edu>
(cherry picked from commit 930cfbe58e2e87f5a4d431d89a3c204934e6e858)
---
 haddock-api/src/Haddock/Interface/Create.hs | 1 +
 haddock-api/src/Haddock/InterfaceFile.hs    | 6 ++++--
 haddock-api/src/Haddock/Types.hs            | 7 +++++++
 3 files changed, 12 insertions(+), 2 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index ff53fd3c..024cd02d 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -132,6 +132,7 @@ createInterface tm flags modMap instIfaceMap = do
 
   return $! Interface {
     ifaceMod             = mdl
+  , ifaceIsSig           = Module.isHoleModule sem_mdl
   , ifaceOrigFilename    = msHsFilePath ms
   , ifaceInfo            = info
   , ifaceDoc             = Documentation mbDoc modWarn
diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs
index 0d000029..78853a79 100644
--- a/haddock-api/src/Haddock/InterfaceFile.hs
+++ b/haddock-api/src/Haddock/InterfaceFile.hs
@@ -372,9 +372,10 @@ instance Binary InterfaceFile where
 
 
 instance Binary InstalledInterface where
-  put_ bh (InstalledInterface modu info docMap argMap
+  put_ bh (InstalledInterface modu is_sig info docMap argMap
            exps visExps opts subMap fixMap) = do
     put_ bh modu
+    put_ bh is_sig
     put_ bh info
     put_ bh docMap
     put_ bh argMap
@@ -386,6 +387,7 @@ instance Binary InstalledInterface where
 
   get bh = do
     modu    <- get bh
+    is_sig  <- get bh
     info    <- get bh
     docMap  <- get bh
     argMap  <- get bh
@@ -395,7 +397,7 @@ instance Binary InstalledInterface where
     subMap  <- get bh
     fixMap  <- get bh
 
-    return (InstalledInterface modu info docMap argMap
+    return (InstalledInterface modu is_sig info docMap argMap
             exps visExps opts subMap fixMap)
 
 
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 8addfa2f..a6dd6354 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -80,6 +80,9 @@ data Interface = Interface
     -- | The module behind this interface.
     ifaceMod             :: !Module
 
+    -- | Is this a signature?
+  , ifaceIsSig           :: !Bool
+
     -- | Original file name of the module.
   , ifaceOrigFilename    :: !FilePath
 
@@ -157,6 +160,9 @@ data InstalledInterface = InstalledInterface
     -- | The module represented by this interface.
     instMod            :: Module
 
+    -- | Is this a signature?
+  , instIsSig          :: Bool
+
     -- | Textual information about the module.
   , instInfo           :: HaddockModInfo Name
 
@@ -186,6 +192,7 @@ data InstalledInterface = InstalledInterface
 toInstalledIface :: Interface -> InstalledInterface
 toInstalledIface interface = InstalledInterface
   { instMod            = ifaceMod            interface
+  , instIsSig          = ifaceIsSig          interface
   , instInfo           = ifaceInfo           interface
   , instDocMap         = ifaceDocMap         interface
   , instArgMap         = ifaceArgMap         interface
-- 
cgit v1.2.3


From fbbe544c91020da143160bb8c68ee890d214a69e Mon Sep 17 00:00:00 2001
From: "Edward Z. Yang" <ezyang@cs.stanford.edu>
Date: Mon, 13 Mar 2017 03:13:10 -0700
Subject: Render signature module tree separately from modules.

Signed-off-by: Edward Z. Yang <ezyang@cs.stanford.edu>
(cherry picked from commit 2067a2d0afa9cef381d26fb7140b67c62f433fc0)
---
 haddock-api/src/Haddock/Backends/Xhtml.hs | 15 ++++++++++++++-
 1 file changed, 14 insertions(+), 1 deletion(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index 65b427f9..34911b11 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -263,13 +263,20 @@ ppHtmlContents dflags odir doctitle _maybe_package
   themes mathjax_url maybe_index_url
   maybe_source_url maybe_wiki_url ifaces showPkgs prologue debug qual = do
   let tree = mkModuleTree dflags showPkgs
-         [(instMod iface, toInstalledDescription iface) | iface <- ifaces]
+         [(instMod iface, toInstalledDescription iface)
+         | iface <- ifaces
+         , not (instIsSig iface)]
+      sig_tree = mkModuleTree dflags showPkgs
+         [(instMod iface, toInstalledDescription iface)
+         | iface <- ifaces
+         , instIsSig iface]
       html =
         headHtml doctitle Nothing themes mathjax_url +++
         bodyHtml doctitle Nothing
           maybe_source_url maybe_wiki_url
           Nothing maybe_index_url << [
             ppPrologue qual doctitle prologue,
+            ppSignatureTree qual sig_tree,
             ppModuleTree qual tree
           ]
   createDirectoryIfMissing True odir
@@ -282,7 +289,13 @@ ppPrologue qual title (Just doc) =
   divDescription << (h1 << title +++ docElement thediv (rdrDocToHtml qual doc))
 
 
+ppSignatureTree :: Qualification -> [ModuleTree] -> Html
+ppSignatureTree qual ts =
+  divModuleList << (sectionName << "Signatures" +++ mkNodeList qual [] "n" ts)
+
+
 ppModuleTree :: Qualification -> [ModuleTree] -> Html
+ppModuleTree _ [] = mempty
 ppModuleTree qual ts =
   divModuleList << (sectionName << "Modules" +++ mkNodeList qual [] "n" ts)
 
-- 
cgit v1.2.3


From 4e6f4447caf61b6a91a483f30a15354cbf6cfc31 Mon Sep 17 00:00:00 2001
From: "Edward Z. Yang" <ezyang@cs.stanford.edu>
Date: Mon, 13 Mar 2017 15:13:27 -0700
Subject: Documentation.

Signed-off-by: Edward Z. Yang <ezyang@cs.stanford.edu>
(cherry picked from commit 0671abfe7e8ceae2269467a30b77ed9d9656e2cc)
---
 haddock-api/src/Haddock/Interface/Create.hs | 27 ++++++++++++++++++++++-----
 1 file changed, 22 insertions(+), 5 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 024cd02d..502d6599 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -11,6 +11,10 @@
 -- Maintainer  :  haddock@projects.haskell.org
 -- Stability   :  experimental
 -- Portability :  portable
+--
+-- This module provides a single function 'createInterface',
+-- which creates a Haddock 'Interface' from the typechecking
+-- results 'TypecheckedModule' from GHC.
 -----------------------------------------------------------------------------
 module Haddock.Interface.Create (createInterface) where
 
@@ -54,7 +58,11 @@ import HsDecls ( getConDetails )
 -- | Use a 'TypecheckedModule' to produce an 'Interface'.
 -- To do this, we need access to already processed modules in the topological
 -- sort. That's what's in the 'IfaceMap'.
-createInterface :: TypecheckedModule -> [Flag] -> IfaceMap -> InstIfaceMap -> ErrMsgGhc Interface
+createInterface :: TypecheckedModule
+                -> [Flag]       -- Boolean flags
+                -> IfaceMap     -- Locally processed modules
+                -> InstIfaceMap -- External, already installed interfaces
+                -> ErrMsgGhc Interface
 createInterface tm flags modMap instIfaceMap = do
 
   let ms             = pm_mod_summary . tm_parsed_module $ tm
@@ -518,7 +526,7 @@ mkExportItems
   -> WarningMap
   -> GlobalRdrEnv
   -> [Name]             -- exported names (orig)
-  -> [LHsDecl Name]
+  -> [LHsDecl Name]     -- renamed source declarations
   -> Maps
   -> FixMap
   -> [SrcSpan]          -- splice locations
@@ -716,7 +724,7 @@ moduleExports :: Module           -- ^ Module A (identity, NOT semantic)
               -> WarningMap
               -> GlobalRdrEnv     -- ^ The renaming environment used for A
               -> [Name]           -- ^ All the exports of A
-              -> [LHsDecl Name]   -- ^ All the declarations in A
+              -> [LHsDecl Name]   -- ^ All the renamed declarations in A
               -> IfaceMap         -- ^ Already created interfaces
               -> InstIfaceMap     -- ^ Interfaces in other packages
               -> Maps
@@ -765,8 +773,17 @@ moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfa
 -- (For more information, see Trac #69)
 
 
-fullModuleContents :: DynFlags -> WarningMap -> GlobalRdrEnv -> Maps -> FixMap -> [SrcSpan]
-                   -> [LHsDecl Name] -> ErrMsgGhc [ExportItem Name]
+-- | Simplified variant of 'mkExportItems', where we can assume that
+-- every locally defined declaration is exported; thus, we just
+-- zip through the renamed declarations.
+fullModuleContents :: DynFlags
+                   -> WarningMap
+                   -> GlobalRdrEnv      -- ^ The renaming environment
+                   -> Maps
+                   -> FixMap
+                   -> [SrcSpan]         -- ^ Locations of all TH splices
+                   -> [LHsDecl Name]    -- ^ All the renamed declarations
+                   -> ErrMsgGhc [ExportItem Name]
 fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap) fixMap splices decls =
   liftM catMaybes $ mapM mkExportItem (expandSig decls)
   where
-- 
cgit v1.2.3


From f65966b2febe36c8aae8ebee13d3f12a63479e65 Mon Sep 17 00:00:00 2001
From: "Edward Z. Yang" <ezyang@cs.stanford.edu>
Date: Mon, 13 Mar 2017 15:25:09 -0700
Subject: More docs.

Signed-off-by: Edward Z. Yang <ezyang@cs.stanford.edu>
(cherry picked from commit 3d77b373dd5807d5d956719dd7c849a11534fa6a)
---
 haddock-api/src/Haddock/Interface/Create.hs | 5 +++++
 1 file changed, 5 insertions(+)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 502d6599..f1043c03 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -92,6 +92,7 @@ createInterface tm flags modMap instIfaceMap = do
         | Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0
         | otherwise = opts0
 
+  -- Process the top-level module header documentation.
   (!info, mbDoc) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader
 
   let declsWithDocs = topDecls group_
@@ -114,6 +115,8 @@ createInterface tm flags modMap instIfaceMap = do
 
   let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap))
 
+  -- The MAIN functionality: compute the export items which will
+  -- each be the actual documentation of this module.
   exportItems <- mkExportItems modMap mdl sem_mdl allWarnings gre exportedNames decls
                    maps fixMap splices exports instIfaceMap dflags
 
@@ -352,6 +355,8 @@ mkMaps dflags gre instances decls =
 
 
 -- | Get all subordinate declarations inside a declaration, and their docs.
+-- A subordinate declaration is something like the associate type or data
+-- family of a type class.
 subordinates :: InstMap -> HsDecl Name -> [(Name, [HsDocString], Map Int HsDocString)]
 subordinates instMap decl = case decl of
   InstD (ClsInstD d) -> do
-- 
cgit v1.2.3


From 76d0b2b8ac2bfaa7983a9b5ea828f6caf8a6205d Mon Sep 17 00:00:00 2001
From: "Edward Z. Yang" <ezyang@cs.stanford.edu>
Date: Mon, 13 Mar 2017 15:33:25 -0700
Subject: TODO on moduleExports.

Signed-off-by: Edward Z. Yang <ezyang@cs.stanford.edu>
(cherry picked from commit 94610e9b446324f4231fa6ad4c6ac51e4eba8c0e)
---
 haddock-api/src/Haddock/Interface/Create.hs | 6 +++++-
 1 file changed, 5 insertions(+), 1 deletion(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index f1043c03..85401bfa 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -551,7 +551,11 @@ mkExportItems
     lookupExport (IEThingAll (L _ t))    = declWith $ ieWrappedName t
     lookupExport (IEThingWith (L _ t) _ _ _) = declWith $ ieWrappedName t
     lookupExport (IEModuleContents (L _ m)) =
-      -- Pass in identity module, so we can look it up in index correctly
+      -- TODO: We could get more accurate reporting here if IEModuleContents
+      -- also recorded the actual names that are exported here.  We CAN
+      -- compute this info using @gre@ but 'moduleExports does not seem to
+      -- do so.
+      -- NB: Pass in identity module, so we can look it up in index correctly
       moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps fixMap splices
     lookupExport (IEGroup lev docStr)  = return $
       return . ExportGroup lev "" $ processDocString dflags gre docStr
-- 
cgit v1.2.3


From 24694932de26645331eb53b016c84a6a5c171a97 Mon Sep 17 00:00:00 2001
From: "Edward Z. Yang" <ezyang@cs.stanford.edu>
Date: Tue, 14 Mar 2017 03:53:49 -0700
Subject: Better Backpack support with signature merging.

When we merge signatures, we gain exports that don't
necessarily have a source-level declaration corresponding
to them.  This meant Haddock dropped them.

There are two big limitations:

* If there's no export list, we won't report inherited
  signatures.

* If the type has a subordinate, the current hiDecl
  implementation doesn't reconstitute them.

These are probably worth fixing eventually, but this gets
us to minimum viable functionality.

Signed-off-by: Edward Z. Yang <ezyang@cs.stanford.edu>
(cherry picked from commit 6cc832dfb1de6088a4abcaae62b25a7e944d55c3)
---
 haddock-api/src/Haddock/Interface/Create.hs | 46 +++++++++++++++++++++--------
 1 file changed, 34 insertions(+), 12 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 85401bfa..e594feae 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -71,6 +71,7 @@ createInterface tm flags modMap instIfaceMap = do
       !safety        = modInfoSafe mi
       mdl            = ms_mod ms
       sem_mdl        = tcg_semantic_mod (fst (tm_internals_ tm))
+      is_sig         = ms_hsc_src ms == HsigFile
       dflags         = ms_hspp_opts ms
       !instances     = modInfoInstances mi
       !fam_instances = md_fam_insts md
@@ -117,7 +118,7 @@ createInterface tm flags modMap instIfaceMap = do
 
   -- The MAIN functionality: compute the export items which will
   -- each be the actual documentation of this module.
-  exportItems <- mkExportItems modMap mdl sem_mdl allWarnings gre exportedNames decls
+  exportItems <- mkExportItems is_sig modMap mdl sem_mdl allWarnings gre exportedNames decls
                    maps fixMap splices exports instIfaceMap dflags
 
   let !visibleNames = mkVisibleNames maps exportItems opts
@@ -143,7 +144,7 @@ createInterface tm flags modMap instIfaceMap = do
 
   return $! Interface {
     ifaceMod             = mdl
-  , ifaceIsSig           = Module.isHoleModule sem_mdl
+  , ifaceIsSig           = is_sig
   , ifaceOrigFilename    = msHsFilePath ms
   , ifaceInfo            = info
   , ifaceDoc             = Documentation mbDoc modWarn
@@ -525,7 +526,8 @@ collectDocs = go Nothing []
 -- We create the export items even if the module is hidden, since they
 -- might be useful when creating the export items for other modules.
 mkExportItems
-  :: IfaceMap
+  :: Bool               -- is it a signature
+  -> IfaceMap
   -> Module             -- this module
   -> Module             -- semantic module
   -> WarningMap
@@ -540,7 +542,7 @@ mkExportItems
   -> DynFlags
   -> ErrMsgGhc [ExportItem Name]
 mkExportItems
-  modMap thisMod semMod warnings gre exportedNames decls
+  is_sig modMap thisMod semMod warnings gre exportedNames decls
   maps@(docMap, argMap, subMap, declMap, instMap) fixMap splices optExports instIfaceMap dflags =
   case optExports of
     Nothing -> fullModuleContents dflags warnings gre maps fixMap splices decls
@@ -569,8 +571,9 @@ mkExportItems
         Just doc -> return . ExportDoc $ processDocStringParas dflags gre doc
 
     declWith :: Name -> ErrMsgGhc [ ExportItem Name ]
-    declWith t =
-      case findDecl t of
+    declWith t = do
+      r <- findDecl t
+      case r of
         ([L l (ValD _)], (doc, _)) -> do
           -- Top-level binding without type signature
           export <- hiValExportItem dflags t l doc (l `elem` splices) $ M.lookup t fixMap
@@ -649,13 +652,32 @@ mkExportItems
     isExported = (`elem` exportedNames)
 
 
-    findDecl :: Name -> ([LHsDecl Name], (DocForDecl Name, [(Name, DocForDecl Name)]))
+    findDecl :: Name -> ErrMsgGhc ([LHsDecl Name], (DocForDecl Name, [(Name, DocForDecl Name)]))
     findDecl n
-      | m == semMod, Just ds <- M.lookup n declMap =
-          (ds, lookupDocs n warnings docMap argMap subMap)
-      | Just iface <- M.lookup (semToIdMod (moduleUnitId thisMod) m) modMap, Just ds <- M.lookup n (ifaceDeclMap iface) =
-          (ds, lookupDocs n warnings (ifaceDocMap iface) (ifaceArgMap iface) (ifaceSubMap iface))
-      | otherwise = ([], (noDocForDecl, []))
+      | m == semMod =
+          case M.lookup n declMap of
+            Just ds -> return (ds, lookupDocs n warnings docMap argMap subMap)
+            Nothing
+              | is_sig -> do
+                -- OK, so it wasn't in the local declaration map.  It could
+                -- have been inherited from a signature.  Reconstitute it
+                -- from the type.
+                mb_r <- hiDecl dflags n
+                case mb_r of
+                    Nothing -> return ([], (noDocForDecl, []))
+                    -- TODO: If we try harder, we might be able to find
+                    -- a Haddock!  Look in the Haddocks for each thing in
+                    -- requirementContext (pkgState)
+                    Just decl -> return ([decl], (noDocForDecl, []))
+              | otherwise ->
+                return ([], (noDocForDecl, []))
+      | Just iface <- M.lookup (semToIdMod (moduleUnitId thisMod) m) modMap
+      , Just ds <- M.lookup n (ifaceDeclMap iface) =
+          return (ds, lookupDocs n warnings
+                            (ifaceDocMap iface)
+                            (ifaceArgMap iface)
+                            (ifaceSubMap iface))
+      | otherwise = return ([], (noDocForDecl, []))
       where
         m = nameModule n
 
-- 
cgit v1.2.3


From ef93eaac9bc0ca40073763d2e18ced3a51679ead Mon Sep 17 00:00:00 2001
From: "Edward Z. Yang" <ezyang@cs.stanford.edu>
Date: Wed, 22 Mar 2017 13:48:12 -0700
Subject: Annotate signature docs with (signature)

Signed-off-by: Edward Z. Yang <ezyang@cs.stanford.edu>
(cherry picked from commit 07b88c5d4e79b87a319fbb08f8ea01dbb41063c1)
---
 haddock-api/src/Haddock/Backends/Xhtml.hs | 7 +++++--
 1 file changed, 5 insertions(+), 2 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index 34911b11..fc26afbb 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -482,13 +482,16 @@ ppHtmlModule odir doctitle themes
       mdl = ifaceMod iface
       aliases = ifaceModuleAliases iface
       mdl_str = moduleString mdl
+      mdl_str_annot = mdl_str ++ if ifaceIsSig iface
+                                    then " (signature)"
+                                    else ""
       real_qual = makeModuleQual qual aliases mdl
       html =
-        headHtml mdl_str (Just $ "mini_" ++ moduleHtmlFile mdl) themes maybe_mathjax_url +++
+        headHtml mdl_str_annot (Just $ "mini_" ++ moduleHtmlFile mdl) themes maybe_mathjax_url +++
         bodyHtml doctitle (Just iface)
           maybe_source_url maybe_wiki_url
           maybe_contents_url maybe_index_url << [
-            divModuleHeader << (moduleInfo iface +++ (sectionName << mdl_str)),
+            divModuleHeader << (moduleInfo iface +++ (sectionName << mdl_str_annot)),
             ifaceToHtml maybe_source_url maybe_wiki_url iface unicode real_qual
           ]
 
-- 
cgit v1.2.3


From 0567d936e02dcbc41c62b4dd63c7aaafc3383844 Mon Sep 17 00:00:00 2001
From: "Edward Z. Yang" <ezyang@cs.stanford.edu>
Date: Wed, 22 Mar 2017 14:11:25 -0700
Subject: Render help documentation link next to (signature) in title.

Signed-off-by: Edward Z. Yang <ezyang@cs.stanford.edu>
(cherry picked from commit 4eb765ca4205c79539d60b7afa9b7e261a4a49fe)
---
 haddock-api/resources/html/Ocean.std-theme/ocean.css | 5 +++++
 haddock-api/src/Haddock/Backends/Xhtml.hs            | 9 ++++++++-
 2 files changed, 13 insertions(+), 1 deletion(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/resources/html/Ocean.std-theme/ocean.css b/haddock-api/resources/html/Ocean.std-theme/ocean.css
index e8e4d705..29af691b 100644
--- a/haddock-api/resources/html/Ocean.std-theme/ocean.css
+++ b/haddock-api/resources/html/Ocean.std-theme/ocean.css
@@ -88,6 +88,11 @@ pre, code, kbd, samp, tt, .src {
   font-size: 182%; /* 24pt */
 }
 
+#module-header .caption sup {
+  font-size: 70%;
+  font-weight: normal;
+}
+
 .info  {
   font-size: 85%; /* 11pt */
 }
diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index fc26afbb..4cb028b8 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -485,13 +485,17 @@ ppHtmlModule odir doctitle themes
       mdl_str_annot = mdl_str ++ if ifaceIsSig iface
                                     then " (signature)"
                                     else ""
+      mdl_str_linked = mdl_str +++
+                       " (signature" +++
+                       sup << ("[" +++ anchor ! [href signatureDocURL] << "?" +++ "]" ) +++
+                       ")"
       real_qual = makeModuleQual qual aliases mdl
       html =
         headHtml mdl_str_annot (Just $ "mini_" ++ moduleHtmlFile mdl) themes maybe_mathjax_url +++
         bodyHtml doctitle (Just iface)
           maybe_source_url maybe_wiki_url
           maybe_contents_url maybe_index_url << [
-            divModuleHeader << (moduleInfo iface +++ (sectionName << mdl_str_annot)),
+            divModuleHeader << (moduleInfo iface +++ (sectionName << mdl_str_linked)),
             ifaceToHtml maybe_source_url maybe_wiki_url iface unicode real_qual
           ]
 
@@ -499,6 +503,9 @@ ppHtmlModule odir doctitle themes
   writeFile (joinPath [odir, moduleHtmlFile mdl]) (renderToString debug html)
   ppHtmlModuleMiniSynopsis odir doctitle themes maybe_mathjax_url iface unicode real_qual debug
 
+signatureDocURL :: String
+signatureDocURL = "https://wiki.haskell.org/Module_signature"
+
 ppHtmlModuleMiniSynopsis :: FilePath -> String -> Themes
   -> Maybe String -> Interface -> Bool -> Qualification -> Bool -> IO ()
 ppHtmlModuleMiniSynopsis odir _doctitle themes maybe_mathjax_url iface unicode qual debug = do
-- 
cgit v1.2.3


From 18ed871afb82560d5433b2f53e31b4db9353a74e Mon Sep 17 00:00:00 2001
From: Phil Ruffwind <rf@rufflewind.com>
Date: Sat, 1 Apr 2017 05:05:06 -0400
Subject: Update MathJax URL

MathJax is shutting down their CDN:
https://www.mathjax.org/cdn-shutting-down/

They recommend migrating to cdnjs.
---
 haddock-api/src/Haddock/Backends/Xhtml.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index 4cb028b8..c5caa6a2 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -126,7 +126,7 @@ headHtml docTitle miniPage themes mathjax_url =
     ]
   where
     setSynopsis = maybe "" (\p -> "setSynopsis(\"" ++ p ++ "\");") miniPage
-    mjUrl = maybe "https://cdn.mathjax.org/mathjax/latest/MathJax.js?config=TeX-AMS-MML_HTMLorMML" id mathjax_url
+    mjUrl = maybe "https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.0/MathJax.js?config=TeX-AMS-MML_HTMLorMML" id mathjax_url
 
 
 srcButton :: SourceURLs -> Maybe Interface -> Maybe Html
-- 
cgit v1.2.3


From e0ada1743cb722d2f82498a95b201f3ffb303137 Mon Sep 17 00:00:00 2001
From: alexbiehl <alex.biehl@gmail.com>
Date: Tue, 11 Apr 2017 20:35:08 +0200
Subject: Read files for hyperlinker eagerly

This also exposes Documentation.Haddock.Utf8
---
 haddock-api/src/Haddock/Interface/Create.hs | 12 ++++++++----
 haddock-library/haddock-library.cabal       |  2 +-
 2 files changed, 9 insertions(+), 5 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index e594feae..d2ad9294 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -19,6 +19,7 @@
 module Haddock.Interface.Create (createInterface) where
 
 import Documentation.Haddock.Doc (metaDocAppend)
+import Documentation.Haddock.Utf8 as Utf8
 import Haddock.Types
 import Haddock.Options
 import Haddock.GhcUtils
@@ -29,6 +30,7 @@ import Haddock.Backends.Hyperlinker.Types
 import Haddock.Backends.Hyperlinker.Ast as Hyperlinker
 import Haddock.Backends.Hyperlinker.Parser as Hyperlinker
 
+import qualified Data.ByteString as BS
 import qualified Data.Map as M
 import Data.Map (Map)
 import Data.List
@@ -38,6 +40,7 @@ import Data.Ord
 import Control.Applicative
 import Control.Arrow (second)
 import Control.DeepSeq
+import Control.Exception (evaluate)
 import Control.Monad
 import Data.Function (on)
 
@@ -976,10 +979,11 @@ mkMaybeTokenizedSrc flags tm
     summary = pm_mod_summary . tm_parsed_module $ tm
 
 mkTokenizedSrc :: ModSummary -> RenamedSource -> IO [RichToken]
-mkTokenizedSrc ms src =
-    Hyperlinker.enrich src . Hyperlinker.parse <$> rawSrc
-  where
-    rawSrc = readFile $ msHsFilePath ms
+mkTokenizedSrc ms src = do
+  -- make sure to read the whole file at once otherwise
+  -- we run out of file descriptors (see #495)
+  rawSrc <- BS.readFile (msHsFilePath ms) >>= evaluate
+  return $ Hyperlinker.enrich src (Hyperlinker.parse (decodeUtf8 rawSrc))
 
 -- | Find a stand-alone documentation comment by its name.
 findNamedDoc :: String -> [HsDecl Name] -> ErrMsgM (Maybe HsDocString)
diff --git a/haddock-library/haddock-library.cabal b/haddock-library/haddock-library.cabal
index cabfbc67..4e355dd1 100644
--- a/haddock-library/haddock-library.cabal
+++ b/haddock-library/haddock-library.cabal
@@ -34,6 +34,7 @@ library
     Documentation.Haddock.Parser.Monad
     Documentation.Haddock.Types
     Documentation.Haddock.Doc
+    Documentation.Haddock.Utf8
 
   other-modules:
     Data.Attoparsec
@@ -48,7 +49,6 @@ library
     Data.Attoparsec.Internal.Types
     Data.Attoparsec.Number
     Documentation.Haddock.Parser.Util
-    Documentation.Haddock.Utf8
 
 test-suite spec
   type:             exitcode-stdio-1.0
-- 
cgit v1.2.3


From b44676d9acd36b50a93aea6882751284d00013b6 Mon Sep 17 00:00:00 2001
From: alexbiehl <alex.biehl@gmail.com>
Date: Tue, 11 Apr 2017 20:37:06 +0200
Subject: Explicit import list ofr Control.DeepSeq in Haddock.Interface.Create

---
 haddock-api/src/Haddock/Interface/Create.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index d2ad9294..6ff1223c 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -39,7 +39,7 @@ import Data.Monoid
 import Data.Ord
 import Control.Applicative
 import Control.Arrow (second)
-import Control.DeepSeq
+import Control.DeepSeq (force)
 import Control.Exception (evaluate)
 import Control.Monad
 import Data.Function (on)
-- 
cgit v1.2.3


From e9cd7b1b52228b9ef8e1bd4e6cb1f2583740fcee Mon Sep 17 00:00:00 2001
From: Kyrill Briantsev <kyrab@mail.ru>
Date: Thu, 12 Jan 2017 13:23:50 +0300
Subject: Prevent GHC API from doing optimization passes.

---
 haddock-api/src/Haddock.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index bbaea359..6af0874a 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -397,7 +397,7 @@ withGhc' libDir flags ghcActs = runGhc (Just libDir) $ do
     ghcMode   = CompManager,
     ghcLink   = NoLink
     }
-  let dynflags'' = gopt_unset dynflags' Opt_SplitObjs
+  let dynflags'' = updOptLevel 0 $ gopt_unset dynflags' Opt_SplitObjs
   defaultCleanupHandler dynflags'' $ do
       -- ignore the following return-value, which is a list of packages
       -- that may need to be re-linked: Haddock doesn't do any
-- 
cgit v1.2.3


From 70885ce16e1b0b9bf19fe0efb85a48daa0e5c281 Mon Sep 17 00:00:00 2001
From: alexbiehl <alex.biehl@gmail.com>
Date: Tue, 18 Apr 2017 16:45:32 +0200
Subject: Travis: Use ghc-8.2.1 on master

---
 .travis.yml                             | 84 +++++++++++++++++++++++++++------
 haddock-api/haddock-api.cabal           |  5 +-
 haddock-api/src/Haddock.hs              | 25 ++++++----
 haddock-library/haddock-library.cabal   |  5 +-
 haddock-test/src/Test/Haddock/Config.hs | 17 +++++--
 haddock.cabal                           | 53 ++++++++++++---------
 6 files changed, 136 insertions(+), 53 deletions(-)

(limited to 'haddock-api/src')

diff --git a/.travis.yml b/.travis.yml
index 405f8753..c1f8f504 100644
--- a/.travis.yml
+++ b/.travis.yml
@@ -1,26 +1,80 @@
+# This Travis job script has been generated by a script via
+#
+#   make_travis_yml_2.hs 'haddock.cabal'
+#
+# For more information, see https://github.com/hvr/multi-ghc-travis
+#
+language: c
 sudo: false
 
+git:
+  submodules: false  # whether to recursively clone submodules
+
+cache:
+  directories:
+    - $HOME/.cabal/packages
+    - $HOME/.cabal/store
+
+before_cache:
+  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log
+  # remove files that are regenerated by 'cabal update'
+  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.*
+  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json
+  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache
+  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar
+  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx
+
 matrix:
   include:
-    - env: CABALVER=head GHCVER=head
-      addons: {apt: {packages: [cabal-install-head,ghc-head],  sources: [hvr-ghc]}}
+    - compiler: "ghc-8.2.1"
+    # env: TEST=--disable-tests BENCH=--disable-benchmarks
+      addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.2.1], sources: [hvr-ghc]}}
+    - compiler: "ghc-head"
+    # env: TEST=--disable-tests BENCH=--disable-benchmarks
+      addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-head], sources: [hvr-ghc]}}
 
   allow_failures:
-    - env: CABALVER=head GHCVER=head
+    - compiler: "ghc-head"
 
 before_install:
- - export PATH=$HOME/.cabal/bin:/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH
+ - HC=${CC}
+ - unset CC
+ - PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$PATH
+ - PKGNAME='haddock'
+
+install:
  - cabal --version
- - cabal update
- - cd haddock-library
- - cabal install --only-dependencies --enable-tests
-# - cabal install doctest
- # --ghc-options=-Werror
- - cabal configure --enable-tests && cabal build && cabal test
-# - doctest -isrc -i$(echo vendor/attoparsec-*) -optP-include -optPdist/build/autogen/cabal_macros.h src/Documentation/Haddock/Parser.hs
- - cabal install
- - cd ..
- - (cd haddock-api/ && cabal install --only-dependencies --enable-tests && cabal configure --enable-tests && cabal build && cabal test && cabal install)
+ - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
+ - BENCH=${BENCH---enable-benchmarks}
+ - TEST=${TEST---enable-tests}
+ - travis_retry cabal update -v
+ - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config
+ - rm -fv cabal.project.local
+ - rm -f cabal.project.freeze
+ - cabal new-build -w ${HC} ${TEST} ${BENCH} --dep -j2 all
+ - cabal new-build -w ${HC} --disable-tests --disable-benchmarks --dep -j2 all
 
+# Here starts the actual work to be performed for the package under test;
+# any command which exits with a non-zero exit code causes the build to fail.
 script:
- - cabal configure --enable-tests && cabal build && cabal test
+ - if [ -f configure.ac ]; then autoreconf -i; fi
+ - rm -rf dist/
+ - cabal sdist # test that a source-distribution can be generated
+ - cd dist/
+ - SRCTAR=(${PKGNAME}-*.tar.gz)
+ - SRC_BASENAME="${SRCTAR/%.tar.gz}"
+ - tar -xvf "./$SRC_BASENAME.tar.gz"
+ - cd "$SRC_BASENAME/"
+## from here on, CWD is inside the extracted source-tarball
+ - rm -fv cabal.project.local
+ # this builds all libraries and executables (without tests/benchmarks)
+ - rm -f cabal.project.freeze
+ - cabal new-build -w ${HC} --disable-tests --disable-benchmarks all
+ # this builds all libraries and executables (including tests/benchmarks)
+ # - rm -rf ./dist-newstyle
+
+ # build & run tests
+ - cabal new-build -w ${HC} ${TEST} ${BENCH} all
+ - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} all; fi
+
+# EOF
diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal
index f98a8202..921e16eb 100644
--- a/haddock-api/haddock-api.cabal
+++ b/haddock-api/haddock-api.cabal
@@ -12,7 +12,7 @@ bug-reports:          https://github.com/haskell/haddock/issues
 copyright:            (c) Simon Marlow, David Waern
 category:             Documentation
 build-type:           Simple
-cabal-version:        >= 1.10
+cabal-version:        >= 2.0
 stability:            experimental
 
 data-dir:
@@ -120,6 +120,9 @@ test-suite spec
     , hspec
     , QuickCheck == 2.*
 
+  build-tool-depends:
+    hspec-discover:hspec-discover
+
 source-repository head
   type:     git
   location: https://github.com/haskell/haddock.git
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 6af0874a..dec85b79 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -426,15 +426,22 @@ getHaddockLibDir flags =
 #ifdef IN_GHC_TREE
       getInTreeDir
 #else
-      d <- getDataDir -- provided by Cabal
-      doesDirectoryExist d >>= \exists -> case exists of
-        True -> return d
-        False -> do
-          -- If directory does not exist then we are probably invoking from
-          -- ./dist/build/haddock/haddock so we use ./resources as a fallback.
-          doesDirectoryExist "resources" >>= \exists_ -> case exists_ of
-            True -> return "resources"
-            False -> die ("Haddock's resource directory (" ++ d ++ ") does not exist!\n")
+      -- if data directory does not exist we are probably
+      -- invoking from either ./haddock-api or ./
+      let res_dirs = [ getDataDir -- provided by Cabal
+                     , pure "resources"
+                     , pure "haddock-api/resources"
+                     ]
+
+          check get_path = do
+            p <- get_path
+            exists <- doesDirectoryExist p
+            pure $ if exists then Just p else Nothing
+
+      dirs <- mapM check res_dirs  
+      case [p | Just p <- dirs] of
+        (p : _) -> return p 
+        _       -> die "Haddock's resource directory does not exist!\n"
 #endif
     fs -> return (last fs)
 
diff --git a/haddock-library/haddock-library.cabal b/haddock-library/haddock-library.cabal
index 463569a3..b7a20758 100644
--- a/haddock-library/haddock-library.cabal
+++ b/haddock-library/haddock-library.cabal
@@ -14,7 +14,7 @@ homepage:             http://www.haskell.org/haddock/
 bug-reports:          https://github.com/haskell/haddock/issues
 category:             Documentation
 build-type:           Simple
-cabal-version:        >= 1.10
+cabal-version:        >= 2.0
 stability:            experimental
 
 library
@@ -78,6 +78,9 @@ test-suite spec
     , hspec
     , QuickCheck == 2.*
 
+  build-tool-depends:
+    hspec-discover:hspec-discover
+    
 source-repository head
   type:     git
   subdir:   haddock-library
diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs
index e1e920f2..50616c7f 100644
--- a/haddock-test/src/Test/Haddock/Config.hs
+++ b/haddock-test/src/Test/Haddock/Config.hs
@@ -165,11 +165,18 @@ loadConfig ccfg dcfg flags files = do
     cfgEnv <- (:) ("haddock_datadir", dcfgResDir dcfg) <$> getEnvironment
 
     systemHaddockPath <- List.lookup "HADDOCK_PATH" <$> getEnvironment
-    cfgHaddockPath <- case flagsHaddockPath flags <|> systemHaddockPath of
+    haddockOnPath <- findExecutable "haddock"
+
+    let haddock_path = msum [ flagsHaddockPath flags
+                            , systemHaddockPath
+                            , haddockOnPath
+                            ]
+
+    cfgHaddockPath <- case haddock_path of
         Just path -> pure path
-        Nothing -> do
-            hPutStrLn stderr $ "Haddock executable not specified"
-            exitFailure
+        Nothing   -> do
+          hPutStrLn stderr "Haddock executable not found"
+          exitFailure
 
     ghcPath <- init <$> rawSystemStdout normal cfgHaddockPath
         ["--print-ghc-path"]
@@ -195,7 +202,7 @@ loadConfig ccfg dcfg flags files = do
     let cfgAccept = FlagAccept `elem` flags
 
     let cfgCheckConfig = ccfg
-    let cfgDirConfig = dcfg
+    let cfgDirConfig   = dcfg
 
     return $ Config { .. }
 
diff --git a/haddock.cabal b/haddock.cabal
index a79f8c78..fa8a3531 100644
--- a/haddock.cabal
+++ b/haddock.cabal
@@ -12,9 +12,10 @@ bug-reports:          https://github.com/haskell/haddock/issues
 copyright:            (c) Simon Marlow, David Waern
 category:             Documentation
 build-type:           Simple
-cabal-version:        >= 1.10
+cabal-version:        >= 2.0
 stability:            experimental
-
+tested-with:          GHC==8.2.*, GHC==8.3
+                      
 extra-source-files:
   CHANGES
   README.md
@@ -130,32 +131,40 @@ test-suite driver-test
 
 test-suite html-test
   type:             exitcode-stdio-1.0
-  default-language: Haskell2010
-  main-is:          Main.hs
-  hs-source-dirs:   html-test
-  build-depends:    base, filepath, haddock-test == 0.0.1
+  -- This tells cabal that this test depends on the executable
+  -- component 'haddock' from this very same package, as well
+  -- as adding the build-folder where the `haddock`
+  -- executable can be found in front of $PATH
+  build-tool-depends: haddock:haddock
+  default-language:   Haskell2010
+  main-is:            Main.hs
+  hs-source-dirs:     html-test
+  build-depends:      base, filepath, haddock-test == 0.0.1
 
 test-suite hypsrc-test
-  type:             exitcode-stdio-1.0
-  default-language: Haskell2010
-  main-is:          Main.hs
-  hs-source-dirs:   hypsrc-test
-  build-depends:    base, filepath, haddock-test == 0.0.1
-  ghc-options:      -Wall -fwarn-tabs
+  type:               exitcode-stdio-1.0
+  build-tool-depends: haddock:haddock
+  default-language:   Haskell2010
+  main-is:            Main.hs
+  hs-source-dirs:     hypsrc-test
+  build-depends:      base, filepath, haddock-test == 0.0.1
+  ghc-options:        -Wall -fwarn-tabs
 
 test-suite latex-test
-  type:             exitcode-stdio-1.0
-  default-language: Haskell2010
-  main-is:          Main.hs
-  hs-source-dirs:   latex-test
-  build-depends:    base, filepath, haddock-test == 0.0.1
+  type:               exitcode-stdio-1.0
+  build-tool-depends: haddock:haddock
+  default-language:   Haskell2010
+  main-is:            Main.hs
+  hs-source-dirs:     latex-test
+  build-depends:      base, filepath, haddock-test == 0.0.1
 
 test-suite hoogle-test
-  type:             exitcode-stdio-1.0
-  default-language: Haskell2010
-  main-is:          Main.hs
-  hs-source-dirs:   hoogle-test
-  build-depends:    base, filepath, haddock-test == 0.0.1
+  type:               exitcode-stdio-1.0
+  build-tool-depends: haddock:haddock
+  default-language:   Haskell2010
+  main-is:            Main.hs
+  hs-source-dirs:     hoogle-test
+  build-depends:      base, filepath, haddock-test == 0.0.1
 
 source-repository head
   type:     git
-- 
cgit v1.2.3


From c0b1d8b7dc6331efb62e05ad317af781069c13be Mon Sep 17 00:00:00 2001
From: Alexander Biehl <abiehl@novomind.com>
Date: Tue, 25 Apr 2017 11:33:10 +0200
Subject: Expand signatures for class declarations

---
 haddock-api/src/Haddock/Interface/Create.hs | 24 +++++++++++++++++-------
 1 file changed, 17 insertions(+), 7 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 6ff1223c..26ac0281 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -819,20 +819,30 @@ fullModuleContents :: DynFlags
                    -> [LHsDecl Name]    -- ^ All the renamed declarations
                    -> ErrMsgGhc [ExportItem Name]
 fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap) fixMap splices decls =
-  liftM catMaybes $ mapM mkExportItem (expandSig decls)
+  liftM catMaybes $ mapM mkExportItem (expandSigDecls decls)
   where
     -- A type signature can have multiple names, like:
     --   foo, bar :: Types..
     --
     -- We go through the list of declarations and expand type signatures, so
     -- that every type signature has exactly one name!
-    expandSig :: [LHsDecl name] -> [LHsDecl name]
-    expandSig = foldr f []
+    expandSigDecls :: [LHsDecl name] -> [LHsDecl name]
+    expandSigDecls = concatMap f
       where
-        f :: LHsDecl name -> [LHsDecl name] -> [LHsDecl name]
-        f (L l (SigD (TypeSig    names t)))   xs = foldr (\n acc -> L l (SigD (TypeSig      [n] t)) : acc) xs names
-        f (L l (SigD (ClassOpSig b names t))) xs = foldr (\n acc -> L l (SigD (ClassOpSig b [n] t)) : acc) xs names
-        f x xs = x : xs
+        f (L l (SigD sig))              = [ L l (SigD s) | s <- expandSig sig ]
+
+        -- also expand type signatures for class methods
+        f (L l (TyClD cls@ClassDecl{})) =
+          [ L l (TyClD cls { tcdSigs = concatMap expandLSig (tcdSigs cls) }) ]
+        f x = [x]
+
+    expandLSig :: LSig name -> [LSig name]
+    expandLSig (L l sig) = [ L l s | s <- expandSig sig ]
+
+    expandSig :: Sig name -> [Sig name]
+    expandSig (TypeSig names t)      = [ TypeSig [n] t      | n <- names ]
+    expandSig (ClassOpSig b names t) = [ ClassOpSig b [n] t | n <- names ]
+    expandSig x                      = [x]
 
     mkExportItem :: LHsDecl Name -> ErrMsgGhc (Maybe (ExportItem Name))
     mkExportItem (L _ (DocD (DocGroup lev docStr))) = do
-- 
cgit v1.2.3


From 968045e574783fe8bdde7afbb825d4dcd82ae0e7 Mon Sep 17 00:00:00 2001
From: Alexander Biehl <abiehl@novomind.com>
Date: Tue, 25 Apr 2017 13:39:49 +0200
Subject: Hoogle: Correctly print classes with associated data types

---
 haddock-api/src/Haddock/Backends/Hoogle.hs | 5 ++++-
 1 file changed, 4 insertions(+), 1 deletion(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 86a73c33..183b669e 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -22,6 +22,7 @@ import Haddock.GhcUtils
 import Haddock.Types hiding (Version)
 import Haddock.Utils hiding (out)
 
+import HsBinds (emptyLHsBinds)
 import GHC
 import Outputable
 import NameSet
@@ -157,7 +158,9 @@ pp_sig dflags names (L _ typ)  =
 
 -- note: does not yet output documentation for class methods
 ppClass :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String]
-ppClass dflags decl subdocs = (out dflags decl{tcdSigs=[]} ++ ppTyFams) :  ppMethods
+ppClass dflags decl subdocs =
+  (out dflags decl{tcdSigs=[], tcdATs=[], tcdATDefs=[], tcdMeths=emptyLHsBinds}
+    ++ ppTyFams) :  ppMethods
     where
 
         ppMethods = concat . map (ppSig' . unLoc . add_ctxt) $ tcdSigs decl
-- 
cgit v1.2.3


From ce3647ea278606f43615817ecb2865d96ca8b39e Mon Sep 17 00:00:00 2001
From: "Edward Z. Yang" <ezyang@cs.stanford.edu>
Date: Sat, 22 Apr 2017 20:38:26 -0700
Subject: Render (signature) only if it actually is a signature!

I forgot a conditional, oops!

Signed-off-by: Edward Z. Yang <ezyang@cs.stanford.edu>
(cherry picked from commit a0c4790e15a2d3fab8d830eee8fcd639fe6d39c9)
---
 haddock-api/src/Haddock/Backends/Xhtml.hs | 7 +++++--
 1 file changed, 5 insertions(+), 2 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index c5caa6a2..31a748cb 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -485,10 +485,13 @@ ppHtmlModule odir doctitle themes
       mdl_str_annot = mdl_str ++ if ifaceIsSig iface
                                     then " (signature)"
                                     else ""
-      mdl_str_linked = mdl_str +++
-                       " (signature" +++
+      mdl_str_linked
+        | ifaceIsSig iface
+        = mdl_str +++ " (signature" +++
                        sup << ("[" +++ anchor ! [href signatureDocURL] << "?" +++ "]" ) +++
                        ")"
+        | otherwise
+        = toHtml mdl_str
       real_qual = makeModuleQual qual aliases mdl
       html =
         headHtml mdl_str_annot (Just $ "mini_" ++ moduleHtmlFile mdl) themes maybe_mathjax_url +++
-- 
cgit v1.2.3


From 4346ad26ac1346aa5e59991315f6969c844bea60 Mon Sep 17 00:00:00 2001
From: alexbiehl <alex.biehl@gmail.com>
Date: Wed, 26 Apr 2017 07:07:04 +0200
Subject: Remove anything related to obsolete frames mode

---
 .../resources/html/Ocean.std-theme/ocean.css       |   4 -
 haddock-api/resources/html/haddock-util.js         | 132 +--------------------
 haddock-api/src/Haddock/Backends/Xhtml.hs          |  70 ++---------
 html-test/ref/A.html                               |   4 +-
 html-test/ref/B.html                               |   4 +-
 html-test/ref/Bold.html                            |   4 +-
 html-test/ref/Bug1.html                            |   4 +-
 html-test/ref/Bug195.html                          |   4 +-
 html-test/ref/Bug2.html                            |   4 +-
 html-test/ref/Bug201.html                          |   4 +-
 html-test/ref/Bug253.html                          |   4 +-
 html-test/ref/Bug26.html                           |   4 +-
 html-test/ref/Bug280.html                          |  21 ++--
 html-test/ref/Bug294.html                          |   4 +-
 html-test/ref/Bug298.html                          |   4 +-
 html-test/ref/Bug3.html                            |   4 +-
 html-test/ref/Bug308.html                          |   4 +-
 html-test/ref/Bug308CrossModule.html               |   4 +-
 html-test/ref/Bug310.html                          |   4 +-
 html-test/ref/Bug313.html                          |   4 +-
 html-test/ref/Bug335.html                          |   4 +-
 html-test/ref/Bug387.html                          |   4 +-
 html-test/ref/Bug4.html                            |   4 +-
 html-test/ref/Bug6.html                            |   4 +-
 html-test/ref/Bug7.html                            |   4 +-
 html-test/ref/Bug8.html                            |   2 +-
 html-test/ref/Bug85.html                           |   4 +-
 html-test/ref/BugDeprecated.html                   |   4 +-
 html-test/ref/BugExportHeadings.html               |   4 +-
 html-test/ref/Bugs.html                            |   4 +-
 html-test/ref/DeprecatedClass.html                 |   4 +-
 html-test/ref/DeprecatedData.html                  |   4 +-
 html-test/ref/DeprecatedFunction.html              |   4 +-
 html-test/ref/DeprecatedFunction2.html             |   4 +-
 html-test/ref/DeprecatedFunction3.html             |   4 +-
 html-test/ref/DeprecatedModule.html                |   4 +-
 html-test/ref/DeprecatedModule2.html               |   4 +-
 html-test/ref/DeprecatedNewtype.html               |   4 +-
 html-test/ref/DeprecatedReExport.html              |   4 +-
 html-test/ref/DeprecatedRecord.html                |   4 +-
 html-test/ref/DeprecatedTypeFamily.html            |   4 +-
 html-test/ref/DeprecatedTypeSynonym.html           |   4 +-
 html-test/ref/Examples.html                        |   4 +-
 html-test/ref/Extensions.html                      |   4 +-
 html-test/ref/FunArgs.html                         |   4 +-
 html-test/ref/GADTRecords.html                     |   4 +-
 html-test/ref/Hash.html                            |   4 +-
 html-test/ref/HiddenInstances.html                 |   4 +-
 html-test/ref/HiddenInstancesB.html                |   4 +-
 html-test/ref/Hyperlinks.html                      |   4 +-
 html-test/ref/IgnoreExports.html                   |   4 +-
 html-test/ref/ImplicitParams.html                  |   4 +-
 html-test/ref/Instances.html                       |   2 +-
 html-test/ref/Math.html                            |   4 +-
 html-test/ref/Minimal.html                         |   2 +-
 html-test/ref/ModuleWithWarning.html               |   4 +-
 html-test/ref/NamedDoc.html                        |   4 +-
 html-test/ref/Nesting.html                         |   4 +-
 html-test/ref/NoLayout.html                        |   4 +-
 html-test/ref/NonGreedy.html                       |   4 +-
 html-test/ref/Operators.html                       |   2 +-
 html-test/ref/OrphanInstances.html                 |   4 +-
 html-test/ref/OrphanInstancesClass.html            |   4 +-
 html-test/ref/OrphanInstancesType.html             |   4 +-
 html-test/ref/PatternSyns.html                     |   2 +-
 html-test/ref/PromotedTypes.html                   |   4 +-
 html-test/ref/Properties.html                      |   4 +-
 html-test/ref/PruneWithWarning.html                |   4 +-
 html-test/ref/QuasiExpr.html                       |   4 +-
 html-test/ref/QuasiQuote.html                      |   4 +-
 html-test/ref/SpuriousSuperclassConstraints.html   |   2 +-
 html-test/ref/TH.html                              |   4 +-
 html-test/ref/TH2.html                             |   2 +-
 html-test/ref/Test.html                            |   4 +-
 html-test/ref/Threaded.html                        |   4 +-
 html-test/ref/Threaded_TH.html                     |   2 +-
 html-test/ref/Ticket112.html                       |   4 +-
 html-test/ref/Ticket61.html                        |   4 +-
 html-test/ref/Ticket75.html                        |   4 +-
 html-test/ref/TitledPicture.html                   |   4 +-
 html-test/ref/TypeFamilies.html                    |   4 +-
 html-test/ref/TypeFamilies2.html                   |   4 +-
 html-test/ref/TypeOperators.html                   |   4 +-
 html-test/ref/Unicode.html                         |   4 +-
 html-test/ref/Visible.html                         |   4 +-
 html-test/ref/haddock-util.js                      | 132 +--------------------
 86 files changed, 174 insertions(+), 493 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/resources/html/Ocean.std-theme/ocean.css b/haddock-api/resources/html/Ocean.std-theme/ocean.css
index 9d2c644f..3bfc8982 100644
--- a/haddock-api/resources/html/Ocean.std-theme/ocean.css
+++ b/haddock-api/resources/html/Ocean.std-theme/ocean.css
@@ -327,10 +327,6 @@ div#style-menu-holder {
 }
 
 #synopsis {
-  display: none;
-}
-
-.no-frame #synopsis {
   display: block;
   position: fixed;
   right: 0;
diff --git a/haddock-api/resources/html/haddock-util.js b/haddock-api/resources/html/haddock-util.js
index 92d07d2a..05bdaef5 100644
--- a/haddock-api/resources/html/haddock-util.js
+++ b/haddock-api/resources/html/haddock-util.js
@@ -1,7 +1,7 @@
 // Haddock JavaScript utilities
 
 var rspace = /\s\s+/g,
-	  rtrim = /^\s+|\s+$/g;
+    rtrim = /^\s+|\s+$/g;
 
 function spaced(s) { return (" " + s + " ").replace(rspace, " "); }
 function trim(s)   { return s.replace(rtrim, ""); }
@@ -109,136 +109,6 @@ function getCookie(name) {
   return null;
 }
 
-
-
-var max_results = 75; // 50 is not enough to search for map in the base libraries
-var shown_range = null;
-var last_search = null;
-
-function quick_search()
-{
-    perform_search(false);
-}
-
-function full_search()
-{
-    perform_search(true);
-}
-
-
-function perform_search(full)
-{
-    var text = document.getElementById("searchbox").value.toLowerCase();
-    if (text == last_search && !full) return;
-    last_search = text;
-
-    var table = document.getElementById("indexlist");
-    var status = document.getElementById("searchmsg");
-    var children = table.firstChild.childNodes;
-
-    // first figure out the first node with the prefix
-    var first = bisect(-1);
-    var last = (first == -1 ? -1 : bisect(1));
-
-    if (first == -1)
-    {
-        table.className = "";
-        status.innerHTML = "No results found, displaying all";
-    }
-    else if (first == 0 && last == children.length - 1)
-    {
-        table.className = "";
-        status.innerHTML = "";
-    }
-    else if (last - first >= max_results && !full)
-    {
-        table.className = "";
-        status.innerHTML = "More than " + max_results + ", press Search to display";
-    }
-    else
-    {
-        // decide what you need to clear/show
-        if (shown_range)
-            setclass(shown_range[0], shown_range[1], "indexrow");
-        setclass(first, last, "indexshow");
-        shown_range = [first, last];
-        table.className = "indexsearch";
-        status.innerHTML = "";
-    }
-
-
-    function setclass(first, last, status)
-    {
-        for (var i = first; i <= last; i++)
-        {
-            children[i].className = status;
-        }
-    }
-
-
-    // do a binary search, treating 0 as ...
-    // return either -1 (no 0's found) or location of most far match
-    function bisect(dir)
-    {
-        var first = 0, finish = children.length - 1;
-        var mid, success = false;
-
-        while (finish - first > 3)
-        {
-            mid = Math.floor((finish + first) / 2);
-
-            var i = checkitem(mid);
-            if (i == 0) i = dir;
-            if (i == -1)
-                finish = mid;
-            else
-                first = mid;
-        }
-        var a = (dir == 1 ? first : finish);
-        var b = (dir == 1 ? finish : first);
-        for (var i = b; i != a - dir; i -= dir)
-        {
-            if (checkitem(i) == 0) return i;
-        }
-        return -1;
-    }
-
-
-    // from an index, decide what the result is
-    // 0 = match, -1 is lower, 1 is higher
-    function checkitem(i)
-    {
-        var s = getitem(i).toLowerCase().substr(0, text.length);
-        if (s == text) return 0;
-        else return (s > text ? -1 : 1);
-    }
-
-
-    // from an index, get its string
-    // this abstracts over alternates
-    function getitem(i)
-    {
-        for ( ; i >= 0; i--)
-        {
-            var s = children[i].firstChild.firstChild.data;
-            if (s.indexOf(' ') == -1)
-                return s;
-        }
-        return ""; // should never be reached
-    }
-}
-
-function setSynopsis(filename) {
-    if (parent.window.synopsis && parent.window.synopsis.location) {
-        if (parent.window.synopsis.location.replace) {
-            // In Firefox this avoids adding the change to the history.
-            parent.window.synopsis.location.replace(filename);
-        } else {
-            parent.window.synopsis.location = filename;
-        }
-    }
-}
-
 function addMenuItem(html) {
   var menu = document.getElementById("page-menu");
   if (menu) {
diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index 31a748cb..34ecc5b8 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -108,8 +108,8 @@ copyHtmlBits odir libdir themes = do
   return ()
 
 
-headHtml :: String -> Maybe String -> Themes -> Maybe String -> Html
-headHtml docTitle miniPage themes mathjax_url =
+headHtml :: String -> Themes -> Maybe String -> Html
+headHtml docTitle themes mathjax_url =
   header << [
     meta ! [httpequiv "Content-Type", content "text/html; charset=UTF-8"],
     thetitle << docTitle,
@@ -118,14 +118,11 @@ headHtml docTitle miniPage themes mathjax_url =
     script ! [src mjUrl, thetype "text/javascript"] << noHtml,
     script ! [thetype "text/javascript"]
         -- NB: Within XHTML, the content of script tags needs to be
-        -- a <![CDATA[ section. Will break if the miniPage name could
-        -- have "]]>" in it!
-      << primHtml (
-          "//<![CDATA[\nwindow.onload = function () {pageLoad();"
-          ++ setSynopsis ++ "};\n//]]>\n")
+        -- a <![CDATA[ section.
+      << primHtml
+          "//<![CDATA[\nwindow.onload = function () {pageLoad();};\n//]]>\n"
     ]
   where
-    setSynopsis = maybe "" (\p -> "setSynopsis(\"" ++ p ++ "\");") miniPage
     mjUrl = maybe "https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.0/MathJax.js?config=TeX-AMS-MML_HTMLorMML" id mathjax_url
 
 
@@ -271,7 +268,7 @@ ppHtmlContents dflags odir doctitle _maybe_package
          | iface <- ifaces
          , instIsSig iface]
       html =
-        headHtml doctitle Nothing themes mathjax_url +++
+        headHtml doctitle themes mathjax_url +++
         bodyHtml doctitle Nothing
           maybe_source_url maybe_wiki_url
           Nothing maybe_index_url << [
@@ -372,7 +369,7 @@ ppHtmlIndex odir doctitle _maybe_package themes
 
   where
     indexPage showLetters ch items =
-      headHtml (doctitle ++ " (" ++ indexName ch ++ ")") Nothing themes maybe_mathjax_url +++
+      headHtml (doctitle ++ " (" ++ indexName ch ++ ")") themes maybe_mathjax_url +++
       bodyHtml doctitle Nothing
         maybe_source_url maybe_wiki_url
         maybe_contents_url Nothing << [
@@ -494,7 +491,7 @@ ppHtmlModule odir doctitle themes
         = toHtml mdl_str
       real_qual = makeModuleQual qual aliases mdl
       html =
-        headHtml mdl_str_annot (Just $ "mini_" ++ moduleHtmlFile mdl) themes maybe_mathjax_url +++
+        headHtml mdl_str_annot themes maybe_mathjax_url +++
         bodyHtml doctitle (Just iface)
           maybe_source_url maybe_wiki_url
           maybe_contents_url maybe_index_url << [
@@ -504,24 +501,10 @@ ppHtmlModule odir doctitle themes
 
   createDirectoryIfMissing True odir
   writeFile (joinPath [odir, moduleHtmlFile mdl]) (renderToString debug html)
-  ppHtmlModuleMiniSynopsis odir doctitle themes maybe_mathjax_url iface unicode real_qual debug
 
 signatureDocURL :: String
 signatureDocURL = "https://wiki.haskell.org/Module_signature"
 
-ppHtmlModuleMiniSynopsis :: FilePath -> String -> Themes
-  -> Maybe String -> Interface -> Bool -> Qualification -> Bool -> IO ()
-ppHtmlModuleMiniSynopsis odir _doctitle themes maybe_mathjax_url iface unicode qual debug = do
-  let mdl = ifaceMod iface
-      html =
-        headHtml (moduleString mdl) Nothing themes maybe_mathjax_url +++
-        miniBody <<
-          (divModuleHeader << sectionName << moduleString mdl +++
-           miniSynopsis mdl iface unicode qual)
-  createDirectoryIfMissing True odir
-  writeFile (joinPath [odir, "mini_" ++ moduleHtmlFile mdl]) (renderToString debug html)
-
-
 ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> Bool -> Qualification -> Html
 ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual
   = ppModuleContents qual exports (not . null $ ifaceRnOrphanInstances iface) +++
@@ -572,43 +555,6 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual
     linksInfo = (maybe_source_url, maybe_wiki_url)
 
 
-miniSynopsis :: Module -> Interface -> Bool -> Qualification -> Html
-miniSynopsis mdl iface unicode qual =
-    divInterface << concatMap (processForMiniSynopsis mdl unicode qual) exports
-  where
-    exports = numberSectionHeadings (ifaceRnExportItems iface)
-
-
-processForMiniSynopsis :: Module -> Bool -> Qualification -> ExportItem DocName
-                       -> [Html]
-processForMiniSynopsis mdl unicode qual ExportDecl { expItemDecl = L _loc decl0 } =
-  ((divTopDecl <<).(declElem <<)) <$> case decl0 of
-    TyClD d -> let b = ppTyClBinderWithVarsMini mdl d in case d of
-        (FamDecl decl)    -> [ppTyFamHeader True False decl unicode qual]
-        (DataDecl{})   -> [keyword "data" <+> b]
-        (SynDecl{})    -> [keyword "type" <+> b]
-        (ClassDecl {}) -> [keyword "class" <+> b]
-    SigD (TypeSig lnames _) ->
-      map (ppNameMini Prefix mdl . nameOccName . getName . unLoc) lnames
-    _ -> []
-processForMiniSynopsis _ _ qual (ExportGroup lvl _id txt) =
-  [groupTag lvl << docToHtml Nothing qual (mkMeta txt)]
-processForMiniSynopsis _ _ _ _ = []
-
-
-ppNameMini :: Notation -> Module -> OccName -> Html
-ppNameMini notation mdl nm =
-    anchor ! [ href (moduleNameUrl mdl nm)
-             , target mainFrameName ]
-      << ppBinder' notation nm
-
-
-ppTyClBinderWithVarsMini :: Module -> TyClDecl DocName -> Html
-ppTyClBinderWithVarsMini mdl decl =
-  let n = tcdName decl
-      ns = tyvarNames $ tcdTyVars decl -- it's safe to use tcdTyVars, see code above
-  in ppTypeApp n [] ns (\is_infix -> ppNameMini is_infix mdl . nameOccName . getName) ppTyName
-
 ppModuleContents :: Qualification
                  -> [ExportItem DocName]
                  -> Bool -- ^ Orphans sections
diff --git a/html-test/ref/A.html b/html-test/ref/A.html
index 64a2916b..edd95fe8 100644
--- a/html-test/ref/A.html
+++ b/html-test/ref/A.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_A.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -183,4 +183,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_A.html&quot;);};
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/B.html b/html-test/ref/B.html
index b1e43a51..f4ce89d4 100644
--- a/html-test/ref/B.html
+++ b/html-test/ref/B.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_B.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -171,4 +171,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_B.html&quot;);};
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/Bold.html b/html-test/ref/Bold.html
index d8f8b3d4..a7cb4e7f 100644
--- a/html-test/ref/Bold.html
+++ b/html-test/ref/Bold.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_Bold.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -95,4 +95,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_Bold.html&quot;);
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/Bug1.html b/html-test/ref/Bug1.html
index 5ea4ff26..37a37527 100644
--- a/html-test/ref/Bug1.html
+++ b/html-test/ref/Bug1.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_Bug1.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -98,4 +98,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_Bug1.html&quot;);
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/Bug195.html b/html-test/ref/Bug195.html
index b7f10741..ca5c2cc0 100644
--- a/html-test/ref/Bug195.html
+++ b/html-test/ref/Bug195.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_Bug195.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -181,4 +181,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_Bug195.html&quot;
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/Bug2.html b/html-test/ref/Bug2.html
index 98d7f06d..5b88feae 100644
--- a/html-test/ref/Bug2.html
+++ b/html-test/ref/Bug2.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_Bug2.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -61,4 +61,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_Bug2.html&quot;);
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/Bug201.html b/html-test/ref/Bug201.html
index 19cb1aae..04cb0991 100644
--- a/html-test/ref/Bug201.html
+++ b/html-test/ref/Bug201.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_Bug201.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -100,4 +100,4 @@ because there's a space before closing @
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/Bug253.html b/html-test/ref/Bug253.html
index 2210b023..28482b24 100644
--- a/html-test/ref/Bug253.html
+++ b/html-test/ref/Bug253.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_Bug253.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -95,4 +95,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_Bug253.html&quot;
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/Bug26.html b/html-test/ref/Bug26.html
index 9382a738..8b0644aa 100644
--- a/html-test/ref/Bug26.html
+++ b/html-test/ref/Bug26.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_Bug26.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -203,4 +203,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_Bug26.html&quot;)
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/Bug280.html b/html-test/ref/Bug280.html
index fa8ca0de..6c533a28 100644
--- a/html-test/ref/Bug280.html
+++ b/html-test/ref/Bug280.html
@@ -1,4 +1,3 @@
-<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
 <html xmlns="http://www.w3.org/1999/xhtml"
 ><head
   ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"
@@ -10,9 +9,9 @@
     ><script src="https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.0/MathJax.js?config=TeX-AMS-MML_HTMLorMML" type="text/javascript"
     ></script
     ><script type="text/javascript"
-    >//<![CDATA[
-window.onload = function () {pageLoad();setSynopsis("mini_Bug280.html");};
-//]]>
+    >//
+window.onload = function () {pageLoad();};
+//
 </script
     ></head
   ><body
@@ -28,7 +27,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Bug280.html");};
 	  ></li
 	></ul
       ><p class="caption empty"
-      >&nbsp;</p
+      ></p
       ></div
     ><div id="content"
     ><div id="module-header"
@@ -38,8 +37,8 @@ window.onload = function () {pageLoad();setSynopsis("mini_Bug280.html");};
 	    >Copyright</th
 	    ><td
 	    >Foo<br
-         />Bar<br
-         />Baz</td
+	       />Bar<br
+	       />Baz</td
 	    ></tr
 	  ><tr
 	  ><th
@@ -55,9 +54,9 @@ window.onload = function () {pageLoad();setSynopsis("mini_Bug280.html");};
       ><p class="caption"
 	>Description</p
 	><div class="doc"
-		><p
-		>The module description</p
-		></div
+	><p
+	  >The module description</p
+	  ></div
 	></div
       ><div id="interface"
       ><h1
@@ -78,4 +77,4 @@ window.onload = function () {pageLoad();setSynopsis("mini_Bug280.html");};
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/Bug294.html b/html-test/ref/Bug294.html
index 44aad9d1..3a82af80 100644
--- a/html-test/ref/Bug294.html
+++ b/html-test/ref/Bug294.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_Bug294.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -229,4 +229,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_Bug294.html&quot;
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/Bug298.html b/html-test/ref/Bug298.html
index a748e92a..cba626b6 100644
--- a/html-test/ref/Bug298.html
+++ b/html-test/ref/Bug298.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_Bug298.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -137,4 +137,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_Bug298.html&quot;
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/Bug3.html b/html-test/ref/Bug3.html
index d5f589ed..4a9cf8bc 100644
--- a/html-test/ref/Bug3.html
+++ b/html-test/ref/Bug3.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_Bug3.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -78,4 +78,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_Bug3.html&quot;);
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/Bug308.html b/html-test/ref/Bug308.html
index 03f287d5..d816fef5 100644
--- a/html-test/ref/Bug308.html
+++ b/html-test/ref/Bug308.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_Bug308.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -109,4 +109,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_Bug308.html&quot;
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/Bug308CrossModule.html b/html-test/ref/Bug308CrossModule.html
index d9ed0b19..60f371af 100644
--- a/html-test/ref/Bug308CrossModule.html
+++ b/html-test/ref/Bug308CrossModule.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_Bug308CrossModule.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -87,4 +87,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_Bug308CrossModule
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/Bug310.html b/html-test/ref/Bug310.html
index 2ba8dfb9..468e64eb 100644
--- a/html-test/ref/Bug310.html
+++ b/html-test/ref/Bug310.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_Bug310.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -97,4 +97,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_Bug310.html&quot;
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/Bug313.html b/html-test/ref/Bug313.html
index a6573eaa..4fc1682c 100644
--- a/html-test/ref/Bug313.html
+++ b/html-test/ref/Bug313.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_Bug313.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -130,4 +130,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_Bug313.html&quot;
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/Bug335.html b/html-test/ref/Bug335.html
index f9eec481..d1602c7b 100644
--- a/html-test/ref/Bug335.html
+++ b/html-test/ref/Bug335.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_Bug335.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -123,4 +123,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_Bug335.html&quot;
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/Bug387.html b/html-test/ref/Bug387.html
index 6305a38d..27d47e75 100644
--- a/html-test/ref/Bug387.html
+++ b/html-test/ref/Bug387.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_Bug387.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -109,4 +109,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_Bug387.html&quot;
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/Bug4.html b/html-test/ref/Bug4.html
index 722d4102..fe6f47d1 100644
--- a/html-test/ref/Bug4.html
+++ b/html-test/ref/Bug4.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_Bug4.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -77,4 +77,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_Bug4.html&quot;);
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/Bug6.html b/html-test/ref/Bug6.html
index 34fc4054..678f4070 100644
--- a/html-test/ref/Bug6.html
+++ b/html-test/ref/Bug6.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_Bug6.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -335,4 +335,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_Bug6.html&quot;);
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/Bug7.html b/html-test/ref/Bug7.html
index cf6f2f2a..ef26d62f 100644
--- a/html-test/ref/Bug7.html
+++ b/html-test/ref/Bug7.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_Bug7.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -190,4 +190,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_Bug7.html&quot;);
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/Bug8.html b/html-test/ref/Bug8.html
index d6cef1b2..1b6c1525 100644
--- a/html-test/ref/Bug8.html
+++ b/html-test/ref/Bug8.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_Bug8.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
diff --git a/html-test/ref/Bug85.html b/html-test/ref/Bug85.html
index 8bb9b850..467dda0e 100644
--- a/html-test/ref/Bug85.html
+++ b/html-test/ref/Bug85.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_Bug85.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -145,4 +145,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_Bug85.html&quot;)
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/BugDeprecated.html b/html-test/ref/BugDeprecated.html
index 2fb509d8..96fdab34 100644
--- a/html-test/ref/BugDeprecated.html
+++ b/html-test/ref/BugDeprecated.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_BugDeprecated.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -191,4 +191,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_BugDeprecated.htm
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/BugExportHeadings.html b/html-test/ref/BugExportHeadings.html
index 8d444e26..2a05bed9 100644
--- a/html-test/ref/BugExportHeadings.html
+++ b/html-test/ref/BugExportHeadings.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_BugExportHeadings.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -211,4 +211,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_BugExportHeadings
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/Bugs.html b/html-test/ref/Bugs.html
index b83036c8..c29004f3 100644
--- a/html-test/ref/Bugs.html
+++ b/html-test/ref/Bugs.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_Bugs.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -77,4 +77,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_Bugs.html&quot;);
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/DeprecatedClass.html b/html-test/ref/DeprecatedClass.html
index ac14b0d4..f055f36f 100644
--- a/html-test/ref/DeprecatedClass.html
+++ b/html-test/ref/DeprecatedClass.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_DeprecatedClass.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -165,4 +165,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_DeprecatedClass.h
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/DeprecatedData.html b/html-test/ref/DeprecatedData.html
index 248de4cb..aeb2a7c8 100644
--- a/html-test/ref/DeprecatedData.html
+++ b/html-test/ref/DeprecatedData.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_DeprecatedData.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -187,4 +187,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_DeprecatedData.ht
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/DeprecatedFunction.html b/html-test/ref/DeprecatedFunction.html
index 59206ac9..f4381d96 100644
--- a/html-test/ref/DeprecatedFunction.html
+++ b/html-test/ref/DeprecatedFunction.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_DeprecatedFunction.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -105,4 +105,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_DeprecatedFunctio
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/DeprecatedFunction2.html b/html-test/ref/DeprecatedFunction2.html
index 36159359..b8985bcd 100644
--- a/html-test/ref/DeprecatedFunction2.html
+++ b/html-test/ref/DeprecatedFunction2.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_DeprecatedFunction2.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -79,4 +79,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_DeprecatedFunctio
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/DeprecatedFunction3.html b/html-test/ref/DeprecatedFunction3.html
index 1bfc7d90..b62e1ee3 100644
--- a/html-test/ref/DeprecatedFunction3.html
+++ b/html-test/ref/DeprecatedFunction3.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_DeprecatedFunction3.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -79,4 +79,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_DeprecatedFunctio
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/DeprecatedModule.html b/html-test/ref/DeprecatedModule.html
index a6b2e0e8..84c7a885 100644
--- a/html-test/ref/DeprecatedModule.html
+++ b/html-test/ref/DeprecatedModule.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_DeprecatedModule.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -77,4 +77,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_DeprecatedModule.
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/DeprecatedModule2.html b/html-test/ref/DeprecatedModule2.html
index bd7a7f31..862f79ee 100644
--- a/html-test/ref/DeprecatedModule2.html
+++ b/html-test/ref/DeprecatedModule2.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_DeprecatedModule2.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -71,4 +71,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_DeprecatedModule2
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/DeprecatedNewtype.html b/html-test/ref/DeprecatedNewtype.html
index 3d826f57..a03d63fb 100644
--- a/html-test/ref/DeprecatedNewtype.html
+++ b/html-test/ref/DeprecatedNewtype.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_DeprecatedNewtype.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -153,4 +153,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_DeprecatedNewtype
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/DeprecatedReExport.html b/html-test/ref/DeprecatedReExport.html
index e5a3c38c..52f2b8e9 100644
--- a/html-test/ref/DeprecatedReExport.html
+++ b/html-test/ref/DeprecatedReExport.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_DeprecatedReExport.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -120,4 +120,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_DeprecatedReExpor
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/DeprecatedRecord.html b/html-test/ref/DeprecatedRecord.html
index ff217c4d..79b7b7f9 100644
--- a/html-test/ref/DeprecatedRecord.html
+++ b/html-test/ref/DeprecatedRecord.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_DeprecatedRecord.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -145,4 +145,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_DeprecatedRecord.
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/DeprecatedTypeFamily.html b/html-test/ref/DeprecatedTypeFamily.html
index 4a5028f3..1d94e99b 100644
--- a/html-test/ref/DeprecatedTypeFamily.html
+++ b/html-test/ref/DeprecatedTypeFamily.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_DeprecatedTypeFamily.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -119,4 +119,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_DeprecatedTypeFam
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/DeprecatedTypeSynonym.html b/html-test/ref/DeprecatedTypeSynonym.html
index 8f1896df..cb7a3afe 100644
--- a/html-test/ref/DeprecatedTypeSynonym.html
+++ b/html-test/ref/DeprecatedTypeSynonym.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_DeprecatedTypeSynonym.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -111,4 +111,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_DeprecatedTypeSyn
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/Examples.html b/html-test/ref/Examples.html
index 7f742f2f..f706eef1 100644
--- a/html-test/ref/Examples.html
+++ b/html-test/ref/Examples.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_Examples.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -170,4 +170,4 @@ bar
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/Extensions.html b/html-test/ref/Extensions.html
index 01dde2d3..e21785c0 100644
--- a/html-test/ref/Extensions.html
+++ b/html-test/ref/Extensions.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_Extensions.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -85,4 +85,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_Extensions.html&q
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/FunArgs.html b/html-test/ref/FunArgs.html
index 4c285c41..df597e12 100644
--- a/html-test/ref/FunArgs.html
+++ b/html-test/ref/FunArgs.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_FunArgs.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -281,4 +281,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_FunArgs.html&quot
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/GADTRecords.html b/html-test/ref/GADTRecords.html
index 6c091ac3..3b036aae 100644
--- a/html-test/ref/GADTRecords.html
+++ b/html-test/ref/GADTRecords.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_GADTRecords.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -211,4 +211,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_GADTRecords.html&
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/Hash.html b/html-test/ref/Hash.html
index ac422955..4ad1c27e 100644
--- a/html-test/ref/Hash.html
+++ b/html-test/ref/Hash.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_Hash.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -408,4 +408,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_Hash.html&quot;);
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/HiddenInstances.html b/html-test/ref/HiddenInstances.html
index 5071e702..8c7312d7 100644
--- a/html-test/ref/HiddenInstances.html
+++ b/html-test/ref/HiddenInstances.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_HiddenInstances.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -289,4 +289,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_HiddenInstances.h
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/HiddenInstancesB.html b/html-test/ref/HiddenInstancesB.html
index b3cf9ef9..77af69d0 100644
--- a/html-test/ref/HiddenInstancesB.html
+++ b/html-test/ref/HiddenInstancesB.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_HiddenInstancesB.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -161,4 +161,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_HiddenInstancesB.
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/Hyperlinks.html b/html-test/ref/Hyperlinks.html
index 66b14d7a..db1953e3 100644
--- a/html-test/ref/Hyperlinks.html
+++ b/html-test/ref/Hyperlinks.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_Hyperlinks.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -83,4 +83,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_Hyperlinks.html&q
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/IgnoreExports.html b/html-test/ref/IgnoreExports.html
index 235d601c..262bb769 100644
--- a/html-test/ref/IgnoreExports.html
+++ b/html-test/ref/IgnoreExports.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_IgnoreExports.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -97,4 +97,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_IgnoreExports.htm
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/ImplicitParams.html b/html-test/ref/ImplicitParams.html
index c08a565a..d22e7f4c 100644
--- a/html-test/ref/ImplicitParams.html
+++ b/html-test/ref/ImplicitParams.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_ImplicitParams.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -113,4 +113,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_ImplicitParams.ht
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/Instances.html b/html-test/ref/Instances.html
index ba6ef185..b014e8df 100644
--- a/html-test/ref/Instances.html
+++ b/html-test/ref/Instances.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_Instances.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
diff --git a/html-test/ref/Math.html b/html-test/ref/Math.html
index 7e85367d..46f283e3 100644
--- a/html-test/ref/Math.html
+++ b/html-test/ref/Math.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_Math.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -97,4 +97,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_Math.html&quot;);
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/Minimal.html b/html-test/ref/Minimal.html
index ac28b0d9..b7507bd7 100644
--- a/html-test/ref/Minimal.html
+++ b/html-test/ref/Minimal.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_Minimal.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
diff --git a/html-test/ref/ModuleWithWarning.html b/html-test/ref/ModuleWithWarning.html
index a1761bce..ca7b2b3f 100644
--- a/html-test/ref/ModuleWithWarning.html
+++ b/html-test/ref/ModuleWithWarning.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_ModuleWithWarning.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -77,4 +77,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_ModuleWithWarning
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/NamedDoc.html b/html-test/ref/NamedDoc.html
index 631f2043..a10aa305 100644
--- a/html-test/ref/NamedDoc.html
+++ b/html-test/ref/NamedDoc.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_NamedDoc.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -61,4 +61,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_NamedDoc.html&quo
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/Nesting.html b/html-test/ref/Nesting.html
index 370c6a88..7ce0c0d8 100644
--- a/html-test/ref/Nesting.html
+++ b/html-test/ref/Nesting.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_Nesting.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -355,4 +355,4 @@ with more of the indented list content.</p
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/NoLayout.html b/html-test/ref/NoLayout.html
index d8148b0e..43352864 100644
--- a/html-test/ref/NoLayout.html
+++ b/html-test/ref/NoLayout.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_NoLayout.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -81,4 +81,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_NoLayout.html&quo
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/NonGreedy.html b/html-test/ref/NonGreedy.html
index c389fc6a..6ed1563f 100644
--- a/html-test/ref/NonGreedy.html
+++ b/html-test/ref/NonGreedy.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_NonGreedy.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -77,4 +77,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_NonGreedy.html&qu
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/Operators.html b/html-test/ref/Operators.html
index 27b3427d..d498a906 100644
--- a/html-test/ref/Operators.html
+++ b/html-test/ref/Operators.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_Operators.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
diff --git a/html-test/ref/OrphanInstances.html b/html-test/ref/OrphanInstances.html
index 0ef094d5..257e2e41 100644
--- a/html-test/ref/OrphanInstances.html
+++ b/html-test/ref/OrphanInstances.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_OrphanInstances.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -111,4 +111,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_OrphanInstances.h
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/OrphanInstancesClass.html b/html-test/ref/OrphanInstancesClass.html
index 98641d0b..93594d90 100644
--- a/html-test/ref/OrphanInstancesClass.html
+++ b/html-test/ref/OrphanInstancesClass.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_OrphanInstancesClass.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -83,4 +83,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_OrphanInstancesCl
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/OrphanInstancesType.html b/html-test/ref/OrphanInstancesType.html
index d616edf9..5d7a76c9 100644
--- a/html-test/ref/OrphanInstancesType.html
+++ b/html-test/ref/OrphanInstancesType.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_OrphanInstancesType.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -77,4 +77,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_OrphanInstancesTy
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/PatternSyns.html b/html-test/ref/PatternSyns.html
index 2052d87c..9f0caaa2 100644
--- a/html-test/ref/PatternSyns.html
+++ b/html-test/ref/PatternSyns.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_PatternSyns.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
diff --git a/html-test/ref/PromotedTypes.html b/html-test/ref/PromotedTypes.html
index 5bb95fdb..6d4c57be 100644
--- a/html-test/ref/PromotedTypes.html
+++ b/html-test/ref/PromotedTypes.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_PromotedTypes.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -217,4 +217,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_PromotedTypes.htm
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/Properties.html b/html-test/ref/Properties.html
index 27f3a93a..4ce37acd 100644
--- a/html-test/ref/Properties.html
+++ b/html-test/ref/Properties.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_Properties.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -87,4 +87,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_Properties.html&q
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/PruneWithWarning.html b/html-test/ref/PruneWithWarning.html
index 7523c657..e714ec21 100644
--- a/html-test/ref/PruneWithWarning.html
+++ b/html-test/ref/PruneWithWarning.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_PruneWithWarning.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -64,4 +64,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_PruneWithWarning.
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/QuasiExpr.html b/html-test/ref/QuasiExpr.html
index c51ac526..0b5b8054 100644
--- a/html-test/ref/QuasiExpr.html
+++ b/html-test/ref/QuasiExpr.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_QuasiExpr.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -321,4 +321,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_QuasiExpr.html&qu
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/QuasiQuote.html b/html-test/ref/QuasiQuote.html
index 251c48dc..4919e48d 100644
--- a/html-test/ref/QuasiQuote.html
+++ b/html-test/ref/QuasiQuote.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_QuasiQuote.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -61,4 +61,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_QuasiQuote.html&q
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/SpuriousSuperclassConstraints.html b/html-test/ref/SpuriousSuperclassConstraints.html
index 285ab05c..b7c707c5 100644
--- a/html-test/ref/SpuriousSuperclassConstraints.html
+++ b/html-test/ref/SpuriousSuperclassConstraints.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_SpuriousSuperclassConstraints.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
diff --git a/html-test/ref/TH.html b/html-test/ref/TH.html
index b0500019..c3b71206 100644
--- a/html-test/ref/TH.html
+++ b/html-test/ref/TH.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_TH.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -59,4 +59,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_TH.html&quot;);};
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/TH2.html b/html-test/ref/TH2.html
index 71bc1083..5562cb67 100644
--- a/html-test/ref/TH2.html
+++ b/html-test/ref/TH2.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_TH2.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
diff --git a/html-test/ref/Test.html b/html-test/ref/Test.html
index 49fb4704..e84ed0dd 100644
--- a/html-test/ref/Test.html
+++ b/html-test/ref/Test.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_Test.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -2285,4 +2285,4 @@ is at the beginning of the line).</pre
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/Threaded.html b/html-test/ref/Threaded.html
index bb31f300..ac6a66b9 100644
--- a/html-test/ref/Threaded.html
+++ b/html-test/ref/Threaded.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_Threaded.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -90,4 +90,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_Threaded.html&quo
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/Threaded_TH.html b/html-test/ref/Threaded_TH.html
index 2890ca6b..89f276c9 100644
--- a/html-test/ref/Threaded_TH.html
+++ b/html-test/ref/Threaded_TH.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_Threaded_TH.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
diff --git a/html-test/ref/Ticket112.html b/html-test/ref/Ticket112.html
index 7e1c02aa..74b65663 100644
--- a/html-test/ref/Ticket112.html
+++ b/html-test/ref/Ticket112.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_Ticket112.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -77,4 +77,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_Ticket112.html&qu
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/Ticket61.html b/html-test/ref/Ticket61.html
index cb9ba8bd..cfc2e7f7 100644
--- a/html-test/ref/Ticket61.html
+++ b/html-test/ref/Ticket61.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_Ticket61.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -85,4 +85,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_Ticket61.html&quo
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/Ticket75.html b/html-test/ref/Ticket75.html
index 07e75296..616f5d47 100644
--- a/html-test/ref/Ticket75.html
+++ b/html-test/ref/Ticket75.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_Ticket75.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -113,4 +113,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_Ticket75.html&quo
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/TitledPicture.html b/html-test/ref/TitledPicture.html
index 04d1476b..927631f8 100644
--- a/html-test/ref/TitledPicture.html
+++ b/html-test/ref/TitledPicture.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_TitledPicture.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -107,4 +107,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_TitledPicture.htm
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/TypeFamilies.html b/html-test/ref/TypeFamilies.html
index db6ee1c3..c6301a56 100644
--- a/html-test/ref/TypeFamilies.html
+++ b/html-test/ref/TypeFamilies.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_TypeFamilies.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -1825,4 +1825,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_TypeFamilies.html
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/TypeFamilies2.html b/html-test/ref/TypeFamilies2.html
index 156486d0..65ab0317 100644
--- a/html-test/ref/TypeFamilies2.html
+++ b/html-test/ref/TypeFamilies2.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_TypeFamilies2.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -343,4 +343,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_TypeFamilies2.htm
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/TypeOperators.html b/html-test/ref/TypeOperators.html
index 53428892..b461ac71 100644
--- a/html-test/ref/TypeOperators.html
+++ b/html-test/ref/TypeOperators.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_TypeOperators.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -187,4 +187,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_TypeOperators.htm
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/Unicode.html b/html-test/ref/Unicode.html
index 59f715e8..ae1d4293 100644
--- a/html-test/ref/Unicode.html
+++ b/html-test/ref/Unicode.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_Unicode.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -77,4 +77,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_Unicode.html&quot
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/Visible.html b/html-test/ref/Visible.html
index 47568b65..d9b8cd11 100644
--- a/html-test/ref/Visible.html
+++ b/html-test/ref/Visible.html
@@ -10,7 +10,7 @@
     ></script
     ><script type="text/javascript"
     >//
-window.onload = function () {pageLoad();setSynopsis(&quot;mini_Visible.html&quot;);};
+window.onload = function () {pageLoad();};
 //
 </script
     ></head
@@ -63,4 +63,4 @@ window.onload = function () {pageLoad();setSynopsis(&quot;mini_Visible.html&quot
     ></div
     ></body
   ></html
->
+>
\ No newline at end of file
diff --git a/html-test/ref/haddock-util.js b/html-test/ref/haddock-util.js
index 92d07d2a..05bdaef5 100644
--- a/html-test/ref/haddock-util.js
+++ b/html-test/ref/haddock-util.js
@@ -1,7 +1,7 @@
 // Haddock JavaScript utilities
 
 var rspace = /\s\s+/g,
-	  rtrim = /^\s+|\s+$/g;
+    rtrim = /^\s+|\s+$/g;
 
 function spaced(s) { return (" " + s + " ").replace(rspace, " "); }
 function trim(s)   { return s.replace(rtrim, ""); }
@@ -109,136 +109,6 @@ function getCookie(name) {
   return null;
 }
 
-
-
-var max_results = 75; // 50 is not enough to search for map in the base libraries
-var shown_range = null;
-var last_search = null;
-
-function quick_search()
-{
-    perform_search(false);
-}
-
-function full_search()
-{
-    perform_search(true);
-}
-
-
-function perform_search(full)
-{
-    var text = document.getElementById("searchbox").value.toLowerCase();
-    if (text == last_search && !full) return;
-    last_search = text;
-
-    var table = document.getElementById("indexlist");
-    var status = document.getElementById("searchmsg");
-    var children = table.firstChild.childNodes;
-
-    // first figure out the first node with the prefix
-    var first = bisect(-1);
-    var last = (first == -1 ? -1 : bisect(1));
-
-    if (first == -1)
-    {
-        table.className = "";
-        status.innerHTML = "No results found, displaying all";
-    }
-    else if (first == 0 && last == children.length - 1)
-    {
-        table.className = "";
-        status.innerHTML = "";
-    }
-    else if (last - first >= max_results && !full)
-    {
-        table.className = "";
-        status.innerHTML = "More than " + max_results + ", press Search to display";
-    }
-    else
-    {
-        // decide what you need to clear/show
-        if (shown_range)
-            setclass(shown_range[0], shown_range[1], "indexrow");
-        setclass(first, last, "indexshow");
-        shown_range = [first, last];
-        table.className = "indexsearch";
-        status.innerHTML = "";
-    }
-
-
-    function setclass(first, last, status)
-    {
-        for (var i = first; i <= last; i++)
-        {
-            children[i].className = status;
-        }
-    }
-
-
-    // do a binary search, treating 0 as ...
-    // return either -1 (no 0's found) or location of most far match
-    function bisect(dir)
-    {
-        var first = 0, finish = children.length - 1;
-        var mid, success = false;
-
-        while (finish - first > 3)
-        {
-            mid = Math.floor((finish + first) / 2);
-
-            var i = checkitem(mid);
-            if (i == 0) i = dir;
-            if (i == -1)
-                finish = mid;
-            else
-                first = mid;
-        }
-        var a = (dir == 1 ? first : finish);
-        var b = (dir == 1 ? finish : first);
-        for (var i = b; i != a - dir; i -= dir)
-        {
-            if (checkitem(i) == 0) return i;
-        }
-        return -1;
-    }
-
-
-    // from an index, decide what the result is
-    // 0 = match, -1 is lower, 1 is higher
-    function checkitem(i)
-    {
-        var s = getitem(i).toLowerCase().substr(0, text.length);
-        if (s == text) return 0;
-        else return (s > text ? -1 : 1);
-    }
-
-
-    // from an index, get its string
-    // this abstracts over alternates
-    function getitem(i)
-    {
-        for ( ; i >= 0; i--)
-        {
-            var s = children[i].firstChild.firstChild.data;
-            if (s.indexOf(' ') == -1)
-                return s;
-        }
-        return ""; // should never be reached
-    }
-}
-
-function setSynopsis(filename) {
-    if (parent.window.synopsis && parent.window.synopsis.location) {
-        if (parent.window.synopsis.location.replace) {
-            // In Firefox this avoids adding the change to the history.
-            parent.window.synopsis.location.replace(filename);
-        } else {
-            parent.window.synopsis.location = filename;
-        }
-    }
-}
-
 function addMenuItem(html) {
   var menu = document.getElementById("page-menu");
   if (menu) {
-- 
cgit v1.2.3


From 67d6345e7b941008080ea79ea462229f0f377d50 Mon Sep 17 00:00:00 2001
From: Alex Biehl <alexbiehl@gmail.com>
Date: Wed, 26 Apr 2017 07:49:10 +0200
Subject: Cherry-picked remaining commits from haddock-2.17.4-release (#603)

* Release haddock/haddock-api 2.17.4 and haddock-library 1.4.3

* Set version bounds for haddock-library

NB: This allows GHC 8.2.1's base

* Set version bounds for haddock & haddock-api

The version bounds support GHC 8.2

* Merge (temporary) v2.17.3 branch into v2.17

This allows us to delete the v2.17.3 branch

* Fixup changelog

* Pin down haddock-api to a single version

as otherwise `haddock`'s package version has no proper meaning

* fix source-repo spec for haddock-api
---
 CHANGES                               | 14 ++++++++++++
 haddock-api/haddock-api.cabal         | 42 ++++++++++++++++++-----------------
 haddock-api/src/Haddock/Types.hs      |  4 ++--
 haddock-library/haddock-library.cabal | 10 ++++-----
 haddock.cabal                         |  7 ++++--
 5 files changed, 48 insertions(+), 29 deletions(-)

(limited to 'haddock-api/src')

diff --git a/CHANGES b/CHANGES
index 4389c58a..7e3d052a 100644
--- a/CHANGES
+++ b/CHANGES
@@ -1,3 +1,17 @@
+Changes in version 2.17.4
+
+ * Fix 'internal error: links: UnhelpfulSpan' (#554, #565)
+
+ * Hyperlink backend knows about `DataKinds` (#510)
+
+ * Fix rendering of class methods for `Eq` and `Ord` (#549)
+
+ * Export `MDoc` and `toInstalledIface` from `Haddock.Types`
+
+Changes in version 2.17.3.1
+
+ * Disable `NFData` instances for GHC types when GHC >= 8.0.2 (#537)
+
 Changes in version 2.17.3
 
  * Remove framed view of the HTML documentation
diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal
index 921e16eb..20b656b9 100644
--- a/haddock-api/haddock-api.cabal
+++ b/haddock-api/haddock-api.cabal
@@ -1,5 +1,5 @@
 name:                 haddock-api
-version:              2.17.3
+version:              2.17.4
 synopsis:             A documentation-generation tool for Haskell libraries
 description:          Haddock is a documentation-generation tool for Haskell
                       libraries
@@ -33,28 +33,29 @@ data-files:
   latex/haddock.sty
 
 library
-  default-language:
-      Haskell2010
+  default-language: Haskell2010
 
-  build-depends:
-      base >= 4.3 && < 4.11
-    , bytestring
-    , filepath
-    , directory
-    , containers
-    , transformers
-    , deepseq
-    , array
-    , xhtml >= 3000.2 && < 3000.3
-    , Cabal >= 1.10
-    , ghc-boot
-    , ghc == 8.2.*
+  -- this package typically supports only single major versions
+  build-depends: base            == 4.10.*
+               , Cabal           == 2.0.*
+               , ghc             == 8.2.*
+               , ghc-paths       == 0.1.*
+               , haddock-library >= 1.4.2 && < 1.5
+               , xhtml           == 3000.2.*
 
-    , ghc-paths
-    , haddock-library == 1.4.*
+  -- Versions for the dependencies below are transitively pinned by
+  -- the non-reinstallable `ghc` package and hence need no version
+  -- bounds
+  build-depends: array
+               , bytestring
+               , containers
+               , deepseq
+               , directory
+               , filepath
+               , ghc-boot
+               , transformers
 
-  hs-source-dirs:
-      src
+  hs-source-dirs: src
 
   ghc-options: -funbox-strict-fields -Wall -fwarn-tabs -O2
 
@@ -125,4 +126,5 @@ test-suite spec
 
 source-repository head
   type:     git
+  subdir:   haddock-api
   location: https://github.com/haskell/haddock.git
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index a6dd6354..803995cc 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -460,8 +460,8 @@ instance (NFData a, NFData mod)
     DocExamples a             -> a `deepseq` ()
     DocHeader a               -> a `deepseq` ()
 
-#if __GLASGOW_HASKELL__ < 801
--- These were added to GHC itself in 8.2.1
+#if !MIN_VERSION_ghc(8,0,2)
+-- These were added to GHC itself in 8.0.2
 instance NFData Name where rnf x = seq x ()
 instance NFData OccName where rnf x = seq x ()
 instance NFData ModuleName where rnf x = seq x ()
diff --git a/haddock-library/haddock-library.cabal b/haddock-library/haddock-library.cabal
index b7a20758..be433e6a 100644
--- a/haddock-library/haddock-library.cabal
+++ b/haddock-library/haddock-library.cabal
@@ -1,5 +1,5 @@
 name:                 haddock-library
-version:              1.4.2
+version:              1.4.3
 synopsis:             Library exposing some functionality of Haddock.
 description:          Haddock is a documentation-generation tool for Haskell
                       libraries. These modules expose some functionality of it
@@ -21,10 +21,10 @@ library
   default-language:     Haskell2010
 
   build-depends:
-      base >= 4.5 && < 4.11
-    , bytestring
-    , transformers
-    , deepseq
+      base         >= 4.5     && < 4.11
+    , bytestring   >= 0.9.2.1 && < 0.11
+    , transformers >= 0.3.0   && < 0.6
+    , deepseq      >= 1.3     && < 1.5
 
   hs-source-dirs:       src, vendor/attoparsec-0.12.1.1
   ghc-options:          -funbox-strict-fields -Wall -fwarn-tabs -O2
diff --git a/haddock.cabal b/haddock.cabal
index fa8a3531..598f2b9a 100644
--- a/haddock.cabal
+++ b/haddock.cabal
@@ -1,5 +1,5 @@
 name:                 haddock
-version:              2.17.3
+version:              2.17.4
 synopsis:             A documentation-generation tool for Haskell libraries
 description:          Haddock is a documentation-generation tool for Haskell
                       libraries
@@ -43,6 +43,7 @@ executable haddock
   hs-source-dirs:       driver
   ghc-options:          -funbox-strict-fields -Wall -fwarn-tabs -O2 -threaded
 
+  -- haddock typically only supports a single GHC major version
   build-depends:
     base >= 4.3 && < 4.11
   if flag(in-ghc-tree)
@@ -120,7 +121,9 @@ executable haddock
       Haddock.Syb
       Haddock.Convert
   else
-    build-depends:  haddock-api == 2.17.*
+    -- in order for haddock's advertised version number to have proper meaning,
+    -- we pin down to a single haddock-api version.
+    build-depends:  haddock-api == 2.17.4
 
 test-suite driver-test
   type:             exitcode-stdio-1.0
-- 
cgit v1.2.3


From 393920f125d1870c4fec5a09a5ac2dddc8da746b Mon Sep 17 00:00:00 2001
From: Sergey Vinokurov <serg.foo@gmail.com>
Date: Sun, 30 Oct 2016 17:39:50 +0200
Subject: Improve error message

---
 haddock-api/src/Haddock.hs                       | 2 +-
 html-test/ref/SpuriousSuperclassConstraints.html | 4 ++--
 html-test/src/SpuriousSuperclassConstraints.hs   | 2 +-
 3 files changed, 4 insertions(+), 4 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index dec85b79..3971a5b7 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -489,7 +489,7 @@ shortcutFlags flags = do
 
   when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags)
         && Flag_Html `elem` flags) $
-    throwE "-h cannot be used with --gen-index or --gen-contents"
+    throwE "-h/--html cannot be used with --gen-index or --gen-contents"
 
   when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags)
         && Flag_Hoogle `elem` flags) $
diff --git a/html-test/ref/SpuriousSuperclassConstraints.html b/html-test/ref/SpuriousSuperclassConstraints.html
index b7c707c5..0f38d15c 100644
--- a/html-test/ref/SpuriousSuperclassConstraints.html
+++ b/html-test/ref/SpuriousSuperclassConstraints.html
@@ -56,7 +56,7 @@ window.onload = function () {pageLoad();};
 	    >http://www.haskell.org/pipermail/haskell-cafe/2012-September/103600.html</a
 	    ></p
 	  ><p
-	  >And here is the corresponding theard on glasgow-haskell-users:</p
+	  >And here is the corresponding thread on glasgow-haskell-users:</p
 	  ><p
 	  ><a href="#"
 	    >http://www.haskell.org/pipermail/glasgow-haskell-users/2012-September/022914.html</a
@@ -229,4 +229,4 @@ Fix spurious superclass constraints bug.</pre
     ></div
     ></body
   ></html
->
\ No newline at end of file
+>
diff --git a/html-test/src/SpuriousSuperclassConstraints.hs b/html-test/src/SpuriousSuperclassConstraints.hs
index d9e43e1c..3e230945 100644
--- a/html-test/src/SpuriousSuperclassConstraints.hs
+++ b/html-test/src/SpuriousSuperclassConstraints.hs
@@ -7,7 +7,7 @@
 --
 --   <http://www.haskell.org/pipermail/haskell-cafe/2012-September/103600.html>
 --
--- And here is the corresponding theard on glasgow-haskell-users:
+-- And here is the corresponding thread on glasgow-haskell-users:
 --
 --   <http://www.haskell.org/pipermail/glasgow-haskell-users/2012-September/022914.html>
 --
-- 
cgit v1.2.3


From 2163981e773b76212b2265a1eb03208ee2e7edf2 Mon Sep 17 00:00:00 2001
From: Alex Biehl <alexbiehl@gmail.com>
Date: Mon, 1 May 2017 17:40:36 +0200
Subject: Lazily decode docMap and argMap (#610)

These are only used in case of a doc reexport so most of the time
decoding these is wasted work.
---
 haddock-api/src/Haddock/InterfaceFile.hs | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs
index 78853a79..3365581f 100644
--- a/haddock-api/src/Haddock/InterfaceFile.hs
+++ b/haddock-api/src/Haddock/InterfaceFile.hs
@@ -83,7 +83,7 @@ binaryInterfaceMagic = 0xD0Cface
 --
 binaryInterfaceVersion :: Word16
 #if (__GLASGOW_HASKELL__ >= 802) && (__GLASGOW_HASKELL__ < 804)
-binaryInterfaceVersion = 29
+binaryInterfaceVersion = 30
 
 binaryInterfaceVersionCompatibility :: [Word16]
 binaryInterfaceVersionCompatibility = [binaryInterfaceVersion]
@@ -377,6 +377,7 @@ instance Binary InstalledInterface where
     put_ bh modu
     put_ bh is_sig
     put_ bh info
+    lazyPut bh (docMap, argMap)
     put_ bh docMap
     put_ bh argMap
     put_ bh exps
@@ -389,8 +390,7 @@ instance Binary InstalledInterface where
     modu    <- get bh
     is_sig  <- get bh
     info    <- get bh
-    docMap  <- get bh
-    argMap  <- get bh
+    ~(docMap, argMap) <- lazyGet bh
     exps    <- get bh
     visExps <- get bh
     opts    <- get bh
-- 
cgit v1.2.3


From e0e6615dd421f1b332ce2b11a98de768fa7c29a8 Mon Sep 17 00:00:00 2001
From: Alex Biehl <alexbiehl@gmail.com>
Date: Mon, 1 May 2017 21:59:23 +0200
Subject: Fix Binary instance for InstalledInterface (#611)

(#610) introduced lazy decoding for docs from InstalledInterface but
forgot to remove the original calls to get and put_
---
 haddock-api/src/Haddock/InterfaceFile.hs | 2 --
 1 file changed, 2 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs
index 3365581f..e5c2face 100644
--- a/haddock-api/src/Haddock/InterfaceFile.hs
+++ b/haddock-api/src/Haddock/InterfaceFile.hs
@@ -378,8 +378,6 @@ instance Binary InstalledInterface where
     put_ bh is_sig
     put_ bh info
     lazyPut bh (docMap, argMap)
-    put_ bh docMap
-    put_ bh argMap
     put_ bh exps
     put_ bh visExps
     put_ bh opts
-- 
cgit v1.2.3


From b35eed2a9f1c82131f51f55c771ac2372127520d Mon Sep 17 00:00:00 2001
From: Alex Biehl <alexbiehl@gmail.com>
Date: Fri, 12 May 2017 21:02:33 +0200
Subject: Haddock: Fix broken lazy IO in prologue reading (#615)

We previously used withFile in conjunction with hGetContents. The list returned
by the latter wasn't completely forced by the time we left the withFile block,
meaning that we would try to read from a closed handle.
---
 haddock-api/src/Haddock.hs | 5 +++--
 1 file changed, 3 insertions(+), 2 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 3971a5b7..f0e7e6c7 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -547,9 +547,10 @@ getPrologue :: DynFlags -> [Flag] -> IO (Maybe (MDoc RdrName))
 getPrologue dflags flags =
   case [filename | Flag_Prologue filename <- flags ] of
     [] -> return Nothing
-    [filename] -> withFile filename ReadMode $ \h -> do
+    [filename] -> do
+      h <- openFile filename ReadMode
       hSetEncoding h utf8
-      str <- hGetContents h
+      str <- hGetContents h -- semi-closes the handle
       return . Just $! parseParas dflags str
     _ -> throwE "multiple -p/--prologue options"
 
-- 
cgit v1.2.3


From 506f614402192bd7b6a9a608e925a01b373b2bdc Mon Sep 17 00:00:00 2001
From: Doug Wilson <dwilson@ricoh.co.nz>
Date: Sun, 28 May 2017 05:54:53 +1200
Subject: Improve Syb code (#621)

Specialize.hs and Ast.hs are modified to have their Syb code not recurse into
Name or Id in HsSyn types.

Specialize.hs is refactored to have fewer calls to Syb functions.

Syb.hs has some foldl calls replaced with foldl' calls.

There is still a lot of performance on the floor of Ast.hs. The RenamedSource
is traversed many times, and lookupBySpan is very inefficient. everywhereBut and
lookupBySpan dominate the runtime whenever --hyperlinked-source is passed.
---
 .../src/Haddock/Backends/Hyperlinker/Ast.hs        | 28 ++++++-----
 haddock-api/src/Haddock/Interface/Specialize.hs    | 58 +++++++++-------------
 haddock-api/src/Haddock/Syb.hs                     | 55 +++++++++++++++++---
 3 files changed, 88 insertions(+), 53 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index b97f0ead..78beacf2 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -2,12 +2,12 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TypeFamilies #-}
-
+{-# LANGUAGE TypeApplications #-}
 
 module Haddock.Backends.Hyperlinker.Ast (enrich) where
 
 
-import Haddock.Syb
+import qualified Haddock.Syb as Syb
 import Haddock.Backends.Hyperlinker.Types
 
 import qualified GHC
@@ -16,6 +16,9 @@ import Control.Applicative
 import Data.Data
 import Data.Maybe
 
+everythingInRenamedSource :: (Alternative f, Data x)
+  => (forall a. Data a => a -> f r) -> x -> f r
+everythingInRenamedSource f = Syb.everythingButType @GHC.Name (<|>) f
 
 -- | Add more detailed information to token stream using GHC API.
 enrich :: GHC.RenamedSource -> [Token] -> [RichToken]
@@ -53,7 +56,7 @@ enrichToken _ _ = Nothing
 -- | Obtain details map for variables ("normally" used identifiers).
 variables :: GHC.RenamedSource -> DetailsMap
 variables =
-    everything (<|>) (var `combine` rec)
+    everythingInRenamedSource (var `Syb.combine` rec)
   where
     var term = case cast term of
         (Just (GHC.L sspan (GHC.HsVar name))) ->
@@ -68,8 +71,7 @@ variables =
 
 -- | Obtain details map for types.
 types :: GHC.RenamedSource -> DetailsMap
-types =
-    everything (<|>) ty
+types = everythingInRenamedSource ty
   where
     ty term = case cast term of
         (Just (GHC.L sspan (GHC.HsTyVar _ name))) ->
@@ -81,9 +83,10 @@ types =
 -- That includes both identifiers bound by pattern matching or declared using
 -- ordinary assignment (in top-level declarations, let-expressions and where
 -- clauses).
+
 binds :: GHC.RenamedSource -> DetailsMap
-binds =
-    everything (<|>) (fun `combine` pat `combine` tvar)
+binds = everythingInRenamedSource
+      (fun `Syb.combine` pat `Syb.combine` tvar)
   where
     fun term = case cast term of
         (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.Name)) ->
@@ -93,7 +96,7 @@ binds =
         (Just (GHC.L sspan (GHC.VarPat name))) ->
             pure (sspan, RtkBind (GHC.unLoc name))
         (Just (GHC.L _ (GHC.ConPatIn (GHC.L sspan name) recs))) ->
-            [(sspan, RtkVar name)] ++ everything (<|>) rec recs
+            [(sspan, RtkVar name)] ++ everythingInRenamedSource rec recs
         (Just (GHC.L _ (GHC.AsPat (GHC.L sspan name) _))) ->
             pure (sspan, RtkBind name)
         _ -> empty
@@ -112,8 +115,8 @@ binds =
 decls :: GHC.RenamedSource -> DetailsMap
 decls (group, _, _, _) = concatMap ($ group)
     [ concat . map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds
-    , everything (<|>) fun . GHC.hs_valds
-    , everything (<|>) (con `combine` ins)
+    , everythingInRenamedSource fun . GHC.hs_valds
+    , everythingInRenamedSource (con `Syb.combine` ins)
     ]
   where
     typ (GHC.L _ t) = case t of
@@ -127,7 +130,8 @@ decls (group, _, _, _) = concatMap ($ group)
         _ -> empty
     con term = case cast term of
         (Just cdcl) ->
-            map decl (GHC.getConNames cdcl) ++ everything (<|>) fld cdcl
+            map decl (GHC.getConNames cdcl)
+              ++ everythingInRenamedSource fld cdcl
         Nothing -> empty
     ins term = case cast term of
         (Just (GHC.DataFamInstD inst)) -> pure . tyref $ GHC.dfid_tycon inst
@@ -149,7 +153,7 @@ decls (group, _, _, _) = concatMap ($ group)
 -- import lists.
 imports :: GHC.RenamedSource -> DetailsMap
 imports src@(_, imps, _, _) =
-    everything (<|>) ie src ++ mapMaybe (imp . GHC.unLoc) imps
+    everythingInRenamedSource ie src ++ mapMaybe (imp . GHC.unLoc) imps
   where
     ie term = case cast term of
         (Just (GHC.IEVar v)) -> pure $ var $ GHC.ieLWrappedName v
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index 28bbf305..8c28cd5a 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -1,9 +1,9 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE Rank2Types #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE RecordWildCards #-}
 
-
 module Haddock.Interface.Specialize
     ( specializeInstHead
     ) where
@@ -27,73 +27,66 @@ 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 _ (L _ name')) | name == name' = details
-    step typ = typ
-
+import Data.Foldable
 
 -- | 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)
+specialize :: forall name a. (Ord name, DataId name, NamedThing name)
             => Data a
             => [(name, HsType name)] -> a -> a
-specialize' = flip $ foldr (uncurry specialize)
+specialize specs = go
+  where
+    go :: forall x. Data x => x -> x
+    go = everywhereButType @name $ mkT $ sugar . specialize_ty_var
+    specialize_ty_var (HsTyVar _ (L _ name'))
+      | Just t <- Map.lookup name' spec_map = t
+    specialize_ty_var typ = typ
+    -- This is a tricky recursive definition that is guaranteed to terminate
+    -- because a type binder cannot be instantiated with a type that depends
+    -- on that binder. i.e. @a -> Maybe a@ is invalid
+    spec_map = Map.fromList [ (n, go t) | (n, t) <- specs]
 
 
 -- | 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, DataId name)
+specializeTyVarBndrs :: (Ord name, DataId name, NamedThing name)
                      => Data a
                      => LHsQTyVars name -> [HsType name]
                      -> a -> a
 specializeTyVarBndrs bndrs typs =
-    specialize' $ zip bndrs' typs
+    specialize $ zip bndrs' typs
   where
     bndrs' = map (bname . unLoc) . hsq_explicit $ bndrs
     bname (UserTyVar (L _ name)) = name
     bname (KindedTyVar (L _ name) _) = name
 
 
-specializePseudoFamilyDecl :: (Eq name, DataId name)
+specializePseudoFamilyDecl :: (Ord name, DataId name, NamedThing name)
                            => LHsQTyVars name -> [HsType name]
                            -> PseudoFamilyDecl name
                            -> PseudoFamilyDecl name
 specializePseudoFamilyDecl bndrs typs decl =
-    decl { pfdTyVars = map specializeTyVars (pfdTyVars decl) }
-  where
-    specializeTyVars = specializeTyVarBndrs bndrs typs
-
+  decl {pfdTyVars = map (specializeTyVarBndrs bndrs typs) (pfdTyVars decl)}
 
-specializeSig :: forall name . (Eq name, DataId name, SetName name)
+specializeSig :: forall name . (Ord name, DataId name, SetName name, NamedThing name)
               => LHsQTyVars name -> [HsType name]
               -> Sig name
               -> Sig name
 specializeSig bndrs typs (TypeSig lnames typ) =
-    TypeSig lnames (typ { hswc_body = (hswc_body typ) { hsib_body = noLoc typ'}})
+  TypeSig lnames (typ {hswc_body = (hswc_body typ) {hsib_body = noLoc typ'}})
   where
     true_type :: HsType name
     true_type = unLoc (hsSigWcType typ)
     typ' :: HsType name
-    typ' = rename fv . sugar $ specializeTyVarBndrs bndrs typs true_type
+    typ' = rename fv $ specializeTyVarBndrs bndrs typs true_type
     fv = foldr Set.union Set.empty . map freeVariables $ typs
 specializeSig _ _ sig = sig
 
 
 -- | Make all details of instance head (signatures, associated types)
 -- specialized to that particular instance type.
-specializeInstHead :: (Eq name, DataId name, SetName name)
+specializeInstHead :: (Ord name, DataId name, SetName name, NamedThing name)
                    => InstHead name -> InstHead name
 specializeInstHead ihd@InstHead { ihdInstType = clsi@ClassInst { .. }, .. } =
     ihd { ihdInstType = instType' }
@@ -115,12 +108,7 @@ specializeInstHead ihd = ihd
 -- 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 = sugarOperators . sugarTuples . sugarLists
-
+sugar = sugarOperators . sugarTuples . sugarLists
 
 sugarLists :: NamedThing name => HsType name -> HsType name
 sugarLists (HsAppTy (L _ (HsTyVar _ (L _ name))) ltyp)
diff --git a/haddock-api/src/Haddock/Syb.hs b/haddock-api/src/Haddock/Syb.hs
index 4847e486..7e34ae8c 100644
--- a/haddock-api/src/Haddock/Syb.hs
+++ b/haddock-api/src/Haddock/Syb.hs
@@ -1,8 +1,11 @@
 {-# LANGUAGE Rank2Types #-}
-
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module Haddock.Syb
-    ( everything, everythingWithState, everywhere
+    ( everything, everythingButType, everythingWithState
+    , everywhere, everywhereButType
     , mkT
     , combine
     ) where
@@ -10,16 +13,41 @@ module Haddock.Syb
 
 import Data.Data
 import Control.Applicative
+import Data.Maybe
+import Data.Foldable
 
+-- | Returns true if a == t.
+-- requires AllowAmbiguousTypes
+isType :: forall a b. (Typeable a, Typeable b) => b -> Bool
+isType _ = isJust $ eqT @a @b
 
 -- | Perform a query on each level of a tree.
 --
 -- This is stolen directly from SYB package and copied here to not introduce
 -- additional dependencies.
-everything :: (r -> r -> r) -> (forall a. Data a => a -> r)
+everything :: (r -> r -> r)
+           -> (forall a. Data a => a -> r)
            -> (forall a. Data a => a -> r)
-everything k f x = foldl k (f x) (gmapQ (everything k f) x)
+everything k f x = foldl' k (f x) (gmapQ (everything k f) x)
+
+-- | Variation of "everything" with an added stop condition
+-- Just like 'everything', this is stolen from SYB package.
+everythingBut :: (r -> r -> r)
+              -> (forall a. Data a => a -> (r, Bool))
+              -> (forall a. Data a => a -> r)
+everythingBut k f x = let (v, stop) = f x
+                      in if stop
+                           then v
+                           else foldl' k v (gmapQ (everythingBut k f) x)
 
+-- | Variation of "everything" that does not recurse into children of type t
+-- requires AllowAmbiguousTypes
+everythingButType ::
+  forall t r. (Typeable t)
+  => (r -> r -> r)
+  -> (forall a. Data a => a -> r)
+  -> (forall a. Data a => a -> r)
+everythingButType k f = everythingBut k $ (,) <$> f <*> isType @t
 
 -- | Perform a query with state on each level of a tree.
 --
@@ -31,8 +59,7 @@ everythingWithState :: s -> (r -> r -> r)
                     -> (forall a. Data a => a -> r)
 everythingWithState s k f x =
     let (r, s') = f x s
-    in foldl k r (gmapQ (everythingWithState s' k f) x)
-
+    in foldl' k r (gmapQ (everythingWithState s' k f) x)
 
 -- | Apply transformation on each level of a tree.
 --
@@ -40,6 +67,22 @@ everythingWithState s k f x =
 everywhere :: (forall a. Data a => a -> a) -> (forall a. Data a => a -> a)
 everywhere f = f . gmapT (everywhere f)
 
+-- | Variation on everywhere with an extra stop condition
+-- Just like 'everything', this is stolen from SYB package.
+everywhereBut :: (forall a. Data a => a -> Bool)
+  -> (forall a. Data a => a -> a)
+  -> (forall a. Data a => a -> a)
+everywhereBut q f x
+    | q x       = x
+    | otherwise = f (gmapT (everywhereBut q f) x)
+
+-- | Variation of "everywhere" that does not recurse into children of type t
+-- requires AllowAmbiguousTypes
+everywhereButType :: forall t . (Typeable t)
+  => (forall a. Data a => a -> a)
+  -> (forall a. Data a => a -> a)
+everywhereButType = everywhereBut (isType @t)
+
 -- | Create generic transformation.
 --
 -- Another function stolen from SYB package.
-- 
cgit v1.2.3


From eca0677beaa78f31485055c432bf481dc06007a9 Mon Sep 17 00:00:00 2001
From: Alex Biehl <alexbiehl@gmail.com>
Date: Tue, 30 May 2017 19:01:37 +0200
Subject: Clear fixme comment (#625)

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

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index ffe42c4f..035c8e9e 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -520,9 +520,8 @@ ppClassDecl summary links instances fixities loc d subdocs
                                                , f@(n',_) <- fixities
                                                , n == n' ]
                                  names = map unLoc lnames ]
-                           -- FIXME: is taking just the first name ok? Is it possible that
-                           -- there are different subdocs for different names in a single
-                           -- type signature?
+                           -- N.B. taking just the first name is ok. Signatures with multiple names
+                           -- are expanded so that each name gets its own signature.
 
     minimalBit = case [ s | MinimalSig _ (L _ s) <- sigs ] of
       -- Miminal complete definition = every shown method
-- 
cgit v1.2.3


From fdf1b017b07e12769a7ca605b41dc76842838855 Mon Sep 17 00:00:00 2001
From: Alex Biehl <alexbiehl@gmail.com>
Date: Tue, 30 May 2017 19:02:12 +0200
Subject: Make haddock-library and haddock-api warning free (#626)

---
 haddock-api/src/Haddock.hs                         | 12 ++++++------
 haddock-api/src/Haddock/GhcUtils.hs                |  4 ----
 haddock-api/src/Haddock/Interface/Specialize.hs    |  1 -
 haddock-library/src/Documentation/Haddock/Types.hs |  4 +++-
 4 files changed, 9 insertions(+), 12 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index f0e7e6c7..57ea5fea 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -398,12 +398,12 @@ withGhc' libDir flags ghcActs = runGhc (Just libDir) $ do
     ghcLink   = NoLink
     }
   let dynflags'' = updOptLevel 0 $ gopt_unset dynflags' Opt_SplitObjs
-  defaultCleanupHandler dynflags'' $ do
-      -- ignore the following return-value, which is a list of packages
-      -- that may need to be re-linked: Haddock doesn't do any
-      -- dynamic or static linking at all!
-      _ <- setSessionDynFlags dynflags''
-      ghcActs dynflags''
+
+  -- ignore the following return-value, which is a list of packages
+  -- that may need to be re-linked: Haddock doesn't do any
+  -- dynamic or static linking at all!
+  _ <- setSessionDynFlags dynflags''
+  ghcActs dynflags''
   where
     parseGhcFlags :: MonadIO m => DynFlags -> m DynFlags
     parseGhcFlags dynflags = do
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index c8e5ea8b..dcc1d834 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -17,17 +17,13 @@ module Haddock.GhcUtils where
 
 
 import Control.Arrow
-import Data.Function
 
 import Exception
 import Outputable
 import Name
 import Lexeme
 import Module
-import RdrName (GlobalRdrEnv)
-import GhcMonad (withSession)
 import HscTypes
-import UniqFM
 import GHC
 import Class
 
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index 8c28cd5a..da8c3e7b 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -27,7 +27,6 @@ import Data.Map (Map)
 import qualified Data.Map as Map
 import Data.Set (Set)
 import qualified Data.Set as Set
-import Data.Foldable
 
 -- | Instantiate all occurrences of given names with corresponding types.
 specialize :: forall name a. (Ord name, DataId name, NamedThing name)
diff --git a/haddock-library/src/Documentation/Haddock/Types.hs b/haddock-library/src/Documentation/Haddock/Types.hs
index 4d5bb68a..660878ff 100644
--- a/haddock-library/src/Documentation/Haddock/Types.hs
+++ b/haddock-library/src/Documentation/Haddock/Types.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
+{-# LANGUAGE CPP, DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
 
 -- |
 -- Module      :  Documentation.Haddock.Types
@@ -14,8 +14,10 @@
 -- Exposes documentation data types used for (some) of Haddock.
 module Documentation.Haddock.Types where
 
+#if !MIN_VERSION_base(4,8,0)
 import Data.Foldable
 import Data.Traversable
+#endif
 
 -- | With the advent of 'Version', we may want to start attaching more
 -- meta-data to comments. We make a structure for this ahead of time
-- 
cgit v1.2.3


From bfb3563f730fd1c973a6611a0fba3435fb1df489 Mon Sep 17 00:00:00 2001
From: Alex Biehl <alexbiehl@gmail.com>
Date: Sat, 3 Jun 2017 20:37:28 +0200
Subject: Allow user defined signatures for pattern synonyms (#631)

---
 CHANGES.md                                  |  2 ++
 haddock-api/src/Haddock/GhcUtils.hs         |  5 +++++
 haddock-api/src/Haddock/Interface/Create.hs |  1 +
 html-test/ref/PatternSyns.html              | 29 +++++++++++++++++++++++++++++
 html-test/src/PatternSyns.hs                |  5 +++++
 5 files changed, 42 insertions(+)

(limited to 'haddock-api/src')

diff --git a/CHANGES.md b/CHANGES.md
index 6c2b5d32..95e1763a 100644
--- a/CHANGES.md
+++ b/CHANGES.md
@@ -1,5 +1,7 @@
 ## Changes in version 2.18.0
 
+ * Support user defined signatures on pattern synonyms
+
  * Synopsis is working again (#599)
 
 ## Changes in version 2.17.4
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index dcc1d834..4280cd80 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -88,6 +88,10 @@ filterSigNames p (ClassOpSig is_default ns ty) =
   case filter (p . unLoc) ns of
     []       -> Nothing
     filtered -> Just (ClassOpSig is_default filtered ty)
+filterSigNames p (PatSynSig ns ty) =
+  case filter (p . unLoc) ns of
+    []       -> Nothing
+    filtered -> Just (PatSynSig filtered ty)
 filterSigNames _ _                           = Nothing
 
 ifTrueJust :: Bool -> name -> Maybe name
@@ -110,6 +114,7 @@ sigNameNoLoc _                         = []
 isUserLSig :: LSig name -> Bool
 isUserLSig (L _(TypeSig {}))    = True
 isUserLSig (L _(ClassOpSig {})) = True
+isUserLSig (L _(PatSynSig {}))  = True
 isUserLSig _                    = False
 
 
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 26ac0281..98d4dbe8 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -842,6 +842,7 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap
     expandSig :: Sig name -> [Sig name]
     expandSig (TypeSig names t)      = [ TypeSig [n] t      | n <- names ]
     expandSig (ClassOpSig b names t) = [ ClassOpSig b [n] t | n <- names ]
+    expandSig (PatSynSig names t)    = [ PatSynSig [n] t    | n <- names ]
     expandSig x                      = [x]
 
     mkExportItem :: LHsDecl Name -> ErrMsgGhc (Maybe (ExportItem Name))
diff --git a/html-test/ref/PatternSyns.html b/html-test/ref/PatternSyns.html
index 9f0caaa2..2cf936b3 100644
--- a/html-test/ref/PatternSyns.html
+++ b/html-test/ref/PatternSyns.html
@@ -118,6 +118,16 @@ window.onload = function () {pageLoad();};
 	    > k a (b :: k). <a href="#"
 	    >(&gt;&lt;)</a
 	    > k a b</li
+	  ><li class="src short"
+	  ><span class="keyword"
+	    >pattern</span
+	    > <a href="#"
+	    >PatWithExplicitSig</a
+	    > :: <a href="#"
+	    >Eq</a
+	    > somex =&gt; somex -&gt; <a href="#"
+	    >FooType</a
+	    > somex</li
 	  ></ul
 	></div
       ><div id="interface"
@@ -279,6 +289,25 @@ window.onload = function () {pageLoad();};
 	      ></p
 	    ></div
 	  ></div
+	><div class="top"
+	><p class="src"
+	  ><span class="keyword"
+	    >pattern</span
+	    > <a id="v:PatWithExplicitSig" class="def"
+	    >PatWithExplicitSig</a
+	    > :: <a href="#"
+	    >Eq</a
+	    > somex =&gt; somex -&gt; <a href="#"
+	    >FooType</a
+	    > somex <a href="#" class="selflink"
+	    >#</a
+	    ></p
+	  ><div class="doc"
+	  ><p
+	    >Earlier ghc versions didn't allow explicit signatures
+ on pattern synonyms.</p
+	    ></div
+	  ></div
 	></div
       ></div
     ><div id="footer"
diff --git a/html-test/src/PatternSyns.hs b/html-test/src/PatternSyns.hs
index 8af5eb23..a8de113c 100644
--- a/html-test/src/PatternSyns.hs
+++ b/html-test/src/PatternSyns.hs
@@ -20,3 +20,8 @@ data (a :: *) >< b = Empty
 
 -- | Pattern for 'Empty'
 pattern E = Empty
+
+-- | Earlier ghc versions didn't allow explicit signatures
+-- on pattern synonyms.
+pattern PatWithExplicitSig :: Eq somex => somex -> FooType somex
+pattern PatWithExplicitSig x = FooCtor x
-- 
cgit v1.2.3


From d912ee70fff0718440a6f281ccea73aaf8568685 Mon Sep 17 00:00:00 2001
From: Alex Biehl <alexbiehl@gmail.com>
Date: Sun, 4 Jun 2017 11:56:38 +0200
Subject: Use NameSet for isExported check (#632)

---
 haddock-api/src/Haddock/Interface/Create.hs | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 98d4dbe8..36b0b7bb 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -50,6 +50,7 @@ import qualified SrcLoc
 import GHC
 import HscTypes
 import Name
+import NameSet
 import Bag
 import RdrName
 import TcRnTypes
@@ -651,9 +652,8 @@ mkExportItems
         sub_names = map fst subs'
         fixities = [ (n, f) | n <- name:sub_names, Just f <- [M.lookup n fixMap] ]
 
-
-    isExported = (`elem` exportedNames)
-
+    exportedNameSet = mkNameSet exportedNames
+    isExported n = elemNameSet n exportedNameSet
 
     findDecl :: Name -> ErrMsgGhc ([LHsDecl Name], (DocForDecl Name, [(Name, DocForDecl Name)]))
     findDecl n
-- 
cgit v1.2.3


From 87c551fc668b9251f2647cce8772f205e1cee154 Mon Sep 17 00:00:00 2001
From: Christiaan Baaij <christiaan.baaij@gmail.com>
Date: Fri, 9 Jun 2017 08:26:43 +0200
Subject: Haddock support for bundled pattern synonyms (#627)

* Haddock support for bundled pattern synonyms

* Add fixities to bundled pattern synonyms

* Add bundled pattern synonyms to the synopsis

* Store bundled pattern fixities in expItemFixities

* Add test for bundled pattern synonyms

* Stop threading fixities

* Include bundled pattern synonyms for re-exported data types

Sadly, fixity information isn't found for re-exported data types

* Support for pattern synonyms

* Modify tests after #631

* Test some reexport variations

* Also lookup bundled pattern synonyms from `InstalledInterface`s

* Check isExported for bundled pattern synonyms

* Pattern synonym is exported check

* Always look for pattern synonyms in the current module

Another overlooked cornercase

* Account for types named twice in export lists

Also introduce a fast function for nubbing on a `Name` and use it
throughout the code base.

* correct fixities for reexported pattern synonyms

* Fuse concatMap and map

* Remove obsolete import

* Add pattern synonyms to visible exports

* Fix test

* Remove corner case
---
 CHANGES.md                                         |   2 +
 haddock-api/src/Haddock/Backends/LaTeX.hs          |  32 +-
 haddock-api/src/Haddock/Backends/Xhtml.hs          |   4 +-
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs     |  56 ++-
 haddock-api/src/Haddock/Backends/Xhtml/Layout.hs   |   4 +
 haddock-api/src/Haddock/GhcUtils.hs                |  14 +-
 .../src/Haddock/Interface/AttachInstances.hs       |  11 +-
 haddock-api/src/Haddock/Interface/Create.hs        | 183 +++++---
 haddock-api/src/Haddock/Interface/Rename.hs        |  12 +-
 haddock-api/src/Haddock/InterfaceFile.hs           |   8 +-
 haddock-api/src/Haddock/Types.hs                   |  50 ++-
 html-test/ref/BundledPatterns.html                 | 474 +++++++++++++++++++++
 html-test/ref/BundledPatterns2.html                | 472 ++++++++++++++++++++
 html-test/src/BundledPatterns.hs                   | 110 +++++
 html-test/src/BundledPatterns2.hs                  |  10 +
 15 files changed, 1329 insertions(+), 113 deletions(-)
 create mode 100644 html-test/ref/BundledPatterns.html
 create mode 100644 html-test/ref/BundledPatterns2.html
 create mode 100644 html-test/src/BundledPatterns.hs
 create mode 100644 html-test/src/BundledPatterns2.hs

(limited to 'haddock-api/src')

diff --git a/CHANGES.md b/CHANGES.md
index 95e1763a..628b0968 100644
--- a/CHANGES.md
+++ b/CHANGES.md
@@ -4,6 +4,8 @@
 
  * Synopsis is working again (#599)
 
+ * Support for bundled pattern synonyms (#494, #551, #626)
+
 ## Changes in version 2.17.4
 
  * Fix 'internal error: links: UnhelpfulSpan' (#554, #565)
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 53cfccff..18660b3f 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -227,8 +227,8 @@ isExportModule _ = Nothing
 processExport :: ExportItem DocName -> LaTeX
 processExport (ExportGroup lev _id0 doc)
   = ppDocGroup lev (docToLaTeX doc)
-processExport (ExportDecl decl doc subdocs insts fixities _splice)
-  = ppDecl decl doc insts subdocs fixities
+processExport (ExportDecl decl pats doc subdocs insts fixities _splice)
+  = ppDecl decl pats doc insts subdocs fixities
 processExport (ExportNoDecl y [])
   = ppDocName y
 processExport (ExportNoDecl y subs)
@@ -278,16 +278,17 @@ moduleBasename mdl = map (\c -> if c == '.' then '-' else c)
 
 
 ppDecl :: LHsDecl DocName
+       -> [(HsDecl DocName,DocForDecl DocName)]
        -> DocForDecl DocName
        -> [DocInstance DocName]
        -> [(DocName, DocForDecl DocName)]
        -> [(DocName, Fixity)]
        -> LaTeX
 
-ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs _fixities = case decl of
+ppDecl (L loc decl) pats (doc, fnArgsDoc) instances subdocs _fixities = case decl of
   TyClD d@(FamDecl {})          -> ppTyFam False loc doc d unicode
   TyClD d@(DataDecl {})
-                                -> ppDataDecl instances subdocs loc (Just doc) d unicode
+                                -> ppDataDecl pats instances subdocs loc (Just doc) d unicode
   TyClD d@(SynDecl {})          -> ppTySyn loc (doc, fnArgsDoc) d unicode
 -- Family instances happen via FamInst now
 --  TyClD d@(TySynonym {})
@@ -565,11 +566,11 @@ lookupAnySubdoc n subdocs = case lookup n subdocs of
 -------------------------------------------------------------------------------
 
 
-ppDataDecl :: [DocInstance DocName] ->
+ppDataDecl :: [(HsDecl DocName,DocForDecl DocName)] -> [DocInstance DocName] ->
               [(DocName, DocForDecl DocName)] -> SrcSpan ->
               Maybe (Documentation DocName) -> TyClDecl DocName -> Bool ->
               LaTeX
-ppDataDecl instances subdocs _loc doc dataDecl unicode
+ppDataDecl pats instances subdocs _loc doc dataDecl unicode
 
    =  declWithDoc (ppDataHeader dataDecl unicode <+> whereBit)
                   (if null body then Nothing else Just (vcat body))
@@ -579,10 +580,12 @@ ppDataDecl instances subdocs _loc doc dataDecl unicode
     cons      = dd_cons (tcdDataDefn dataDecl)
     resTy     = (unLoc . head) cons
 
-    body = catMaybes [constrBit, doc >>= documentationToLaTeX]
+    body = catMaybes [constrBit,patternBit, doc >>= documentationToLaTeX]
 
     (whereBit, leaders)
-      | null cons = (empty,[])
+      | null cons
+      , null pats = (empty,[])
+      | null cons = (decltt (keyword "where"), repeat empty)
       | otherwise = case resTy of
         ConDeclGADT{} -> (decltt (keyword "where"), repeat empty)
         _             -> (empty, (decltt (text "=") : repeat (decltt (text "|"))))
@@ -594,6 +597,19 @@ ppDataDecl instances subdocs _loc doc dataDecl unicode
           vcat (zipWith (ppSideBySideConstr subdocs unicode) leaders cons) $$
           text "\\end{tabulary}\\par"
 
+    patternBit
+      | null cons = Nothing
+      | otherwise = Just $
+          text "\\haddockbeginconstrs" $$
+          vcat [ hsep [ keyword "pattern"
+                      , hsep $ punctuate comma $ map (ppDocBinder . unLoc) lnames
+                      , dcolon unicode
+                      , ppLType unicode (hsSigType ty)
+                      ] <-> rDoc (fmap _doc . combineDocumentation . fst $ d)
+               | (SigD (PatSynSig lnames ty),d) <- pats
+               ] $$
+          text "\\end{tabulary}\\par"
+
     instancesBit = ppDocInstances unicode instances
 
 
diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index 34ecc5b8..249389b9 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -604,8 +604,8 @@ processExport :: Bool -> LinksInfo -> Bool -> Qualification
 processExport _ _ _ _ ExportDecl { expItemDecl = L _ (InstD _) } = Nothing -- Hide empty instances
 processExport summary _ _ qual (ExportGroup lev id0 doc)
   = nothingIf summary $ groupHeading lev id0 << docToHtml (Just id0) qual (mkMeta doc)
-processExport summary links unicode qual (ExportDecl decl doc subdocs insts fixities splice)
-  = processDecl summary $ ppDecl summary links decl doc insts fixities subdocs splice unicode qual
+processExport summary links unicode qual (ExportDecl decl pats doc subdocs insts fixities splice)
+  = processDecl summary $ ppDecl summary links decl pats doc insts fixities subdocs splice unicode qual
 processExport summary _ _ qual (ExportNoDecl y [])
   = processDeclOneLiner summary $ ppDocName qual Prefix True y
 processExport summary _ _ qual (ExportNoDecl y subs)
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 035c8e9e..716050fa 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -41,11 +41,12 @@ import BooleanFormula
 import RdrName ( rdrNameOcc )
 
 ppDecl :: Bool -> LinksInfo -> LHsDecl DocName
-       -> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, Fixity)]
+       -> [(HsDecl DocName, DocForDecl 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
+ppDecl summ links (L loc decl) pats (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@(DataDecl {})        -> ppDataDecl summ links instances fixities subdocs loc mbDoc d pats 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
@@ -613,7 +614,7 @@ ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead {..}) =
             , [subFamInstDetails iid pdecl])
           where
             pdata = keyword "data" <+> typ
-            pdecl = pdata <+> ppShortDataDecl False True dd unicode qual
+            pdecl = pdata <+> ppShortDataDecl False True dd [] unicode qual
   where
     iid = instanceId origin no orphan ihd
     typ = ppAppNameTypes ihdClsName ihdKinds ihdTypes unicode qual
@@ -662,20 +663,23 @@ instanceId origin no orphan ihd = concat $
 
 
 -- TODO: print contexts
-ppShortDataDecl :: Bool -> Bool -> TyClDecl DocName -> Unicode -> Qualification -> Html
-ppShortDataDecl summary dataInst dataDecl unicode qual
+ppShortDataDecl :: Bool -> Bool -> TyClDecl DocName
+                -> [(HsDecl DocName,DocForDecl DocName)]
+                -> Unicode -> Qualification -> Html
+ppShortDataDecl summary dataInst dataDecl pats unicode qual
 
-  | [] <- cons = dataHeader
+  | [] <- cons
+  , [] <- pats = dataHeader
 
-  | [lcon] <- cons, isH98,
+  | [lcon] <- cons, [] <- pats, isH98,
     (cHead,cBody,cFoot) <- ppShortConstrParts summary dataInst (unLoc lcon) unicode qual
        = (dataHeader <+> equals <+> cHead) +++ cBody +++ cFoot
 
-  | isH98 = dataHeader
-      +++ shortSubDecls dataInst (zipWith doConstr ('=':repeat '|') cons)
+  | [] <- pats, isH98 = dataHeader
+      +++ shortSubDecls dataInst (zipWith doConstr ('=':repeat '|') cons ++ pats1)
 
   | otherwise = (dataHeader <+> keyword "where")
-      +++ shortSubDecls dataInst (map doGADTConstr cons)
+      +++ shortSubDecls dataInst (map doGADTConstr cons ++ pats1)
 
   where
     dataHeader
@@ -689,16 +693,25 @@ ppShortDataDecl summary dataInst dataDecl unicode qual
                   ConDeclH98 {} -> True
                   ConDeclGADT{} -> False
 
+    pats1 = [ hsep [ keyword "pattern"
+                   , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames
+                   , dcolon unicode
+                   , ppLType unicode qual (hsSigType typ)
+                   ]
+            | (SigD (PatSynSig lnames typ),_) <- pats
+            ]
+
 
 ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)] ->
               [(DocName, DocForDecl DocName)] ->
               SrcSpan -> Documentation DocName -> TyClDecl DocName ->
+              [(HsDecl DocName,DocForDecl DocName)] ->
               Splice -> Unicode -> Qualification -> Html
-ppDataDecl summary links instances fixities subdocs loc doc dataDecl
+ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats
            splice unicode qual
 
-  | summary   = ppShortDataDecl summary False dataDecl unicode qual
-  | otherwise = header_ +++ docSection Nothing qual doc +++ constrBit +++ instancesBit
+  | summary   = ppShortDataDecl summary False dataDecl pats unicode qual
+  | otherwise = header_ +++ docSection Nothing qual doc +++ constrBit +++ patternBit +++ instancesBit
 
   where
     docname   = tcdName dataDecl
@@ -713,7 +726,9 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl
     fix = ppFixities (filter (\(n,_) -> n == docname) fixities) qual
 
     whereBit
-      | null cons = noHtml
+      | null cons
+      , null pats = noHtml
+      | null cons = keyword "where"
       | otherwise = if isH98 then noHtml else keyword "where"
 
     constrBit = subConstructors qual
@@ -723,6 +738,17 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl
                                      (map unLoc (getConNames (unLoc c)))) fixities
       ]
 
+    patternBit = subPatterns qual
+      [ (hsep [ keyword "pattern"
+              , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames
+              , dcolon unicode
+              , ppLType unicode qual (hsSigType typ)
+              ] <+> ppFixities subfixs qual
+        ,combineDocumentation (fst d), [])
+      | (SigD (PatSynSig lnames typ),d) <- pats
+      , let subfixs = filter (\(n,_) -> any (\cn -> cn == n) (map unLoc lnames)) fixities
+      ]
+
     instancesBit = ppInstances links (OriginData docname) instances
         splice unicode qual
 
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
index 41457f72..6993c7f6 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
@@ -29,6 +29,7 @@ module Haddock.Backends.Xhtml.Layout (
   subArguments,
   subAssociatedTypes,
   subConstructors,
+  subPatterns,
   subEquations,
   subFields,
   subInstances, subOrphanInstances,
@@ -180,6 +181,9 @@ subAssociatedTypes = divSubDecls "associated-types" "Associated Types" . subBloc
 subConstructors :: Qualification -> [SubDecl] -> Html
 subConstructors qual = divSubDecls "constructors" "Constructors" . subTable qual
 
+subPatterns :: Qualification -> [SubDecl] -> Html
+subPatterns qual = divSubDecls "bundled-patterns" "Bundled Patterns" . subTable qual
+
 subFields :: Qualification -> [SubDecl] -> Html
 subFields qual = divSubDecls "fields" "Fields" . subDlist qual
 
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 4280cd80..02867833 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE FlexibleInstances, ViewPatterns #-}
+{-# LANGUAGE BangPatterns, FlexibleInstances, ViewPatterns #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 {-# OPTIONS_HADDOCK hide #-}
 -----------------------------------------------------------------------------
@@ -21,6 +21,7 @@ import Control.Arrow
 import Exception
 import Outputable
 import Name
+import NameSet
 import Lexeme
 import Module
 import HscTypes
@@ -135,6 +136,17 @@ declATs _ = []
 pretty :: Outputable a => DynFlags -> a -> String
 pretty = showPpr
 
+nubByName :: (a -> Name) -> [a] -> [a]
+nubByName f ns = go emptyNameSet ns
+  where
+    go !_ [] = []
+    go !s (x:xs)
+      | y `elemNameSet` s = go s xs
+      | otherwise         = let !s' = extendNameSet s y
+                            in x : go s' xs
+      where
+        y = f x
+
 -------------------------------------------------------------------------------
 -- * Located
 -------------------------------------------------------------------------------
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index d5d74819..7a3182b8 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -21,7 +21,6 @@ import Haddock.GhcUtils
 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
@@ -109,13 +108,17 @@ attachToExportItem expInfo iface ifaceMap instIfaceMap export =
       return $ e { expItemInstances = insts }
     e -> return e
   where
-    attachFixities e@ExportDecl{ expItemDecl = L _ d } = e { expItemFixities =
-      nubBy ((==) `on` fst) $ expItemFixities e ++
+    attachFixities e@ExportDecl{ expItemDecl = L _ d
+                               , expItemPats = patsyns
+                               } = e { expItemFixities =
+      nubByName fst $ expItemFixities e ++
       [ (n',f) | n <- getMainDeclBinder d
               , Just subs <- [instLookup instSubMap n iface ifaceMap instIfaceMap]
-              , n' <- n : subs
+              , n' <- n : (subs ++ patsyn_names)
               , Just f <- [instLookup instFixMap n' iface ifaceMap instIfaceMap]
       ] }
+      where
+        patsyn_names = concatMap (getMainDeclBinder . fst) patsyns
 
     attachFixities e = e
     -- spanName: attach the location to the name that is the same file as the instance location
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 36b0b7bb..0984894d 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -42,7 +42,7 @@ import Control.Arrow (second)
 import Control.DeepSeq (force)
 import Control.Exception (evaluate)
 import Control.Monad
-import Data.Function (on)
+import Data.Traversable
 
 import qualified Packages
 import qualified Module
@@ -81,7 +81,10 @@ createInterface tm flags modMap instIfaceMap = do
       !fam_instances = md_fam_insts md
       !exportedNames = modInfoExports mi
 
-      (TcGblEnv {tcg_rdr_env = gre, tcg_warns = warnings}, md) = tm_internals_ tm
+      (TcGblEnv { tcg_rdr_env = gre
+                , tcg_warns   = warnings
+                , tcg_patsyns = patsyns
+                }, md) = tm_internals_ tm
 
   -- The renamed source should always be available to us, but it's best
   -- to be on the safe side.
@@ -101,6 +104,28 @@ createInterface tm flags modMap instIfaceMap = do
   (!info, mbDoc) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader
 
   let declsWithDocs = topDecls group_
+
+      exports0 = fmap (reverse . map unLoc) mayExports
+      exports
+        | OptIgnoreExports `elem` opts = Nothing
+        | otherwise = exports0
+      warningMap = mkWarningMap dflags warnings gre exportedNames
+
+      localBundledPatSyns :: Map Name [Name]
+      localBundledPatSyns =
+        case exports of
+          Nothing  -> M.empty
+          Just ies ->
+            M.map (nubByName id) $
+            M.fromListWith (++) [ (ieWrappedName ty_name, bundled_patsyns)
+                                | IEThingWith (L _ ty_name) _ exported _ <- ies
+                                , let bundled_patsyns =
+                                        filter is_patsyn (map (ieWrappedName . unLoc) exported)
+                                , not (null bundled_patsyns)
+                                ]
+        where
+          is_patsyn name = elemNameSet name (mkNameSet (map getName patsyns))
+
       fixMap = mkFixMap group_
       (decls, _) = unzip declsWithDocs
       localInsts = filter (nameIsLocalOrFrom sem_mdl)
@@ -112,18 +137,12 @@ createInterface tm flags modMap instIfaceMap = do
       maps@(!docMap, !argMap, !subMap, !declMap, _) =
         mkMaps dflags gre localInsts declsWithDocs
 
-  let exports0 = fmap (reverse . map unLoc) mayExports
-      exports
-        | OptIgnoreExports `elem` opts = Nothing
-        | otherwise = exports0
-      warningMap = mkWarningMap dflags warnings gre exportedNames
-
   let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap))
 
   -- The MAIN functionality: compute the export items which will
   -- each be the actual documentation of this module.
   exportItems <- mkExportItems is_sig modMap mdl sem_mdl allWarnings gre exportedNames decls
-                   maps fixMap splices exports instIfaceMap dflags
+                   maps localBundledPatSyns fixMap splices exports instIfaceMap dflags
 
   let !visibleNames = mkVisibleNames maps exportItems opts
 
@@ -147,32 +166,33 @@ createInterface tm flags modMap instIfaceMap = do
   tokenizedSrc <- mkMaybeTokenizedSrc flags tm
 
   return $! Interface {
-    ifaceMod             = mdl
-  , ifaceIsSig           = is_sig
-  , ifaceOrigFilename    = msHsFilePath ms
-  , ifaceInfo            = info
-  , ifaceDoc             = Documentation mbDoc modWarn
-  , ifaceRnDoc           = Documentation Nothing Nothing
-  , ifaceOptions         = opts
-  , ifaceDocMap          = docMap
-  , ifaceArgMap          = argMap
-  , ifaceRnDocMap        = M.empty
-  , ifaceRnArgMap        = M.empty
-  , ifaceExportItems     = prunedExportItems
-  , ifaceRnExportItems   = []
-  , ifaceExports         = exportedNames
-  , ifaceVisibleExports  = visibleNames
-  , ifaceDeclMap         = declMap
-  , ifaceSubMap          = subMap
-  , ifaceFixMap          = fixMap
-  , ifaceModuleAliases   = aliases
-  , ifaceInstances       = instances
-  , ifaceFamInstances    = fam_instances
+    ifaceMod               = mdl
+  , ifaceIsSig             = is_sig
+  , ifaceOrigFilename      = msHsFilePath ms
+  , ifaceInfo              = info
+  , ifaceDoc               = Documentation mbDoc modWarn
+  , ifaceRnDoc             = Documentation Nothing Nothing
+  , ifaceOptions           = opts
+  , ifaceDocMap            = docMap
+  , ifaceArgMap            = argMap
+  , ifaceRnDocMap          = M.empty
+  , ifaceRnArgMap          = M.empty
+  , ifaceExportItems       = prunedExportItems
+  , ifaceRnExportItems     = []
+  , ifaceExports           = exportedNames
+  , ifaceVisibleExports    = visibleNames
+  , ifaceDeclMap           = declMap
+  , ifaceBundledPatSynMap  = localBundledPatSyns
+  , ifaceSubMap            = subMap
+  , ifaceFixMap            = fixMap
+  , ifaceModuleAliases     = aliases
+  , ifaceInstances         = instances
+  , ifaceFamInstances      = fam_instances
   , ifaceOrphanInstances   = [] -- Filled in `attachInstances`
   , ifaceRnOrphanInstances = [] -- Filled in `renameInterface`
-  , ifaceHaddockCoverage = coverage
-  , ifaceWarningMap      = warningMap
-  , ifaceTokenizedSrc    = tokenizedSrc
+  , ifaceHaddockCoverage   = coverage
+  , ifaceWarningMap        = warningMap
+  , ifaceTokenizedSrc      = tokenizedSrc
   }
 
 -- | Given all of the @import M as N@ declarations in a package,
@@ -295,8 +315,9 @@ mkMaps :: DynFlags
        -> [(LHsDecl Name, [HsDocString])]
        -> Maps
 mkMaps dflags gre instances decls =
-  let (a, b, c, d) = unzip4 $ map mappings decls
-  in (f' $ map (nubBy ((==) `on` fst)) a , f b, f c, f d, instanceMap)
+  let
+    (a, b, c, d) = unzip4 $ map mappings decls
+  in (f' $ map (nubByName fst) a , f b, f c, f d, instanceMap)
   where
     f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b
     f = M.fromListWith (<>) . concat
@@ -362,7 +383,9 @@ mkMaps dflags gre instances decls =
 -- | Get all subordinate declarations inside a declaration, and their docs.
 -- A subordinate declaration is something like the associate type or data
 -- family of a type class.
-subordinates :: InstMap -> HsDecl Name -> [(Name, [HsDocString], Map Int HsDocString)]
+subordinates :: InstMap
+             -> HsDecl Name
+             -> [(Name, [HsDocString], Map Int HsDocString)]
 subordinates instMap decl = case decl of
   InstD (ClsInstD d) -> do
     DataFamInstDecl { dfid_tycon = L l _
@@ -539,6 +562,7 @@ mkExportItems
   -> [Name]             -- exported names (orig)
   -> [LHsDecl Name]     -- renamed source declarations
   -> Maps
+  -> Map Name [Name]
   -> FixMap
   -> [SrcSpan]          -- splice locations
   -> Maybe [IE Name]
@@ -547,15 +571,21 @@ mkExportItems
   -> ErrMsgGhc [ExportItem Name]
 mkExportItems
   is_sig modMap thisMod semMod warnings gre exportedNames decls
-  maps@(docMap, argMap, subMap, declMap, instMap) fixMap splices optExports instIfaceMap dflags =
+  maps@(docMap, argMap, subMap, declMap, instMap) patSynMap fixMap splices optExports instIfaceMap dflags =
   case optExports of
     Nothing -> fullModuleContents dflags warnings gre maps fixMap splices decls
     Just exports -> liftM concat $ mapM lookupExport exports
   where
-    lookupExport (IEVar (L _ x))         = declWith $ ieWrappedName x
-    lookupExport (IEThingAbs (L _ t))    = declWith $ ieWrappedName t
-    lookupExport (IEThingAll (L _ t))    = declWith $ ieWrappedName t
-    lookupExport (IEThingWith (L _ t) _ _ _) = declWith $ ieWrappedName t
+    lookupExport (IEVar (L _ x))         = declWith [] $ ieWrappedName x
+    lookupExport (IEThingAbs (L _ t))    = declWith [] $ ieWrappedName t
+    lookupExport (IEThingAll (L _ t))    = do
+      let name     = ieWrappedName t
+      pats <- findBundledPatterns name
+      declWith pats name
+    lookupExport (IEThingWith (L _ t) _ _ _) = do
+      let name     = ieWrappedName t
+      pats <- findBundledPatterns name
+      declWith pats name
     lookupExport (IEModuleContents (L _ m)) =
       -- TODO: We could get more accurate reporting here if IEModuleContents
       -- also recorded the actual names that are exported here.  We CAN
@@ -574,8 +604,8 @@ mkExportItems
         Nothing -> []
         Just doc -> return . ExportDoc $ processDocStringParas dflags gre doc
 
-    declWith :: Name -> ErrMsgGhc [ ExportItem Name ]
-    declWith t = do
+    declWith :: [(HsDecl Name, DocForDecl Name)] -> Name -> ErrMsgGhc [ ExportItem Name ]
+    declWith pats t = do
       r <- findDecl t
       case r of
         ([L l (ValD _)], (doc, _)) -> do
@@ -612,15 +642,15 @@ mkExportItems
                     -- fromJust is safe since we already checked in guards
                     -- that 't' is a name declared in this declaration.
                     let newDecl = L loc . SigD . fromJust $ filterSigNames (== t) sig
-                    in return [ mkExportDecl t newDecl docs_ ]
+                    in return [ mkExportDecl t newDecl pats docs_ ]
 
                   L loc (TyClD cl@ClassDecl{}) -> do
                     mdef <- liftGhcToErrMsgGhc $ minimalDef t
                     let sig = maybeToList $ fmap (noLoc . MinimalSig NoSourceText . noLoc . fmap noLoc) mdef
                     return [ mkExportDecl t
-                      (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_ ]
+                      (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) pats docs_ ]
 
-                  _ -> return [ mkExportDecl t decl docs_ ]
+                  _ -> return [ mkExportDecl t decl pats docs_ ]
 
         -- Declaration from another package
         ([], _) -> do
@@ -637,20 +667,24 @@ mkExportItems
                    liftErrMsg $ tell
                       ["Warning: Couldn't find .haddock for export " ++ pretty dflags t]
                    let subs_ = [ (n, noDocForDecl) | (n, _, _) <- subordinates instMap (unLoc decl) ]
-                   return [ mkExportDecl t decl (noDocForDecl, subs_) ]
+                   return [ mkExportDecl t decl pats (noDocForDecl, subs_) ]
                 Just iface ->
-                   return [ mkExportDecl t decl (lookupDocs t warnings (instDocMap iface) (instArgMap iface) (instSubMap iface)) ]
+                   return [ mkExportDecl t decl pats (lookupDocs t warnings (instDocMap iface) (instArgMap iface) (instSubMap iface)) ]
 
         _ -> return []
 
 
-    mkExportDecl :: Name -> LHsDecl Name -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ExportItem Name
-    mkExportDecl name decl (doc, subs) = decl'
+    mkExportDecl :: Name -> LHsDecl Name -> [(HsDecl Name, DocForDecl Name)]
+                 -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ExportItem Name
+    mkExportDecl name decl pats (doc, subs) = decl'
       where
-        decl' = ExportDecl (restrictTo sub_names (extractDecl name decl)) doc subs' [] fixities False
+        decl' = ExportDecl (restrictTo sub_names (extractDecl name decl)) pats' doc subs' [] fixities False
         subs' = filter (isExported . fst) subs
+        pats' = [ d | d@(patsyn_decl, _) <- pats
+                    , all isExported (getMainDeclBinder patsyn_decl) ]
         sub_names = map fst subs'
-        fixities = [ (n, f) | n <- name:sub_names, Just f <- [M.lookup n fixMap] ]
+        pat_names = [ n | (patsyn_decl, _) <- pats', n <- getMainDeclBinder patsyn_decl]
+        fixities = [ (n, f) | n <- name:sub_names++pat_names, Just f <- [M.lookup n fixMap] ]
 
     exportedNameSet = mkNameSet exportedNames
     isExported n = elemNameSet n exportedNameSet
@@ -684,6 +718,40 @@ mkExportItems
       where
         m = nameModule n
 
+    findBundledPatterns :: Name -> ErrMsgGhc [(HsDecl Name, DocForDecl Name)]
+    findBundledPatterns t =
+      let
+        m = nameModule t
+
+        local_bundled_patsyns =
+          M.findWithDefault [] t patSynMap
+
+        iface_bundled_patsyns
+          | Just iface <- M.lookup (semToIdMod (moduleUnitId thisMod) m) modMap
+          , Just patsyns <- M.lookup t (ifaceBundledPatSynMap iface)
+          = patsyns
+
+          | Just iface <- M.lookup m instIfaceMap
+          , Just patsyns <- M.lookup t (instBundledPatSynMap iface)
+          = patsyns
+
+          | otherwise
+          = []
+
+        patsyn_decls = do
+          for (local_bundled_patsyns ++ iface_bundled_patsyns) $ \patsyn_name -> do
+            -- call declWith here so we don't have to prepare the pattern synonym for
+            -- showing ourselves.
+            export_items <- declWith [] patsyn_name
+            pure [ (unLoc patsyn_decl, patsyn_doc)
+                 | ExportDecl {
+                       expItemDecl  = patsyn_decl
+                     , expItemMbDoc = patsyn_doc
+                     } <- export_items
+                 ]
+
+      in concat <$> patsyn_decls
+
 -- | Given a 'Module' from a 'Name', convert it into a 'Module' that
 -- we can actually find in the 'IfaceMap'.
 semToIdMod :: UnitId -> Module -> Module
@@ -718,7 +786,7 @@ hiValExportItem dflags name nLoc doc splice fixity = do
   mayDecl <- hiDecl dflags name
   case mayDecl of
     Nothing -> return (ExportNoDecl name [])
-    Just decl -> return (ExportDecl (fixSpan decl) doc [] [] fixities splice)
+    Just decl -> return (ExportDecl (fixSpan decl) [] doc [] [] fixities splice)
   where
     fixSpan (L l t) = L (SrcLoc.combineSrcSpans l nLoc) t
     fixities = case fixity of
@@ -873,12 +941,12 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap
     fixities name subs = [ (n,f) | n <- name : map fst subs
                                  , Just f <- [M.lookup n fixMap] ]
 
-    expDecl decl l name = return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices))
+    expDecl decl l name = return $ Just (ExportDecl decl [] doc subs [] (fixities name subs) (l `elem` splices))
       where (doc, subs) = lookupDocs name warnings docMap argMap subMap
 
     expInst decl l name =
         let (doc, subs) = lookupDocs name warnings docMap argMap subMap in
-        return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices))
+        return $ Just (ExportDecl decl [] doc subs [] (fixities name subs) (l `elem` splices))
 
 
 -- | Sometimes the declaration we want to export is not the "main" declaration:
@@ -958,8 +1026,9 @@ mkVisibleNames (_, _, _, _, instMap) exports opts
   | otherwise = let ns = concatMap exportName exports
                 in seqList ns `seq` ns
   where
-    exportName e@ExportDecl {} = name ++ subs
-      where subs = map fst (expItemSubDocs e)
+    exportName e@ExportDecl {} = name ++ subs ++ patsyns
+      where subs    = map fst (expItemSubDocs e)
+            patsyns = concatMap (getMainDeclBinder . fst) (expItemPats e)
             name = case unLoc $ expItemDecl e of
               InstD d -> maybeToList $ M.lookup (getInstLoc d) instMap
               decl    -> getMainDeclBinder decl
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index b43860fb..5820c61e 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -55,7 +55,7 @@ renameInterface dflags renamingEnv warnings iface =
 
       -- combine the missing names and filter out the built-ins, which would
       -- otherwise always be missing.
-      missingNames = nub $ filter isExternalName  -- XXX: isExternalName filters out too much
+      missingNames = nubByName id $ filter isExternalName  -- XXX: isExternalName filters out too much
                     (missingNames1 ++ missingNames2 ++ missingNames3
                      ++ missingNames4 ++ missingNames5)
 
@@ -314,6 +314,11 @@ renameInstHead InstHead {..} = do
 renameLDecl :: LHsDecl Name -> RnM (LHsDecl DocName)
 renameLDecl (L loc d) = return . L loc =<< renameDecl d
 
+renamePats :: [(HsDecl Name,DocForDecl Name)] -> RnM [(HsDecl DocName,DocForDecl DocName)]
+renamePats = mapM
+  (\(d,doc) -> do { d'   <- renameDecl d
+                  ; doc' <- renameDocForDecl doc
+                  ; return (d',doc')})
 
 renameDecl :: HsDecl Name -> RnM (HsDecl DocName)
 renameDecl decl = case decl of
@@ -601,15 +606,16 @@ renameExportItem item = case item of
   ExportGroup lev id_ doc -> do
     doc' <- renameDoc doc
     return (ExportGroup lev id_ doc')
-  ExportDecl decl doc subs instances fixities splice -> do
+  ExportDecl decl pats doc subs instances fixities splice -> do
     decl' <- renameLDecl decl
+    pats' <- renamePats pats
     doc'  <- renameDocForDecl doc
     subs' <- mapM renameSub subs
     instances' <- forM instances renameDocInstance
     fixities' <- forM fixities $ \(name, fixity) -> do
       name' <- lookupRn name
       return (name', fixity)
-    return (ExportDecl decl' doc' subs' instances' fixities' splice)
+    return (ExportDecl decl' pats' doc' subs' instances' fixities' splice)
   ExportNoDecl x subs -> do
     x'    <- lookupRn x
     subs' <- mapM lookupRn subs
diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs
index e5c2face..054c1384 100644
--- a/haddock-api/src/Haddock/InterfaceFile.hs
+++ b/haddock-api/src/Haddock/InterfaceFile.hs
@@ -83,7 +83,7 @@ binaryInterfaceMagic = 0xD0Cface
 --
 binaryInterfaceVersion :: Word16
 #if (__GLASGOW_HASKELL__ >= 802) && (__GLASGOW_HASKELL__ < 804)
-binaryInterfaceVersion = 30
+binaryInterfaceVersion = 31
 
 binaryInterfaceVersionCompatibility :: [Word16]
 binaryInterfaceVersionCompatibility = [binaryInterfaceVersion]
@@ -373,7 +373,7 @@ instance Binary InterfaceFile where
 
 instance Binary InstalledInterface where
   put_ bh (InstalledInterface modu is_sig info docMap argMap
-           exps visExps opts subMap fixMap) = do
+           exps visExps opts subMap patSynMap fixMap) = do
     put_ bh modu
     put_ bh is_sig
     put_ bh info
@@ -382,6 +382,7 @@ instance Binary InstalledInterface where
     put_ bh visExps
     put_ bh opts
     put_ bh subMap
+    put_ bh patSynMap
     put_ bh fixMap
 
   get bh = do
@@ -393,10 +394,11 @@ instance Binary InstalledInterface where
     visExps <- get bh
     opts    <- get bh
     subMap  <- get bh
+    patSynMap <- get bh
     fixMap  <- get bh
 
     return (InstalledInterface modu is_sig info docMap argMap
-            exps visExps opts subMap fixMap)
+            exps visExps opts subMap patSynMap fixMap)
 
 
 instance Binary DocOption where
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 803995cc..bfc8e32b 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -103,6 +103,9 @@ data Interface = Interface
     -- names of subordinate declarations mapped to their parent declarations.
   , ifaceDeclMap         :: !(Map Name [LHsDecl Name])
 
+    -- | Bundled pattern synonym declarations for specific types.
+  , ifaceBundledPatSynMap :: !(Map Name [Name])
+
     -- | Documentation of declarations originating from the module (including
     -- subordinates).
   , ifaceDocMap          :: !(DocMap Name)
@@ -158,49 +161,53 @@ type WarningMap = Map Name (Doc Name)
 data InstalledInterface = InstalledInterface
   {
     -- | The module represented by this interface.
-    instMod            :: Module
+    instMod              :: Module
 
     -- | Is this a signature?
-  , instIsSig          :: Bool
+  , instIsSig            :: Bool
 
     -- | Textual information about the module.
-  , instInfo           :: HaddockModInfo Name
+  , instInfo             :: HaddockModInfo Name
 
     -- | Documentation of declarations originating from the module (including
     -- subordinates).
-  , instDocMap         :: DocMap Name
+  , instDocMap           :: DocMap Name
 
-  , instArgMap         :: ArgMap Name
+  , instArgMap           :: ArgMap Name
 
     -- | All names exported by this module.
-  , instExports        :: [Name]
+  , instExports          :: [Name]
 
     -- | All \"visible\" names exported by the module.
     -- A visible name is a name that will show up in the documentation of the
     -- module.
-  , instVisibleExports :: [Name]
+  , instVisibleExports   :: [Name]
 
     -- | Haddock options for this module (prune, ignore-exports, etc).
-  , instOptions        :: [DocOption]
+  , instOptions          :: [DocOption]
+
+  , instSubMap           :: Map Name [Name]
 
-  , instSubMap         :: Map Name [Name]
-  , instFixMap         :: Map Name Fixity
+  , instBundledPatSynMap :: Map Name [Name]
+  
+  , instFixMap           :: Map Name Fixity
   }
 
 
 -- | Convert an 'Interface' to an 'InstalledInterface'
 toInstalledIface :: Interface -> InstalledInterface
 toInstalledIface interface = InstalledInterface
-  { instMod            = ifaceMod            interface
-  , instIsSig          = ifaceIsSig          interface
-  , instInfo           = ifaceInfo           interface
-  , instDocMap         = ifaceDocMap         interface
-  , instArgMap         = ifaceArgMap         interface
-  , instExports        = ifaceExports        interface
-  , instVisibleExports = ifaceVisibleExports interface
-  , instOptions        = ifaceOptions        interface
-  , instSubMap         = ifaceSubMap         interface
-  , instFixMap         = ifaceFixMap         interface
+  { instMod              = ifaceMod              interface
+  , instIsSig            = ifaceIsSig            interface
+  , instInfo             = ifaceInfo             interface
+  , instDocMap           = ifaceDocMap           interface
+  , instArgMap           = ifaceArgMap           interface
+  , instExports          = ifaceExports          interface
+  , instVisibleExports   = ifaceVisibleExports   interface
+  , instOptions          = ifaceOptions          interface
+  , instSubMap           = ifaceSubMap           interface
+  , instBundledPatSynMap = ifaceBundledPatSynMap interface
+  , instFixMap           = ifaceFixMap           interface
   }
 
 
@@ -217,6 +224,9 @@ data ExportItem name
         -- | A declaration.
         expItemDecl :: !(LHsDecl name)
 
+        -- | Bundled patterns for a data type declaration
+      , expItemPats :: ![(HsDecl name, DocForDecl name)]
+
         -- | Maybe a doc comment, and possibly docs for arguments (if this
         -- decl is a function or type-synonym).
       , expItemMbDoc :: !(DocForDecl name)
diff --git a/html-test/ref/BundledPatterns.html b/html-test/ref/BundledPatterns.html
new file mode 100644
index 00000000..bf6c073c
--- /dev/null
+++ b/html-test/ref/BundledPatterns.html
@@ -0,0 +1,474 @@
+<html xmlns="http://www.w3.org/1999/xhtml"
+><head
+  ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"
+     /><title
+    >BundledPatterns</title
+    ><link href="#" rel="stylesheet" type="text/css" title="Ocean"
+     /><script src="haddock-util.js" type="text/javascript"
+    ></script
+    ><script src="https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.0/MathJax.js?config=TeX-AMS-MML_HTMLorMML" type="text/javascript"
+    ></script
+    ><script type="text/javascript"
+    >//
+window.onload = function () {pageLoad();};
+//
+</script
+    ></head
+  ><body
+  ><div id="package-header"
+    ><ul class="links" id="page-menu"
+      ><li
+	><a href="#"
+	  >Contents</a
+	  ></li
+	><li
+	><a href="#"
+	  >Index</a
+	  ></li
+	></ul
+      ><p class="caption empty"
+      ></p
+      ></div
+    ><div id="content"
+    ><div id="module-header"
+      ><table class="info"
+	><tr
+	  ><th
+	    >Safe Haskell</th
+	    ><td
+	    >None</td
+	    ></tr
+	  ></table
+	><p class="caption"
+	>BundledPatterns</p
+	></div
+      ><div id="synopsis"
+      ><p id="control.syn" class="caption expander" onclick="toggleSection('syn')"
+	>Synopsis</p
+	><ul id="section.syn" class="hide" onclick="toggleSection('syn')"
+	><li class="src short"
+	  ><span class="keyword"
+	    >data</span
+	    > <a href="#"
+	    >Vec</a
+	    > :: <a href="#"
+	    >Nat</a
+	    > -&gt; <a href="#"
+	    >*</a
+	    > -&gt; <a href="#"
+	    >*</a
+	    > <span class="keyword"
+	    >where</span
+	    ><ul class="subs"
+	    ><li
+	      ><a href="#"
+		>Nil</a
+		> :: <a href="#"
+		>Vec</a
+		> 0 a</li
+	      ><li
+	      ><span class="keyword"
+		>pattern</span
+		> <a href="#"
+		>(:&gt;)</a
+		> :: a -&gt; <a href="#"
+		>Vec</a
+		> n a -&gt; <a href="#"
+		>Vec</a
+		> (n <a href="#"
+		>+</a
+		> 1) a</li
+	      ></ul
+	    ></li
+	  ><li class="src short"
+	  ><span class="keyword"
+	    >data</span
+	    > <a href="#"
+	    >RTree</a
+	    > :: <a href="#"
+	    >Nat</a
+	    > -&gt; <a href="#"
+	    >*</a
+	    > -&gt; <a href="#"
+	    >*</a
+	    > <span class="keyword"
+	    >where</span
+	    ><ul class="subs"
+	    ><li
+	      ><span class="keyword"
+		>pattern</span
+		> <a href="#"
+		>LR</a
+		> :: a -&gt; <a href="#"
+		>RTree</a
+		> 0 a</li
+	      ><li
+	      ><span class="keyword"
+		>pattern</span
+		> <a href="#"
+		>BR</a
+		> :: <a href="#"
+		>RTree</a
+		> d a -&gt; <a href="#"
+		>RTree</a
+		> d a -&gt; <a href="#"
+		>RTree</a
+		> (d <a href="#"
+		>+</a
+		> 1) a</li
+	      ></ul
+	    ></li
+	  ></ul
+	></div
+      ><div id="interface"
+      ><h1
+	>Documentation</h1
+	><div class="top"
+	><p class="src"
+	  ><span class="keyword"
+	    >data</span
+	    > <a id="t:Vec" class="def"
+	    >Vec</a
+	    > :: <a href="#"
+	    >Nat</a
+	    > -&gt; <a href="#"
+	    >*</a
+	    > -&gt; <a href="#"
+	    >*</a
+	    > <span class="keyword"
+	    >where</span
+	    > <a href="#" class="selflink"
+	    >#</a
+	    ></p
+	  ><div class="doc"
+	  ><p
+	    >Fixed size vectors.</p
+	    ><ul
+	    ><li
+	      >Lists with their length encoded in their type</li
+	      ><li
+	      ><code
+		><a href="#"
+		  >Vec</a
+		  ></code
+		>tor elements have an <strong
+		>ASCENDING</strong
+		> subscript starting from 0 and
+   ending at <code
+		><code
+		  ><a href="#"
+		    >length</a
+		    ></code
+		  > - 1</code
+		>.</li
+	      ></ul
+	    ></div
+	  ><div class="subs constructors"
+	  ><p class="caption"
+	    >Constructors</p
+	    ><table
+	    ><tr
+	      ><td class="src"
+		><a id="v:Nil" class="def"
+		  >Nil</a
+		  > :: <a href="#"
+		  >Vec</a
+		  > 0 a</td
+		><td class="doc empty"
+		></td
+		></tr
+	      ></table
+	    ></div
+	  ><div class="subs bundled-patterns"
+	  ><p class="caption"
+	    >Bundled Patterns</p
+	    ><table
+	    ><tr
+	      ><td class="src"
+		><span class="keyword"
+		  >pattern</span
+		  > <a id="v::-62-" class="def"
+		  >(:&gt;)</a
+		  > :: a -&gt; <a href="#"
+		  >Vec</a
+		  > n a -&gt; <a href="#"
+		  >Vec</a
+		  > (n <a href="#"
+		  >+</a
+		  > 1) a <span class="fixity"
+		  >infixr 5</span
+		  ><span class="rightedge"
+		  ></span
+		  ></td
+		><td class="doc"
+		><p
+		  >Add an element to the head of a vector.</p
+		  ><pre class="screen"
+		  ><code class="prompt"
+		    >&gt;&gt;&gt; </code
+		    ><strong class="userinput"
+		    ><code
+		      >3:&gt;4:&gt;5:&gt;Nil
+</code
+		      ></strong
+		    >&lt;3,4,5&gt;
+<code class="prompt"
+		    >&gt;&gt;&gt; </code
+		    ><strong class="userinput"
+		    ><code
+		      >let x = 3:&gt;4:&gt;5:&gt;Nil
+</code
+		      ></strong
+		    ><code class="prompt"
+		    >&gt;&gt;&gt; </code
+		    ><strong class="userinput"
+		    ><code
+		      >:t x
+</code
+		      ></strong
+		    >x :: Num a =&gt; Vec 3 a
+</pre
+		  ><p
+		  >Can be used as a pattern:</p
+		  ><pre class="screen"
+		  ><code class="prompt"
+		    >&gt;&gt;&gt; </code
+		    ><strong class="userinput"
+		    ><code
+		      >let f (x :&gt; y :&gt; _) = x + y
+</code
+		      ></strong
+		    ><code class="prompt"
+		    >&gt;&gt;&gt; </code
+		    ><strong class="userinput"
+		    ><code
+		      >:t f
+</code
+		      ></strong
+		    >f :: Num a =&gt; Vec ((n + 1) + 1) a -&gt; a
+<code class="prompt"
+		    >&gt;&gt;&gt; </code
+		    ><strong class="userinput"
+		    ><code
+		      >f (3:&gt;4:&gt;5:&gt;6:&gt;7:&gt;Nil)
+</code
+		      ></strong
+		    >7
+</pre
+		  ><p
+		  >Also in conjunctions with (<code
+		    >:&lt;</code
+		    >):</p
+		  ><pre class="screen"
+		  ><code class="prompt"
+		    >&gt;&gt;&gt; </code
+		    ><strong class="userinput"
+		    ><code
+		      >let g (a :&gt; b :&gt; (_ :&lt; y :&lt; x)) = a + b +  x + y
+</code
+		      ></strong
+		    ><code class="prompt"
+		    >&gt;&gt;&gt; </code
+		    ><strong class="userinput"
+		    ><code
+		      >:t g
+</code
+		      ></strong
+		    >g :: Num a =&gt; Vec ((((n + 1) + 1) + 1) + 1) a -&gt; a
+<code class="prompt"
+		    >&gt;&gt;&gt; </code
+		    ><strong class="userinput"
+		    ><code
+		      >g (1:&gt;2:&gt;3:&gt;4:&gt;5:&gt;Nil)
+</code
+		      ></strong
+		    >12
+</pre
+		  ></td
+		></tr
+	      ></table
+	    ></div
+	  ></div
+	><div class="top"
+	><p class="src"
+	  ><span class="keyword"
+	    >data</span
+	    > <a id="t:RTree" class="def"
+	    >RTree</a
+	    > :: <a href="#"
+	    >Nat</a
+	    > -&gt; <a href="#"
+	    >*</a
+	    > -&gt; <a href="#"
+	    >*</a
+	    > <span class="keyword"
+	    >where</span
+	    > <a href="#" class="selflink"
+	    >#</a
+	    ></p
+	  ><div class="doc"
+	  ><p
+	    >Perfect depth binary tree.</p
+	    ><ul
+	    ><li
+	      >Only has elements at the leaf of the tree</li
+	      ><li
+	      >A tree of depth <em
+		>d</em
+		> has <em
+		>2^d</em
+		> elements.</li
+	      ></ul
+	    ></div
+	  ><div class="subs bundled-patterns"
+	  ><p class="caption"
+	    >Bundled Patterns</p
+	    ><table
+	    ><tr
+	      ><td class="src"
+		><span class="keyword"
+		  >pattern</span
+		  > <a id="v:LR" class="def"
+		  >LR</a
+		  > :: a -&gt; <a href="#"
+		  >RTree</a
+		  > 0 a</td
+		><td class="doc"
+		><p
+		  >Leaf of a perfect depth tree</p
+		  ><pre class="screen"
+		  ><code class="prompt"
+		    >&gt;&gt;&gt; </code
+		    ><strong class="userinput"
+		    ><code
+		      >LR 1
+</code
+		      ></strong
+		    >1
+<code class="prompt"
+		    >&gt;&gt;&gt; </code
+		    ><strong class="userinput"
+		    ><code
+		      >let x = LR 1
+</code
+		      ></strong
+		    ><code class="prompt"
+		    >&gt;&gt;&gt; </code
+		    ><strong class="userinput"
+		    ><code
+		      >:t x
+</code
+		      ></strong
+		    >x :: Num a =&gt; RTree 0 a
+</pre
+		  ><p
+		  >Can be used as a pattern:</p
+		  ><pre class="screen"
+		  ><code class="prompt"
+		    >&gt;&gt;&gt; </code
+		    ><strong class="userinput"
+		    ><code
+		      >let f (LR a) (LR b) = a + b
+</code
+		      ></strong
+		    ><code class="prompt"
+		    >&gt;&gt;&gt; </code
+		    ><strong class="userinput"
+		    ><code
+		      >:t f
+</code
+		      ></strong
+		    >f :: Num a =&gt; RTree 0 a -&gt; RTree 0 a -&gt; a
+<code class="prompt"
+		    >&gt;&gt;&gt; </code
+		    ><strong class="userinput"
+		    ><code
+		      >f (LR 1) (LR 2)
+</code
+		      ></strong
+		    >3
+</pre
+		  ></td
+		></tr
+	      ><tr
+	      ><td class="src"
+		><span class="keyword"
+		  >pattern</span
+		  > <a id="v:BR" class="def"
+		  >BR</a
+		  > :: <a href="#"
+		  >RTree</a
+		  > d a -&gt; <a href="#"
+		  >RTree</a
+		  > d a -&gt; <a href="#"
+		  >RTree</a
+		  > (d <a href="#"
+		  >+</a
+		  > 1) a</td
+		><td class="doc"
+		><p
+		  >Branch of a perfect depth tree</p
+		  ><pre class="screen"
+		  ><code class="prompt"
+		    >&gt;&gt;&gt; </code
+		    ><strong class="userinput"
+		    ><code
+		      >BR (LR 1) (LR 2)
+</code
+		      ></strong
+		    >&lt;1,2&gt;
+<code class="prompt"
+		    >&gt;&gt;&gt; </code
+		    ><strong class="userinput"
+		    ><code
+		      >let x = BR (LR 1) (LR 2)
+</code
+		      ></strong
+		    ><code class="prompt"
+		    >&gt;&gt;&gt; </code
+		    ><strong class="userinput"
+		    ><code
+		      >:t x
+</code
+		      ></strong
+		    >x :: Num a =&gt; RTree 1 a
+</pre
+		  ><p
+		  >Case be used a pattern:</p
+		  ><pre class="screen"
+		  ><code class="prompt"
+		    >&gt;&gt;&gt; </code
+		    ><strong class="userinput"
+		    ><code
+		      >let f (BR (LR a) (LR b)) = LR (a + b)
+</code
+		      ></strong
+		    ><code class="prompt"
+		    >&gt;&gt;&gt; </code
+		    ><strong class="userinput"
+		    ><code
+		      >:t f
+</code
+		      ></strong
+		    >f :: Num a =&gt; RTree 1 a -&gt; RTree 0 a
+<code class="prompt"
+		    >&gt;&gt;&gt; </code
+		    ><strong class="userinput"
+		    ><code
+		      >f (BR (LR 1) (LR 2))
+</code
+		      ></strong
+		    >3
+</pre
+		  ></td
+		></tr
+	      ></table
+	    ></div
+	  ></div
+	></div
+      ></div
+    ><div id="footer"
+    ></div
+    ></body
+  ></html
+>
\ No newline at end of file
diff --git a/html-test/ref/BundledPatterns2.html b/html-test/ref/BundledPatterns2.html
new file mode 100644
index 00000000..3d1d4da0
--- /dev/null
+++ b/html-test/ref/BundledPatterns2.html
@@ -0,0 +1,472 @@
+<html xmlns="http://www.w3.org/1999/xhtml"
+><head
+  ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"
+     /><title
+    >BundledPatterns2</title
+    ><link href="#" rel="stylesheet" type="text/css" title="Ocean"
+     /><script src="haddock-util.js" type="text/javascript"
+    ></script
+    ><script src="https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.0/MathJax.js?config=TeX-AMS-MML_HTMLorMML" type="text/javascript"
+    ></script
+    ><script type="text/javascript"
+    >//
+window.onload = function () {pageLoad();};
+//
+</script
+    ></head
+  ><body
+  ><div id="package-header"
+    ><ul class="links" id="page-menu"
+      ><li
+	><a href="#"
+	  >Contents</a
+	  ></li
+	><li
+	><a href="#"
+	  >Index</a
+	  ></li
+	></ul
+      ><p class="caption empty"
+      ></p
+      ></div
+    ><div id="content"
+    ><div id="module-header"
+      ><table class="info"
+	><tr
+	  ><th
+	    >Safe Haskell</th
+	    ><td
+	    >None</td
+	    ></tr
+	  ></table
+	><p class="caption"
+	>BundledPatterns2</p
+	></div
+      ><div id="synopsis"
+      ><p id="control.syn" class="caption expander" onclick="toggleSection('syn')"
+	>Synopsis</p
+	><ul id="section.syn" class="hide" onclick="toggleSection('syn')"
+	><li class="src short"
+	  ><span class="keyword"
+	    >data</span
+	    > <a href="#"
+	    >Vec</a
+	    > :: <a href="#"
+	    >Nat</a
+	    > -&gt; <a href="#"
+	    >*</a
+	    > -&gt; <a href="#"
+	    >*</a
+	    > <span class="keyword"
+	    >where</span
+	    ><ul class="subs"
+	    ><li
+	      ><span class="keyword"
+		>pattern</span
+		> <a href="#"
+ 		>Empty</a
+ 		> :: <a href="#"
+ 		>Vec</a
+ 		> 0 a</li
+ 	      ><li
+ 	      ><span class="keyword"
+ 		>pattern</span
+ 		> <a href="#"
+		>(:&gt;)</a
+		> :: a -&gt; <a href="#"
+		>Vec</a
+		> n a -&gt; <a href="#"
+		>Vec</a
+		> (n <a href="#"
+		>+</a
+		> 1) a</li
+	      ></ul
+	    ></li
+	  ><li class="src short"
+	  ><span class="keyword"
+	    >data</span
+	    > <a href="#"
+	    >RTree</a
+	    > :: <a href="#"
+	    >Nat</a
+	    > -&gt; <a href="#"
+	    >*</a
+	    > -&gt; <a href="#"
+	    >*</a
+	    > <span class="keyword"
+	    >where</span
+	    ><ul class="subs"
+	    ><li
+	      ><span class="keyword"
+		>pattern</span
+		> <a href="#"
+		>LR</a
+		> :: a -&gt; <a href="#"
+		>RTree</a
+		> 0 a</li
+	      ><li
+	      ><span class="keyword"
+		>pattern</span
+		> <a href="#"
+		>BR</a
+		> :: <a href="#"
+		>RTree</a
+		> d a -&gt; <a href="#"
+		>RTree</a
+		> d a -&gt; <a href="#"
+		>RTree</a
+		> (d <a href="#"
+		>+</a
+		> 1) a</li
+	      ></ul
+	    ></li
+	  ></ul
+	></div
+      ><div id="interface"
+      ><h1
+	>Documentation</h1
+	><div class="top"
+	><p class="src"
+	  ><span class="keyword"
+	    >data</span
+	    > <a id="t:Vec" class="def"
+	    >Vec</a
+	    > :: <a href="#"
+	    >Nat</a
+	    > -&gt; <a href="#"
+	    >*</a
+	    > -&gt; <a href="#"
+	    >*</a
+	    > <span class="keyword"
+	    >where</span
+	    > <a href="#" class="selflink"
+	    >#</a
+	    ></p
+	  ><div class="doc"
+	  ><p
+	    >Fixed size vectors.</p
+	    ><ul
+	    ><li
+	      >Lists with their length encoded in their type</li
+	      ><li
+	      ><code
+		><a href="#"
+		  >Vec</a
+		  ></code
+		>tor elements have an <strong
+		>ASCENDING</strong
+		> subscript starting from 0 and
+   ending at <code
+		><code
+		  ><a href="#"
+		    >length</a
+		    ></code
+		  > - 1</code
+		>.</li
+	      ></ul
+	    ></div
+	  ><div class="subs bundled-patterns"
+	  ><p class="caption"
+	    >Bundled Patterns</p
+	    ><table
+	    ><tr
+	      ><td class="src"
+		><span class="keyword"
+		  >pattern</span
+ 		  > <a id="v:Empty" class="def"
+ 		  >Empty</a
+ 		  > :: <a href="#"
+ 		  >Vec</a
+ 		  > 0 a</td
+ 		><td class="doc empty"
+ 		></td
+ 		></tr
+ 	      ><tr
+ 	      ><td class="src"
+ 		><span class="keyword"
+ 		  >pattern</span
+		  > <a id="v::-62-" class="def"
+		  >(:&gt;)</a
+		  > :: a -&gt; <a href="#"
+		  >Vec</a
+		  > n a -&gt; <a href="#"
+		  >Vec</a
+		  > (n <a href="#"
+		  >+</a
+		  > 1) a <span class="fixity"
+		  >infixr 5</span
+		  ><span class="rightedge"
+		  ></span
+		  ></td
+		><td class="doc"
+		><p
+		  >Add an element to the head of a vector.</p
+		  ><pre class="screen"
+		  ><code class="prompt"
+		    >&gt;&gt;&gt; </code
+		    ><strong class="userinput"
+		    ><code
+		      >3:&gt;4:&gt;5:&gt;Nil
+</code
+		      ></strong
+		    >&lt;3,4,5&gt;
+<code class="prompt"
+		    >&gt;&gt;&gt; </code
+		    ><strong class="userinput"
+		    ><code
+		      >let x = 3:&gt;4:&gt;5:&gt;Nil
+</code
+		      ></strong
+		    ><code class="prompt"
+		    >&gt;&gt;&gt; </code
+		    ><strong class="userinput"
+		    ><code
+		      >:t x
+</code
+		      ></strong
+		    >x :: Num a =&gt; Vec 3 a
+</pre
+		  ><p
+		  >Can be used as a pattern:</p
+		  ><pre class="screen"
+		  ><code class="prompt"
+		    >&gt;&gt;&gt; </code
+		    ><strong class="userinput"
+		    ><code
+		      >let f (x :&gt; y :&gt; _) = x + y
+</code
+		      ></strong
+		    ><code class="prompt"
+		    >&gt;&gt;&gt; </code
+		    ><strong class="userinput"
+		    ><code
+		      >:t f
+</code
+		      ></strong
+		    >f :: Num a =&gt; Vec ((n + 1) + 1) a -&gt; a
+<code class="prompt"
+		    >&gt;&gt;&gt; </code
+		    ><strong class="userinput"
+		    ><code
+		      >f (3:&gt;4:&gt;5:&gt;6:&gt;7:&gt;Nil)
+</code
+		      ></strong
+		    >7
+</pre
+		  ><p
+		  >Also in conjunctions with (<code
+		    >:&lt;</code
+		    >):</p
+		  ><pre class="screen"
+		  ><code class="prompt"
+		    >&gt;&gt;&gt; </code
+		    ><strong class="userinput"
+		    ><code
+		      >let g (a :&gt; b :&gt; (_ :&lt; y :&lt; x)) = a + b +  x + y
+</code
+		      ></strong
+		    ><code class="prompt"
+		    >&gt;&gt;&gt; </code
+		    ><strong class="userinput"
+		    ><code
+		      >:t g
+</code
+		      ></strong
+		    >g :: Num a =&gt; Vec ((((n + 1) + 1) + 1) + 1) a -&gt; a
+<code class="prompt"
+		    >&gt;&gt;&gt; </code
+		    ><strong class="userinput"
+		    ><code
+		      >g (1:&gt;2:&gt;3:&gt;4:&gt;5:&gt;Nil)
+</code
+		      ></strong
+		    >12
+</pre
+		  ></td
+		></tr
+	      ></table
+	    ></div
+	  ></div
+	><div class="top"
+	><p class="src"
+	  ><span class="keyword"
+	    >data</span
+	    > <a id="t:RTree" class="def"
+	    >RTree</a
+	    > :: <a href="#"
+	    >Nat</a
+	    > -&gt; <a href="#"
+	    >*</a
+	    > -&gt; <a href="#"
+	    >*</a
+	    > <span class="keyword"
+	    >where</span
+	    > <a href="#" class="selflink"
+	    >#</a
+	    ></p
+	  ><div class="doc"
+	  ><p
+	    >Perfect depth binary tree.</p
+	    ><ul
+	    ><li
+	      >Only has elements at the leaf of the tree</li
+	      ><li
+	      >A tree of depth <em
+		>d</em
+		> has <em
+		>2^d</em
+		> elements.</li
+	      ></ul
+	    ></div
+	  ><div class="subs bundled-patterns"
+	  ><p class="caption"
+	    >Bundled Patterns</p
+	    ><table
+	    ><tr
+	      ><td class="src"
+		><span class="keyword"
+		  >pattern</span
+		  > <a id="v:LR" class="def"
+		  >LR</a
+		  > :: a -&gt; <a href="#"
+		  >RTree</a
+		  > 0 a</td
+		><td class="doc"
+		><p
+		  >Leaf of a perfect depth tree</p
+		  ><pre class="screen"
+		  ><code class="prompt"
+		    >&gt;&gt;&gt; </code
+		    ><strong class="userinput"
+		    ><code
+		      >LR 1
+</code
+		      ></strong
+		    >1
+<code class="prompt"
+		    >&gt;&gt;&gt; </code
+		    ><strong class="userinput"
+		    ><code
+		      >let x = LR 1
+</code
+		      ></strong
+		    ><code class="prompt"
+		    >&gt;&gt;&gt; </code
+		    ><strong class="userinput"
+		    ><code
+		      >:t x
+</code
+		      ></strong
+		    >x :: Num a =&gt; RTree 0 a
+</pre
+		  ><p
+		  >Can be used as a pattern:</p
+		  ><pre class="screen"
+		  ><code class="prompt"
+		    >&gt;&gt;&gt; </code
+		    ><strong class="userinput"
+		    ><code
+		      >let f (LR a) (LR b) = a + b
+</code
+		      ></strong
+		    ><code class="prompt"
+		    >&gt;&gt;&gt; </code
+		    ><strong class="userinput"
+		    ><code
+		      >:t f
+</code
+		      ></strong
+		    >f :: Num a =&gt; RTree 0 a -&gt; RTree 0 a -&gt; a
+<code class="prompt"
+		    >&gt;&gt;&gt; </code
+		    ><strong class="userinput"
+		    ><code
+		      >f (LR 1) (LR 2)
+</code
+		      ></strong
+		    >3
+</pre
+		  ></td
+		></tr
+	      ><tr
+	      ><td class="src"
+		><span class="keyword"
+		  >pattern</span
+		  > <a id="v:BR" class="def"
+		  >BR</a
+		  > :: <a href="#"
+		  >RTree</a
+		  > d a -&gt; <a href="#"
+		  >RTree</a
+		  > d a -&gt; <a href="#"
+		  >RTree</a
+		  > (d <a href="#"
+		  >+</a
+		  > 1) a</td
+		><td class="doc"
+		><p
+		  >Branch of a perfect depth tree</p
+		  ><pre class="screen"
+		  ><code class="prompt"
+		    >&gt;&gt;&gt; </code
+		    ><strong class="userinput"
+		    ><code
+		      >BR (LR 1) (LR 2)
+</code
+		      ></strong
+		    >&lt;1,2&gt;
+<code class="prompt"
+		    >&gt;&gt;&gt; </code
+		    ><strong class="userinput"
+		    ><code
+		      >let x = BR (LR 1) (LR 2)
+</code
+		      ></strong
+		    ><code class="prompt"
+		    >&gt;&gt;&gt; </code
+		    ><strong class="userinput"
+		    ><code
+		      >:t x
+</code
+		      ></strong
+		    >x :: Num a =&gt; RTree 1 a
+</pre
+		  ><p
+		  >Case be used a pattern:</p
+		  ><pre class="screen"
+		  ><code class="prompt"
+		    >&gt;&gt;&gt; </code
+		    ><strong class="userinput"
+		    ><code
+		      >let f (BR (LR a) (LR b)) = LR (a + b)
+</code
+		      ></strong
+		    ><code class="prompt"
+		    >&gt;&gt;&gt; </code
+		    ><strong class="userinput"
+		    ><code
+		      >:t f
+</code
+		      ></strong
+		    >f :: Num a =&gt; RTree 1 a -&gt; RTree 0 a
+<code class="prompt"
+		    >&gt;&gt;&gt; </code
+		    ><strong class="userinput"
+		    ><code
+		      >f (BR (LR 1) (LR 2))
+</code
+		      ></strong
+		    >3
+</pre
+		  ></td
+		></tr
+	      ></table
+	    ></div
+	  ></div
+	></div
+      ></div
+    ><div id="footer"
+    ></div
+    ></body
+  ></html
+>
\ No newline at end of file
diff --git a/html-test/src/BundledPatterns.hs b/html-test/src/BundledPatterns.hs
new file mode 100644
index 00000000..443e64fa
--- /dev/null
+++ b/html-test/src/BundledPatterns.hs
@@ -0,0 +1,110 @@
+{-# LANGUAGE DataKinds, GADTs, KindSignatures, PatternSynonyms, TypeOperators,
+             ViewPatterns #-}
+module BundledPatterns (Vec(Nil,(:>)), RTree (LR,BR)) where
+
+import GHC.TypeLits
+import Prelude hiding (head, tail)
+import Unsafe.Coerce
+
+-- | Fixed size vectors.
+--
+-- * Lists with their length encoded in their type
+-- * 'Vec'tor elements have an __ASCENDING__ subscript starting from 0 and
+--   ending at @'length' - 1@.
+data Vec :: Nat -> * -> * where
+  Nil  :: Vec 0 a
+  Cons :: a -> Vec n a -> Vec (n + 1) a
+
+infixr 5 `Cons`
+
+-- | Add an element to the head of a vector.
+--
+-- >>> 3:>4:>5:>Nil
+-- <3,4,5>
+-- >>> let x = 3:>4:>5:>Nil
+-- >>> :t x
+-- x :: Num a => Vec 3 a
+--
+-- Can be used as a pattern:
+--
+-- >>> let f (x :> y :> _) = x + y
+-- >>> :t f
+-- f :: Num a => Vec ((n + 1) + 1) a -> a
+-- >>> f (3:>4:>5:>6:>7:>Nil)
+-- 7
+--
+-- Also in conjunctions with (':<'):
+--
+-- >>> let g (a :> b :> (_ :< y :< x)) = a + b +  x + y
+-- >>> :t g
+-- g :: Num a => Vec ((((n + 1) + 1) + 1) + 1) a -> a
+-- >>> g (1:>2:>3:>4:>5:>Nil)
+-- 12
+pattern (:>) :: a -> Vec n a -> Vec (n + 1) a
+pattern (:>) x xs <- ((\ys -> (head ys,tail ys)) -> (x,xs))
+  where
+    (:>) x xs = Cons x xs
+
+infixr 5 :>
+
+head :: Vec (n + 1) a -> a
+head (x `Cons` _) = x
+
+tail :: Vec (n + 1) a -> Vec n a
+tail (_ `Cons` xs) = unsafeCoerce xs
+
+-- | Perfect depth binary tree.
+--
+-- * Only has elements at the leaf of the tree
+-- * A tree of depth /d/ has /2^d/ elements.
+data RTree :: Nat -> * -> * where
+  LR_ :: a -> RTree 0 a
+  BR_ :: RTree d a -> RTree d a -> RTree (d+1) a
+
+textract :: RTree 0 a -> a
+textract (LR_ x) = x
+{-# NOINLINE textract #-}
+
+tsplit :: RTree (d+1) a -> (RTree d a,RTree d a)
+tsplit (BR_ l r) = (unsafeCoerce l, unsafeCoerce r)
+{-# NOINLINE tsplit #-}
+
+-- | Leaf of a perfect depth tree
+--
+-- >>> LR 1
+-- 1
+-- >>> let x = LR 1
+-- >>> :t x
+-- x :: Num a => RTree 0 a
+--
+-- Can be used as a pattern:
+--
+-- >>> let f (LR a) (LR b) = a + b
+-- >>> :t f
+-- f :: Num a => RTree 0 a -> RTree 0 a -> a
+-- >>> f (LR 1) (LR 2)
+-- 3
+pattern LR :: a -> RTree 0 a
+pattern LR x <- (textract -> x)
+  where
+    LR x = LR_ x
+
+-- | Branch of a perfect depth tree
+--
+-- >>> BR (LR 1) (LR 2)
+-- <1,2>
+-- >>> let x = BR (LR 1) (LR 2)
+-- >>> :t x
+-- x :: Num a => RTree 1 a
+--
+-- Case be used a pattern:
+--
+-- >>> let f (BR (LR a) (LR b)) = LR (a + b)
+-- >>> :t f
+-- f :: Num a => RTree 1 a -> RTree 0 a
+-- >>> f (BR (LR 1) (LR 2))
+-- 3
+pattern BR :: RTree d a -> RTree d a -> RTree (d+1) a
+pattern BR l r <- ((\t -> (tsplit t)) -> (l,r))
+  where
+    BR l r = BR_ l r
diff --git a/html-test/src/BundledPatterns2.hs b/html-test/src/BundledPatterns2.hs
new file mode 100644
index 00000000..5e9a83a7
--- /dev/null
+++ b/html-test/src/BundledPatterns2.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE DataKinds, GADTs, KindSignatures, PatternSynonyms, TypeOperators,
+             ViewPatterns #-}
+module BundledPatterns2 (Vec((:>), Empty), RTree(..)) where
+
+import GHC.TypeLits
+
+import BundledPatterns
+
+pattern Empty :: Vec 0 a
+pattern Empty <- Nil
-- 
cgit v1.2.3


From d5d8cd1722b06f17155e830f2242a073b0a983eb Mon Sep 17 00:00:00 2001
From: Doug Wilson <dwilson@ricoh.co.nz>
Date: Fri, 23 Jun 2017 06:23:29 +1200
Subject: Use new function getNameToInstancesIndex instead of tcRnGetInfo
 (#639)

* Use new function getNameToInstancesIndex instead of tcRnGetInfo

There is some significant performance improvement in the ghc testsuite.

haddock.base: -23.3%
haddock.Cabal: -16.7%
haddock.compiler: -19.8%

* Remove unused imports
---
 .../src/Haddock/Interface/AttachInstances.hs       | 82 +++++++++++-----------
 1 file changed, 40 insertions(+), 42 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index 7a3182b8..527c6bcc 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -21,7 +21,7 @@ import Haddock.GhcUtils
 import Control.Arrow hiding ((<+>))
 import Data.List
 import Data.Ord (comparing)
-import Data.Maybe ( maybeToList, mapMaybe )
+import Data.Maybe ( maybeToList, mapMaybe, fromMaybe )
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 
@@ -32,14 +32,13 @@ import ErrUtils
 import FamInstEnv
 import FastString
 import GHC
-import GhcMonad (withSession)
 import InstEnv
 import MonadUtils (liftIO)
 import Name
+import NameEnv
 import Outputable (text, sep, (<+>))
 import PrelNames
 import SrcLoc
-import TcRnDriver (tcRnGetInfo)
 import TyCon
 import TyCoRep
 import TysPrim( funTyCon )
@@ -52,13 +51,15 @@ type ExportInfo = (ExportedNames, Modules)
 
 -- Also attaches fixities
 attachInstances :: ExportInfo -> [Interface] -> InstIfaceMap -> Ghc [Interface]
-attachInstances expInfo ifaces instIfaceMap = mapM attach ifaces
+attachInstances expInfo ifaces instIfaceMap = do
+  (_msgs, mb_index) <- getNameToInstancesIndex
+  mapM (attach $ fromMaybe emptyNameEnv mb_index) ifaces
   where
     -- TODO: take an IfaceMap as input
     ifaceMap = Map.fromList [ (ifaceMod i, i) | i <- ifaces ]
 
-    attach iface = do
-      newItems <- mapM (attachToExportItem expInfo iface ifaceMap instIfaceMap)
+    attach index iface = do
+      newItems <- mapM (attachToExportItem index expInfo iface ifaceMap instIfaceMap)
                        (ifaceExportItems iface)
       let orphanInstances = attachOrphanInstances expInfo iface ifaceMap instIfaceMap (ifaceInstances iface)
       return $ iface { ifaceExportItems = newItems
@@ -74,37 +75,42 @@ attachOrphanInstances expInfo iface ifaceMap instIfaceMap cls_instances =
   ]
 
 
-attachToExportItem :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap
-                   -> ExportItem Name
-                   -> Ghc (ExportItem Name)
-attachToExportItem expInfo iface ifaceMap instIfaceMap export =
+attachToExportItem
+  :: NameEnv ([ClsInst], [FamInst])
+  -> ExportInfo
+  -> Interface
+  -> IfaceMap
+  -> InstIfaceMap
+  -> ExportItem Name
+  -> Ghc (ExportItem Name)
+attachToExportItem index expInfo iface ifaceMap instIfaceMap export =
   case attachFixities export of
     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 = [ (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
-                          , not $ isNameHidden expInfo (fi_fam i)
-                          , not $ any (isTypeHidden expInfo) (fi_tys i)
-                          , let opaque = isTypeHidden expInfo (fi_rhs i)
-                          ]
-              cls_insts = [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, spanName n (synifyInstHead i) (L eSpan (tcdName d)))
-                          | let is = [ (instanceSig i, getName i) | i <- cls_instances ]
-                          , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is
-                          , not $ isInstanceHidden expInfo cls tys
-                          ]
+      insts <-
+        let mb_instances  = lookupNameEnv index (tcdName d)
+            cls_instances = maybeToList mb_instances >>= fst
+            fam_instances = maybeToList mb_instances >>= snd
+            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
+                        , not $ isNameHidden expInfo (fi_fam i)
+                        , not $ any (isTypeHidden expInfo) (fi_tys i)
+                        , let opaque = isTypeHidden expInfo (fi_rhs i)
+                        ]
+            cls_insts = [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, spanName n (synifyInstHead i) (L eSpan (tcdName d)))
+                        | let is = [ (instanceSig 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 = [ (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
-            liftIO $ putMsg dfs (sep $ map mkBug famInstErrs)
-            return $ cls_insts ++ cleanFamInsts
-        Nothing -> return []
+            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
+          liftIO $ putMsg dfs (sep $ map mkBug famInstErrs)
+          return $ cls_insts ++ cleanFamInsts
       return $ e { expItemInstances = insts }
     e -> return e
   where
@@ -145,14 +151,6 @@ instLookup f name iface ifaceMap instIfaceMap =
       iface' <- Map.lookup (nameModule name) ifaceMaps
       Map.lookup name (f iface')
 
--- | Like GHC's getInfo but doesn't cut things out depending on the
--- interative context, which we don't set sufficiently anyway.
-getAllInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[ClsInst],[FamInst]))
-getAllInfo name = withSession $ \hsc_env -> do
-   (_msgs, r) <- liftIO $ tcRnGetInfo hsc_env name
-   return r
-
-
 --------------------------------------------------------------------------------
 -- Collecting and sorting instances
 --------------------------------------------------------------------------------
-- 
cgit v1.2.3


From cf7addb983bd2079b221199f8ec09c8edaeb8956 Mon Sep 17 00:00:00 2001
From: Alex Biehl <alexbiehl@gmail.com>
Date: Fri, 23 Jun 2017 14:44:41 +0200
Subject: Lookup fixities for reexports without subordinates (#642)

So we agree that reexported declarations which do not have subordinates (for example top-level functions) shouldn't have gotten fixities reexported according to the current logic. I wondered why for example Prelude.($) which is obviously reexported from GHC.Base has fixities attached (c.f. http://hackage.haskell.org/package/base-4.9.1.0/docs/Prelude.html#v:-36-).

The reason is this: In mkMaps we lookup all the subordinates of top-level declarations, of course top-level functions don't have subordinates so for them the resulting list is empty. In #644 I established the invariant that there won't be any empty lists in the subordinate map. Without the patch from #642 top-level functions now started to fail reexporting their fixities.
---
 haddock-api/src/Haddock/Interface/AttachInstances.hs | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index 527c6bcc..a2cdb752 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -18,6 +18,7 @@ import Haddock.Types
 import Haddock.Convert
 import Haddock.GhcUtils
 
+import Control.Applicative
 import Control.Arrow hiding ((<+>))
 import Data.List
 import Data.Ord (comparing)
@@ -119,7 +120,7 @@ attachToExportItem index expInfo iface ifaceMap instIfaceMap export =
                                } = e { expItemFixities =
       nubByName fst $ expItemFixities e ++
       [ (n',f) | n <- getMainDeclBinder d
-              , Just subs <- [instLookup instSubMap n iface ifaceMap instIfaceMap]
+              , Just subs <- [instLookup instSubMap n iface ifaceMap instIfaceMap <|> Just []]
               , n' <- n : (subs ++ patsyn_names)
               , Just f <- [instLookup instFixMap n' iface ifaceMap instIfaceMap]
       ] }
-- 
cgit v1.2.3


From 2d919a367139482cd76398ca1e90dff6f5427779 Mon Sep 17 00:00:00 2001
From: Alex Biehl <alexbiehl@gmail.com>
Date: Fri, 23 Jun 2017 18:30:45 +0200
Subject: Don't include names with empty subordinates in maps (#644)

These are unecessary anyway and just blow up interface size
---
 haddock-api/src/Haddock/Interface/Create.hs | 10 +++-
 html-test/ref/PR643.html                    | 80 +++++++++++++++++++++++++++++
 html-test/src/PR643.hs                      |  3 ++
 html-test/src/PR643_1.hs                    |  7 +++
 4 files changed, 99 insertions(+), 1 deletion(-)
 create mode 100644 html-test/ref/PR643.html
 create mode 100644 html-test/src/PR643.hs
 create mode 100644 html-test/src/PR643_1.hs

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 0984894d..50643e2a 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -317,7 +317,12 @@ mkMaps :: DynFlags
 mkMaps dflags gre instances decls =
   let
     (a, b, c, d) = unzip4 $ map mappings decls
-  in (f' $ map (nubByName fst) a , f b, f c, f d, instanceMap)
+  in ( f' (map (nubByName fst) a)
+     , f  (filterMapping (not . M.null) b)
+     , f  (filterMapping (not . null) c)
+     , f  (filterMapping (not . null) d)
+     , instanceMap
+     )
   where
     f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b
     f = M.fromListWith (<>) . concat
@@ -325,6 +330,9 @@ mkMaps dflags gre instances decls =
     f' :: [[(Name, MDoc Name)]] -> Map Name (MDoc Name)
     f' = M.fromListWith metaDocAppend . concat
 
+    filterMapping :: (b -> Bool) ->  [[(a, b)]] -> [[(a, b)]]
+    filterMapping p = map (filter (p . snd))
+
     mappings :: (LHsDecl Name, [HsDocString])
              -> ( [(Name, MDoc Name)]
                 , [(Name, Map Int (MDoc Name))]
diff --git a/html-test/ref/PR643.html b/html-test/ref/PR643.html
new file mode 100644
index 00000000..46e1e7ed
--- /dev/null
+++ b/html-test/ref/PR643.html
@@ -0,0 +1,80 @@
+<html xmlns="http://www.w3.org/1999/xhtml"
+><head
+  ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"
+     /><title
+    >PR643</title
+    ><link href="#" rel="stylesheet" type="text/css" title="Ocean"
+     /><script src="haddock-util.js" type="text/javascript"
+    ></script
+    ><script src="https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.0/MathJax.js?config=TeX-AMS-MML_HTMLorMML" type="text/javascript"
+    ></script
+    ><script type="text/javascript"
+    >//
+window.onload = function () {pageLoad();};
+//
+</script
+    ></head
+  ><body
+  ><div id="package-header"
+    ><ul class="links" id="page-menu"
+      ><li
+	><a href="#"
+	  >Contents</a
+	  ></li
+	><li
+	><a href="#"
+	  >Index</a
+	  ></li
+	></ul
+      ><p class="caption empty"
+      ></p
+      ></div
+    ><div id="content"
+    ><div id="module-header"
+      ><table class="info"
+	><tr
+	  ><th
+	    >Safe Haskell</th
+	    ><td
+	    >Safe</td
+	    ></tr
+	  ></table
+	><p class="caption"
+	>PR643</p
+	></div
+      ><div id="synopsis"
+      ><p id="control.syn" class="caption expander" onclick="toggleSection('syn')"
+	>Synopsis</p
+	><ul id="section.syn" class="hide" onclick="toggleSection('syn')"
+	><li class="src short"
+	  ><a href="#"
+	    >test</a
+	    > :: ()</li
+	  ></ul
+	></div
+      ><div id="interface"
+      ><h1
+	>Documentation</h1
+	><div class="top"
+	><p class="src"
+	  ><a id="v:test" class="def"
+	    >test</a
+	    > :: () <span class="fixity"
+	    >infixr 5</span
+	    ><span class="rightedge"
+	    ></span
+	    > <a href="#" class="selflink"
+	    >#</a
+	    ></p
+	  ><div class="doc"
+	  ><p
+	    >Some big documentation</p
+	    ></div
+	  ></div
+	></div
+      ></div
+    ><div id="footer"
+    ></div
+    ></body
+  ></html
+>
\ No newline at end of file
diff --git a/html-test/src/PR643.hs b/html-test/src/PR643.hs
new file mode 100644
index 00000000..565e5b57
--- /dev/null
+++ b/html-test/src/PR643.hs
@@ -0,0 +1,3 @@
+module PR643 (test) where
+
+import PR643_1
diff --git a/html-test/src/PR643_1.hs b/html-test/src/PR643_1.hs
new file mode 100644
index 00000000..ecd0db94
--- /dev/null
+++ b/html-test/src/PR643_1.hs
@@ -0,0 +1,7 @@
+module PR643_1 where
+
+infixr 5 `test`
+
+-- | Some big documentation
+test :: ()
+test = ()
-- 
cgit v1.2.3


From af3e6c7c027389df18b15ee9a9d72ffc97dc1852 Mon Sep 17 00:00:00 2001
From: Alex Biehl <alexbiehl@gmail.com>
Date: Thu, 29 Jun 2017 19:54:49 +0200
Subject: Make per-argument docs for class methods work again (#648)

* Make per-argument docs for class methods work again

* Test case
---
 CHANGES.md                                  |   6 +-
 haddock-api/src/Haddock/Interface/Create.hs |   5 +-
 html-test/ref/Bug647.html                   | 114 ++++++++++++++++++++++++++++
 html-test/src/Bug647.hs                     |   6 ++
 4 files changed, 127 insertions(+), 4 deletions(-)
 create mode 100644 html-test/ref/Bug647.html
 create mode 100644 html-test/src/Bug647.hs

(limited to 'haddock-api/src')

diff --git a/CHANGES.md b/CHANGES.md
index 628b0968..1cbaf62e 100644
--- a/CHANGES.md
+++ b/CHANGES.md
@@ -1,9 +1,11 @@
 ## Changes in version 2.18.0
 
- * Support user defined signatures on pattern synonyms
-
  * Synopsis is working again (#599)
 
+ * Per-argument documentation on class methods working again (#647)
+
+ * Support user defined signatures on pattern synonyms
+
  * Support for bundled pattern synonyms (#494, #551, #626)
 
 ## Changes in version 2.17.4
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 50643e2a..9227c378 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -429,8 +429,9 @@ typeDocs :: HsDecl Name -> Map Int HsDocString
 typeDocs d =
   let docs = go 0 in
   case d of
-    SigD (TypeSig _ ty)   -> docs (unLoc (hsSigWcType ty))
-    SigD (PatSynSig _ ty) -> docs (unLoc (hsSigType ty))
+    SigD (TypeSig _ ty)      -> docs (unLoc (hsSigWcType ty))
+    SigD (ClassOpSig _ _ ty) -> docs (unLoc (hsSigType ty))
+    SigD (PatSynSig _ ty)    -> docs (unLoc (hsSigType ty))
     ForD (ForeignImport _ ty _ _)   -> docs (unLoc (hsSigType ty))
     TyClD (SynDecl { tcdRhs = ty }) -> docs (unLoc ty)
     _ -> M.empty
diff --git a/html-test/ref/Bug647.html b/html-test/ref/Bug647.html
new file mode 100644
index 00000000..086840ab
--- /dev/null
+++ b/html-test/ref/Bug647.html
@@ -0,0 +1,114 @@
+<html xmlns="http://www.w3.org/1999/xhtml"
+><head
+  ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"
+     /><title
+    >Bug647</title
+    ><link href="#" rel="stylesheet" type="text/css" title="Ocean"
+     /><script src="haddock-util.js" type="text/javascript"
+    ></script
+    ><script src="https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.0/MathJax.js?config=TeX-AMS-MML_HTMLorMML" type="text/javascript"
+    ></script
+    ><script type="text/javascript"
+    >//
+window.onload = function () {pageLoad();};
+//
+</script
+    ></head
+  ><body
+  ><div id="package-header"
+    ><ul class="links" id="page-menu"
+      ><li
+	><a href="#"
+	  >Contents</a
+	  ></li
+	><li
+	><a href="#"
+	  >Index</a
+	  ></li
+	></ul
+      ><p class="caption empty"
+      ></p
+      ></div
+    ><div id="content"
+    ><div id="module-header"
+      ><table class="info"
+	><tr
+	  ><th
+	    >Safe Haskell</th
+	    ><td
+	    >Safe</td
+	    ></tr
+	  ></table
+	><p class="caption"
+	>Bug647</p
+	></div
+      ><div id="interface"
+      ><h1
+	>Documentation</h1
+	><div class="top"
+	><p class="src"
+	  ><span class="keyword"
+	    >class</span
+	    > <a id="t:Bug647" class="def"
+	    >Bug647</a
+	    > a <span class="keyword"
+	    >where</span
+	    > <a href="#" class="selflink"
+	    >#</a
+	    ></p
+	  ><div class="subs minimal"
+	  ><p class="caption"
+	    >Minimal complete definition</p
+	    ><p class="src"
+	    ><a href="#"
+	      >f</a
+	      ></p
+	    ></div
+	  ><div class="subs methods"
+	  ><p class="caption"
+	    >Methods</p
+	    ><p class="src"
+	    ><a id="v:f" class="def"
+	      >f</a
+	      > <a href="#" class="selflink"
+	      >#</a
+	      ></p
+	    ><div class="subs arguments"
+	    ><p class="caption"
+	      >Arguments</p
+	      ><table
+	      ><tr
+		><td class="src"
+		  >:: a</td
+		  ><td class="doc"
+		  ><p
+		    >doc for arg1</p
+		    ></td
+		  ></tr
+		><tr
+		><td class="src"
+		  >-&gt; a</td
+		  ><td class="doc"
+		  ><p
+		    >doc for arg2</p
+		    ></td
+		  ></tr
+		><tr
+		><td class="src"
+		  >-&gt; a</td
+		  ><td class="doc"
+		  ><p
+		    >doc for arg3</p
+		    ></td
+		  ></tr
+		></table
+	      ></div
+	    ></div
+	  ></div
+	></div
+      ></div
+    ><div id="footer"
+    ></div
+    ></body
+  ></html
+>
\ No newline at end of file
diff --git a/html-test/src/Bug647.hs b/html-test/src/Bug647.hs
new file mode 100644
index 00000000..4143092a
--- /dev/null
+++ b/html-test/src/Bug647.hs
@@ -0,0 +1,6 @@
+module Bug647 where
+
+class Bug647 a where
+	f :: a -- ^ doc for arg1
+	  -> a -- ^ doc for arg2
+	  -> a -- ^ doc for arg3
\ No newline at end of file
-- 
cgit v1.2.3


From 901b327f46dc4bd70cd310ae2c6339aa9ce572bb Mon Sep 17 00:00:00 2001
From: Bartosz Nitka <niteria@gmail.com>
Date: Sun, 2 Jul 2017 11:12:01 +0100
Subject: Fix haddock: internal error: links: UnhelpfulSpan (#561)

* Fix haddock: internal error: links: UnhelpfulSpan

This fixes #554 for me. I believe this is another fall out
of `wildcard-refactor`, like #549.

* Comment to clarify why we take the methods name location
---
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 6 ++++--
 haddock-api/src/Haddock/Convert.hs             | 4 ++--
 2 files changed, 6 insertions(+), 4 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 716050fa..cda0611a 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -635,8 +635,10 @@ ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification
 ppInstanceSigs links splice unicode qual sigs = do
     TypeSig lnames typ <- sigs
     let names = map unLoc lnames
-        L loc rtyp = hsSigWcType typ
-    return $ ppSimpleSig links splice unicode qual loc names rtyp
+        L _ rtyp = hsSigWcType typ
+    -- Instance methods signatures are synified and thus don't have a useful 
+    -- SrcSpan value. Use the methods name location instead.
+    return $ ppSimpleSig links splice unicode qual (getLoc $ head $ lnames) names rtyp
 
 
 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 577b1a3c..4aaaed9d 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -29,7 +29,7 @@ import Name
 import NameSet ( emptyNameSet )
 import RdrName ( mkVarUnqual )
 import PatSyn
-import SrcLoc ( Located, noLoc, unLoc )
+import SrcLoc ( Located, noLoc, unLoc, GenLocated(..), srcLocSpan )
 import TcType ( tcSplitSigmaTy )
 import TyCon
 import Type
@@ -318,7 +318,7 @@ synifyDataCon use_gadt_syntax dc =
                          , con_doc =  Nothing }
 
 synifyName :: NamedThing n => n -> Located Name
-synifyName = noLoc . getName
+synifyName n = L (srcLocSpan (getSrcLoc n)) (getName n)
 
 
 synifyIdSig :: SynifyTypeState -> Id -> Sig Name
-- 
cgit v1.2.3


From a330da5297106ff214cbb5e74965d9d1ef9dab7b Mon Sep 17 00:00:00 2001
From: Alex Biehl <alexbiehl@gmail.com>
Date: Mon, 3 Jul 2017 19:43:04 +0200
Subject: Document record fields when DuplicateRecordFields is enabled (#649)

---
 haddock-api/src/Haddock/Interface/Create.hs |   2 +-
 html-test/ref/DuplicateRecordFields.html    | 160 ++++++++++++++++++++++++++++
 html-test/src/DuplicateRecordFields.hs      |  25 +++++
 3 files changed, 186 insertions(+), 1 deletion(-)
 create mode 100644 html-test/ref/DuplicateRecordFields.html
 create mode 100644 html-test/src/DuplicateRecordFields.hs

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 9227c378..b9179d11 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -79,7 +79,7 @@ createInterface tm flags modMap instIfaceMap = do
       dflags         = ms_hspp_opts ms
       !instances     = modInfoInstances mi
       !fam_instances = md_fam_insts md
-      !exportedNames = modInfoExports mi
+      !exportedNames = modInfoExportsWithSelectors mi
 
       (TcGblEnv { tcg_rdr_env = gre
                 , tcg_warns   = warnings
diff --git a/html-test/ref/DuplicateRecordFields.html b/html-test/ref/DuplicateRecordFields.html
new file mode 100644
index 00000000..4430b50a
--- /dev/null
+++ b/html-test/ref/DuplicateRecordFields.html
@@ -0,0 +1,160 @@
+<html xmlns="http://www.w3.org/1999/xhtml"
+><head
+  ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"
+     /><title
+    >DuplicateRecordFields</title
+    ><link href="#" rel="stylesheet" type="text/css" title="Ocean"
+     /><script src="haddock-util.js" type="text/javascript"
+    ></script
+    ><script src="https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.0/MathJax.js?config=TeX-AMS-MML_HTMLorMML" type="text/javascript"
+    ></script
+    ><script type="text/javascript"
+    >//
+window.onload = function () {pageLoad();};
+//
+</script
+    ></head
+  ><body
+  ><div id="package-header"
+    ><ul class="links" id="page-menu"
+      ><li
+	><a href="#"
+	  >Contents</a
+	  ></li
+	><li
+	><a href="#"
+	  >Index</a
+	  ></li
+	></ul
+      ><p class="caption empty"
+      ></p
+      ></div
+    ><div id="content"
+    ><div id="module-header"
+      ><table class="info"
+	><tr
+	  ><th
+	    >Safe Haskell</th
+	    ><td
+	    >Safe</td
+	    ></tr
+	  ></table
+	><p class="caption"
+	>DuplicateRecordFields</p
+	></div
+      ><div id="interface"
+      ><h1
+	>Documentation</h1
+	><div class="top"
+	><p class="src"
+	  ><span class="keyword"
+	    >data</span
+	    > <a id="t:RawReplay" class="def"
+	    >RawReplay</a
+	    > <a href="#" class="selflink"
+	    >#</a
+	    ></p
+	  ><div class="subs constructors"
+	  ><p class="caption"
+	    >Constructors</p
+	    ><table
+	    ><tr
+	      ><td class="src"
+		><a id="v:RawReplay" class="def"
+		  >RawReplay</a
+		  ></td
+		><td class="doc empty"
+		></td
+		></tr
+	      ><tr
+	      ><td colspan="2"
+		><div class="subs fields"
+		  ><p class="caption"
+		    >Fields</p
+		    ><ul
+		    ><li
+		      ><dfn class="src"
+			><a id="v:headerSize" class="def"
+			  >headerSize</a
+			  > :: Int</dfn
+			><div class="doc"
+			><p
+			  >The byte size of the first section.</p
+			  ></div
+			></li
+		      ><li
+		      ><dfn class="src"
+			><a id="v:headerCRC" class="def"
+			  >headerCRC</a
+			  > :: Int</dfn
+			><div class="doc"
+			><p
+			  >The CRC of the first section.</p
+			  ></div
+			></li
+		      ><li
+		      ><dfn class="src"
+			><a id="v:header" class="def"
+			  >header</a
+			  > :: Int</dfn
+			><div class="doc"
+			><p
+			  >The first section.</p
+			  ></div
+			></li
+		      ><li
+		      ><dfn class="src"
+			><a id="v:contentSize" class="def"
+			  >contentSize</a
+			  > :: Int</dfn
+			><div class="doc"
+			><p
+			  >The byte size of the second section.</p
+			  ></div
+			></li
+		      ><li
+		      ><dfn class="src"
+			><a id="v:contentCRC" class="def"
+			  >contentCRC</a
+			  > :: Int</dfn
+			><div class="doc"
+			><p
+			  >The CRC of the second section.</p
+			  ></div
+			></li
+		      ><li
+		      ><dfn class="src"
+			><a id="v:content" class="def"
+			  >content</a
+			  > :: Int</dfn
+			><div class="doc"
+			><p
+			  >The second section.</p
+			  ></div
+			></li
+		      ><li
+		      ><dfn class="src"
+			><a id="v:footer" class="def"
+			  >footer</a
+			  > :: Int</dfn
+			><div class="doc"
+			><p
+			  >Arbitrary data after the second section. In replays generated by
+ Rocket League, this is always empty. However it is not technically
+ invalid to put something here.</p
+			  ></div
+			></li
+		      ></ul
+		    ></div
+		  ></td
+		></tr
+	      ></table
+	    ></div
+	  ></div
+	></div
+      ></div
+    ><div id="footer"
+    ></div
+    ></body
+  ></html
+>
\ No newline at end of file
diff --git a/html-test/src/DuplicateRecordFields.hs b/html-test/src/DuplicateRecordFields.hs
new file mode 100644
index 00000000..2cf9ff43
--- /dev/null
+++ b/html-test/src/DuplicateRecordFields.hs
@@ -0,0 +1,25 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+module DuplicateRecordFields (RawReplay(..)) where
+
+import Prelude hiding (Int)
+
+data Int = Int
+
+data RawReplay = RawReplay
+    { headerSize :: Int
+    -- ^ The byte size of the first section.
+    , headerCRC :: Int
+    -- ^ The CRC of the first section.
+    , header :: Int
+    -- ^ The first section.
+    , contentSize :: Int
+    -- ^ The byte size of the second section.
+    , contentCRC :: Int
+    -- ^ The CRC of the second section.
+    , content :: Int
+    -- ^ The second section.
+    , footer :: Int
+    -- ^ Arbitrary data after the second section. In replays generated by
+    -- Rocket League, this is always empty. However it is not technically
+    -- invalid to put something here.
+    }
\ No newline at end of file
-- 
cgit v1.2.3


From 22cbf4d9509d3b537e6c2fcf4c95ae73d930b9aa Mon Sep 17 00:00:00 2001
From: Yuji Yamamoto <whosekiteneverfly@gmail.com>
Date: Tue, 4 Jul 2017 23:13:12 +0900
Subject: Avoid errors on non UTF-8 Windows (#566)
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

* Avoid errors on non UTF-8 Windows

Problem
====

haddock exits with errors like below:

`(1)`

```
haddock: internal error: <stderr>: hPutChar: invalid argument (invalid character)
```

`(2)`

```
haddock: internal error: Language\Haskell\HsColour\Anchors.hs: hGetContents: invalid argument (invalid byte sequence)
```

`(1)` is caused by printing [the "bullet" character](http://www.fileformat.info/info/unicode/char/2022/index.htm) onto stderr.
For example, this warning contains it:

```
Language\Haskell\HsColour\ANSI.hs:62:10: warning: [-Wmissing-methods]
    • No explicit implementation for
        ‘toEnum’
    • In the instance declaration for ‘Enum Highlight’
```

`(2)` is caused when the input file of `readFile` contains some Unicode characters.
In the case above, '⇒' is the cause.

Environment
----

OS: Windows 10
haddock: 2.17.3
GHC: 8.0.1

Solution
====

Add `hSetEncoding handle utf8` to avoid the errors.

Note
====

- I found the detailed causes by these changes for debugging:
    - https://github.com/haskell/haddock/commit/8f29edb6b02691c1cf4c479f6c6f3f922b35a55b
    - https://github.com/haskell/haddock/commit/1dd23bf2065a1e1f2c14d0f4abd847c906b4ecb4
- These errors happen even after executing `chcp 65001` on the console.
  According to the debug code, `hGetEncoding stderr` returns `CP932` regardless of the console encoding.

* Avoid 'internal error: <stderr>: hPutChar: invalid argument (invalid character)' non UTF-8 Windows

Better solution for 59411754a6db41d17820733c076e6a72bcdbd82b's (1)
---
 haddock-api/src/Haddock/Interface.hs | 11 +++++++++++
 1 file changed, 11 insertions(+)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs
index 62b0aea9..cdc3064e 100644
--- a/haddock-api/src/Haddock/Interface.hs
+++ b/haddock-api/src/Haddock/Interface.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Haddock.Interface
@@ -48,14 +49,20 @@ import qualified Data.Set as Set
 import Distribution.Verbosity
 import System.Directory
 import System.FilePath
+import System.IO
 import Text.Printf
 
 import Digraph
 import DynFlags hiding (verbosity)
 import Exception
 import GHC hiding (verbosity)
+#if defined(mingw32_HOST_OS)
+import GHC.IO.Encoding.CodePage (mkLocaleEncoding)
+import GHC.IO.Encoding.Failure (CodingFailureMode(TransliterateCodingFailure))
+#endif
 import HscTypes
 import FastString (unpackFS)
+import MonadUtils (liftIO)
 
 -- | Create 'Interface's and a link environment by typechecking the list of
 -- modules using the GHC API and processing the resulting syntax trees.
@@ -68,6 +75,10 @@ processModules
   -> Ghc ([Interface], LinkEnv) -- ^ Resulting list of interfaces and renaming
                                 -- environment
 processModules verbosity modules flags extIfaces = do
+#if defined(mingw32_HOST_OS)
+  -- Avoid internal error: <stderr>: hPutChar: invalid argument (invalid character)' non UTF-8 Windows
+  liftIO $ hSetEncoding stderr $ mkLocaleEncoding TransliterateCodingFailure
+#endif
 
   out verbosity verbose "Creating interfaces..."
   let instIfaceMap =  Map.fromList [ (instMod iface, iface) | ext <- extIfaces
-- 
cgit v1.2.3


From 42e49d322d5ef3b6e13740642844b2ba57e96b95 Mon Sep 17 00:00:00 2001
From: Alex Biehl <alexbiehl@gmail.com>
Date: Fri, 7 Jul 2017 19:17:15 +0200
Subject: Remove redudant import warning (#651)

---
 haddock-api/src/Haddock/Interface.hs | 9 +++++----
 1 file changed, 5 insertions(+), 4 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs
index cdc3064e..f2d099b3 100644
--- a/haddock-api/src/Haddock/Interface.hs
+++ b/haddock-api/src/Haddock/Interface.hs
@@ -49,20 +49,21 @@ import qualified Data.Set as Set
 import Distribution.Verbosity
 import System.Directory
 import System.FilePath
-import System.IO
 import Text.Printf
 
 import Digraph
 import DynFlags hiding (verbosity)
 import Exception
 import GHC hiding (verbosity)
+import HscTypes
+import FastString (unpackFS)
+import MonadUtils (liftIO)
+
 #if defined(mingw32_HOST_OS)
+import System.IO
 import GHC.IO.Encoding.CodePage (mkLocaleEncoding)
 import GHC.IO.Encoding.Failure (CodingFailureMode(TransliterateCodingFailure))
 #endif
-import HscTypes
-import FastString (unpackFS)
-import MonadUtils (liftIO)
 
 -- | Create 'Interface's and a link environment by typechecking the list of
 -- modules using the GHC API and processing the resulting syntax trees.
-- 
cgit v1.2.3


From 3d3166d75c0012112a49fee4c2f6cbf82de383fa Mon Sep 17 00:00:00 2001
From: Alexander Biehl <alexbiehl@gmail.com>
Date: Mon, 31 Jul 2017 20:15:32 +0200
Subject: Move `DocMarkup` from haddock-api to haddock-library (#659)

* Move `DocMarkup` from haddock-api to haddock-library

* Move more markup related functions

* Markup module

* CHANGELOG
---
 CHANGES.md                                         |  2 +
 haddock-api/haddock-api.cabal                      |  2 +-
 haddock-api/src/Documentation/Haddock.hs           |  6 +-
 haddock-api/src/Haddock/Backends/Hoogle.hs         |  1 +
 haddock-api/src/Haddock/Backends/LaTeX.hs          |  1 +
 .../src/Haddock/Backends/Xhtml/DocMarkup.hs        |  1 +
 haddock-api/src/Haddock/Types.hs                   | 32 +----------
 haddock-api/src/Haddock/Utils.hs                   | 67 ----------------------
 haddock-library/haddock-library.cabal              |  3 +-
 .../src/Documentation/Haddock/Markup.hs            | 59 +++++++++++++++++++
 haddock-library/src/Documentation/Haddock/Types.hs | 27 +++++++++
 11 files changed, 100 insertions(+), 101 deletions(-)
 create mode 100644 haddock-library/src/Documentation/Haddock/Markup.hs

(limited to 'haddock-api/src')

diff --git a/CHANGES.md b/CHANGES.md
index aa8789c0..bf60817a 100644
--- a/CHANGES.md
+++ b/CHANGES.md
@@ -2,6 +2,8 @@
 
  * to be released
 
+ * Move markup related data types to haddock-library
+
 ## Changes in version 2.18.1
 
  * Synopsis is working again (#599)
diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal
index de959955..6cde7266 100644
--- a/haddock-api/haddock-api.cabal
+++ b/haddock-api/haddock-api.cabal
@@ -42,7 +42,7 @@ library
                , Cabal           ^>= 2.0.0
                , ghc             ^>= 8.2
                , ghc-paths       ^>= 0.1.0.9
-               , haddock-library ^>= 1.4.4
+               , haddock-library ^>= 1.4.5
                , xhtml           ^>= 3000.2.2
 
   -- Versions for the dependencies below are transitively pinned by
diff --git a/haddock-api/src/Documentation/Haddock.hs b/haddock-api/src/Documentation/Haddock.hs
index 14605e92..10d6849a 100644
--- a/haddock-api/src/Documentation/Haddock.hs
+++ b/haddock-api/src/Documentation/Haddock.hs
@@ -39,7 +39,8 @@ module Documentation.Haddock (
   DocH(..),
   Example(..),
   Hyperlink(..),
-  DocMarkup(..),
+  DocMarkup,
+  DocMarkupH(..),
   Documentation(..),
   ArgMap,
   AliasMap,
@@ -69,12 +70,11 @@ module Documentation.Haddock (
   withGhc
 ) where
 
-
+import Documentation.Haddock.Markup (markup)
 import Haddock.InterfaceFile
 import Haddock.Interface
 import Haddock.Types
 import Haddock.Options
-import Haddock.Utils
 import Haddock
 
 
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 183b669e..3a9f6e43 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -18,6 +18,7 @@ module Haddock.Backends.Hoogle (
 
 import BasicTypes (OverlapFlag(..), OverlapMode(..), SourceText(..))
 import InstEnv (ClsInst(..))
+import Documentation.Haddock.Markup
 import Haddock.GhcUtils
 import Haddock.Types hiding (Version)
 import Haddock.Utils hiding (out)
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 18660b3f..1b248d2e 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -16,6 +16,7 @@ module Haddock.Backends.LaTeX (
 ) where
 
 
+import Documentation.Haddock.Markup
 import Haddock.Types
 import Haddock.Utils
 import Haddock.GhcUtils
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
index e36f9528..18c8a0ff 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
@@ -20,6 +20,7 @@ module Haddock.Backends.Xhtml.DocMarkup (
 ) where
 
 import Data.List
+import Documentation.Haddock.Markup
 import Haddock.Backends.Xhtml.Names
 import Haddock.Backends.Xhtml.Utils
 import Haddock.Types
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index bfc8e32b..de599bd8 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -189,7 +189,7 @@ data InstalledInterface = InstalledInterface
   , instSubMap           :: Map Name [Name]
 
   , instBundledPatSynMap :: Map Name [Name]
-  
+
   , instFixMap           :: Map Name Fixity
   }
 
@@ -443,6 +443,8 @@ type LDoc id = Located (Doc id)
 type Doc id = DocH (ModuleName, OccName) id
 type MDoc id = MetaDoc (ModuleName, OccName) id
 
+type DocMarkup id a = DocMarkupH (ModuleName, OccName) id a
+
 instance (NFData a, NFData mod)
          => NFData (DocH mod a) where
   rnf doc = case doc of
@@ -494,34 +496,6 @@ exampleToString :: Example -> String
 exampleToString (Example expression result) =
     ">>> " ++ expression ++ "\n" ++  unlines result
 
-
-data DocMarkup id a = Markup
-  { markupEmpty                :: a
-  , markupString               :: String -> a
-  , markupParagraph            :: a -> a
-  , markupAppend               :: a -> a -> a
-  , markupIdentifier           :: id -> a
-  , markupIdentifierUnchecked  :: (ModuleName, OccName) -> a
-  , markupModule               :: String -> a
-  , markupWarning              :: a -> a
-  , markupEmphasis             :: a -> a
-  , markupBold                 :: a -> a
-  , markupMonospaced           :: a -> a
-  , markupUnorderedList        :: [a] -> a
-  , markupOrderedList          :: [a] -> a
-  , markupDefList              :: [(a,a)] -> a
-  , markupCodeBlock            :: a -> a
-  , markupHyperlink            :: Hyperlink -> a
-  , markupAName                :: String -> a
-  , markupPic                  :: Picture -> a
-  , markupMathInline           :: String -> a
-  , markupMathDisplay          :: String -> a
-  , markupProperty             :: String -> a
-  , markupExample              :: [Example] -> a
-  , markupHeader               :: Header a -> a
-  }
-
-
 data HaddockModInfo name = HaddockModInfo
   { hmi_description :: Maybe (Doc name)
   , hmi_copyright   :: Maybe String
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index 404cfcf6..7a9d65a4 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -37,8 +37,6 @@ module Haddock.Utils (
   html_xrefs_ref, html_xrefs_ref',
 
   -- * Doc markup
-  markup,
-  idMarkup,
   mkMeta,
 
   -- * List utilities
@@ -448,71 +446,6 @@ spanWith p xs@(a:as)
   | Just b <- p a = let (bs,cs) = spanWith p as in (b:bs,cs)
   | otherwise     = ([],xs)
 
-
------------------------------------------------------------------------------
--- * Put here temporarily
------------------------------------------------------------------------------
-
-
-markup :: DocMarkup id a -> Doc id -> a
-markup m DocEmpty                    = markupEmpty m
-markup m (DocAppend d1 d2)           = markupAppend m (markup m d1) (markup m d2)
-markup m (DocString s)               = markupString m s
-markup m (DocParagraph d)            = markupParagraph m (markup m d)
-markup m (DocIdentifier x)           = markupIdentifier m x
-markup m (DocIdentifierUnchecked x)  = markupIdentifierUnchecked m x
-markup m (DocModule mod0)            = markupModule m mod0
-markup m (DocWarning d)              = markupWarning m (markup m d)
-markup m (DocEmphasis d)             = markupEmphasis m (markup m d)
-markup m (DocBold d)                 = markupBold m (markup m d)
-markup m (DocMonospaced d)           = markupMonospaced m (markup m d)
-markup m (DocUnorderedList ds)       = markupUnorderedList m (map (markup m) ds)
-markup m (DocOrderedList ds)         = markupOrderedList m (map (markup m) ds)
-markup m (DocDefList ds)             = markupDefList m (map (markupPair m) ds)
-markup m (DocCodeBlock d)            = markupCodeBlock m (markup m d)
-markup m (DocHyperlink l)            = markupHyperlink m l
-markup m (DocAName ref)              = markupAName m ref
-markup m (DocPic img)                = markupPic m img
-markup m (DocMathInline mathjax)     = markupMathInline m mathjax
-markup m (DocMathDisplay mathjax)    = markupMathDisplay m mathjax
-markup m (DocProperty p)             = markupProperty m p
-markup m (DocExamples e)             = markupExample m e
-markup m (DocHeader (Header l t))    = markupHeader m (Header l (markup m t))
-
-
-markupPair :: DocMarkup id a -> (Doc id, Doc id) -> (a, a)
-markupPair m (a,b) = (markup m a, markup m b)
-
-
--- | The identity markup
-idMarkup :: DocMarkup a (Doc a)
-idMarkup = Markup {
-  markupEmpty                = DocEmpty,
-  markupString               = DocString,
-  markupParagraph            = DocParagraph,
-  markupAppend               = DocAppend,
-  markupIdentifier           = DocIdentifier,
-  markupIdentifierUnchecked  = DocIdentifierUnchecked,
-  markupModule               = DocModule,
-  markupWarning              = DocWarning,
-  markupEmphasis             = DocEmphasis,
-  markupBold                 = DocBold,
-  markupMonospaced           = DocMonospaced,
-  markupUnorderedList        = DocUnorderedList,
-  markupOrderedList          = DocOrderedList,
-  markupDefList              = DocDefList,
-  markupCodeBlock            = DocCodeBlock,
-  markupHyperlink            = DocHyperlink,
-  markupAName                = DocAName,
-  markupPic                  = DocPic,
-  markupMathInline           = DocMathInline,
-  markupMathDisplay          = DocMathDisplay,
-  markupProperty             = DocProperty,
-  markupExample              = DocExamples,
-  markupHeader               = DocHeader
-  }
-
-
 -----------------------------------------------------------------------------
 -- * System tools
 -----------------------------------------------------------------------------
diff --git a/haddock-library/haddock-library.cabal b/haddock-library/haddock-library.cabal
index 2e720d7b..44834aa9 100644
--- a/haddock-library/haddock-library.cabal
+++ b/haddock-library/haddock-library.cabal
@@ -31,10 +31,11 @@ library
   ghc-options:          -funbox-strict-fields -Wall -fwarn-tabs -O2
 
   exposed-modules:
+    Documentation.Haddock.Doc
+    Documentation.Haddock.Markup
     Documentation.Haddock.Parser
     Documentation.Haddock.Parser.Monad
     Documentation.Haddock.Types
-    Documentation.Haddock.Doc
     Documentation.Haddock.Utf8
 
   other-modules:
diff --git a/haddock-library/src/Documentation/Haddock/Markup.hs b/haddock-library/src/Documentation/Haddock/Markup.hs
new file mode 100644
index 00000000..b16cf049
--- /dev/null
+++ b/haddock-library/src/Documentation/Haddock/Markup.hs
@@ -0,0 +1,59 @@
+module Documentation.Haddock.Markup where
+
+import Documentation.Haddock.Types
+
+markup :: DocMarkupH mod id a -> DocH mod id -> a
+markup m DocEmpty                    = markupEmpty m
+markup m (DocAppend d1 d2)           = markupAppend m (markup m d1) (markup m d2)
+markup m (DocString s)               = markupString m s
+markup m (DocParagraph d)            = markupParagraph m (markup m d)
+markup m (DocIdentifier x)           = markupIdentifier m x
+markup m (DocIdentifierUnchecked x)  = markupIdentifierUnchecked m x
+markup m (DocModule mod0)            = markupModule m mod0
+markup m (DocWarning d)              = markupWarning m (markup m d)
+markup m (DocEmphasis d)             = markupEmphasis m (markup m d)
+markup m (DocBold d)                 = markupBold m (markup m d)
+markup m (DocMonospaced d)           = markupMonospaced m (markup m d)
+markup m (DocUnorderedList ds)       = markupUnorderedList m (map (markup m) ds)
+markup m (DocOrderedList ds)         = markupOrderedList m (map (markup m) ds)
+markup m (DocDefList ds)             = markupDefList m (map (markupPair m) ds)
+markup m (DocCodeBlock d)            = markupCodeBlock m (markup m d)
+markup m (DocHyperlink l)            = markupHyperlink m l
+markup m (DocAName ref)              = markupAName m ref
+markup m (DocPic img)                = markupPic m img
+markup m (DocMathInline mathjax)     = markupMathInline m mathjax
+markup m (DocMathDisplay mathjax)    = markupMathDisplay m mathjax
+markup m (DocProperty p)             = markupProperty m p
+markup m (DocExamples e)             = markupExample m e
+markup m (DocHeader (Header l t))    = markupHeader m (Header l (markup m t))
+
+markupPair :: DocMarkupH mod id a -> (DocH mod id, DocH mod id) -> (a, a)
+markupPair m (a,b) = (markup m a, markup m b)
+
+-- | The identity markup
+idMarkup :: DocMarkupH mod id (DocH mod id)
+idMarkup = Markup {
+  markupEmpty                = DocEmpty,
+  markupString               = DocString,
+  markupParagraph            = DocParagraph,
+  markupAppend               = DocAppend,
+  markupIdentifier           = DocIdentifier,
+  markupIdentifierUnchecked  = DocIdentifierUnchecked,
+  markupModule               = DocModule,
+  markupWarning              = DocWarning,
+  markupEmphasis             = DocEmphasis,
+  markupBold                 = DocBold,
+  markupMonospaced           = DocMonospaced,
+  markupUnorderedList        = DocUnorderedList,
+  markupOrderedList          = DocOrderedList,
+  markupDefList              = DocDefList,
+  markupCodeBlock            = DocCodeBlock,
+  markupHyperlink            = DocHyperlink,
+  markupAName                = DocAName,
+  markupPic                  = DocPic,
+  markupMathInline           = DocMathInline,
+  markupMathDisplay          = DocMathDisplay,
+  markupProperty             = DocProperty,
+  markupExample              = DocExamples,
+  markupHeader               = DocHeader
+  }
diff --git a/haddock-library/src/Documentation/Haddock/Types.hs b/haddock-library/src/Documentation/Haddock/Types.hs
index 660878ff..1e87edc0 100644
--- a/haddock-library/src/Documentation/Haddock/Types.hs
+++ b/haddock-library/src/Documentation/Haddock/Types.hs
@@ -80,3 +80,30 @@ data DocH mod id
   | DocExamples [Example]
   | DocHeader (Header (DocH mod id))
   deriving (Eq, Show, Functor, Foldable, Traversable)
+
+data DocMarkupH mod id a = Markup
+  { markupEmpty                :: a
+  , markupString               :: String -> a
+  , markupParagraph            :: a -> a
+  , markupAppend               :: a -> a -> a
+  , markupIdentifier           :: id -> a
+  , markupIdentifierUnchecked  :: mod -> a
+  , markupModule               :: String -> a
+  , markupWarning              :: a -> a
+  , markupEmphasis             :: a -> a
+  , markupBold                 :: a -> a
+  , markupMonospaced           :: a -> a
+  , markupUnorderedList        :: [a] -> a
+  , markupOrderedList          :: [a] -> a
+  , markupDefList              :: [(a,a)] -> a
+  , markupCodeBlock            :: a -> a
+  , markupHyperlink            :: Hyperlink -> a
+  , markupAName                :: String -> a
+  , markupPic                  :: Picture -> a
+  , markupMathInline           :: String -> a
+  , markupMathDisplay          :: String -> a
+  , markupProperty             :: String -> a
+  , markupExample              :: [Example] -> a
+  , markupHeader               :: Header a -> a
+  }
+
-- 
cgit v1.2.3


From 4d765e3cd0a735f9a7e8d13fb6633f9ee534fbfb Mon Sep 17 00:00:00 2001
From: Moritz Drexl <mdrexl@fastmail.fm>
Date: Sat, 5 Aug 2017 16:44:40 +0200
Subject: Fix renaming after instance signature specializing (#660)

* rework rename

* Add regression test for Bug 613

* update tests

* update changelog
---
 CHANGES.md                                      |   2 +
 haddock-api/src/Haddock/Interface/Specialize.hs | 132 +++++-------
 html-test/ref/Bug613.html                       | 260 ++++++++++++++++++++++++
 html-test/ref/Instances.html                    | 178 ++++++++--------
 html-test/src/Bug613.hs                         |  16 ++
 5 files changed, 418 insertions(+), 170 deletions(-)
 create mode 100644 html-test/ref/Bug613.html
 create mode 100644 html-test/src/Bug613.hs

(limited to 'haddock-api/src')

diff --git a/CHANGES.md b/CHANGES.md
index bf60817a..5050339d 100644
--- a/CHANGES.md
+++ b/CHANGES.md
@@ -2,6 +2,8 @@
 
  * to be released
 
+ * Fix renaming of type variables after specializing instance method signatures (#613)
+
  * Move markup related data types to haddock-library
 
 ## Changes in version 2.18.1
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index da8c3e7b..84168151 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -17,7 +17,6 @@ import Name
 import FastString
 
 import Control.Monad
-import Control.Monad.Trans.Reader
 import Control.Monad.Trans.State
 
 import Data.Data
@@ -204,7 +203,7 @@ setInternalOccName occ name =
 
 -- | Compute set of free variables of given type.
 freeVariables :: forall name. (NamedThing name, DataId name)
-              => HsType name -> Set NameRep
+              => HsType name -> Set Name
 freeVariables =
     everythingWithState Set.empty Set.union query
   where
@@ -213,7 +212,7 @@ freeVariables =
             (Set.empty, Set.union ctx (bndrsNames bndrs))
         Just (HsTyVar _ (L _ name))
             | getName name `Set.member` ctx -> (Set.empty, ctx)
-            | otherwise -> (Set.singleton $ getNameRep name, ctx)
+            | otherwise -> (Set.singleton $ getName name, ctx)
         _ -> (Set.empty, ctx)
     bndrsNames = Set.fromList . map (getName . tyVarName . unLoc)
 
@@ -225,33 +224,36 @@ freeVariables =
 -- @(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
-    }
-
+-- like @(a -> b0) -> b@).
+rename :: (Eq name, DataId name, SetName name)
+       => Set Name -> HsType name -> HsType name
+rename fv typ = evalState (renameType typ) env
+  where
+    env = RenameEnv
+      { rneHeadFVs = Map.fromList . map mkPair . Set.toList $ fv
+      , rneSigFVs = Set.map getNameRep $ freeVariables typ
+      , rneCtx = Map.empty
+      }
+    mkPair name = (getNameRep name, name)
 
 -- | Renaming monad.
-type Rename name = Reader (RenameEnv name)
-
--- | Binding generation monad.
-type Rebind name = State (RenameEnv name)
+type Rename name = State (RenameEnv name)
 
 data RenameEnv name = RenameEnv
-    { rneFV :: Set NameRep
-    , rneCtx :: Map Name name
-    }
+  { rneHeadFVs :: Map NameRep Name
+  , rneSigFVs :: Set NameRep
+  , rneCtx :: Map Name name
+  }
 
 
-renameType :: SetName name => HsType name -> Rename name (HsType name)
-renameType (HsForAllTy bndrs lt) = rebind bndrs $ \bndrs' ->
+renameType :: (Eq name, SetName name)
+           => HsType name -> Rename name (HsType name)
+renameType (HsForAllTy bndrs lt) =
     HsForAllTy
-        <$> pure bndrs'
+        <$> mapM (located renameBinder) bndrs
         <*> renameLType lt
 renameType (HsQualTy lctxt lt) =
-  HsQualTy
+    HsQualTy
         <$> located renameContext lctxt
         <*> renameLType lt
 renameType (HsTyVar ip name) = HsTyVar ip <$> located renameName name
@@ -281,85 +283,61 @@ renameType (HsWildCardTy wc) = pure (HsWildCardTy wc)
 renameType (HsAppsTy _) = error "HsAppsTy: Only used before renaming"
 
 
-renameLType :: SetName name => LHsType name -> Rename name (LHsType name)
+renameLType :: (Eq name, SetName name)
+            => LHsType name -> Rename name (LHsType name)
 renameLType = located renameType
 
 
-renameLTypes :: SetName name => [LHsType name] -> Rename name [LHsType name]
+renameLTypes :: (Eq name, SetName name)
+             => [LHsType name] -> Rename name [LHsType name]
 renameLTypes = mapM renameLType
 
 
-renameContext :: SetName name => HsContext name -> Rename name (HsContext name)
+renameContext :: (Eq name, 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 $ fromMaybe name (Map.lookup (getName name) ctx)
-
-
-rebind :: SetName name
-       => [LHsTyVarBndr name] -> ([LHsTyVarBndr 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
-                  => [LHsTyVarBndr name] -> Rebind name [LHsTyVarBndr name]
-rebindLTyVarBndrs lbndrs = mapM (located rebindTyVarBndr) lbndrs
+renameBinder :: (Eq name, SetName name)
+             => HsTyVarBndr name -> Rename name (HsTyVarBndr name)
+renameBinder (UserTyVar lname) = UserTyVar <$> located renameName lname
+renameBinder (KindedTyVar lname lkind) =
+  KindedTyVar <$> located renameName lname <*> located renameType lkind
 
 
-rebindTyVarBndr :: SetName name
-                => HsTyVarBndr name -> Rebind name (HsTyVarBndr name)
-rebindTyVarBndr (UserTyVar (L l name)) =
-    UserTyVar . L l <$> rebindName name
-rebindTyVarBndr (KindedTyVar name kinds) =
-    KindedTyVar <$> located rebindName name <*> pure kinds
-
-
-rebindName :: SetName name => name -> Rebind name name
-rebindName name = do
+-- | Core renaming logic.
+renameName :: (Eq name, SetName name) => name -> Rename name name
+renameName 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
+      Nothing
+        | Just headTv <- Map.lookup (getNameRep name) rneHeadFVs
+        , headTv /= getName name -> freshName name
+      Just name' -> return name'
+      _ -> return name
 
 
 -- | Generate fresh occurrence name, put it into context and return.
-freshName :: SetName name => name -> Rebind name name
+freshName :: SetName name => name -> Rename 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 }
+    modify $ \rne -> rne
+      { rneCtx = Map.insert (getName name) name' (rneCtx rne) }
     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 :: NamedThing name => Rename name (Set NameRep)
 takenNames = do
     RenameEnv { .. } <- get
-    return $ Set.union rneFV (ctxElems rneCtx)
+    return $ headReps rneHeadFVs `Set.union`
+             rneSigFVs `Set.union`
+             ctxElems rneCtx
   where
+    headReps = Set.fromList . Map.keys
     ctxElems = Set.fromList . map getNameRep . Map.elems
 
 
@@ -371,15 +349,7 @@ findFreshName 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 =
+alternativeNames name =
     [ stringNameRep $ str ++ show i | i :: Int <- [0..] ]
   where
     str = nameRepString name
diff --git a/html-test/ref/Bug613.html b/html-test/ref/Bug613.html
new file mode 100644
index 00000000..924f37d4
--- /dev/null
+++ b/html-test/ref/Bug613.html
@@ -0,0 +1,260 @@
+<html xmlns="http://www.w3.org/1999/xhtml"
+><head
+  ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"
+     /><title
+    >Bug613</title
+    ><link href="#" rel="stylesheet" type="text/css" title="Ocean"
+     /><script src="haddock-util.js" type="text/javascript"
+    ></script
+    ><script src="https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.0/MathJax.js?config=TeX-AMS-MML_HTMLorMML" type="text/javascript"
+    ></script
+    ><script type="text/javascript"
+    >//
+window.onload = function () {pageLoad();};
+//
+</script
+    ></head
+  ><body
+  ><div id="package-header"
+    ><ul class="links" id="page-menu"
+      ><li
+	><a href="#"
+	  >Contents</a
+	  ></li
+	><li
+	><a href="#"
+	  >Index</a
+	  ></li
+	></ul
+      ><p class="caption empty"
+      ></p
+      ></div
+    ><div id="content"
+    ><div id="module-header"
+      ><table class="info"
+	><tr
+	  ><th
+	    >Safe Haskell</th
+	    ><td
+	    >Safe</td
+	    ></tr
+	  ></table
+	><p class="caption"
+	>Bug613</p
+	></div
+      ><div id="synopsis"
+      ><p id="control.syn" class="caption expander" onclick="toggleSection('syn')"
+	>Synopsis</p
+	><ul id="section.syn" class="hide" onclick="toggleSection('syn')"
+	><li class="src short"
+	  ><span class="keyword"
+	    >class</span
+	    > <a href="#"
+	    >Functor</a
+	    > f <span class="keyword"
+	    >where</span
+	    ><ul class="subs"
+	    ></ul
+	    ></li
+	  ><li class="src short"
+	  ><span class="keyword"
+	    >data</span
+	    > <a href="#"
+	    >ThreeVars</a
+	    > a0 a b = <a href="#"
+	    >ThreeVars</a
+	    > a b</li
+	  ></ul
+	></div
+      ><div id="interface"
+      ><h1
+	>Documentation</h1
+	><div class="top"
+	><p class="src"
+	  ><span class="keyword"
+	    >class</span
+	    > <a id="t:Functor" class="def"
+	    >Functor</a
+	    > f <span class="keyword"
+	    >where</span
+	    > <a href="#" class="selflink"
+	    >#</a
+	    ></p
+	  ><div class="subs minimal"
+	  ><p class="caption"
+	    >Minimal complete definition</p
+	    ><p class="src"
+	    ><a href="#"
+	      >fmap</a
+	      ></p
+	    ></div
+	  ><div class="subs methods"
+	  ><p class="caption"
+	    >Methods</p
+	    ><p class="src"
+	    ><a id="v:fmap" class="def"
+	      >fmap</a
+	      > :: (a -&gt; b) -&gt; f a -&gt; f b <a href="#" class="selflink"
+	      >#</a
+	      ></p
+	    ></div
+	  ><div class="subs instances"
+	  ><p id="control.i:Functor" class="caption collapser" onclick="toggleSection('i:Functor')"
+	    >Instances</p
+	    ><div id="section.i:Functor" class="show"
+	    ><table
+	      ><tr
+		><td class="src clearfix"
+		  ><span class="inst-left"
+		    ><span id="control.i:ic:Functor:Functor:1" class="instance expander" onclick="toggleSection('i:ic:Functor:Functor:1')"
+		      ></span
+		      > <a href="#"
+		      >Functor</a
+		      > (<a href="#"
+		      >Either</a
+		      > a)</span
+		    > <a href="#" class="selflink"
+		    >#</a
+		    ></td
+		  ><td class="doc empty"
+		  ></td
+		  ></tr
+		><tr
+		><td colspan="2"
+		  ><div id="section.i:ic:Functor:Functor:1" class="inst-details hide"
+		    ><div class="subs methods"
+		      ><p class="caption"
+			>Methods</p
+			><p class="src"
+			><a href="#"
+			  >fmap</a
+			  > :: (a0 -&gt; b) -&gt; <a href="#"
+			  >Either</a
+			  > a a0 -&gt; <a href="#"
+			  >Either</a
+			  > a b <a href="#" class="selflink"
+			  >#</a
+			  ></p
+			></div
+		      ></div
+		    ></td
+		  ></tr
+		><tr
+		><td class="src clearfix"
+		  ><span class="inst-left"
+		    ><span id="control.i:ic:Functor:Functor:2" class="instance expander" onclick="toggleSection('i:ic:Functor:Functor:2')"
+		      ></span
+		      > <a href="#"
+		      >Functor</a
+		      > (<a href="#"
+		      >ThreeVars</a
+		      > a0 a)</span
+		    > <a href="#" class="selflink"
+		    >#</a
+		    ></td
+		  ><td class="doc empty"
+		  ></td
+		  ></tr
+		><tr
+		><td colspan="2"
+		  ><div id="section.i:ic:Functor:Functor:2" class="inst-details hide"
+		    ><div class="subs methods"
+		      ><p class="caption"
+			>Methods</p
+			><p class="src"
+			><a href="#"
+			  >fmap</a
+			  > :: (a1 -&gt; b) -&gt; <a href="#"
+			  >ThreeVars</a
+			  > a0 a a1 -&gt; <a href="#"
+			  >ThreeVars</a
+			  > a0 a b <a href="#" class="selflink"
+			  >#</a
+			  ></p
+			></div
+		      ></div
+		    ></td
+		  ></tr
+		></table
+	      ></div
+	    ></div
+	  ></div
+	><div class="top"
+	><p class="src"
+	  ><span class="keyword"
+	    >data</span
+	    > <a id="t:ThreeVars" class="def"
+	    >ThreeVars</a
+	    > a0 a b <a href="#" class="selflink"
+	    >#</a
+	    ></p
+	  ><div class="doc"
+	  ><p
+	    >Phantom type a0 is added to block the first renaming from a to a0. This ensures that the renamer doesn't create a new conflict</p
+	    ></div
+	  ><div class="subs constructors"
+	  ><p class="caption"
+	    >Constructors</p
+	    ><table
+	    ><tr
+	      ><td class="src"
+		><a id="v:ThreeVars" class="def"
+		  >ThreeVars</a
+		  > a b</td
+		><td class="doc empty"
+		></td
+		></tr
+	      ></table
+	    ></div
+	  ><div class="subs instances"
+	  ><p id="control.i:ThreeVars" class="caption collapser" onclick="toggleSection('i:ThreeVars')"
+	    >Instances</p
+	    ><div id="section.i:ThreeVars" class="show"
+	    ><table
+	      ><tr
+		><td class="src clearfix"
+		  ><span class="inst-left"
+		    ><span id="control.i:id:ThreeVars:Functor:1" class="instance expander" onclick="toggleSection('i:id:ThreeVars:Functor:1')"
+		      ></span
+		      > <a href="#"
+		      >Functor</a
+		      > (<a href="#"
+		      >ThreeVars</a
+		      > a0 a)</span
+		    > <a href="#" class="selflink"
+		    >#</a
+		    ></td
+		  ><td class="doc empty"
+		  ></td
+		  ></tr
+		><tr
+		><td colspan="2"
+		  ><div id="section.i:id:ThreeVars:Functor:1" class="inst-details hide"
+		    ><div class="subs methods"
+		      ><p class="caption"
+			>Methods</p
+			><p class="src"
+			><a href="#"
+			  >fmap</a
+			  > :: (a1 -&gt; b) -&gt; <a href="#"
+			  >ThreeVars</a
+			  > a0 a a1 -&gt; <a href="#"
+			  >ThreeVars</a
+			  > a0 a b <a href="#" class="selflink"
+			  >#</a
+			  ></p
+			></div
+		      ></div
+		    ></td
+		  ></tr
+		></table
+	      ></div
+	    ></div
+	  ></div
+	></div
+      ></div
+    ><div id="footer"
+    ></div
+    ></body
+  ></html
+>
\ No newline at end of file
diff --git a/html-test/ref/Instances.html b/html-test/ref/Instances.html
index b014e8df..c9ca6f82 100644
--- a/html-test/ref/Instances.html
+++ b/html-test/ref/Instances.html
@@ -102,9 +102,9 @@ window.onload = function () {pageLoad();};
 			  >&lt;~~</a
 			  > <a href="#"
 			  >Int</a
-			  >) -&gt; a -&gt; a <a href="#"
+			  >) -&gt; a0 -&gt; a <a href="#"
 			  >&lt;~~</a
-			  > a <a href="#" class="selflink"
+			  > a0 <a href="#" class="selflink"
 			  >#</a
 			  ></p
 			><p class="src"
@@ -114,7 +114,7 @@ window.onload = function () {pageLoad();};
 			  >&lt;~~</a
 			  > (a <a href="#"
 			  >&lt;~~</a
-			  > a)) -&gt; <a href="#"
+			  > a0)) -&gt; <a href="#"
 			  >Int</a
 			  > -&gt; a <a href="#"
 			  >&lt;~~</a
@@ -298,9 +298,9 @@ window.onload = function () {pageLoad();};
 			  >Either</a
 			  > a <a href="#"
 			  >Int</a
-			  > -&gt; a -&gt; <a href="#"
+			  > -&gt; a0 -&gt; <a href="#"
 			  >Either</a
-			  > a a <a href="#" class="selflink"
+			  > a a0 <a href="#" class="selflink"
 			  >#</a
 			  ></p
 			><p class="src"
@@ -310,7 +310,7 @@ window.onload = function () {pageLoad();};
 			  >Either</a
 			  > a (<a href="#"
 			  >Either</a
-			  > a a) -&gt; <a href="#"
+			  > a a0) -&gt; <a href="#"
 			  >Int</a
 			  > -&gt; <a href="#"
 			  >Either</a
@@ -356,13 +356,13 @@ window.onload = function () {pageLoad();};
 			  >foo</a
 			  > :: (f a, <a href="#"
 			  >Int</a
-			  >) -&gt; a -&gt; (f a, a) <a href="#" class="selflink"
+			  >) -&gt; a0 -&gt; (f a, a0) <a href="#" class="selflink"
 			  >#</a
 			  ></p
 			><p class="src"
 			><a href="#"
 			  >foo'</a
-			  > :: (f a, (f a, a)) -&gt; <a href="#"
+			  > :: (f a, (f a, a0)) -&gt; <a href="#"
 			  >Int</a
 			  > -&gt; (f a, (f a, <a href="#"
 			  >Int</a
@@ -402,9 +402,9 @@ window.onload = function () {pageLoad();};
 			  >&lt;~~</a
 			  > <a href="#"
 			  >Int</a
-			  >) -&gt; a -&gt; a <a href="#"
+			  >) -&gt; a0 -&gt; a <a href="#"
 			  >&lt;~~</a
-			  > a <a href="#" class="selflink"
+			  > a0 <a href="#" class="selflink"
 			  >#</a
 			  ></p
 			><p class="src"
@@ -414,7 +414,7 @@ window.onload = function () {pageLoad();};
 			  >&lt;~~</a
 			  > (a <a href="#"
 			  >&lt;~~</a
-			  > a)) -&gt; <a href="#"
+			  > a0)) -&gt; <a href="#"
 			  >Int</a
 			  > -&gt; a <a href="#"
 			  >&lt;~~</a
@@ -456,13 +456,13 @@ window.onload = function () {pageLoad();};
 			  >foo</a
 			  > :: (a, a, <a href="#"
 			  >Int</a
-			  >) -&gt; a -&gt; (a, a, a) <a href="#" class="selflink"
+			  >) -&gt; a0 -&gt; (a, a, a0) <a href="#" class="selflink"
 			  >#</a
 			  ></p
 			><p class="src"
 			><a href="#"
 			  >foo'</a
-			  > :: (a, a, (a, a, a)) -&gt; <a href="#"
+			  > :: (a, a, (a, a, a0)) -&gt; <a href="#"
 			  >Int</a
 			  > -&gt; (a, a, (a, a, <a href="#"
 			  >Int</a
@@ -502,9 +502,9 @@ window.onload = function () {pageLoad();};
 			  >Quux</a
 			  > a b <a href="#"
 			  >Int</a
-			  > -&gt; a -&gt; <a href="#"
+			  > -&gt; a0 -&gt; <a href="#"
 			  >Quux</a
-			  > a b a <a href="#" class="selflink"
+			  > a b a0 <a href="#" class="selflink"
 			  >#</a
 			  ></p
 			><p class="src"
@@ -514,7 +514,7 @@ window.onload = function () {pageLoad();};
 			  >Quux</a
 			  > a b (<a href="#"
 			  >Quux</a
-			  > a b a) -&gt; <a href="#"
+			  > a b a0) -&gt; <a href="#"
 			  >Int</a
 			  > -&gt; <a href="#"
 			  >Quux</a
@@ -562,11 +562,11 @@ window.onload = function () {pageLoad();};
 			  >LiftedRep</a
 			  >) a <a href="#"
 			  >Int</a
-			  > -&gt; a -&gt; (<a href="#"
+			  > -&gt; a0 -&gt; (<a href="#"
 			  >LiftedRep</a
 			  > -&gt; <a href="#"
 			  >LiftedRep</a
-			  >) a a <a href="#" class="selflink"
+			  >) a a0 <a href="#" class="selflink"
 			  >#</a
 			  ></p
 			><p class="src"
@@ -580,7 +580,7 @@ window.onload = function () {pageLoad();};
 			  >LiftedRep</a
 			  > -&gt; <a href="#"
 			  >LiftedRep</a
-			  >) a a) -&gt; <a href="#"
+			  >) a a0) -&gt; <a href="#"
 			  >Int</a
 			  > -&gt; (<a href="#"
 			  >LiftedRep</a
@@ -1002,19 +1002,19 @@ window.onload = function () {pageLoad();};
 			><p class="src"
 			><a href="#"
 			  >bar'</a
-			  > :: (a, b, (a, b, (a, b, a))) -&gt; (a, b, (a, b, (a, b, b))) <a href="#" class="selflink"
+			  > :: (a, b, (a, b, (a, b, a))) -&gt; (a, b, (a, b, (a, b, b0))) <a href="#" class="selflink"
 			  >#</a
 			  ></p
 			><p class="src"
 			><a href="#"
 			  >bar0</a
-			  > :: ((a, b, (a, b, a)), (a, b, (a, b, a))) -&gt; ((a, b, b), (a, b, c)) <a href="#" class="selflink"
+			  > :: ((a, b, (a, b, a)), (a, b, (a, b, a))) -&gt; ((a, b, b0), (a, b, c)) <a href="#" class="selflink"
 			  >#</a
 			  ></p
 			><p class="src"
 			><a href="#"
 			  >bar1</a
-			  > :: ((a, b, (a, b, a)), (a, b, (a, b, a))) -&gt; ((a, b, b), (a, b, c)) <a href="#" class="selflink"
+			  > :: ((a, b, (a, b, a)), (a, b, (a, b, a))) -&gt; ((a, b, b0), (a, b, c)) <a href="#" class="selflink"
 			  >#</a
 			  ></p
 			></div
@@ -1076,7 +1076,7 @@ window.onload = function () {pageLoad();};
 			  >Quux</a
 			  > a c (<a href="#"
 			  >Quux</a
-			  > a c b)) <a href="#" class="selflink"
+			  > a c b0)) <a href="#" class="selflink"
 			  >#</a
 			  ></p
 			><p class="src"
@@ -1092,9 +1092,9 @@ window.onload = function () {pageLoad();};
 			  >Quux</a
 			  > a b c)) -&gt; (<a href="#"
 			  >Quux</a
-			  > a c b, <a href="#"
+			  > a c b0, <a href="#"
 			  >Quux</a
-			  > a c c) <a href="#" class="selflink"
+			  > a c c0) <a href="#" class="selflink"
 			  >#</a
 			  ></p
 			><p class="src"
@@ -1110,9 +1110,9 @@ window.onload = function () {pageLoad();};
 			  >Quux</a
 			  > a b c)) -&gt; (<a href="#"
 			  >Quux</a
-			  > a c b, <a href="#"
+			  > a c b0, <a href="#"
 			  >Quux</a
-			  > a c c) <a href="#" class="selflink"
+			  > a c c0) <a href="#" class="selflink"
 			  >#</a
 			  ></p
 			></div
@@ -1202,7 +1202,7 @@ window.onload = function () {pageLoad();};
 			  >forall</span
 			  > a. a -&gt; a) -&gt; (b, <span class="keyword"
 			  >forall</span
-			  > a. a -&gt; [c]) -&gt; (b, c) <a href="#" class="selflink"
+			  > c0. c0 -&gt; [c]) -&gt; (b, c1) <a href="#" class="selflink"
 			  >#</a
 			  ></p
 			><p class="src"
@@ -1222,9 +1222,9 @@ window.onload = function () {pageLoad();};
 			  >forall</span
 			  > b. (<span class="keyword"
 			  >forall</span
-			  > a. a -&gt; [c]) -&gt; c) -&gt; <span class="keyword"
+			  > b. b -&gt; [c]) -&gt; c0) -&gt; <span class="keyword"
 			  >forall</span
-			  > a. a -&gt; b <a href="#" class="selflink"
+			  > c1. c1 -&gt; b <a href="#" class="selflink"
 			  >#</a
 			  ></p
 			></div
@@ -1256,31 +1256,31 @@ window.onload = function () {pageLoad();};
 			  >baz</a
 			  > :: (a -&gt; b) -&gt; (<span class="keyword"
 			  >forall</span
-			  > c. c -&gt; c) -&gt; (b, <span class="keyword"
+			  > a0. a0 -&gt; a0) -&gt; (b0, <span class="keyword"
 			  >forall</span
-			  > c. c -&gt; a -&gt; b) -&gt; (b, c) <a href="#" class="selflink"
+			  > c. c -&gt; a -&gt; b) -&gt; (b0, c) <a href="#" class="selflink"
 			  >#</a
 			  ></p
 			><p class="src"
 			><a href="#"
 			  >baz'</a
-			  > :: b -&gt; (<span class="keyword"
+			  > :: b0 -&gt; (<span class="keyword"
 			  >forall</span
-			  > c. c -&gt; a -&gt; b) -&gt; (<span class="keyword"
+			  > b1. b1 -&gt; a -&gt; b) -&gt; (<span class="keyword"
 			  >forall</span
-			  > c. c -&gt; a -&gt; b) -&gt; [(b, a -&gt; b)] <a href="#" class="selflink"
+			  > b2. b2 -&gt; a -&gt; b) -&gt; [(b0, a -&gt; b)] <a href="#" class="selflink"
 			  >#</a
 			  ></p
 			><p class="src"
 			><a href="#"
 			  >baz''</a
-			  > :: b -&gt; (<span class="keyword"
+			  > :: b0 -&gt; (<span class="keyword"
 			  >forall</span
-			  > c. (<span class="keyword"
+			  > b1. (<span class="keyword"
 			  >forall</span
-			  > d. d -&gt; a -&gt; b) -&gt; c) -&gt; <span class="keyword"
+			  > b2. b2 -&gt; a -&gt; b) -&gt; c) -&gt; <span class="keyword"
 			  >forall</span
-			  > c. c -&gt; b <a href="#" class="selflink"
+			  > c. c -&gt; b0 <a href="#" class="selflink"
 			  >#</a
 			  ></p
 			></div
@@ -1312,31 +1312,31 @@ window.onload = function () {pageLoad();};
 			  >baz</a
 			  > :: (a, b, c) -&gt; (<span class="keyword"
 			  >forall</span
-			  > d. d -&gt; d) -&gt; (b, <span class="keyword"
+			  > a0. a0 -&gt; a0) -&gt; (b0, <span class="keyword"
 			  >forall</span
-			  > d. d -&gt; (a, b, c)) -&gt; (b, c) <a href="#" class="selflink"
+			  > c0. c0 -&gt; (a, b, c)) -&gt; (b0, c1) <a href="#" class="selflink"
 			  >#</a
 			  ></p
 			><p class="src"
 			><a href="#"
 			  >baz'</a
-			  > :: b -&gt; (<span class="keyword"
+			  > :: b0 -&gt; (<span class="keyword"
 			  >forall</span
-			  > d. d -&gt; (a, b, c)) -&gt; (<span class="keyword"
+			  > b1. b1 -&gt; (a, b, c)) -&gt; (<span class="keyword"
 			  >forall</span
-			  > d. d -&gt; (a, b, c)) -&gt; [(b, (a, b, c))] <a href="#" class="selflink"
+			  > b2. b2 -&gt; (a, b, c)) -&gt; [(b0, (a, b, c))] <a href="#" class="selflink"
 			  >#</a
 			  ></p
 			><p class="src"
 			><a href="#"
 			  >baz''</a
-			  > :: b -&gt; (<span class="keyword"
+			  > :: b0 -&gt; (<span class="keyword"
 			  >forall</span
-			  > d. (<span class="keyword"
+			  > b1. (<span class="keyword"
 			  >forall</span
-			  > e. e -&gt; (a, b, c)) -&gt; c) -&gt; <span class="keyword"
+			  > b2. b2 -&gt; (a, b, c)) -&gt; c0) -&gt; <span class="keyword"
 			  >forall</span
-			  > d. d -&gt; b <a href="#" class="selflink"
+			  > c1. c1 -&gt; b0 <a href="#" class="selflink"
 			  >#</a
 			  ></p
 			></div
@@ -1372,25 +1372,25 @@ window.onload = function () {pageLoad();};
 			  >Quux</a
 			  > a b c -&gt; (<span class="keyword"
 			  >forall</span
-			  > d. d -&gt; d) -&gt; (b, <span class="keyword"
+			  > a0. a0 -&gt; a0) -&gt; (b0, <span class="keyword"
 			  >forall</span
-			  > d. d -&gt; <a href="#"
+			  > c0. c0 -&gt; <a href="#"
 			  >Quux</a
-			  > a b c) -&gt; (b, c) <a href="#" class="selflink"
+			  > a b c) -&gt; (b0, c1) <a href="#" class="selflink"
 			  >#</a
 			  ></p
 			><p class="src"
 			><a href="#"
 			  >baz'</a
-			  > :: b -&gt; (<span class="keyword"
+			  > :: b0 -&gt; (<span class="keyword"
 			  >forall</span
-			  > d. d -&gt; <a href="#"
+			  > b1. b1 -&gt; <a href="#"
 			  >Quux</a
 			  > a b c) -&gt; (<span class="keyword"
 			  >forall</span
-			  > d. d -&gt; <a href="#"
+			  > b2. b2 -&gt; <a href="#"
 			  >Quux</a
-			  > a b c) -&gt; [(b, <a href="#"
+			  > a b c) -&gt; [(b0, <a href="#"
 			  >Quux</a
 			  > a b c)] <a href="#" class="selflink"
 			  >#</a
@@ -1398,15 +1398,15 @@ window.onload = function () {pageLoad();};
 			><p class="src"
 			><a href="#"
 			  >baz''</a
-			  > :: b -&gt; (<span class="keyword"
+			  > :: b0 -&gt; (<span class="keyword"
 			  >forall</span
-			  > d. (<span class="keyword"
+			  > b1. (<span class="keyword"
 			  >forall</span
-			  > e. e -&gt; <a href="#"
+			  > b2. b2 -&gt; <a href="#"
 			  >Quux</a
-			  > a b c) -&gt; c) -&gt; <span class="keyword"
+			  > a b c) -&gt; c0) -&gt; <span class="keyword"
 			  >forall</span
-			  > d. d -&gt; b <a href="#" class="selflink"
+			  > c1. c1 -&gt; b0 <a href="#" class="selflink"
 			  >#</a
 			  ></p
 			></div
@@ -1438,31 +1438,31 @@ window.onload = function () {pageLoad();};
 			  >baz</a
 			  > :: (a, [b], b, a) -&gt; (<span class="keyword"
 			  >forall</span
-			  > c. c -&gt; c) -&gt; (b, <span class="keyword"
+			  > a0. a0 -&gt; a0) -&gt; (b0, <span class="keyword"
 			  >forall</span
-			  > c. c -&gt; (a, [b], b, a)) -&gt; (b, c) <a href="#" class="selflink"
+			  > c. c -&gt; (a, [b], b, a)) -&gt; (b0, c) <a href="#" class="selflink"
 			  >#</a
 			  ></p
 			><p class="src"
 			><a href="#"
 			  >baz'</a
-			  > :: b -&gt; (<span class="keyword"
+			  > :: b0 -&gt; (<span class="keyword"
 			  >forall</span
-			  > c. c -&gt; (a, [b], b, a)) -&gt; (<span class="keyword"
+			  > b1. b1 -&gt; (a, [b], b, a)) -&gt; (<span class="keyword"
 			  >forall</span
-			  > c. c -&gt; (a, [b], b, a)) -&gt; [(b, (a, [b], b, a))] <a href="#" class="selflink"
+			  > b2. b2 -&gt; (a, [b], b, a)) -&gt; [(b0, (a, [b], b, a))] <a href="#" class="selflink"
 			  >#</a
 			  ></p
 			><p class="src"
 			><a href="#"
 			  >baz''</a
-			  > :: b -&gt; (<span class="keyword"
+			  > :: b0 -&gt; (<span class="keyword"
 			  >forall</span
-			  > c. (<span class="keyword"
+			  > b1. (<span class="keyword"
 			  >forall</span
-			  > d. d -&gt; (a, [b], b, a)) -&gt; c) -&gt; <span class="keyword"
+			  > b2. b2 -&gt; (a, [b], b, a)) -&gt; c) -&gt; <span class="keyword"
 			  >forall</span
-			  > c. c -&gt; b <a href="#" class="selflink"
+			  > c. c -&gt; b0 <a href="#" class="selflink"
 			  >#</a
 			  ></p
 			></div
@@ -1546,9 +1546,9 @@ window.onload = function () {pageLoad();};
 			  >Quux</a
 			  > a b <a href="#"
 			  >Int</a
-			  > -&gt; a -&gt; <a href="#"
+			  > -&gt; a0 -&gt; <a href="#"
 			  >Quux</a
-			  > a b a <a href="#" class="selflink"
+			  > a b a0 <a href="#" class="selflink"
 			  >#</a
 			  ></p
 			><p class="src"
@@ -1558,7 +1558,7 @@ window.onload = function () {pageLoad();};
 			  >Quux</a
 			  > a b (<a href="#"
 			  >Quux</a
-			  > a b a) -&gt; <a href="#"
+			  > a b a0) -&gt; <a href="#"
 			  >Int</a
 			  > -&gt; <a href="#"
 			  >Quux</a
@@ -1628,7 +1628,7 @@ window.onload = function () {pageLoad();};
 			  >Quux</a
 			  > a c (<a href="#"
 			  >Quux</a
-			  > a c b)) <a href="#" class="selflink"
+			  > a c b0)) <a href="#" class="selflink"
 			  >#</a
 			  ></p
 			><p class="src"
@@ -1644,9 +1644,9 @@ window.onload = function () {pageLoad();};
 			  >Quux</a
 			  > a b c)) -&gt; (<a href="#"
 			  >Quux</a
-			  > a c b, <a href="#"
+			  > a c b0, <a href="#"
 			  >Quux</a
-			  > a c c) <a href="#" class="selflink"
+			  > a c c0) <a href="#" class="selflink"
 			  >#</a
 			  ></p
 			><p class="src"
@@ -1662,9 +1662,9 @@ window.onload = function () {pageLoad();};
 			  >Quux</a
 			  > a b c)) -&gt; (<a href="#"
 			  >Quux</a
-			  > a c b, <a href="#"
+			  > a c b0, <a href="#"
 			  >Quux</a
-			  > a c c) <a href="#" class="selflink"
+			  > a c c0) <a href="#" class="selflink"
 			  >#</a
 			  ></p
 			></div
@@ -1700,25 +1700,25 @@ window.onload = function () {pageLoad();};
 			  >Quux</a
 			  > a b c -&gt; (<span class="keyword"
 			  >forall</span
-			  > d. d -&gt; d) -&gt; (b, <span class="keyword"
+			  > a0. a0 -&gt; a0) -&gt; (b0, <span class="keyword"
 			  >forall</span
-			  > d. d -&gt; <a href="#"
+			  > c0. c0 -&gt; <a href="#"
 			  >Quux</a
-			  > a b c) -&gt; (b, c) <a href="#" class="selflink"
+			  > a b c) -&gt; (b0, c1) <a href="#" class="selflink"
 			  >#</a
 			  ></p
 			><p class="src"
 			><a href="#"
 			  >baz'</a
-			  > :: b -&gt; (<span class="keyword"
+			  > :: b0 -&gt; (<span class="keyword"
 			  >forall</span
-			  > d. d -&gt; <a href="#"
+			  > b1. b1 -&gt; <a href="#"
 			  >Quux</a
 			  > a b c) -&gt; (<span class="keyword"
 			  >forall</span
-			  > d. d -&gt; <a href="#"
+			  > b2. b2 -&gt; <a href="#"
 			  >Quux</a
-			  > a b c) -&gt; [(b, <a href="#"
+			  > a b c) -&gt; [(b0, <a href="#"
 			  >Quux</a
 			  > a b c)] <a href="#" class="selflink"
 			  >#</a
@@ -1726,15 +1726,15 @@ window.onload = function () {pageLoad();};
 			><p class="src"
 			><a href="#"
 			  >baz''</a
-			  > :: b -&gt; (<span class="keyword"
+			  > :: b0 -&gt; (<span class="keyword"
 			  >forall</span
-			  > d. (<span class="keyword"
+			  > b1. (<span class="keyword"
 			  >forall</span
-			  > e. e -&gt; <a href="#"
+			  > b2. b2 -&gt; <a href="#"
 			  >Quux</a
-			  > a b c) -&gt; c) -&gt; <span class="keyword"
+			  > a b c) -&gt; c0) -&gt; <span class="keyword"
 			  >forall</span
-			  > d. d -&gt; b <a href="#" class="selflink"
+			  > c1. c1 -&gt; b0 <a href="#" class="selflink"
 			  >#</a
 			  ></p
 			></div
diff --git a/html-test/src/Bug613.hs b/html-test/src/Bug613.hs
new file mode 100644
index 00000000..effef695
--- /dev/null
+++ b/html-test/src/Bug613.hs
@@ -0,0 +1,16 @@
+module Bug613  where
+
+import Prelude (Either(Left, Right))
+
+class Functor f where
+  fmap :: (a -> b) -> f a -> f b
+
+instance Functor (Either a) where
+  fmap _ (Left x) = Left x
+  fmap f (Right y) = Right (f y)
+
+-- | Phantom type a0 is added to block the first renaming from a to a0. This ensures that the renamer doesn't create a new conflict
+data ThreeVars a0 a b = ThreeVars a b
+
+instance Functor (ThreeVars a0 a) where
+  fmap f (ThreeVars a b) = ThreeVars a (f b)
-- 
cgit v1.2.3


From 3fddb62913c72f29843335aa796c2e444ded1608 Mon Sep 17 00:00:00 2001
From: Tim Baumann <tim@timbaumann.info>
Date: Sun, 6 Aug 2017 11:33:38 +0200
Subject: Fix: Generate pattern signatures for constructors exported as
 patterns (#663)

* Fix pretty-printing of pattern signatures

Pattern synonyms can have up to two contexts, both having a
different semantic meaning: The first holds the constraints
required to perform the matching, the second contains the
constraints provided by a successful pattern match. When the
first context is empty but the second is not it is necessary
to render the first, empty context.

* Generate pattern synonym signatures for ctors exported as patterns

This fixes #653.

* Simplify extractPatternSyn

It is not necessary to generate the simplest type signature since
it will be simplified when pretty-printed.

* Add changelog entries for PR #663

* Fix extractPatternSyn error message
---
 CHANGES.md                                     |   5 +
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 242 ++++++++++++++-----------
 haddock-api/src/Haddock/Interface/Create.hs    |  34 +++-
 haddock-api/src/Haddock/Types.hs               |   6 +
 html-test/ref/ConstructorPatternExport.html    | 124 +++++++++++++
 html-test/ref/PatternSyns.html                 |  76 ++++++++
 html-test/src/ConstructorPatternExport.hs      |  26 +++
 html-test/src/PatternSyns.hs                   |   8 +-
 8 files changed, 412 insertions(+), 109 deletions(-)
 create mode 100644 html-test/ref/ConstructorPatternExport.html
 create mode 100644 html-test/src/ConstructorPatternExport.hs

(limited to 'haddock-api/src')

diff --git a/CHANGES.md b/CHANGES.md
index 5050339d..f96ac325 100644
--- a/CHANGES.md
+++ b/CHANGES.md
@@ -6,6 +6,11 @@
 
  * Move markup related data types to haddock-library
 
+ * Fix: Show empty constraint contexts in pattern type signatures (#663)
+
+ * Fix: Generate constraint signatures for constructors exported as pattern
+   synonyms (#663)
+
 ## Changes in version 2.18.1
 
  * Synopsis is working again (#599)
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index cda0611a..c78bee2d 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -71,9 +71,9 @@ ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
             Splice -> Unicode -> Qualification -> Html
 ppFunSig summary links loc doc docnames typ fixities splice unicode qual =
   ppSigLike summary links loc mempty doc docnames fixities (unLoc typ, pp_typ)
-            splice unicode qual
+            splice unicode qual HideEmptyContexts
   where
-    pp_typ = ppLType unicode qual typ
+    pp_typ = ppLType unicode qual HideEmptyContexts typ
 
 ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
              [Located DocName] -> LHsSigType DocName ->
@@ -87,20 +87,20 @@ ppLPatSig summary links loc (doc, _argDocs) docnames typ fixities splice unicode
     pref1 = hsep [ keyword "pattern"
                  , hsep $ punctuate comma $ map (ppBinder summary . getOccName) docnames
                  , dcolon unicode
-                 , ppLType unicode qual (hsSigType typ)
+                 , ppPatSigType unicode qual (hsSigType typ)
                  ]
 
 ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName ->
              [DocName] -> [(DocName, Fixity)] -> (HsType DocName, Html) ->
-             Splice -> Unicode -> Qualification -> Html
+             Splice -> Unicode -> Qualification -> HideEmptyContexts -> Html
 ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ)
-          splice unicode qual =
+          splice unicode qual emptyCtxts =
   ppTypeOrFunSig summary links loc docnames typ doc
     ( addFixities $ leader <+> ppTypeSig summary occnames pp_typ unicode
     , addFixities . concatHtml . punctuate comma $ map (ppBinder False) occnames
     , dcolon unicode
     )
-    splice unicode qual
+    splice unicode qual emptyCtxts
   where
     occnames = map (nameOccName . getName) docnames
     addFixities html
@@ -110,8 +110,8 @@ ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ)
 
 ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsType DocName
                -> DocForDecl DocName -> (Html, Html, Html)
-               -> Splice -> Unicode -> Qualification -> Html
-ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) splice unicode qual
+               -> Splice -> Unicode -> Qualification -> HideEmptyContexts -> Html
+ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) splice unicode qual emptyCtxts
   | summary = pref1
   | Map.null argDocs = topDeclElem links loc splice docnames pref1 +++ docSection curName qual doc
   | otherwise = topDeclElem links loc splice docnames pref2 +++
@@ -132,14 +132,14 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep)
       | null (unLoc lctxt)
       = do_largs n leader ltype
       | otherwise
-      = (leader <+> ppLContextNoArrow lctxt unicode qual, Nothing, [])
+      = (leader <+> ppLContextNoArrow lctxt unicode qual emptyCtxts, Nothing, [])
         : do_largs n (darrow unicode) ltype
 
     do_args n leader (HsFunTy lt r)
-      = (leader <+> ppLFunLhType unicode qual lt, argDoc n, [])
+      = (leader <+> ppLFunLhType unicode qual emptyCtxts lt, argDoc n, [])
         : do_largs (n+1) (arrow unicode) r
     do_args n leader t
-      = [(leader <+> ppType unicode qual t, argDoc n, [])]
+      = [(leader <+> ppType unicode qual emptyCtxts t, argDoc n, [])]
 
 ppForAll :: [LHsTyVarBndr DocName] -> Unicode -> Qualification -> Html
 ppForAll tvs unicode qual =
@@ -197,11 +197,11 @@ ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars
         splice unicode qual
   = ppTypeOrFunSig summary links loc [name] (unLoc ltype) doc
                    (full <+> fixs, hdr <+> fixs, spaceHtml +++ equals)
-                   splice unicode qual
+                   splice unicode qual ShowEmptyToplevelContexts
   where
     hdr  = hsep ([keyword "type", ppBinder summary occ]
                  ++ ppTyVars unicode qual (hsQTvExplicit ltyvars))
-    full = hdr <+> equals <+> ppLType unicode qual ltype
+    full = hdr <+> equals <+> ppPatSigType unicode qual ltype
     occ  = nameOccName . getName $ name
     fixs
       | summary   = noHtml
@@ -220,14 +220,14 @@ ppTyName :: Name -> Html
 ppTyName = ppName Prefix
 
 
-ppSimpleSig :: LinksInfo -> Splice -> Unicode -> Qualification -> SrcSpan
+ppSimpleSig :: LinksInfo -> Splice -> Unicode -> Qualification -> HideEmptyContexts -> SrcSpan
             -> [DocName] -> HsType DocName
             -> Html
-ppSimpleSig links splice unicode qual loc names typ =
+ppSimpleSig links splice unicode qual emptyCtxts loc names typ =
     topDeclElem' names $ ppTypeSig True occNames ppTyp unicode
   where
     topDeclElem' = topDeclElem links loc splice
-    ppTyp = ppType unicode qual typ
+    ppTyp = ppType unicode qual emptyCtxts typ
     occNames = map getOccName names
 
 
@@ -321,7 +321,7 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode
     ppTyFamEqn TyFamEqn { tfe_tycon = n, tfe_rhs = rhs
                         , tfe_pats = HsIB { hsib_body = ts }}
       = ( ppAppNameTypes (unLoc n) [] (map unLoc ts) unicode qual
-          <+> equals <+> ppType unicode qual (unLoc rhs)
+          <+> equals <+> ppType unicode qual HideEmptyContexts (unLoc rhs)
         , Nothing, [] )
 
 
@@ -377,7 +377,7 @@ ppAppDocNameTyVarBndrs summ unicode qual n vs =
 ppAppNameTypes :: DocName -> [HsType DocName] -> [HsType DocName]
                -> Unicode -> Qualification -> Html
 ppAppNameTypes n ks ts unicode qual =
-    ppTypeApp n ks ts (\p -> ppDocName qual p True) (ppParendType unicode qual)
+    ppTypeApp n ks ts (\p -> ppDocName qual p True) (ppParendType unicode qual HideEmptyContexts)
 
 
 -- | General printing of type applications
@@ -398,32 +398,35 @@ ppTypeApp n ks ts ppDN ppT = ppDN Prefix n <+> hsep (map ppT $ ks ++ ts)
 
 
 ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Unicode
-                              -> Qualification -> Html
+                              -> Qualification -> HideEmptyContexts -> Html
 ppLContext        = ppContext        . unLoc
 ppLContextNoArrow = ppContextNoArrow . unLoc
 
-ppContextNoArrow :: HsContext DocName -> Unicode -> Qualification -> Html
-ppContextNoArrow cxt unicode qual = fromMaybe noHtml $
-                                    ppContextNoLocsMaybe (map unLoc cxt) unicode qual
+ppContextNoArrow :: HsContext DocName -> Unicode -> Qualification -> HideEmptyContexts -> Html
+ppContextNoArrow cxt unicode qual emptyCtxts = fromMaybe noHtml $
+                                               ppContextNoLocsMaybe (map unLoc cxt) unicode qual emptyCtxts
 
 
-ppContextNoLocs :: [HsType DocName] -> Unicode -> Qualification -> Html
-ppContextNoLocs cxt unicode qual = maybe noHtml (<+> darrow unicode) $
-                                   ppContextNoLocsMaybe cxt unicode qual
+ppContextNoLocs :: [HsType DocName] -> Unicode -> Qualification -> HideEmptyContexts -> Html
+ppContextNoLocs cxt unicode qual emptyCtxts = maybe noHtml (<+> darrow unicode) $
+                                              ppContextNoLocsMaybe cxt unicode qual emptyCtxts
 
 
-ppContextNoLocsMaybe :: [HsType DocName] -> Unicode -> Qualification -> Maybe Html
-ppContextNoLocsMaybe []  _       _    = Nothing
-ppContextNoLocsMaybe cxt unicode qual = Just $ ppHsContext cxt unicode qual
+ppContextNoLocsMaybe :: [HsType DocName] -> Unicode -> Qualification -> HideEmptyContexts -> Maybe Html
+ppContextNoLocsMaybe [] _ _ emptyCtxts =
+  case emptyCtxts of
+    HideEmptyContexts -> Nothing
+    ShowEmptyToplevelContexts -> Just (toHtml "()")
+ppContextNoLocsMaybe cxt unicode qual _ = Just $ ppHsContext cxt unicode qual
 
-ppContext :: HsContext DocName -> Unicode -> Qualification -> Html
-ppContext cxt unicode qual = ppContextNoLocs (map unLoc cxt) unicode qual
+ppContext :: HsContext DocName -> Unicode -> Qualification -> HideEmptyContexts -> Html
+ppContext cxt unicode qual emptyCtxts = ppContextNoLocs (map unLoc cxt) unicode qual emptyCtxts
 
 
-ppHsContext :: [HsType DocName] -> Unicode -> Qualification-> Html
-ppHsContext []  _       _     = noHtml
+ppHsContext :: [HsType DocName] -> Unicode -> Qualification -> Html
+ppHsContext []  _       _    = noHtml
 ppHsContext [p] unicode qual = ppCtxType unicode qual p
-ppHsContext cxt unicode qual = parenList (map (ppType unicode qual) cxt)
+ppHsContext cxt unicode qual = parenList (map (ppType unicode qual HideEmptyContexts) cxt)
 
 
 -------------------------------------------------------------------------------
@@ -436,7 +439,7 @@ ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName
            -> Unicode -> Qualification -> Html
 ppClassHdr summ lctxt n tvs fds unicode qual =
   keyword "class"
-  <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode qual else noHtml)
+  <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode qual HideEmptyContexts else noHtml)
   <+> ppAppDocNameTyVarBndrs summ unicode qual n (hsQTvExplicit tvs)
   <+> ppFds fds unicode qual
 
@@ -592,7 +595,7 @@ ppInstHead :: LinksInfo -> Splice -> Unicode -> Qualification
 ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead {..}) =
     case ihdInstType of
         ClassInst { .. } ->
-            ( subInstHead iid $ ppContextNoLocs clsiCtx unicode qual <+> typ
+            ( subInstHead iid $ ppContextNoLocs clsiCtx unicode qual HideEmptyContexts <+> typ
             , mdoc
             , [subInstDetails iid ats sigs]
             )
@@ -607,7 +610,7 @@ ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead {..}) =
           where
             ptype = keyword "type" <+> typ
             prhs = ptype <+> maybe noHtml
-                                   (\t -> equals <+> ppType unicode qual t) rhs
+                                   (\t -> equals <+> ppType unicode qual HideEmptyContexts t) rhs
         DataInst dd ->
             ( subInstHead iid pdata
             , mdoc
@@ -636,9 +639,9 @@ ppInstanceSigs links splice unicode qual sigs = do
     TypeSig lnames typ <- sigs
     let names = map unLoc lnames
         L _ rtyp = hsSigWcType typ
-    -- Instance methods signatures are synified and thus don't have a useful 
+    -- Instance methods signatures are synified and thus don't have a useful
     -- SrcSpan value. Use the methods name location instead.
-    return $ ppSimpleSig links splice unicode qual (getLoc $ head $ lnames) names rtyp
+    return $ ppSimpleSig links splice unicode qual HideEmptyContexts (getLoc $ head $ lnames) names rtyp
 
 
 lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2
@@ -698,7 +701,7 @@ ppShortDataDecl summary dataInst dataDecl pats unicode qual
     pats1 = [ hsep [ keyword "pattern"
                    , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames
                    , dcolon unicode
-                   , ppLType unicode qual (hsSigType typ)
+                   , ppPatSigType unicode qual (hsSigType typ)
                    ]
             | (SigD (PatSynSig lnames typ),_) <- pats
             ]
@@ -744,7 +747,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats
       [ (hsep [ keyword "pattern"
               , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames
               , dcolon unicode
-              , ppLType unicode qual (hsSigType typ)
+              , ppPatSigType unicode qual (hsSigType typ)
               ] <+> ppFixities subfixs qual
         ,combineDocumentation (fst d), [])
       | (SigD (PatSynSig lnames typ),d) <- pats
@@ -769,17 +772,17 @@ 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)
+            : map (ppLParendType unicode qual HideEmptyContexts) args), noHtml, noHtml)
     RecCon (L _ fields) ->
       (header_ unicode qual +++ ppOcc <+> char '{',
        doRecordFields fields,
        char '}')
     InfixCon arg1 arg2 ->
-      (header_ unicode qual +++ hsep [ppLParendType unicode qual arg1,
-            ppOccInfix, ppLParendType unicode qual arg2],
+      (header_ unicode qual +++ hsep [ppLParendType unicode qual HideEmptyContexts arg1,
+            ppOccInfix, ppLParendType unicode qual HideEmptyContexts arg2],
        noHtml, noHtml)
 
-  ConDeclGADT {} -> (ppOcc <+> dcolon unicode <+> ppLType unicode qual resTy,noHtml,noHtml)
+  ConDeclGADT {} -> (ppOcc <+> dcolon unicode <+> ppLType unicode qual HideEmptyContexts resTy,noHtml,noHtml)
 
   where
     resTy = hsib_body (con_type con)
@@ -811,7 +814,7 @@ ppConstrHdr forall_ tvs ctxt unicode qual
  = (if null tvs then noHtml else ppForall)
    +++
    (if null ctxt then noHtml
-    else ppContextNoArrow ctxt unicode qual
+    else ppContextNoArrow ctxt unicode qual HideEmptyContexts
          <+> darrow unicode +++ toHtml " ")
   where
     ppForall | forall_   = forallSymbol unicode <+> hsep (map (ppName Prefix) tvs)
@@ -827,15 +830,15 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con)
       ConDeclH98{} -> case con_details con of
         PrefixCon args ->
           hsep ((header_ +++ ppOcc)
-            : map (ppLParendType unicode qual) args)
+            : map (ppLParendType unicode qual HideEmptyContexts) args)
           <+> fixity
 
         RecCon _ -> header_ +++ ppOcc <+> fixity
 
         InfixCon arg1 arg2 ->
-          hsep [header_ +++ ppLParendType unicode qual arg1,
+          hsep [header_ +++ ppLParendType unicode qual HideEmptyContexts arg1,
             ppOccInfix,
-            ppLParendType unicode qual arg2]
+            ppLParendType unicode qual HideEmptyContexts arg2]
           <+> fixity
 
       ConDeclGADT{} -> doGADTCon resTy
@@ -852,7 +855,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
+        <+> ppLType unicode qual HideEmptyContexts ty
         <+> fixity
 
     fixity  = ppFixities fixities qual
@@ -879,9 +882,12 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con)
 ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification
                   -> ConDeclField DocName -> SubDecl
 ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) =
-  (hsep (punctuate comma (map ((ppBinder False) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names)) <+> dcolon unicode <+> ppLType unicode qual ltype,
-    mbDoc,
-    [])
+  ( hsep (punctuate comma (map ((ppBinder False) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names))
+      <+> dcolon unicode
+      <+> ppLType unicode qual HideEmptyContexts 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
@@ -891,7 +897,7 @@ ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) =
 ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocName -> Html
 ppShortField summary unicode qual (ConDeclField names ltype _)
   = hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names))
-    <+> dcolon unicode <+> ppLType unicode qual ltype
+    <+> dcolon unicode <+> ppLType unicode qual HideEmptyContexts ltype
 
 
 -- | Print the LHS of a data\/newtype declaration.
@@ -906,7 +912,7 @@ ppDataHeader summary decl@(DataDecl { tcdDataDefn =
     (case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" })
     <+>
     -- context
-    ppLContext ctxt unicode qual <+>
+    ppLContext ctxt unicode qual HideEmptyContexts <+>
     -- T a b c ..., or a :+: b
     ppDataBinderWithVars summary unicode qual decl
     <+> case ks of
@@ -958,19 +964,18 @@ maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p
                                | otherwise            = p
 
 
-ppLType, ppLParendType, ppLFunLhType :: Unicode -> Qualification
-                                     -> Located (HsType DocName) -> Html
-ppLType       unicode qual y = ppType unicode qual (unLoc y)
-ppLParendType unicode qual y = ppParendType unicode qual (unLoc y)
-ppLFunLhType  unicode qual y = ppFunLhType unicode qual (unLoc y)
+ppLType, ppLParendType, ppLFunLhType :: Unicode -> Qualification -> HideEmptyContexts -> Located (HsType DocName) -> Html
+ppLType       unicode qual emptyCtxts y = ppType unicode qual emptyCtxts (unLoc y)
+ppLParendType unicode qual emptyCtxts y = ppParendType unicode qual emptyCtxts (unLoc y)
+ppLFunLhType  unicode qual emptyCtxts y = ppFunLhType unicode qual emptyCtxts (unLoc y)
 
+ppCtxType :: Unicode -> Qualification -> HsType DocName -> Html
+ppCtxType unicode qual ty = ppr_mono_ty pREC_CTX ty unicode qual HideEmptyContexts
 
-ppType, ppCtxType, ppParendType, ppFunLhType :: Unicode -> Qualification
-                                             -> HsType DocName -> Html
-ppType       unicode qual ty = ppr_mono_ty pREC_TOP ty unicode qual
-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
+ppType, ppParendType, ppFunLhType :: Unicode -> Qualification -> HideEmptyContexts -> HsType DocName -> Html
+ppType       unicode qual emptyCtxts ty = ppr_mono_ty pREC_TOP ty unicode qual emptyCtxts
+ppParendType unicode qual emptyCtxts ty = ppr_mono_ty pREC_CON ty unicode qual emptyCtxts
+ppFunLhType  unicode qual emptyCtxts ty = ppr_mono_ty pREC_FUN ty unicode qual emptyCtxts
 
 ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr DocName -> Html
 ppHsTyVarBndr _       qual (UserTyVar (L _ name)) =
@@ -983,62 +988,85 @@ ppLKind :: Unicode -> Qualification -> LHsKind DocName -> Html
 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
+ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual HideEmptyContexts
+
+ppPatSigType :: Unicode -> Qualification -> LHsType DocName -> Html
+ppPatSigType unicode qual typ =
+  let emptyCtxts =
+        if hasNonEmptyContext typ && isFirstContextEmpty typ
+          then ShowEmptyToplevelContexts
+          else HideEmptyContexts
+  in ppLType unicode qual emptyCtxts typ
+  where
+    hasNonEmptyContext :: LHsType name -> Bool
+    hasNonEmptyContext t =
+      case unLoc t of
+        HsForAllTy _ s -> hasNonEmptyContext s
+        HsQualTy cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True
+        HsFunTy _ s -> hasNonEmptyContext s
+        _ -> False
+    isFirstContextEmpty :: LHsType name -> Bool
+    isFirstContextEmpty t =
+      case unLoc t of
+        HsForAllTy _ s -> isFirstContextEmpty s
+        HsQualTy cxt _ -> null (unLoc cxt)
+        HsFunTy _ s -> isFirstContextEmpty s
+        _ -> False
 
 ppForAllPart :: Unicode -> Qualification -> [LHsTyVarBndr DocName] -> Html
 ppForAllPart unicode qual tvs = hsep (forallSymbol unicode : ppTyVars unicode qual tvs) +++ dot
 
-ppr_mono_lty :: Int -> LHsType DocName -> Unicode -> Qualification -> Html
+ppr_mono_lty :: Int -> LHsType DocName -> Unicode -> Qualification -> HideEmptyContexts -> 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 tvs ty) unicode qual
+ppr_mono_ty :: Int -> HsType DocName -> Unicode -> Qualification -> HideEmptyContexts -> Html
+ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode qual emptyCtxts
   = maybeParen ctxt_prec pREC_FUN $
-    ppForAllPart unicode qual tvs <+> ppr_mono_lty pREC_TOP ty unicode qual
+    ppForAllPart unicode qual tvs <+> ppr_mono_lty pREC_TOP ty unicode qual emptyCtxts
 
-ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode qual
+ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode qual emptyCtxts
   = maybeParen ctxt_prec pREC_FUN $
-    ppLContext ctxt unicode qual <+> ppr_mono_lty pREC_TOP ty unicode qual
+    ppLContext ctxt unicode qual emptyCtxts <+> ppr_mono_lty pREC_TOP ty unicode qual emptyCtxts
 
 -- UnicodeSyntax alternatives
-ppr_mono_ty _ (HsTyVar _ (L _ 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 _ (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 _         (HsSumTy tys) u q = sumParens (map (ppLType u q) tys)
-ppr_mono_ty _         (HsKindSig ty kind) u q =
-    parens (ppr_mono_lty pREC_TOP ty u q <+> dcolon u <+> ppLKind u q kind)
-ppr_mono_ty _         (HsListTy ty)       u q = brackets (ppr_mono_lty pREC_TOP ty u q)
-ppr_mono_ty _         (HsPArrTy ty)       u q = pabrackets (ppr_mono_lty pREC_TOP ty u q)
-ppr_mono_ty ctxt_prec (HsIParamTy (L _ 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 {})        _ _ = toHtml "{..}"
+ppr_mono_ty _         (HsBangTy b ty)     u q _ = ppBang b +++ ppLParendType u q HideEmptyContexts ty
+ppr_mono_ty _         (HsTyVar _ (L _ name)) _ q _ = ppDocName q Prefix True name
+ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2)   u q e = ppr_fun_ty ctxt_prec ty1 ty2 u q e
+ppr_mono_ty _         (HsTupleTy con tys) u q _ = tupleParens con (map (ppLType u q HideEmptyContexts) tys)
+ppr_mono_ty _         (HsSumTy tys) u q _ = sumParens (map (ppLType u q HideEmptyContexts) tys)
+ppr_mono_ty _         (HsKindSig ty kind) u q e =
+    parens (ppr_mono_lty pREC_TOP ty u q e <+> dcolon u <+> ppLKind u q kind)
+ppr_mono_ty _         (HsListTy ty)       u q _ = brackets (ppr_mono_lty pREC_TOP ty u q HideEmptyContexts)
+ppr_mono_ty _         (HsPArrTy ty)       u q _ = pabrackets (ppr_mono_lty pREC_TOP ty u q HideEmptyContexts)
+ppr_mono_ty ctxt_prec (HsIParamTy (L _ n) ty) u q _ =
+    maybeParen ctxt_prec pREC_CTX $ ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q HideEmptyContexts
+ppr_mono_ty _         (HsSpliceTy {})     _ _ _ = error "ppr_mono_ty HsSpliceTy"
+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 Promoted _ tys) u q = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys
-ppr_mono_ty _         (HsExplicitListTy NotPromoted _ tys) u q = 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 _         (HsCoreTy {})       _ _ _ = error "ppr_mono_ty HsCoreTy"
+ppr_mono_ty _         (HsExplicitListTy Promoted _ tys) u q _ = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys
+ppr_mono_ty _         (HsExplicitListTy NotPromoted _ tys) u q _ = brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys
+ppr_mono_ty _         (HsExplicitTupleTy _ tys) u q _ = promoQuote $ parenList $ map (ppLType u q HideEmptyContexts) tys
+ppr_mono_ty _         (HsAppsTy {})       _ _ _ = error "ppr_mono_ty HsAppsTy"
 
-ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode qual
+ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode qual _
   = maybeParen ctxt_prec pREC_CTX $
-    ppr_mono_lty pREC_OP ty1 unicode qual <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode qual
+    ppr_mono_lty pREC_OP ty1 unicode qual HideEmptyContexts <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode qual HideEmptyContexts
 
-ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode qual
+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]
+    hsep [ppr_mono_lty pREC_FUN fun_ty unicode qual HideEmptyContexts, ppr_mono_lty pREC_CON arg_ty unicode qual HideEmptyContexts]
 
-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
+    ppr_mono_lty pREC_OP ty1 unicode qual HideEmptyContexts <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual HideEmptyContexts
   where
     -- `(:)` 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.
@@ -1047,25 +1075,25 @@ ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode qual
         | otherwise = ppr_op'
     ppr_op' = ppLDocName qual Infix op
 
-ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual
+ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual emptyCtxts
 --  = parens (ppr_mono_lty pREC_TOP ty)
-  = ppr_mono_lty ctxt_prec ty unicode qual
+  = ppr_mono_lty ctxt_prec ty unicode qual emptyCtxts
 
-ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual
-  = ppr_mono_lty ctxt_prec ty unicode qual
+ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual emptyCtxts
+  = ppr_mono_lty ctxt_prec ty unicode qual emptyCtxts
 
-ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ _ = char '_'
-ppr_mono_ty _ (HsTyLit n) _ _ = ppr_tylit n
+ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ _ _ = char '_'
+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_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Unicode -> Qualification -> Html
-ppr_fun_ty ctxt_prec ty1 ty2 unicode qual
-  = let p1 = ppr_mono_lty pREC_FUN ty1 unicode qual
-        p2 = ppr_mono_lty pREC_TOP ty2 unicode qual
+ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Unicode -> Qualification -> HideEmptyContexts -> Html
+ppr_fun_ty ctxt_prec ty1 ty2 unicode qual emptyCtxts
+  = let p1 = ppr_mono_lty pREC_FUN ty1 unicode qual HideEmptyContexts
+        p2 = ppr_mono_lty pREC_TOP ty2 unicode qual emptyCtxts
     in
     maybeParen ctxt_prec pREC_FUN $
     hsep [p1, arrow unicode <+> p2]
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index b9179d11..89f7f71b 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -985,7 +985,9 @@ extractDecl name decl
                                          O.$$ O.nest 4 (O.ppr matches))
       TyClD d@DataDecl {} ->
         let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars d))
-        in SigD <$> extractRecSel name n tyvar_tys (dd_cons (tcdDataDefn d))
+        in if isDataConName name
+           then SigD <$> extractPatternSyn name n tyvar_tys (dd_cons (tcdDataDefn d))
+           else SigD <$> extractRecSel name n tyvar_tys (dd_cons (tcdDataDefn d))
       InstD (DataFamInstD DataFamInstDecl { dfid_tycon = L _ n
                                           , dfid_pats = HsIB { hsib_body = tys }
                                           , dfid_defn = defn }) ->
@@ -1003,6 +1005,36 @@ extractDecl name decl
           _ -> error "internal: extractDecl (ClsInstD)"
       _ -> error "internal: extractDecl"
 
+extractPatternSyn :: Name -> Name -> [LHsType Name] -> [LConDecl Name] -> LSig Name
+extractPatternSyn nm t tvs cons =
+  case filter matches cons of
+    [] -> error "extractPatternSyn: constructor pattern not found"
+    con:_ -> extract <$> con
+ where
+  matches :: LConDecl Name -> Bool
+  matches (L _ con) = nm `elem` (unLoc <$> getConNames con)
+  extract :: ConDecl Name -> Sig Name
+  extract con =
+    let args =
+          case getConDetails con of
+            PrefixCon args' -> args'
+            RecCon (L _ fields) -> cd_fld_type . unLoc <$> fields
+            InfixCon arg1 arg2 -> [arg1, arg2]
+        typ = longArrow args (data_ty con)
+        typ' =
+          case con of
+            ConDeclH98 { con_cxt = Just cxt } -> noLoc (HsQualTy cxt typ)
+            _ -> typ
+        typ'' = noLoc (HsQualTy (noLoc []) typ')
+    in PatSynSig [noLoc nm] (mkEmptyImplicitBndrs typ'')
+
+  longArrow :: [LHsType name] -> LHsType name -> LHsType name
+  longArrow inputs output = foldr (\x y -> noLoc (HsFunTy x y)) output inputs
+
+  data_ty con
+    | ConDeclGADT{} <- con = hsib_body $ con_type con
+    | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar NotPromoted (noLoc t))) tvs
+
 extractRecSel :: Name -> Name -> [LHsType Name] -> [LConDecl Name]
               -> LSig Name
 extractRecSel _ _ _ [] = error "extractRecSel: selector not found"
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index de599bd8..724f59bc 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -579,6 +579,12 @@ makeModuleQual qual aliases mdl =
     OptFullQual       -> FullQual
     OptNoQual         -> NoQual
 
+-- | Whether to hide empty contexts
+-- Since pattern synonyms have two contexts with different semantics, it is
+-- important to all of them, even if one of them is empty.
+data HideEmptyContexts
+  = HideEmptyContexts
+  | ShowEmptyToplevelContexts
 
 -----------------------------------------------------------------------------
 -- * Error handling
diff --git a/html-test/ref/ConstructorPatternExport.html b/html-test/ref/ConstructorPatternExport.html
new file mode 100644
index 00000000..20f00d0f
--- /dev/null
+++ b/html-test/ref/ConstructorPatternExport.html
@@ -0,0 +1,124 @@
+<html xmlns="http://www.w3.org/1999/xhtml"
+><head
+  ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"
+     /><title
+    >ConstructorPatternExport</title
+    ><link href="#" rel="stylesheet" type="text/css" title="Ocean"
+     /><script src="haddock-util.js" type="text/javascript"
+    ></script
+    ><script src="https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.0/MathJax.js?config=TeX-AMS-MML_HTMLorMML" type="text/javascript"
+    ></script
+    ><script type="text/javascript"
+    >//
+window.onload = function () {pageLoad();};
+//
+</script
+    ></head
+  ><body
+  ><div id="package-header"
+    ><ul class="links" id="page-menu"
+      ><li
+	><a href="#"
+	  >Contents</a
+	  ></li
+	><li
+	><a href="#"
+	  >Index</a
+	  ></li
+	></ul
+      ><p class="caption empty"
+      ></p
+      ></div
+    ><div id="content"
+    ><div id="module-header"
+      ><table class="info"
+	><tr
+	  ><th
+	    >Safe Haskell</th
+	    ><td
+	    >Safe</td
+	    ></tr
+	  ></table
+	><p class="caption"
+	>ConstructorPatternExport</p
+	></div
+      ><div id="interface"
+      ><h1
+	>Documentation</h1
+	><div class="top"
+	><p class="src"
+	  ><span class="keyword"
+	    >pattern</span
+	    > <a id="v:FooCons" class="def"
+	    >FooCons</a
+	    > :: <a href="#"
+	    >String</a
+	    > -&gt; a -&gt; Foo a <a href="#" class="selflink"
+	    >#</a
+	    ></p
+	  ></div
+	><div class="top"
+	><p class="src"
+	  ><span class="keyword"
+	    >pattern</span
+	    > <a id="v:MyRecCons" class="def"
+	    >MyRecCons</a
+	    > :: <a href="#"
+	    >Bool</a
+	    > -&gt; <a href="#"
+	    >Int</a
+	    > -&gt; MyRec <a href="#" class="selflink"
+	    >#</a
+	    ></p
+	  ></div
+	><div class="top"
+	><p class="src"
+	  ><span class="keyword"
+	    >pattern</span
+	    > <a id="v::-43-" class="def"
+	    >(:+)</a
+	    > :: <a href="#"
+	    >String</a
+	    > -&gt; a -&gt; MyInfix a <a href="#" class="selflink"
+	    >#</a
+	    ></p
+	  ></div
+	><div class="top"
+	><p class="src"
+	  ><span class="keyword"
+	    >pattern</span
+	    > <a id="v:BlubCons" class="def"
+	    >BlubCons</a
+	    > :: () =&gt; <a href="#"
+	    >Show</a
+	    > b =&gt; b -&gt; Blub <a href="#" class="selflink"
+	    >#</a
+	    ></p
+	  ></div
+	><div class="top"
+	><p class="src"
+	  ><span class="keyword"
+	    >pattern</span
+	    > <a id="v:MyGADTCons" class="def"
+	    >MyGADTCons</a
+	    > :: () =&gt; <span class="keyword"
+	    >forall</span
+	    > a. <a href="#"
+	    >Eq</a
+	    > a =&gt; a -&gt; <a href="#"
+	    >Int</a
+	    > -&gt; MyGADT (<a href="#"
+	    >Maybe</a
+	    > <a href="#"
+	    >String</a
+	    >) <a href="#" class="selflink"
+	    >#</a
+	    ></p
+	  ></div
+	></div
+      ></div
+    ><div id="footer"
+    ></div
+    ></body
+  ></html
+>
\ No newline at end of file
diff --git a/html-test/ref/PatternSyns.html b/html-test/ref/PatternSyns.html
index 2cf936b3..37596645 100644
--- a/html-test/ref/PatternSyns.html
+++ b/html-test/ref/PatternSyns.html
@@ -99,6 +99,28 @@ window.onload = function () {pageLoad();};
 	    >FooType</a
 	    > x1))</li
 	  ><li class="src short"
+	  ><span class="keyword"
+	    >data</span
+	    > <a href="#"
+	    >BlubType</a
+	    > = <a href="#"
+	    >Show</a
+	    > x =&gt; <a href="#"
+	    >BlubCtor</a
+	    > x</li
+	  ><li class="src short"
+	  ><span class="keyword"
+	    >pattern</span
+	    > <a href="#"
+	    >Blub</a
+	    > :: () =&gt; <span class="keyword"
+	    >forall</span
+	    > x. <a href="#"
+	    >Show</a
+	    > x =&gt; x -&gt; <a href="#"
+	    >BlubType</a
+	    ></li
+	  ><li class="src short"
 	  ><span class="keyword"
 	    >data</span
 	    > (a :: <a href="#"
@@ -234,6 +256,60 @@ window.onload = function () {pageLoad();};
 	    ></div
 	  ></div
 	><div class="top"
+	><p class="src"
+	  ><span class="keyword"
+	    >data</span
+	    > <a id="t:BlubType" class="def"
+	    >BlubType</a
+	    > <a href="#" class="selflink"
+	    >#</a
+	    ></p
+	  ><div class="doc"
+	  ><p
+	    >BlubType is existentially quantified</p
+	    ></div
+	  ><div class="subs constructors"
+	  ><p class="caption"
+	    >Constructors</p
+	    ><table
+	    ><tr
+	      ><td class="src"
+		><a href="#"
+		  >Show</a
+		  > x =&gt; <a id="v:BlubCtor" class="def"
+		  >BlubCtor</a
+		  > x</td
+		><td class="doc empty"
+		></td
+		></tr
+	      ></table
+	    ></div
+	  ></div
+	><div class="top"
+	><p class="src"
+	  ><span class="keyword"
+	    >pattern</span
+	    > <a id="v:Blub" class="def"
+	    >Blub</a
+	    > :: () =&gt; <span class="keyword"
+	    >forall</span
+	    > x. <a href="#"
+	    >Show</a
+	    > x =&gt; x -&gt; <a href="#"
+	    >BlubType</a
+	    > <a href="#" class="selflink"
+	    >#</a
+	    ></p
+	  ><div class="doc"
+	  ><p
+	    >Pattern synonym for <code
+	      ><a href="#"
+		>Blub</a
+		></code
+	      > x</p
+	    ></div
+	  ></div
+	><div class="top"
 	><p class="src"
 	  ><span class="keyword"
 	    >data</span
diff --git a/html-test/src/ConstructorPatternExport.hs b/html-test/src/ConstructorPatternExport.hs
new file mode 100644
index 00000000..7897b4bc
--- /dev/null
+++ b/html-test/src/ConstructorPatternExport.hs
@@ -0,0 +1,26 @@
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
+
+module ConstructorPatternExport (
+    pattern FooCons
+  , pattern MyRecCons
+  , pattern (:+)
+  , pattern BlubCons
+  , pattern MyGADTCons
+  ) where
+
+data Foo a = FooCons String a
+
+data MyRec = MyRecCons { one :: Bool, two :: Int }
+
+data MyInfix a = String :+ a
+
+data Blub = forall b. Show b => BlubCons b
+
+data MyGADT :: * -> * where
+  MyGADTCons :: forall a. Eq a => a -> Int -> MyGADT (Maybe String)
+
+pattern MyGADTCons' :: () => forall a. Eq a => a -> Int -> MyGADT (Maybe String)
+pattern MyGADTCons' x y = MyGADTCons x y
\ No newline at end of file
diff --git a/html-test/src/PatternSyns.hs b/html-test/src/PatternSyns.hs
index a8de113c..bf0f7848 100644
--- a/html-test/src/PatternSyns.hs
+++ b/html-test/src/PatternSyns.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE PatternSynonyms, PolyKinds, TypeOperators #-}
+{-# LANGUAGE ExistentialQuantification, PatternSynonyms, PolyKinds, TypeOperators #-}
 
 -- | Testing some pattern synonyms
 module PatternSyns where
@@ -15,6 +15,12 @@ pattern Bar x = FooCtor (Foo x)
 -- | Pattern synonym for (':<->')
 pattern x :<-> y = (Foo x, Bar y)
 
+-- | BlubType is existentially quantified
+data BlubType = forall x. Show x => BlubCtor x
+
+-- | Pattern synonym for 'Blub' x
+pattern Blub x = BlubCtor x
+
 -- | Doc for ('><')
 data (a :: *) >< b = Empty
 
-- 
cgit v1.2.3


From f1d326b53fbed5d37f2a83c66e73dbbc94a4354f Mon Sep 17 00:00:00 2001
From: Alexander Biehl <alexbiehl@gmail.com>
Date: Sun, 6 Aug 2017 13:18:02 +0200
Subject: Provide --show-interface option to dump interfaces (#645)

* WIP: Provide --show-interface option to dump interfaces

Like ghcs own --show-iface this flag dumps a binary interface file to
stdout in a human (and machine) readable fashion. Currently it uses
json as output format.

* Fill all the jsonNull stubs

* Rework Bifunctor instance of DocH, update changelog and documentation

* replace changelog, bring DocMarkupH doc back

* Update CHANGES.md

* Update CHANGES.md

* Move Control.Arrow up

It would result in unused import if the Bifunctor instance is not generated.
---
 doc/invoking.rst                                   |   5 +
 haddock-api/haddock-api.cabal                      |   1 +
 haddock-api/src/Haddock.hs                         |   7 ++
 haddock-api/src/Haddock/Interface/Json.hs          | 109 +++++++++++++++++++++
 haddock-api/src/Haddock/Options.hs                 |   6 ++
 haddock-library/CHANGES.md                         |   6 ++
 haddock-library/src/Documentation/Haddock/Types.hs |  33 ++++++-
 haddock.cabal                                      |   1 +
 8 files changed, 167 insertions(+), 1 deletion(-)
 create mode 100644 haddock-api/src/Haddock/Interface/Json.hs

(limited to 'haddock-api/src')

diff --git a/doc/invoking.rst b/doc/invoking.rst
index 83087bac..fc1e4410 100644
--- a/doc/invoking.rst
+++ b/doc/invoking.rst
@@ -88,6 +88,11 @@ The following options are available:
     :option:`--read-interface` option for more details. The interface file is
     in a binary format; don't try to read it.
 
+.. option:: --show-interface=<file>
+
+    Dumps a binary interface file to stdout in a human readable fashion.
+    Uses json as output format.
+
 .. [1]
    Haddock interface files are not the same as Haskell interface files,
    I just couldn't think of a better name.
diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal
index ef4bb98c..d38e9149 100644
--- a/haddock-api/haddock-api.cabal
+++ b/haddock-api/haddock-api.cabal
@@ -73,6 +73,7 @@ library
     Haddock.Interface.Rename
     Haddock.Interface.Create
     Haddock.Interface.AttachInstances
+    Haddock.Interface.Json
     Haddock.Interface.LexParseRn
     Haddock.Interface.ParseModuleHeader
     Haddock.Interface.Specialize
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 57ea5fea..554cb416 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -32,6 +32,7 @@ import Haddock.Backends.LaTeX
 import Haddock.Backends.Hoogle
 import Haddock.Backends.Hyperlinker
 import Haddock.Interface
+import Haddock.Interface.Json
 import Haddock.Parser
 import Haddock.Types
 import Haddock.Version
@@ -68,6 +69,7 @@ import System.Directory (doesDirectoryExist)
 import GHC hiding (verbosity)
 import Config
 import DynFlags hiding (projectVersion, verbosity)
+import ErrUtils
 import Packages
 import Panic (handleGhcException)
 import Module
@@ -164,6 +166,11 @@ haddockWithGhc ghc args = handleTopExceptions $ do
 
     dflags <- getDynFlags
 
+    forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do
+      mIfaceFile <- readInterfaceFiles freshNameCache [(("", Nothing), path)]
+      forM_ mIfaceFile $ \(_, ifaceFile) -> do
+        putMsg dflags (renderJson (jsonInterfaceFile ifaceFile))
+
     if not (null files) then do
       (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files
 
diff --git a/haddock-api/src/Haddock/Interface/Json.hs b/haddock-api/src/Haddock/Interface/Json.hs
new file mode 100644
index 00000000..9a569204
--- /dev/null
+++ b/haddock-api/src/Haddock/Interface/Json.hs
@@ -0,0 +1,109 @@
+{-# LANGUAGE RecordWildCards #-}
+module Haddock.Interface.Json (
+    jsonInstalledInterface
+  , jsonInterfaceFile
+  , renderJson
+  ) where
+
+import BasicTypes
+import Json
+import Module
+import Name
+import Outputable
+
+import Control.Arrow
+import Data.Map (Map)
+import Data.Bifunctor
+import qualified Data.Map as Map
+
+import Haddock.Types
+import Haddock.InterfaceFile
+
+jsonInterfaceFile :: InterfaceFile -> JsonDoc
+jsonInterfaceFile InterfaceFile{..} =
+  jsonObject [ ("link_env" , jsonMap nameStableString (jsonString . moduleNameString . moduleName) ifLinkEnv)
+             , ("inst_ifaces", jsonArray (map jsonInstalledInterface ifInstalledIfaces))
+             ]
+
+jsonInstalledInterface :: InstalledInterface -> JsonDoc
+jsonInstalledInterface InstalledInterface{..} = jsonObject properties
+  where
+    properties =
+      [ ("module"          , jsonModule instMod)
+      , ("is_sig"          , jsonBool instIsSig)
+      , ("info"            , jsonHaddockModInfo instInfo)
+      , ("doc_map"         , jsonMap nameStableString jsonMDoc instDocMap)
+      , ("arg_map"         , jsonMap nameStableString (jsonMap show jsonMDoc) instArgMap)
+      , ("exports"         , jsonArray (map jsonName instExports))
+      , ("visible_exports" , jsonArray (map jsonName instVisibleExports))
+      , ("options"         , jsonArray (map (jsonString . show) instOptions))
+      , ("sub_map"         , jsonMap nameStableString (jsonArray . map jsonName) instSubMap)
+      , ("bundled_patsyns" , jsonMap nameStableString (jsonArray . map jsonName) instBundledPatSynMap)
+      , ("fix_map"         , jsonMap nameStableString jsonFixity instFixMap)
+      ]
+
+jsonHaddockModInfo :: HaddockModInfo Name -> JsonDoc
+jsonHaddockModInfo HaddockModInfo{..} =
+  jsonObject [ ("description" , jsonMaybe jsonDoc hmi_description)
+             , ("copyright"   , jsonMaybe jsonString hmi_copyright)
+             , ("maintainer"  , jsonMaybe jsonString hmi_maintainer)
+             , ("stability"   , jsonMaybe jsonString hmi_stability)
+             , ("protability" , jsonMaybe jsonString hmi_portability)
+             , ("safety"      , jsonMaybe jsonString hmi_safety)
+             , ("language"    , jsonMaybe (jsonString . show) hmi_language)
+             , ("extensions"  , jsonArray (map (jsonString . show) hmi_extensions))
+             ]
+
+jsonMap :: (a -> String) -> (b -> JsonDoc) -> Map a b -> JsonDoc
+jsonMap f g = jsonObject . map (f *** g) . Map.toList
+
+jsonMDoc :: MDoc Name -> JsonDoc
+jsonMDoc MetaDoc{..} =
+  jsonObject [ ("meta", jsonObject [("version", jsonMaybe (jsonString . show) (_version _meta))])
+             , ("doc",  jsonDoc _doc)
+             ]
+
+jsonDoc :: Doc Name -> JsonDoc
+jsonDoc doc = jsonString (show (bimap (moduleNameString . fst) nameStableString doc))
+
+jsonModule :: Module -> JsonDoc
+jsonModule = JSString . moduleStableString
+
+jsonName :: Name -> JsonDoc
+jsonName = JSString . nameStableString
+
+jsonFixity :: Fixity -> JsonDoc
+jsonFixity (Fixity _ prec dir) =
+  jsonObject [ ("prec"      , jsonInt prec)
+             , ("direction" , jsonFixityDirection dir)
+             ]
+
+jsonFixityDirection :: FixityDirection -> JsonDoc
+jsonFixityDirection InfixL = jsonString "infixl"
+jsonFixityDirection InfixR = jsonString "infixr"
+jsonFixityDirection InfixN = jsonString "infix"
+
+renderJson :: JsonDoc -> SDoc
+renderJson = renderJSON
+
+jsonMaybe :: (a -> JsonDoc) -> Maybe a -> JsonDoc
+jsonMaybe = maybe jsonNull
+
+jsonString :: String -> JsonDoc
+jsonString = JSString
+
+jsonObject :: [(String, JsonDoc)] -> JsonDoc
+jsonObject = JSObject
+
+jsonArray :: [JsonDoc] -> JsonDoc
+jsonArray = JSArray
+
+jsonNull :: JsonDoc
+jsonNull = JSNull
+
+jsonInt :: Int -> JsonDoc
+jsonInt = JSInt
+
+jsonBool :: Bool -> JsonDoc
+jsonBool = JSBool
+
diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs
index 0449c829..d73d1a79 100644
--- a/haddock-api/src/Haddock/Options.hs
+++ b/haddock-api/src/Haddock/Options.hs
@@ -25,6 +25,7 @@ module Haddock.Options (
   sourceUrls,
   wikiUrls,
   optDumpInterfaceFile,
+  optShowInterfaceFile,
   optLaTeXStyle,
   optMathjax,
   qualification,
@@ -53,6 +54,7 @@ data Flag
 --  | Flag_DocBook
   | Flag_ReadInterface String
   | Flag_DumpInterface String
+  | Flag_ShowInterface String
   | Flag_Heading String
   | Flag_Html
   | Flag_Hoogle
@@ -112,6 +114,8 @@ options backwardsCompat =
       "read an interface from FILE",
     Option ['D']  ["dump-interface"] (ReqArg Flag_DumpInterface "FILE")
       "write the resulting interface to FILE",
+    Option []     ["show-interface"] (ReqArg Flag_ShowInterface "FILE")
+      "print the interface in a human readable form",
 --    Option ['S']  ["docbook"]  (NoArg Flag_DocBook)
 --  "output in DocBook XML",
     Option ['h']  ["html"]     (NoArg Flag_Html)
@@ -270,6 +274,8 @@ wikiUrls flags =
 optDumpInterfaceFile :: [Flag] -> Maybe FilePath
 optDumpInterfaceFile flags = optLast [ str | Flag_DumpInterface str <- flags ]
 
+optShowInterfaceFile :: [Flag] -> Maybe FilePath
+optShowInterfaceFile flags = optLast [ str | Flag_ShowInterface str <- flags ]
 
 optLaTeXStyle :: [Flag] -> Maybe String
 optLaTeXStyle flags = optLast [ str | Flag_LaTeXStyle str <- flags ]
diff --git a/haddock-library/CHANGES.md b/haddock-library/CHANGES.md
index bebb9982..c52908e1 100644
--- a/haddock-library/CHANGES.md
+++ b/haddock-library/CHANGES.md
@@ -1,3 +1,9 @@
+## Changes in version 1.4.6
+
+ * to be released
+
+ * Bifunctor instance for DocH
+
 ## Changes in version 1.4.5
 
  * Move markup related data types to haddock-library
diff --git a/haddock-library/src/Documentation/Haddock/Types.hs b/haddock-library/src/Documentation/Haddock/Types.hs
index 0ab6bb4c..22cab425 100644
--- a/haddock-library/src/Documentation/Haddock/Types.hs
+++ b/haddock-library/src/Documentation/Haddock/Types.hs
@@ -19,6 +19,11 @@ import Data.Foldable
 import Data.Traversable
 #endif
 
+#if MIN_VERSION_base(4,8,0)
+import Control.Arrow ((***))
+import Data.Bifunctor
+#endif
+
 -- | With the advent of 'Version', we may want to start attaching more
 -- meta-data to comments. We make a structure for this ahead of time
 -- so we don't have to gut half the core each time we want to add such
@@ -81,6 +86,33 @@ data DocH mod id
   | DocHeader (Header (DocH mod id))
   deriving (Eq, Show, Functor, Foldable, Traversable)
 
+#if MIN_VERSION_base(4,8,0)
+instance Bifunctor DocH where
+  bimap _ _ DocEmpty = DocEmpty
+  bimap f g (DocAppend docA docB) = DocAppend (bimap f g docA) (bimap f g docB)
+  bimap _ _ (DocString s) = DocString s
+  bimap f g (DocParagraph doc) = DocParagraph (bimap f g doc)
+  bimap _ g (DocIdentifier i) = DocIdentifier (g i)
+  bimap f _ (DocIdentifierUnchecked m) = DocIdentifierUnchecked (f m)
+  bimap _ _ (DocModule s) = DocModule s
+  bimap f g (DocWarning doc) = DocWarning (bimap f g doc)
+  bimap f g (DocEmphasis doc) = DocEmphasis (bimap f g doc)
+  bimap f g (DocMonospaced doc) = DocMonospaced (bimap f g doc)
+  bimap f g (DocBold doc) = DocBold (bimap f g doc)
+  bimap f g (DocUnorderedList docs) = DocUnorderedList (map (bimap f g) docs)
+  bimap f g (DocOrderedList docs) = DocOrderedList (map (bimap f g) docs)
+  bimap f g (DocDefList docs) = DocDefList (map (bimap f g *** bimap f g) docs)
+  bimap f g (DocCodeBlock doc) = DocCodeBlock (bimap f g doc)
+  bimap _ _ (DocHyperlink hyperlink) = DocHyperlink hyperlink
+  bimap _ _ (DocPic picture) = DocPic picture
+  bimap _ _ (DocMathInline s) = DocMathInline s
+  bimap _ _ (DocMathDisplay s) = DocMathDisplay s
+  bimap _ _ (DocAName s) = DocAName s
+  bimap _ _ (DocProperty s) = DocProperty s
+  bimap _ _ (DocExamples examples) = DocExamples examples
+  bimap f g (DocHeader (Header level title)) = DocHeader (Header level (bimap f g title))
+#endif
+
 -- | 'DocMarkupH' is a set of instructions for marking up documentation.
 -- In fact, it's really just a mapping from 'Doc' to some other
 -- type [a], where [a] is usually the type of the output (HTML, say).
@@ -114,4 +146,3 @@ data DocMarkupH mod id a = Markup
   , markupExample              :: [Example] -> a
   , markupHeader               :: Header a -> a
   }
-
diff --git a/haddock.cabal b/haddock.cabal
index 36c80f33..5ae3443c 100644
--- a/haddock.cabal
+++ b/haddock.cabal
@@ -106,6 +106,7 @@ executable haddock
       Documentation.Haddock
       Haddock
       Haddock.Interface
+      Haddock.Interface.Json
       Haddock.Interface.Rename
       Haddock.Interface.Create
       Haddock.Interface.AttachInstances
-- 
cgit v1.2.3


From f7032e5e48c7a6635e1dca607a37a16c8893e94b Mon Sep 17 00:00:00 2001
From: alexbiehl <alex.biehl@gmail.com>
Date: Wed, 16 Aug 2017 09:06:40 +0200
Subject: Refactoring: Make doc renaming monadic

This allows us to later throw warnings if can't find an identifier
---
 haddock-api/src/Haddock/Interface/Create.hs        | 127 ++++++++++++---------
 haddock-api/src/Haddock/Interface/LexParseRn.hs    |  81 ++++++-------
 haddock-library/src/Documentation/Haddock/Types.hs |   3 +
 3 files changed, 116 insertions(+), 95 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 89f7f71b..87cdb01f 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -30,6 +30,7 @@ import Haddock.Backends.Hyperlinker.Types
 import Haddock.Backends.Hyperlinker.Ast as Hyperlinker
 import Haddock.Backends.Hyperlinker.Parser as Hyperlinker
 
+import Data.Bitraversable
 import qualified Data.ByteString as BS
 import qualified Data.Map as M
 import Data.Map (Map)
@@ -38,8 +39,6 @@ import Data.Maybe
 import Data.Monoid
 import Data.Ord
 import Control.Applicative
-import Control.Arrow (second)
-import Control.DeepSeq (force)
 import Control.Exception (evaluate)
 import Control.Monad
 import Data.Traversable
@@ -109,7 +108,6 @@ createInterface tm flags modMap instIfaceMap = do
       exports
         | OptIgnoreExports `elem` opts = Nothing
         | otherwise = exports0
-      warningMap = mkWarningMap dflags warnings gre exportedNames
 
       localBundledPatSyns :: Map Name [Name]
       localBundledPatSyns =
@@ -134,8 +132,10 @@ createInterface tm flags modMap instIfaceMap = do
       -- Locations of all TH splices
       splices = [ l | L l (SpliceD _) <- hsmodDecls hsm ]
 
-      maps@(!docMap, !argMap, !subMap, !declMap, _) =
-        mkMaps dflags gre localInsts declsWithDocs
+  warningMap <- liftErrMsg (mkWarningMap dflags warnings gre exportedNames)
+
+  maps@(!docMap, !argMap, !subMap, !declMap, _) <-
+    liftErrMsg (mkMaps dflags gre localInsts declsWithDocs)
 
   let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap))
 
@@ -161,7 +161,8 @@ createInterface tm flags modMap instIfaceMap = do
 
   let !aliases =
         mkAliasMap dflags $ tm_renamed_source tm
-      modWarn = moduleWarning dflags gre warnings
+
+  modWarn <- liftErrMsg (moduleWarning dflags gre warnings)
 
   tokenizedSrc <- mkMaybeTokenizedSrc flags tm
 
@@ -245,27 +246,29 @@ lookupModuleDyn dflags Nothing mdlName =
 -- Warnings
 -------------------------------------------------------------------------------
 
-mkWarningMap :: DynFlags -> Warnings -> GlobalRdrEnv -> [Name] -> WarningMap
+mkWarningMap :: DynFlags -> Warnings -> GlobalRdrEnv -> [Name] -> ErrMsgM WarningMap
 mkWarningMap dflags warnings gre exps = case warnings of
-  NoWarnings  -> M.empty
-  WarnAll _   -> M.empty
+  NoWarnings  -> pure M.empty
+  WarnAll _   -> pure M.empty
   WarnSome ws ->
-    let ws' = [ (n, w) | (occ, w) <- ws, elt <- lookupGlobalRdrEnv gre occ
+    let ws' = [ (n, w)
+              | (occ, w) <- ws
+              , elt <- lookupGlobalRdrEnv gre occ
               , let n = gre_name elt, n `elem` exps ]
-    in M.fromList $ map (second $ parseWarning dflags gre) ws'
+    in M.fromList <$> traverse (bitraverse pure (parseWarning dflags gre)) ws'
 
-moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings -> Maybe (Doc Name)
-moduleWarning _ _ NoWarnings = Nothing
-moduleWarning _ _ (WarnSome _) = Nothing
-moduleWarning dflags gre (WarnAll w) = Just $ parseWarning dflags gre w
+moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings -> ErrMsgM (Maybe (Doc Name))
+moduleWarning _ _ NoWarnings = pure Nothing
+moduleWarning _ _ (WarnSome _) = pure Nothing
+moduleWarning dflags gre (WarnAll w) = Just <$> parseWarning dflags gre w
 
-parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> Doc Name
-parseWarning dflags gre w = force $ case w of
+parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> ErrMsgM (Doc Name)
+parseWarning dflags gre w = case w of
   DeprecatedTxt _ msg -> format "Deprecated: " (concatFS $ map (sl_fs . unLoc) msg)
   WarningTxt    _ msg -> format "Warning: "    (concatFS $ map (sl_fs . unLoc) msg)
   where
     format x xs = DocWarning . DocParagraph . DocAppend (DocString x)
-                  . processDocString dflags gre $ HsDocString xs
+                  <$> processDocString dflags gre (HsDocString xs)
 
 
 -------------------------------------------------------------------------------
@@ -313,16 +316,15 @@ mkMaps :: DynFlags
        -> GlobalRdrEnv
        -> [Name]
        -> [(LHsDecl Name, [HsDocString])]
-       -> Maps
-mkMaps dflags gre instances decls =
-  let
-    (a, b, c, d) = unzip4 $ map mappings decls
-  in ( f' (map (nubByName fst) a)
-     , f  (filterMapping (not . M.null) b)
-     , f  (filterMapping (not . null) c)
-     , f  (filterMapping (not . null) d)
-     , instanceMap
-     )
+       -> ErrMsgM Maps
+mkMaps dflags gre instances decls = do
+  (a, b, c, d) <- unzip4 <$> traverse mappings decls
+  pure ( f' (map (nubByName fst) a)
+       , f  (filterMapping (not . M.null) b)
+       , f  (filterMapping (not . null) c)
+       , f  (filterMapping (not . null) d)
+       , instanceMap
+       )
   where
     f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b
     f = M.fromListWith (<>) . concat
@@ -334,35 +336,42 @@ mkMaps dflags gre instances decls =
     filterMapping p = map (filter (p . snd))
 
     mappings :: (LHsDecl Name, [HsDocString])
-             -> ( [(Name, MDoc Name)]
-                , [(Name, Map Int (MDoc Name))]
-                , [(Name, [Name])]
-                , [(Name,  [LHsDecl Name])]
-                )
-    mappings (ldecl, docStrs) =
+             -> ErrMsgM ( [(Name, MDoc Name)]
+                        , [(Name, Map Int (MDoc Name))]
+                        , [(Name, [Name])]
+                        , [(Name,  [LHsDecl Name])]
+                        )
+    mappings (ldecl, docStrs) = do
       let L l decl = ldecl
           declDoc :: [HsDocString] -> Map Int HsDocString
-                  -> (Maybe (MDoc Name), Map Int (MDoc Name))
-          declDoc strs m =
-            let doc' = processDocStrings dflags gre strs
-                m' = M.map (processDocStringParas dflags gre) m
-            in (doc', m')
-          (doc, args) = declDoc docStrs (typeDocs decl)
+                  -> ErrMsgM (Maybe (MDoc Name), Map Int (MDoc Name))
+          declDoc strs m = do
+            doc' <- processDocStrings dflags gre strs
+            m'   <- traverse (processDocStringParas dflags gre) m
+            pure (doc', m')
+
+      (doc, args) <- declDoc docStrs (typeDocs decl)
+
+      let
           subs :: [(Name, [HsDocString], Map Int HsDocString)]
           subs = subordinates instanceMap decl
-          (subDocs, subArgs) = unzip $ map (\(_, strs, m) -> declDoc strs m) subs
+
+      (subDocs, subArgs) <- unzip <$> traverse (\(_, strs, m) -> declDoc strs m) subs
+
+      let
           ns = names l decl
           subNs = [ n | (n, _, _) <- subs ]
           dm = [ (n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs ]
           am = [ (n, args) | n <- ns ] ++ zip subNs subArgs
           sm = [ (n, subNs) | n <- ns ]
           cm = [ (n, [ldecl]) | n <- ns ++ subNs ]
-      in seqList ns `seq`
-          seqList subNs `seq`
-          doc `seq`
-          seqList subDocs `seq`
-          seqList subArgs `seq`
-          (dm, am, sm, cm)
+
+      seqList ns `seq`
+        seqList subNs `seq`
+        doc `seq`
+        seqList subDocs `seq`
+        seqList subArgs `seq`
+        pure (dm, am, sm, cm)
 
     instanceMap :: Map SrcSpan Name
     instanceMap = M.fromList [ (getSrcSpan n, n) | n <- instances ]
@@ -602,16 +611,20 @@ mkExportItems
       -- do so.
       -- NB: Pass in identity module, so we can look it up in index correctly
       moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps fixMap splices
-    lookupExport (IEGroup lev docStr)  = return $
-      return . ExportGroup lev "" $ processDocString dflags gre docStr
+    lookupExport (IEGroup lev docStr)  = liftErrMsg $ do
+      doc <- processDocString dflags gre docStr
+      return [ExportGroup lev "" doc]
 
-    lookupExport (IEDoc docStr)        = return $
-      return . ExportDoc $ processDocStringParas dflags gre docStr
+    lookupExport (IEDoc docStr)        = liftErrMsg $ do
+      doc <- processDocStringParas dflags gre docStr
+      return [ExportDoc doc]
 
     lookupExport (IEDocNamed str)      = liftErrMsg $
-      findNamedDoc str [ unL d | d <- decls ] >>= return . \case
-        Nothing -> []
-        Just doc -> return . ExportDoc $ processDocStringParas dflags gre doc
+      findNamedDoc str [ unL d | d <- decls ] >>= \case
+        Nothing -> return  []
+        Just docStr -> do
+          doc <- processDocStringParas dflags gre docStr
+          return [ExportDoc doc]
 
     declWith :: [(HsDecl Name, DocForDecl Name)] -> Name -> ErrMsgGhc [ ExportItem Name ]
     declWith pats t = do
@@ -924,9 +937,11 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap
 
     mkExportItem :: LHsDecl Name -> ErrMsgGhc (Maybe (ExportItem Name))
     mkExportItem (L _ (DocD (DocGroup lev docStr))) = do
-      return . Just . ExportGroup lev "" $ processDocString dflags gre docStr
+      doc <- liftErrMsg (processDocString dflags gre docStr)
+      return . Just . ExportGroup lev "" $ doc
     mkExportItem (L _ (DocD (DocCommentNamed _ docStr))) = do
-      return . Just . ExportDoc $ processDocStringParas dflags gre docStr
+      doc <- liftErrMsg (processDocStringParas dflags gre docStr)
+      return . Just . ExportDoc $ doc
     mkExportItem (L l (ValD d))
       | name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap =
           -- Top-level binding without type signature.
diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs
index 4f6b2c09..a38e7667 100644
--- a/haddock-api/src/Haddock/Interface/LexParseRn.hs
+++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs
@@ -34,20 +34,21 @@ import RdrName
 import RnEnv (dataTcOccs)
 
 processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString]
-                  -> Maybe (MDoc Name)
-processDocStrings dflags gre strs =
-  case metaDocConcat $ map (processDocStringParas dflags gre) strs of
+                  -> ErrMsgM (Maybe (MDoc Name))
+processDocStrings dflags gre strs = do
+  mdoc <- metaDocConcat <$> traverse (processDocStringParas dflags gre) strs
+  case mdoc of
     -- We check that we don't have any version info to render instead
     -- of just checking if there is no comment: there may not be a
     -- comment but we still want to pass through any meta data.
-    MetaDoc { _meta = Meta { _version = Nothing }, _doc = DocEmpty } -> Nothing
-    x -> Just x
+    MetaDoc { _meta = Meta { _version = Nothing }, _doc = DocEmpty } -> pure Nothing
+    x -> pure (Just x)
 
-processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> MDoc Name
+processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (MDoc Name)
 processDocStringParas dflags gre (HsDocString fs) =
-  overDoc (rename dflags gre) $ parseParas dflags (unpackFS fs)
+  overDocF (rename dflags gre) $ parseParas dflags (unpackFS fs)
 
-processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> Doc Name
+processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Doc Name)
 processDocString dflags gre (HsDocString fs) =
   rename dflags gre $ parseString dflags (unpackFS fs)
 
@@ -60,9 +61,11 @@ processModuleHeader dflags gre safety mayStr = do
       Just (L _ (HsDocString fs)) -> do
         let str = unpackFS fs
             (hmi, doc) = parseModuleHeader dflags str
-            !descr = rename dflags gre <$> hmi_description hmi
-            hmi' = hmi { hmi_description = descr }
-            doc' = overDoc (rename dflags gre) doc
+        !descr <- case hmi_description hmi of
+                    Just hmi_descr -> Just <$> rename dflags gre hmi_descr
+                    Nothing        -> pure Nothing
+        let hmi' = hmi { hmi_description = descr }
+        doc'  <- overDocF (rename dflags gre) doc
         return (hmi', Just doc')
 
   let flags :: [LangExt.Extension]
@@ -82,12 +85,12 @@ processModuleHeader dflags gre safety mayStr = do
 -- fallbacks in case we can't locate the identifiers.
 --
 -- See the comments in the source for implementation commentary.
-rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> Doc Name
+rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> ErrMsgM (Doc Name)
 rename dflags gre = rn
   where
     rn d = case d of
-      DocAppend a b -> DocAppend (rn a) (rn b)
-      DocParagraph doc -> DocParagraph (rn doc)
+      DocAppend a b -> DocAppend <$> rn a <*> rn b
+      DocParagraph doc -> DocParagraph <$> rn doc
       DocIdentifier x -> do
         -- Generate the choices for the possible kind of thing this
         -- is.
@@ -100,7 +103,7 @@ rename dflags gre = rn
           -- We found no names in the env so we start guessing.
           [] ->
             case choices of
-              [] -> DocMonospaced (DocString (showPpr dflags x))
+              [] -> pure (DocMonospaced (DocString (showPpr dflags x)))
               -- There was nothing in the environment so we need to
               -- pick some default from what's available to us. We
               -- diverge here from the old way where we would default
@@ -109,37 +112,37 @@ rename dflags gre = rn
               -- type constructor names (such as in #253). So now we
               -- only get type constructor links if they are actually
               -- in scope.
-              a:_ -> outOfScope dflags a
+              a:_ -> pure (outOfScope dflags a)
 
           -- There is only one name in the environment that matches so
           -- use it.
-          [a] -> DocIdentifier a
+          [a] -> pure (DocIdentifier a)
           -- But when there are multiple names available, default to
           -- type constructors: somewhat awfully GHC returns the
           -- values in the list positionally.
-          a:b:_ | isTyConName a -> DocIdentifier a
-                | otherwise -> DocIdentifier b
+          a:b:_ | isTyConName a -> pure (DocIdentifier a)
+                | otherwise -> pure (DocIdentifier b)
 
-      DocWarning doc -> DocWarning (rn doc)
-      DocEmphasis doc -> DocEmphasis (rn doc)
-      DocBold doc -> DocBold (rn doc)
-      DocMonospaced doc -> DocMonospaced (rn doc)
-      DocUnorderedList docs -> DocUnorderedList (map rn docs)
-      DocOrderedList docs -> DocOrderedList (map rn docs)
-      DocDefList list -> DocDefList [ (rn a, rn b) | (a, b) <- list ]
-      DocCodeBlock doc -> DocCodeBlock (rn doc)
-      DocIdentifierUnchecked x -> DocIdentifierUnchecked x
-      DocModule str -> DocModule str
-      DocHyperlink l -> DocHyperlink l
-      DocPic str -> DocPic str
-      DocMathInline str -> DocMathInline str
-      DocMathDisplay str -> DocMathDisplay str
-      DocAName str -> DocAName str
-      DocProperty p -> DocProperty p
-      DocExamples e -> DocExamples e
-      DocEmpty -> DocEmpty
-      DocString str -> DocString str
-      DocHeader (Header l t) -> DocHeader $ Header l (rn t)
+      DocWarning doc -> DocWarning <$> rn doc
+      DocEmphasis doc -> DocEmphasis <$> rn doc
+      DocBold doc -> DocBold <$> rn doc
+      DocMonospaced doc -> DocMonospaced <$> rn doc
+      DocUnorderedList docs -> DocUnorderedList <$> traverse rn docs
+      DocOrderedList docs -> DocOrderedList <$> traverse rn docs
+      DocDefList list -> DocDefList <$> traverse (\(a, b) -> (,) <$> rn a <*> rn b) list
+      DocCodeBlock doc -> DocCodeBlock <$> rn doc
+      DocIdentifierUnchecked x -> pure (DocIdentifierUnchecked x)
+      DocModule str -> pure (DocModule str)
+      DocHyperlink l -> pure (DocHyperlink l)
+      DocPic str -> pure (DocPic str)
+      DocMathInline str -> pure (DocMathInline str)
+      DocMathDisplay str -> pure (DocMathDisplay str)
+      DocAName str -> pure (DocAName str)
+      DocProperty p -> pure (DocProperty p)
+      DocExamples e -> pure (DocExamples e)
+      DocEmpty -> pure (DocEmpty)
+      DocString str -> pure (DocString str)
+      DocHeader (Header l t) -> DocHeader . Header l <$> rn t
 
 -- | Wrap an identifier that's out of scope (i.e. wasn't found in
 -- 'GlobalReaderEnv' during 'rename') in an appropriate doc. Currently
diff --git a/haddock-library/src/Documentation/Haddock/Types.hs b/haddock-library/src/Documentation/Haddock/Types.hs
index 48b29075..1e76c631 100644
--- a/haddock-library/src/Documentation/Haddock/Types.hs
+++ b/haddock-library/src/Documentation/Haddock/Types.hs
@@ -56,6 +56,9 @@ instance Bitraversable MetaDoc where
 overDoc :: (DocH a b -> DocH c d) -> MetaDoc a b -> MetaDoc c d
 overDoc f d = d { _doc = f $ _doc d }
 
+overDocF :: Functor f => (DocH a b -> f (DocH c d)) -> MetaDoc a b -> f (MetaDoc c d)
+overDocF f d = (\x -> d { _doc = x }) <$> f (_doc d)
+
 type Version = [Int]
 
 data Hyperlink = Hyperlink
-- 
cgit v1.2.3


From 740458ac4d2acf197f2ef8dc94a66f9b160b9c3c Mon Sep 17 00:00:00 2001
From: Alexander Biehl <alexbiehl@gmail.com>
Date: Sat, 19 Aug 2017 20:35:27 +0200
Subject: Hyperlinker: Avoid linear lookup in enrichToken (#669)

* Make Span strict in Position

* Hyperlinker: Use a proper map to enrich tokens
---
 .../src/Haddock/Backends/Hyperlinker/Ast.hs        | 80 ++++++++++++----------
 .../src/Haddock/Backends/Hyperlinker/Types.hs      | 14 ++--
 2 files changed, 53 insertions(+), 41 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index 78beacf2..9d273417 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE RecordWildCards #-}
@@ -13,9 +14,13 @@ import Haddock.Backends.Hyperlinker.Types
 import qualified GHC
 
 import Control.Applicative
+import Control.Monad (guard)
 import Data.Data
+import qualified Data.Map.Strict as Map
 import Data.Maybe
 
+import Prelude hiding (span)
+
 everythingInRenamedSource :: (Alternative f, Data x)
   => (forall a. Data a => a -> f r) -> x -> f r
 everythingInRenamedSource f = Syb.everythingButType @GHC.Name (<|>) f
@@ -28,25 +33,45 @@ enrich src =
         , rtkDetails = enrichToken token detailsMap
         }
   where
-    detailsMap = concatMap ($ src)
-        [ variables
-        , types
-        , decls
-        , binds
-        , imports
-        ]
+    detailsMap =
+      mkDetailsMap (concatMap ($ src)
+                     [ variables
+                     , types
+                     , decls
+                     , binds
+                     , imports
+                     ])
+
+type LTokenDetails = [(GHC.SrcSpan, TokenDetails)]
 
 -- | A map containing association between source locations and "details" of
 -- this location.
 --
--- For the time being, it is just a list of pairs. However, looking up things
--- in such structure has linear complexity. We cannot use any hashmap-like
--- stuff because source locations are not ordered. In the future, this should
--- be replaced with interval tree data structure.
-type DetailsMap = [(GHC.SrcSpan, TokenDetails)]
+type DetailsMap = Map.Map Position (Span, TokenDetails)
+
+mkDetailsMap :: [(GHC.SrcSpan, TokenDetails)] -> DetailsMap
+mkDetailsMap xs =
+  Map.fromListWith select_details [ (start, (token_span, token_details))
+                                  | (ghc_span, token_details) <- xs
+                                  , Just !token_span <- [ghcSrcSpanToSpan ghc_span]
+                                  , let start = spStart token_span
+                                  ]
+  where
+    -- favour token details which appear earlier in the list
+    select_details _new old = old
 
 lookupBySpan :: Span -> DetailsMap -> Maybe TokenDetails
-lookupBySpan tspan = listToMaybe . map snd . filter (matches tspan . fst)
+lookupBySpan span details = do
+  (_, (tok_span, tok_details)) <- Map.lookupLE (spStart span) details
+  guard (tok_span `containsSpan` span )
+  return tok_details
+
+ghcSrcSpanToSpan :: GHC.SrcSpan -> Maybe Span
+ghcSrcSpanToSpan (GHC.RealSrcSpan span) =
+  Just (Span { spStart = Position (GHC.srcSpanStartLine span) (GHC.srcSpanStartCol span)
+             , spEnd   = Position (GHC.srcSpanEndLine span) (GHC.srcSpanEndCol span)
+             })
+ghcSrcSpanToSpan _ = Nothing
 
 enrichToken :: Token -> DetailsMap -> Maybe TokenDetails
 enrichToken (Token typ _ spn) dm
@@ -54,7 +79,7 @@ enrichToken (Token typ _ spn) dm
 enrichToken _ _ = Nothing
 
 -- | Obtain details map for variables ("normally" used identifiers).
-variables :: GHC.RenamedSource -> DetailsMap
+variables :: GHC.RenamedSource -> LTokenDetails
 variables =
     everythingInRenamedSource (var `Syb.combine` rec)
   where
@@ -70,7 +95,7 @@ variables =
         _ -> empty
 
 -- | Obtain details map for types.
-types :: GHC.RenamedSource -> DetailsMap
+types :: GHC.RenamedSource -> LTokenDetails
 types = everythingInRenamedSource ty
   where
     ty term = case cast term of
@@ -84,7 +109,7 @@ types = everythingInRenamedSource ty
 -- ordinary assignment (in top-level declarations, let-expressions and where
 -- clauses).
 
-binds :: GHC.RenamedSource -> DetailsMap
+binds :: GHC.RenamedSource -> LTokenDetails
 binds = everythingInRenamedSource
       (fun `Syb.combine` pat `Syb.combine` tvar)
   where
@@ -112,7 +137,7 @@ binds = everythingInRenamedSource
         _ -> empty
 
 -- | Obtain details map for top-level declarations.
-decls :: GHC.RenamedSource -> DetailsMap
+decls :: GHC.RenamedSource -> LTokenDetails
 decls (group, _, _, _) = concatMap ($ group)
     [ concat . map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds
     , everythingInRenamedSource fun . GHC.hs_valds
@@ -151,7 +176,7 @@ decls (group, _, _, _) = concatMap ($ group)
 --
 -- This map also includes type and variable details for items in export and
 -- import lists.
-imports :: GHC.RenamedSource -> DetailsMap
+imports :: GHC.RenamedSource -> LTokenDetails
 imports src@(_, imps, _, _) =
     everythingInRenamedSource ie src ++ mapMaybe (imp . GHC.unLoc) imps
   where
@@ -168,22 +193,3 @@ imports src@(_, imps, _, _) =
         let (GHC.L sspan name) = GHC.ideclName idecl
         in Just (sspan, RtkModule name)
     imp _ = Nothing
-
--- | Check whether token stream span matches GHC source span.
---
--- Currently, it is implemented as checking whether "our" span is contained
--- in GHC span. The reason for that is because GHC span are generally wider
--- and may spread across couple tokens. For example, @(>>=)@ consists of three
--- tokens: @(@, @>>=@, @)@, but GHC source span associated with @>>=@ variable
--- contains @(@ and @)@. Similarly, qualified identifiers like @Foo.Bar.quux@
--- are tokenized as @Foo@, @.@, @Bar@, @.@, @quux@ but GHC source span
--- associated with @quux@ contains all five elements.
-matches :: Span -> GHC.SrcSpan -> Bool
-matches tspan (GHC.RealSrcSpan aspan)
-    | saspan <= stspan && etspan <= easpan = True
-  where
-    stspan = (posRow . spStart $ tspan, posCol . spStart $ tspan)
-    etspan = (posRow . spEnd $ tspan, posCol . spEnd $ tspan)
-    saspan = (GHC.srcSpanStartLine aspan, GHC.srcSpanStartCol aspan)
-    easpan = (GHC.srcSpanEndLine aspan, GHC.srcSpanEndCol aspan)
-matches _ _ = False
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs
index b27ec4d8..d8ae89e4 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs
@@ -10,7 +10,7 @@ import qualified Data.Map as Map
 data Token = Token
     { tkType :: TokenType
     , tkValue :: String
-    , tkSpan :: Span
+    , tkSpan :: {-# UNPACK #-} !Span
     }
     deriving (Show)
 
@@ -18,14 +18,20 @@ data Position = Position
     { posRow :: !Int
     , posCol :: !Int
     }
-    deriving (Show)
+    deriving (Eq, Ord, Show)
 
 data Span = Span
-    { spStart :: Position
-    , spEnd :: Position
+    { spStart :: !Position
+    , spEnd   :: !Position
     }
     deriving (Show)
 
+-- | Tests whether the first span "contains" the other span, meaning
+-- that it covers at least as much source code. True where spans are equal.
+containsSpan :: Span -> Span -> Bool
+containsSpan s1 s2 =
+  spStart s1 <= spStart s2 && spEnd s1 >= spEnd s2
+
 data TokenType
     = TkIdentifier
     | TkKeyword
-- 
cgit v1.2.3