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

---
 haddock-api/src/Haddock/Backends/LaTeX.hs          |  4 +-
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs     | 18 ++++-----
 haddock-api/src/Haddock/Backends/Xhtml/Layout.hs   | 44 ++++++++++++++++------
 .../src/Haddock/Interface/AttachInstances.hs       | 11 +++---
 haddock-api/src/Haddock/Interface/Rename.hs        |  4 +-
 haddock-api/src/Haddock/Types.hs                   |  4 +-
 6 files changed, 53 insertions(+), 32 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index b717fc01..ee5bc861 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -544,14 +544,14 @@ ppDocInstances unicode (i : rest)
     (is, rest') = spanWith isUndocdInstance rest
 
 isUndocdInstance :: DocInstance a -> Maybe (InstHead a)
-isUndocdInstance (i,Nothing) = Just i
+isUndocdInstance (L _ i,Nothing) = Just i
 isUndocdInstance _ = Nothing
 
 -- | Print a possibly commented instance. The instance header is printed inside
 -- an 'argBox'. The comment is printed to the right of the box in normal comment
 -- style.
 ppDocInstance :: Bool -> DocInstance DocName -> LaTeX
-ppDocInstance unicode (instHead, doc) =
+ppDocInstance unicode (L _ instHead, doc) =
   declWithDoc (ppInstDecl unicode instHead) (fmap docToLaTeX $ fmap _doc doc)
 
 
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 3bf4322d..d24a3f04 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -18,7 +18,6 @@ module Haddock.Backends.Xhtml.Decl (
   tyvarNames
 ) where
 
-
 import Haddock.Backends.Xhtml.DocMarkup
 import Haddock.Backends.Xhtml.Layout
 import Haddock.Backends.Xhtml.Names
@@ -270,7 +269,7 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode
       = subEquations qual $ map (ppTyFamEqn . unLoc) eqns
 
       | otherwise
-      = ppInstances instances docname unicode qual
+      = ppInstances links instances docname unicode qual
 
     -- Individual equation of a closed type family
     ppTyFamEqn TyFamEqn { tfe_tycon = n, tfe_rhs = rhs
@@ -492,18 +491,19 @@ ppClassDecl summary links instances fixities loc d subdocs
     ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a+++" | "+++b) $ map (ppMinimal False) fs
       where wrap | p = parens | otherwise = id
 
-    instancesBit = ppInstances instances nm unicode qual
+    instancesBit = ppInstances links instances nm unicode qual
 
 ppClassDecl _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
 
 
-ppInstances :: [DocInstance DocName] -> DocName -> Unicode -> Qualification -> Html
-ppInstances instances baseName unicode qual
-  = subInstances qual instName (map instDecl instances)
+ppInstances :: LinksInfo -> [DocInstance DocName] -> DocName -> Unicode -> Qualification -> Html
+ppInstances links instances baseName unicode qual
+  = subInstances qual instName links True baseName (map instDecl instances)
+  -- force Splice = True to use line URLs
   where
     instName = getOccString $ getName baseName
-    instDecl :: DocInstance DocName -> SubDecl
-    instDecl (inst, maybeDoc) = (instHead inst, maybeDoc, [])
+    instDecl :: DocInstance DocName -> (SubDecl,SrcSpan)
+    instDecl (L l inst, maybeDoc) = ((instHead inst, maybeDoc, []),l)
     instHead (n, ks, ts, ClassInst cs) = ppContextNoLocs cs unicode qual
         <+> ppAppNameTypes n ks ts unicode qual
     instHead (n, ks, ts, TypeInst rhs) = keyword "type"
@@ -582,7 +582,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl
                                      (map unLoc (con_names (unLoc c)))) fixities
       ]
 
-    instancesBit = ppInstances instances docname unicode qual
+    instancesBit = ppInstances links instances docname unicode qual
 
 
 
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
index b2c60534..923958a7 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
@@ -148,6 +148,20 @@ subTable qual decls = Just $ table << aboves (concatMap subRow decls)
        docElement td << fmap (docToHtml Nothing qual) mdoc)
       : map (cell . (td <<)) subs
 
+-- | Sub table with source information (optional).
+subTableSrc :: Qualification -> LinksInfo -> Bool -> DocName -> [(SubDecl,SrcSpan)] -> Maybe Html
+subTableSrc _ _  _ _ [] = Nothing
+subTableSrc qual lnks splice dn decls = Just $ table << aboves (concatMap subRow decls)
+  where
+    subRow ((decl, mdoc, subs),loc) =
+      (td ! [theclass "src"] << decl
+      <+> linkHtml loc
+      <->
+      docElement td << fmap (docToHtml Nothing qual) mdoc
+      )
+      : map (cell . (td <<)) subs
+    linkHtml loc@(RealSrcSpan _) = links lnks loc splice dn
+    linkHtml _ = noHtml
 
 subBlock :: [Html] -> Maybe Html
 subBlock [] = Nothing
@@ -174,13 +188,15 @@ subEquations :: Qualification -> [SubDecl] -> Html
 subEquations qual = divSubDecls "equations" "Equations" . subTable qual
 
 
+-- | Generate sub table for instance declarations, with source
 subInstances :: Qualification
              -> String -- ^ Class name, used for anchor generation
-             -> [SubDecl] -> Html
-subInstances qual nm = maybe noHtml wrap . instTable
+             -> LinksInfo -> Bool -> DocName
+             -> [(SubDecl,SrcSpan)] -> Html
+subInstances qual nm lnks splice dn = maybe noHtml wrap . instTable
   where
     wrap = (subSection <<) . (subCaption +++)
-    instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTable qual
+    instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTableSrc qual lnks splice dn
     subSection = thediv ! [theclass "subs instances"]
     subCaption = paragraph ! collapseControl id_ True "caption" << "Instances"
     id_ = makeAnchorId $ "i:" ++ nm
@@ -200,12 +216,19 @@ declElem = paragraph ! [theclass "src"]
 -- a box for top level documented names
 -- it adds a source and wiki link at the right hand side of the box
 topDeclElem :: LinksInfo -> SrcSpan -> Bool -> [DocName] -> Html -> Html
-topDeclElem ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice names html =
-    declElem << (html <+> srcLink <+> wikiLink)
+topDeclElem lnks loc splice names html =
+    declElem << (html <+> (links lnks loc splice $ head names))
+        -- FIXME: is it ok to simply take the first name?
+
+-- | Adds a source and wiki link at the right hand side of the box.
+-- Name must be documented, otherwise we wouldn't get here.
+links :: LinksInfo -> SrcSpan -> Bool -> DocName -> Html
+links ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice (Documented n mdl) =
+   (srcLink <+> wikiLink)
   where srcLink = let nameUrl = Map.lookup origPkg sourceMap
                       lineUrl = Map.lookup origPkg lineMap
                       mUrl | splice    = lineUrl
-                                         -- Use the lineUrl as a backup
+                                        -- Use the lineUrl as a backup
                            | otherwise = maybe lineUrl Just nameUrl in
           case mUrl of
             Nothing  -> noHtml
@@ -227,10 +250,7 @@ topDeclElem ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice names htm
         origMod = nameModule n
         origPkg = modulePackageKey origMod
 
-        -- Name must be documented, otherwise we wouldn't get here
-        Documented n mdl = head names
-        -- FIXME: is it ok to simply take the first name?
-
         fname = case loc of
-                RealSrcSpan l -> unpackFS (srcSpanFile l)
-                UnhelpfulSpan _ -> error "topDeclElem UnhelpfulSpan"
+          RealSrcSpan l -> unpackFS (srcSpanFile l)
+          UnhelpfulSpan _ -> error "links: UnhelpfulSpan"
+links _ _ _ _ = noHtml
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index 1341e57f..37203d63 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -72,21 +72,22 @@ attachToExportItem expInfo iface ifaceMap instIfaceMap export =
       mb_info <- getAllInfo (tcdName d)
       insts <- case mb_info of
         Just (_, _, cls_instances, fam_instances) ->
-          let fam_insts = [ (synifyFamInst i opaque, n)
+          let fam_insts = [ (L (getSrcSpan n) $ synifyFamInst i opaque, doc)
                           | i <- sortBy (comparing instFam) fam_instances
-                          , let n = instLookup instDocMap (getName i) iface ifaceMap instIfaceMap
+                          , 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)
+              cls_insts = [ (L (getSrcSpan n) $ synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap)
                           | let is = [ (instanceHead' i, getName i) | i <- cls_instances ]
                           , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is
                           , not $ isInstanceHidden expInfo cls tys
                           ]
               -- fam_insts but with failing type fams filtered out
-              cleanFamInsts = [ (fi, n) | (Right fi, n) <- fam_insts ]
-              famInstErrs = [ errm | (Left errm, _) <- fam_insts ]
+              cleanFamInsts = [ (L l fi, n) | (L l (Right fi), n) <- fam_insts ]
+              famInstErrs = [ errm | (L _ (Left errm), _) <- fam_insts ]
           in do
             dfs <- getDynFlags
             let mkBug = (text "haddock-bug:" <+>) . text
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 1ea212f5..7b9481fe 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -499,10 +499,10 @@ renameExportItem item = case item of
     decl' <- renameLDecl decl
     doc'  <- renameDocForDecl doc
     subs' <- mapM renameSub subs
-    instances' <- forM instances $ \(inst, idoc) -> do
+    instances' <- forM instances $ \(L l inst, idoc) -> do
       inst' <- renameInstHead inst
       idoc' <- mapM renameDoc idoc
-      return (inst', idoc')
+      return (L l inst', idoc')
     fixities' <- forM fixities $ \(name, fixity) -> do
       name' <- lookupRn name
       return (name', fixity)
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index e93294a0..ae90ff07 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -300,8 +300,8 @@ instance OutputableBndr a => Outputable (InstType a) where
   ppr (TypeInst  a) = text "TypeInst"  <+> ppr a
   ppr (DataInst  a) = text "DataInst"  <+> ppr a
 
--- | An instance head that may have documentation.
-type DocInstance name = (InstHead name, Maybe (MDoc name))
+-- | An instance head that may have documentation and a source location.
+type DocInstance name = (Located (InstHead name), Maybe (MDoc name))
 
 -- | The head of an instance. Consists of a class name, a list of kind
 -- parameters, a list of type parameters and an instance type
-- 
cgit v1.2.3


From 8e06728afb0784128ab2df0be7a5d7a191d30ff4 Mon Sep 17 00:00:00 2001
From: Mateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk>
Date: Thu, 22 Jan 2015 23:34:05 +0000
Subject: --package-name and --package-version flags

Used for --hoogle amongst other things. Now we need to teach cabal to
use it. The situation is still a bit sub-par because if the flags aren't
passed in, the crash will occur. Closes #353.
---
 haddock-api/src/Haddock.hs          | 27 ++++++++++++++++++++++++---
 haddock-api/src/Haddock/GhcUtils.hs | 14 --------------
 haddock-api/src/Haddock/Options.hs  | 37 +++++++++++++++++++++++++++++--------
 3 files changed, 53 insertions(+), 25 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 915ad47a..72c544e1 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -25,6 +25,7 @@ module Haddock (
   withGhc
 ) where
 
+import Data.Version
 import Haddock.Backends.Xhtml
 import Haddock.Backends.Xhtml.Themes (getThemes)
 import Haddock.Backends.LaTeX
@@ -36,7 +37,6 @@ import Haddock.Version
 import Haddock.InterfaceFile
 import Haddock.Options
 import Haddock.Utils
-import Haddock.GhcUtils hiding (pretty)
 
 import Control.Monad hiding (forM_)
 import Data.Foldable (forM_)
@@ -66,9 +66,9 @@ import GHC hiding (verbosity)
 import Config
 import DynFlags hiding (projectVersion, verbosity)
 import StaticFlags (discardStaticFlags)
+import Packages
 import Panic (handleGhcException)
 import Module
-import PackageConfig
 import FastString
 
 --------------------------------------------------------------------------------
@@ -252,7 +252,7 @@ render dflags flags qual ifaces installedIfaces srcMap = do
     pkgMod           = ifaceMod (head ifaces)
     pkgKey            = modulePackageKey pkgMod
     pkgStr           = Just (packageKeyString pkgKey)
-    (pkgName,pkgVer) = modulePackageInfo dflags pkgMod
+    (pkgName,pkgVer) = modulePackageInfo dflags flags pkgMod
 
     (srcBase, srcModule, srcEntity, srcLEntity) = sourceUrls flags
     srcMap' = maybe srcMap (\path -> Map.insert pkgKey path srcMap) srcEntity
@@ -299,6 +299,27 @@ render dflags flags qual ifaces installedIfaces srcMap = do
     ppLaTeX title pkgStr visibleIfaces odir (fmap _doc prologue) opt_latex_style
                   libDir
 
+-- | From GHC 7.10, this function has a potential to crash with a
+-- nasty message such as @expectJust getPackageDetails@ because
+-- package name and versions can no longer reliably be extracted in
+-- all cases: if the package is not installed yet then this info is no
+-- longer available. The @--package-name@ and @--package-version@
+-- Haddock flags allow the user to specify this information and it is
+-- returned here if present: if it is not present, the error will
+-- occur. Nasty but that's how it is for now. Potential TODO.
+modulePackageInfo :: DynFlags
+                  -> [Flag] -- ^ Haddock flags are checked as they may
+                            -- contain the package name or version
+                            -- provided by the user which we
+                            -- prioritise
+                  -> Module -> (PackageName, Data.Version.Version)
+modulePackageInfo dflags flags modu =
+  (fromMaybe (packageName pkg) (optPackageName flags),
+   fromMaybe (packageVersion pkg) (optPackageVersion flags))
+  where
+    pkg = getPackageDetails dflags (modulePackageKey modu)
+
+
 -------------------------------------------------------------------------------
 -- * Reading and dumping interface files
 -------------------------------------------------------------------------------
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 5aa9b818..416f5d71 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -16,18 +16,14 @@
 module Haddock.GhcUtils where
 
 
-import Data.Version
 import Control.Applicative  ( (<$>) )
 import Control.Arrow
-import Data.Foldable hiding (concatMap)
 import Data.Function
-import Data.Traversable
 
 import Exception
 import Outputable
 import Name
 import Lexeme
-import Packages
 import Module
 import RdrName (GlobalRdrEnv)
 import GhcMonad (withSession)
@@ -40,15 +36,6 @@ import Class
 moduleString :: Module -> String
 moduleString = moduleNameString . moduleName
 
-
--- return the (name,version) of the package
-modulePackageInfo :: DynFlags -> Module -> (PackageName, Version)
-modulePackageInfo dflags modu =
-    (packageName pkg, packageVersion pkg)
-  where
-    pkg = getPackageDetails dflags (modulePackageKey modu)
-
-
 lookupLoadedHomeModuleGRE  :: GhcMonad m => ModuleName -> m (Maybe GlobalRdrEnv)
 lookupLoadedHomeModuleGRE mod_name = withSession $ \hsc_env ->
   case lookupUFM (hsc_HPT hsc_env) mod_name of
@@ -288,4 +275,3 @@ setStubDir    f d = d{ stubDir    = Just f, includePaths = f : includePaths d }
   -- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file
   -- \#included from the .hc file when compiling with -fvia-C.
 setOutputDir  f = setObjectDir f . setHiDir f . setStubDir f
-
diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs
index 3fa6397f..e847333e 100644
--- a/haddock-api/src/Haddock/Options.hs
+++ b/haddock-api/src/Haddock/Options.hs
@@ -28,15 +28,21 @@ module Haddock.Options (
   qualification,
   verbosity,
   ghcFlags,
-  readIfaceArgs
+  readIfaceArgs,
+  optPackageName,
+  optPackageVersion
 ) where
 
 
-import Distribution.Verbosity
-import Haddock.Utils
-import Haddock.Types
-import System.Console.GetOpt
 import qualified Data.Char as Char
+import           Data.Version
+import           Distribution.Verbosity
+import           FastString
+import           Haddock.Types
+import           Haddock.Utils
+import           Packages
+import           System.Console.GetOpt
+import qualified Text.ParserCombinators.ReadP as RP
 
 
 data Flag
@@ -83,7 +89,9 @@ data Flag
   | Flag_Qualification String
   | Flag_PrettyHtml
   | Flag_NoPrintMissingDocs
-  deriving (Eq)
+  | Flag_PackageName String
+  | Flag_PackageVersion String
+  deriving (Eq, Show)
 
 
 options :: Bool -> [OptDescr Flag]
@@ -107,7 +115,7 @@ options backwardsCompat =
     Option []  ["latex-style"]  (ReqArg Flag_LaTeXStyle "FILE") "provide your own LaTeX style in FILE",
     Option ['U'] ["use-unicode"] (NoArg Flag_UseUnicode) "use Unicode in HTML output",
     Option []  ["hoogle"]     (NoArg Flag_Hoogle)
-      "output for Hoogle",
+      "output for Hoogle; you may want --package-name and --package-version too",
     Option []  ["source-base"]   (ReqArg Flag_SourceBaseURL "URL")
       "URL for a source code link on the contents\nand index pages",
     Option ['s'] (if backwardsCompat then ["source", "source-module"] else ["source-module"])
@@ -171,7 +179,11 @@ options backwardsCompat =
     Option [] ["pretty-html"] (NoArg Flag_PrettyHtml)
       "generate html with newlines and indenting (for use with --html)",
     Option [] ["no-print-missing-docs"] (NoArg Flag_NoPrintMissingDocs)
-      "don't print information about any undocumented entities"
+      "don't print information about any undocumented entities",
+    Option [] ["package-name"] (ReqArg Flag_PackageName "NAME")
+      "name of the package being documented",
+    Option [] ["package-version"] (ReqArg Flag_PackageVersion "VERSION")
+      "version of the package being documented in usual x.y.z.w format"
   ]
 
 
@@ -192,6 +204,15 @@ parseHaddockOpts params =
       usage <- getUsage
       throwE (concat errors ++ usage)
 
+optPackageVersion :: [Flag] -> Maybe Data.Version.Version
+optPackageVersion flags =
+  let ver = optLast [ v | Flag_PackageVersion v <- flags ]
+  in ver >>= fmap fst . optLast . RP.readP_to_S parseVersion
+
+optPackageName :: [Flag] -> Maybe PackageName
+optPackageName flags =
+  optLast [ PackageName $ mkFastString n | Flag_PackageName n <- flags ]
+
 
 optTitle :: [Flag] -> Maybe String
 optTitle flags =
-- 
cgit v1.2.3


From bf77580eb40fa960b701296ac828372d127a43dd Mon Sep 17 00:00:00 2001
From: Mateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk>
Date: Thu, 22 Jan 2015 23:43:18 +0000
Subject: Sort out some module import warnings

---
 haddock-api/src/Haddock/Convert.hs          | 1 -
 haddock-api/src/Haddock/Interface/Rename.hs | 3 +--
 haddock-api/src/Haddock/Types.hs            | 1 -
 3 files changed, 1 insertion(+), 4 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 1b1a8a88..b52c3319 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -23,7 +23,6 @@ import CoAxiom
 import ConLike
 import Data.Either (lefts, rights)
 import Data.List( partition )
-import Data.Monoid (mempty)
 import DataCon
 import FamInstEnv
 import Haddock.Types
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 7b9481fe..7f69b91e 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -13,7 +13,7 @@
 module Haddock.Interface.Rename (renameInterface) where
 
 
-import Data.Traversable (traverse, Traversable)
+import Data.Traversable (mapM)
 
 import Haddock.GhcUtils
 import Haddock.Types
@@ -28,7 +28,6 @@ import Control.Applicative
 import Control.Monad hiding (mapM)
 import Data.List
 import qualified Data.Map as Map hiding ( Map )
-import Data.Traversable (mapM)
 import Prelude hiding (mapM)
 
 
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index ae90ff07..f9cf6e17 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -34,7 +34,6 @@ import GHC hiding (NoLink)
 import DynFlags (ExtensionFlag, Language)
 import OccName
 import Outputable
-import Control.Applicative (Applicative(..))
 import Control.Monad (ap)
 
 -----------------------------------------------------------------------------
-- 
cgit v1.2.3


From df0239b587e2a25531962f5b46f715ebb9b09685 Mon Sep 17 00:00:00 2001
From: Simon Peyton Jones <simonpj@microsoft.com>
Date: Thu, 8 Jan 2015 15:50:22 +0000
Subject: Track naming change in DataCon

(cherry picked from commit 04cf63d0195837ed52075ed7d2676e71831e8a0b)
---
 haddock-api/src/Haddock/Convert.hs | 6 +++---
 1 file changed, 3 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 b52c3319..ac7f8bd8 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -264,15 +264,15 @@ synifyDataCon use_gadt_syntax dc =
   linear_tys = zipWith (\ty bang ->
             let tySyn = synifyType WithinType ty
                 src_bang = case bang of
-                             HsUnpack {} -> HsUserBang (Just True) True
-                             HsStrict    -> HsUserBang (Just False) True
+                             HsUnpack {} -> HsSrcBang (Just True) True
+                             HsStrict    -> HsSrcBang (Just False) True
                              _           -> bang
             in case src_bang of
                  HsNoBang -> tySyn
                  _        -> noLoc $ HsBangTy bang tySyn
             -- HsNoBang never appears, it's implied instead.
           )
-          arg_tys (dataConStrictMarks dc)
+          arg_tys (dataConSrcBangs dc)
   field_tys = zipWith (\field synTy -> noLoc $ ConDeclField
                                                [synifyName field] synTy Nothing)
                 (dataConFieldLabels dc) linear_tys
-- 
cgit v1.2.3


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

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

(limited to 'haddock-api/src')

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


From fdcd1907a358ef274b687e31118277d2487c60e9 Mon Sep 17 00:00:00 2001
From: Ben Gamari <ben@smart-cactus.org>
Date: Wed, 25 Feb 2015 02:01:08 -0500
Subject: Make the error encountered when a package can't be found more
 user-friendly

Closes #369
---
 haddock-api/src/Haddock.hs | 33 +++++++++++++++++++++------------
 1 file changed, 21 insertions(+), 12 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 72c544e1..3e58aba3 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -39,6 +39,7 @@ import Haddock.Options
 import Haddock.Utils
 
 import Control.Monad hiding (forM_)
+import Control.Applicative
 import Data.Foldable (forM_)
 import Data.List (isPrefixOf)
 import Control.Exception
@@ -250,9 +251,9 @@ render dflags flags qual ifaces installedIfaces srcMap = do
     allVisibleIfaces = [ i | i <- allIfaces, OptHide `notElem` instOptions i ]
 
     pkgMod           = ifaceMod (head ifaces)
-    pkgKey            = modulePackageKey pkgMod
+    pkgKey           = modulePackageKey pkgMod
     pkgStr           = Just (packageKeyString pkgKey)
-    (pkgName,pkgVer) = modulePackageInfo dflags flags pkgMod
+    pkgNameVer       = modulePackageInfo dflags flags pkgMod
 
     (srcBase, srcModule, srcEntity, srcLEntity) = sourceUrls flags
     srcMap' = maybe srcMap (\path -> Map.insert pkgKey path srcMap) srcEntity
@@ -288,12 +289,20 @@ render dflags flags qual ifaces installedIfaces srcMap = do
   -- TODO: we throw away Meta for both Hoogle and LaTeX right now,
   -- might want to fix that if/when these two get some work on them
   when (Flag_Hoogle `elem` flags) $ do
-    let pkgNameStr | unpackFS pkgNameFS == "main" && title /= []
-                               = title
-                   | otherwise = unpackFS pkgNameFS
-          where PackageName pkgNameFS = pkgName
-    ppHoogle dflags pkgNameStr pkgVer title (fmap _doc prologue) visibleIfaces
-      odir
+    case pkgNameVer of
+      Nothing -> putStrLn . unlines $
+          [ "haddock: Unable to find a package providing module "
+            ++ moduleNameString (moduleName pkgMod) ++ ", skipping Hoogle."
+          , ""
+          , "         Perhaps try specifying the desired package explicitly"
+            ++ " using the --package-name"
+          , "         and --package-version arguments."
+          ]
+      Just (PackageName pkgNameFS, pkgVer) ->
+          let pkgNameStr | unpackFS pkgNameFS == "main" && title /= [] = title
+                         | otherwise = unpackFS pkgNameFS
+          in ppHoogle dflags pkgNameStr pkgVer title (fmap _doc prologue)
+               visibleIfaces odir
 
   when (Flag_LaTeX `elem` flags) $ do
     ppLaTeX title pkgStr visibleIfaces odir (fmap _doc prologue) opt_latex_style
@@ -312,12 +321,12 @@ modulePackageInfo :: DynFlags
                             -- contain the package name or version
                             -- provided by the user which we
                             -- prioritise
-                  -> Module -> (PackageName, Data.Version.Version)
+                  -> Module -> Maybe (PackageName, Data.Version.Version)
 modulePackageInfo dflags flags modu =
-  (fromMaybe (packageName pkg) (optPackageName flags),
-   fromMaybe (packageVersion pkg) (optPackageVersion flags))
+    cmdline <|> pkgDb
   where
-    pkg = getPackageDetails dflags (modulePackageKey modu)
+    cmdline = (,) <$> optPackageName flags <*> optPackageVersion flags
+    pkgDb = (\pkg -> (packageName pkg, packageVersion pkg)) <$> lookupPackage dflags (modulePackageKey modu)
 
 
 -------------------------------------------------------------------------------
-- 
cgit v1.2.3


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

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

(limited to 'haddock-api/src')

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


From 6dee5e814d1934cbed458894e01b4913452422e6 Mon Sep 17 00:00:00 2001
From: Mateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk>
Date: Fri, 27 Mar 2015 00:05:58 +0000
Subject: Clearly default to variables in out of scope case

---
 CHANGES                                         |  3 ++
 haddock-api/src/Haddock/Interface/LexParseRn.hs | 63 ++++++++++++++++---------
 2 files changed, 43 insertions(+), 23 deletions(-)

(limited to 'haddock-api/src')

diff --git a/CHANGES b/CHANGES
index c988423d..419a7be7 100644
--- a/CHANGES
+++ b/CHANGES
@@ -32,6 +32,9 @@ Changes in version 2.16.0
 
  * Deal better with long synopsis lines (#151)
 
+ * Don't default to type constructors for out-of-scope names (#253 and
+   #375)
+
 Changes in version 2.15.0
 
  * Always read in prologue files as UTF8 (#286 and Cabal #1721)
diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs
index 614e606b..14826eaa 100644
--- a/haddock-api/src/Haddock/Interface/LexParseRn.hs
+++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs
@@ -30,6 +30,7 @@ import Haddock.Types
 import Name
 import Outputable (showPpr)
 import RdrName
+import RnEnv (dataTcOccs)
 
 processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString]
                   -> Maybe (MDoc Name)
@@ -73,7 +74,13 @@ processModuleHeader dflags gre safety mayStr = do
   where
     failure = (emptyHaddockModInfo, Nothing)
 
-
+-- | Takes a 'GlobalRdrEnv' which (hopefully) contains all the
+-- definitions and a parsed comment and we attempt to make sense of
+-- where the identifiers in the comment point to. We're in effect
+-- trying to convert 'RdrName's to 'Name's, with some guesswork and
+-- 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 dflags gre = rn
   where
@@ -81,19 +88,36 @@ rename dflags gre = rn
       DocAppend a b -> DocAppend (rn a) (rn b)
       DocParagraph doc -> DocParagraph (rn doc)
       DocIdentifier x -> do
-        let choices = dataTcOccs' x
+        -- Generate the choices for the possible kind of thing this
+        -- is.
+        let choices = dataTcOccs x
+        -- Try to look up all the names in the GlobalRdrEnv that match
+        -- the names.
         let names = concatMap (\c -> map gre_name (lookupGRE_RdrName c gre)) choices
+
         case names of
+          -- We found no names in the env so we start guessing.
           [] ->
             case choices of
               [] -> DocMonospaced (DocString (showPpr dflags x))
-              [a] -> outOfScope dflags a
-              a:b:_ | isRdrTc a -> outOfScope dflags a
-                    | otherwise -> outOfScope dflags b
+              -- 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
+              -- to type constructors as we're much more likely to
+              -- actually want anchors to regular definitions than
+              -- 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
+
+          -- There is only one name in the environment that matches so
+          -- use it.
           [a] -> DocIdentifier a
-          a:b:_ | isTyConName a -> DocIdentifier a | otherwise -> DocIdentifier b
-              -- If an id can refer to multiple things, we give precedence to type
-              -- constructors.
+          -- 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
 
       DocWarning doc -> DocWarning (rn doc)
       DocEmphasis doc -> DocEmphasis (rn doc)
@@ -114,21 +138,14 @@ rename dflags gre = rn
       DocString str -> DocString str
       DocHeader (Header l t) -> DocHeader $ Header l (rn t)
 
-dataTcOccs' :: RdrName -> [RdrName]
--- If the input is a data constructor, return both it and a type
--- constructor.  This is useful when we aren't sure which we are
--- looking at.
---
--- We use this definition instead of the GHC's to provide proper linking to
--- functions accross modules. See ticket #253 on Haddock Trac.
-dataTcOccs' rdr_name
-  | isDataOcc occ             = [rdr_name, rdr_name_tc]
-  | otherwise                 = [rdr_name]
-  where
-    occ = rdrNameOcc rdr_name
-    rdr_name_tc = setRdrNameSpace rdr_name tcName
-
-
+-- | Wrap an identifier that's out of scope (i.e. wasn't found in
+-- 'GlobalReaderEnv' during 'rename') in an appropriate doc. Currently
+-- we simply monospace the identifier in most cases except when the
+-- identifier is qualified: if the identifier is qualified then we can
+-- still try to guess and generate anchors accross modules but the
+-- users shouldn't rely on this doing the right thing. See tickets
+-- #253 and #375 on the confusion this causes depending on which
+-- default we pick in 'rename'.
 outOfScope :: DynFlags -> RdrName -> Doc a
 outOfScope dflags x =
   case x of
-- 
cgit v1.2.3


From bb0ecbb4053a593cc8ef80a277c4ef40b13998d5 Mon Sep 17 00:00:00 2001
From: Mateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk>
Date: Fri, 27 Mar 2015 01:14:11 +0000
Subject: Fix Hoogle display of constructors

Fixes #361
---
 CHANGES                                    | 2 ++
 haddock-api/src/Haddock/Backends/Hoogle.hs | 5 ++++-
 2 files changed, 6 insertions(+), 1 deletion(-)

(limited to 'haddock-api/src')

diff --git a/CHANGES b/CHANGES
index 419a7be7..15ab0a24 100644
--- a/CHANGES
+++ b/CHANGES
@@ -35,6 +35,8 @@ Changes in version 2.16.0
  * Don't default to type constructors for out-of-scope names (#253 and
    #375)
 
+ * Fix Hoogle display of constructors (#361)
+
 Changes in version 2.15.0
 
  * Always read in prologue files as UTF8 (#286 and Cabal #1721)
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index fe656a4b..ef86958e 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -198,7 +198,10 @@ ppCtor dflags dat subdocs con
         apps = foldl1 (\x y -> reL $ HsAppTy x y)
 
         typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (makeExplicit $ unL $ funs flds)
-        name = out dflags $ map unL $ con_names con
+
+        -- We print the constructors as comma-separated list. See GHC
+        -- docs for con_names on why it is a list to begin with.
+        name = showSDocUnqual dflags . interpp'SP . map unL $ con_names con
 
         resType = case con_res con of
             ResTyH98 -> apps $ map (reL . HsTyVar) $
-- 
cgit v1.2.3


From fdc4e8a1cafdb5accb8cef05c60579df9d438fd7 Mon Sep 17 00:00:00 2001
From: Mateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk>
Date: Fri, 27 Mar 2015 01:45:18 +0000
Subject: Fully qualify names in Hoogle instances output

Closes #263
---
 haddock-api/src/Haddock/Backends/Hoogle.hs | 10 ++++++----
 1 file changed, 6 insertions(+), 4 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index ef86958e..3ffa582f 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -95,13 +95,15 @@ dropComment (x:xs) = x : dropComment xs
 dropComment [] = []
 
 
-out :: Outputable a => DynFlags -> a -> String
-out dflags = f . unwords . map (dropWhile isSpace) . lines . showSDocUnqual dflags . ppr
+outWith :: Outputable a => (SDoc -> String) -> a -> [Char]
+outWith p = f . unwords . map (dropWhile isSpace) . lines . p . ppr
     where
         f xs | " <document comment>" `isPrefixOf` xs = f $ drop 19 xs
         f (x:xs) = x : f xs
         f [] = []
 
+out :: Outputable a => DynFlags -> a -> String
+out dflags = outWith $ showSDocUnqual dflags
 
 operator :: String -> String
 operator (x:xs) | not (isAlphaNum x) && x `notElem` "_' ([{" = '(' : x:xs ++ ")"
@@ -156,8 +158,8 @@ ppClass dflags x = out dflags x{tcdSigs=[]} :
 
 
 ppInstance :: DynFlags -> ClsInst -> [String]
-ppInstance dflags x = [dropComment $ out dflags x]
-
+ppInstance dflags x =
+  [dropComment $ outWith (showSDocForUser dflags alwaysQualify) x]
 
 ppSynonym :: DynFlags -> TyClDecl Name -> [String]
 ppSynonym dflags x = [out dflags x]
-- 
cgit v1.2.3


From 1a65ec54ce8516dc2d09af3b1d20fedd21e64ad6 Mon Sep 17 00:00:00 2001
From: Mateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk>
Date: Fri, 27 Mar 2015 02:43:55 +0000
Subject: Output method documentation in Hoogle backend

One thing of note is that we no longer preserve grouping of methods and
print each method on its own line. We could preserve it if no
documentation is present for any methods in the group if someone asks
for it though.

Fixes #259
---
 CHANGES                                    |  2 ++
 haddock-api/src/Haddock/Backends/Hoogle.hs | 32 ++++++++++++++++++++----------
 2 files changed, 23 insertions(+), 11 deletions(-)

(limited to 'haddock-api/src')

diff --git a/CHANGES b/CHANGES
index f436cf64..7aba49ae 100644
--- a/CHANGES
+++ b/CHANGES
@@ -39,6 +39,8 @@ Changes in version 2.16.0
 
  * Fully qualify names in Hoogle instances output (#263)
 
+ * Output method documentation in Hoogle backend (#259)
+
 Changes in version 2.15.0
 
  * Always read in prologue files as UTF8 (#286 and Cabal #1721)
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 3ffa582f..12dfc1f5 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -109,6 +109,8 @@ operator :: String -> String
 operator (x:xs) | not (isAlphaNum x) && x `notElem` "_' ([{" = '(' : x:xs ++ ")"
 operator x = x
 
+commaSeparate :: Outputable a => DynFlags -> [a] -> String
+commaSeparate dflags = showSDocUnqual dflags . interpp'SP
 
 ---------------------------------------------------------------------
 -- How to print each export
@@ -121,30 +123,38 @@ ppExport dflags ExportDecl { expItemDecl    = L _ decl
     where
         f (TyClD d@DataDecl{})  = ppData dflags d subdocs
         f (TyClD d@SynDecl{})   = ppSynonym dflags d
-        f (TyClD d@ClassDecl{}) = ppClass dflags d
+        f (TyClD d@ClassDecl{}) = ppClass dflags d subdocs
         f (ForD (ForeignImport name typ _ _)) = ppSig dflags $ TypeSig [name] typ []
         f (ForD (ForeignExport name typ _ _)) = ppSig dflags $ TypeSig [name] typ []
         f (SigD sig) = ppSig dflags sig
         f _ = []
 ppExport _ _ = []
 
-
-ppSig :: DynFlags -> Sig Name -> [String]
-ppSig dflags (TypeSig names sig _)
-    = [operator prettyNames ++ " :: " ++ outHsType dflags typ]
+ppSigWithDoc :: DynFlags -> Sig Name -> [(Name, DocForDecl Name)] -> [String]
+ppSigWithDoc dflags (TypeSig names sig _) subdocs
+    = concatMap mkDocSig names
     where
-        prettyNames = intercalate ", " $ map (out dflags) names
+        mkDocSig n = concatMap (ppDocumentation dflags) (getDoc n)
+                     ++ [mkSig n]
+        mkSig n = operator (out dflags n) ++ " :: " ++ outHsType dflags typ
+
+        getDoc :: Located Name -> [Documentation Name]
+        getDoc n = maybe [] (return . fst) (lookup (unL n) subdocs)
+
         typ = case unL sig of
                    HsForAllTy Explicit a b c d  -> HsForAllTy Implicit a b c d
                    HsForAllTy Qualified a b c d -> HsForAllTy Implicit a b c d
                    x -> x
-ppSig _ _ = []
+ppSigWithDoc _ _ _ = []
+
+ppSig :: DynFlags -> Sig Name -> [String]
+ppSig dflags x  = ppSigWithDoc dflags x []
 
 
 -- note: does not yet output documentation for class methods
-ppClass :: DynFlags -> TyClDecl Name -> [String]
-ppClass dflags x = out dflags x{tcdSigs=[]} :
-            concatMap (ppSig dflags . addContext . unL) (tcdSigs x)
+ppClass :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String]
+ppClass dflags x subdocs = out dflags x{tcdSigs=[]} :
+            concatMap (flip (ppSigWithDoc dflags) subdocs . addContext . unL) (tcdSigs x)
     where
         addContext (TypeSig name (L l sig) nwcs) = TypeSig name (L l $ f sig) nwcs
         addContext (MinimalSig src sig) = MinimalSig src sig
@@ -203,7 +213,7 @@ ppCtor dflags dat subdocs con
 
         -- We print the constructors as comma-separated list. See GHC
         -- docs for con_names on why it is a list to begin with.
-        name = showSDocUnqual dflags . interpp'SP . map unL $ con_names con
+        name = commaSeparate dflags . map unL $ con_names con
 
         resType = case con_res con of
             ResTyH98 -> apps $ map (reL . HsTyVar) $
-- 
cgit v1.2.3


From e49d473bf33fa374c60462ad178ac539f026c3ff Mon Sep 17 00:00:00 2001
From: Mateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk>
Date: Fri, 27 Mar 2015 03:04:21 +0000
Subject: Don't print instance safety information in Hoogle

Fixes #168
---
 CHANGES                                    |  2 ++
 haddock-api/src/Haddock/Backends/Hoogle.hs | 13 +++++++++++--
 2 files changed, 13 insertions(+), 2 deletions(-)

(limited to 'haddock-api/src')

diff --git a/CHANGES b/CHANGES
index 7aba49ae..af90b4fc 100644
--- a/CHANGES
+++ b/CHANGES
@@ -41,6 +41,8 @@ Changes in version 2.16.0
 
  * Output method documentation in Hoogle backend (#259)
 
+ * Don't print instance safety information in Hoogle (#168)
+
 Changes in version 2.15.0
 
  * Always read in prologue files as UTF8 (#286 and Cabal #1721)
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 12dfc1f5..914e3466 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -15,7 +15,8 @@ module Haddock.Backends.Hoogle (
     ppHoogle
   ) where
 
-
+import BasicTypes (OverlapFlag(..), OverlapMode(..))
+import InstEnv (ClsInst(..))
 import Haddock.GhcUtils
 import Haddock.Types hiding (Version)
 import Haddock.Utils hiding (out)
@@ -169,7 +170,15 @@ ppClass dflags x subdocs = out dflags x{tcdSigs=[]} :
 
 ppInstance :: DynFlags -> ClsInst -> [String]
 ppInstance dflags x =
-  [dropComment $ outWith (showSDocForUser dflags alwaysQualify) x]
+  [dropComment $ outWith (showSDocForUser dflags alwaysQualify) cls]
+  where
+    -- As per #168, we don't want safety information about the class
+    -- in Hoogle output. The easiest way to achieve this is to set the
+    -- safety information to a state where the Outputable instance
+    -- produces no output which means no overlap and unsafe (or [safe]
+    -- is generated).
+    cls = x { is_flag = OverlapFlag { overlapMode = NoOverlap mempty
+                                    , isSafeOverlap = False } }
 
 ppSynonym :: DynFlags -> TyClDecl Name -> [String]
 ppSynonym dflags x = [out dflags x]
-- 
cgit v1.2.3


From 5d04e313cc52ecf88b0fd0b3d0d39ce6a8dc7406 Mon Sep 17 00:00:00 2001
From: watashi <zejun.wu@gmail.com>
Date: Sun, 26 Apr 2015 16:35:28 -0700
Subject: Do not insert anchor for section headings in contents box

---
 .gitignore                                         |   3 +
 .../src/Haddock/Backends/Xhtml/DocMarkup.hs        |   5 +-
 html-test/ref/Bug387.html                          | 111 +++++++++++++++++++++
 html-test/src/Bug387.hs                            |  12 +++
 4 files changed, 130 insertions(+), 1 deletion(-)
 create mode 100644 html-test/ref/Bug387.html
 create mode 100644 html-test/src/Bug387.hs

(limited to 'haddock-api/src')

diff --git a/.gitignore b/.gitignore
index 6b8d26e0..2d3f4516 100644
--- a/.gitignore
+++ b/.gitignore
@@ -12,3 +12,6 @@
 /doc/configure
 tags
 TAGS
+
+.cabal-sandbox
+cabal.sandbox.config
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
index e807eb94..c23f3f08 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
@@ -62,7 +62,10 @@ parHtmlMarkup qual insertAnchors ppId = Markup {
                                   then anchor ! [href url]
                                        << fromMaybe url mLabel
                                   else toHtml $ fromMaybe url mLabel,
-  markupAName                = \aname -> namedAnchor aname << "",
+  markupAName                = \aname
+                               -> if insertAnchors
+                                  then namedAnchor aname << ""
+                                  else noHtml,
   markupPic                  = \(Picture uri t) -> image ! ([src uri] ++ fromMaybe [] (return . title <$> t)),
   markupProperty             = pre . toHtml,
   markupExample              = examplesToHtml,
diff --git a/html-test/ref/Bug387.html b/html-test/ref/Bug387.html
new file mode 100644
index 00000000..2d2009b1
--- /dev/null
+++ b/html-test/ref/Bug387.html
@@ -0,0 +1,111 @@
+<!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"
+     /><title
+    >Bug387</title
+    ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean"
+     /><script src="haddock-util.js" type="text/javascript"
+    ></script
+    ><script type="text/javascript"
+    >//<![CDATA[
+window.onload = function () {pageLoad();setSynopsis("mini_Bug387.html");};
+//]]>
+</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"
+      >&nbsp;</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"
+	>Bug387</p
+	></div
+      ><div id="table-of-contents"
+      ><p class="caption"
+	>Contents</p
+	><ul
+	><li
+	  ><a href=""
+	    >Section1</a
+	    ></li
+	  ><li
+	  ><a href=""
+	    >Section2</a
+	    ></li
+	  ></ul
+	></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=""
+	    >test1</a
+	    > :: <a href=""
+	    >Int</a
+	    ></li
+	  ><li class="src short"
+	  ><a href=""
+	    >test2</a
+	    > :: <a href=""
+	    >Int</a
+	    ></li
+	  ></ul
+	></div
+      ><div id="interface"
+      ><h1 id="g:1"
+	>Section1<a name="a:section1"
+	  ></a
+	  ></h1
+	><div class="top"
+	><p class="src"
+	  ><a name="v:test1" class="def"
+	    >test1</a
+	    > :: <a href=""
+	    >Int</a
+	    ></p
+	  ></div
+	><h1 id="g:2"
+	>Section2<a name="a:section2"
+	  ></a
+	  ></h1
+	><div class="top"
+	><p class="src"
+	  ><a name="v:test2" class="def"
+	    >test2</a
+	    > :: <a href=""
+	    >Int</a
+	    ></p
+	  ></div
+	></div
+      ></div
+    ><div id="footer"
+    ><p
+      >Produced by <a href=""
+	>Haddock</a
+	> version 2.16.1</p
+      ></div
+    ></body
+  ></html
+>
diff --git a/html-test/src/Bug387.hs b/html-test/src/Bug387.hs
new file mode 100644
index 00000000..d9fed34e
--- /dev/null
+++ b/html-test/src/Bug387.hs
@@ -0,0 +1,12 @@
+module Bug387
+  ( -- * Section1#a:section1#
+    test1
+    -- * Section2#a:section2#
+  , test2
+  ) where
+
+test1 :: Int
+test1 = 223
+
+test2 :: Int
+test2 = 42
-- 
cgit v1.2.3


From bf31846b9f7280b5e75f09e91ca18c4ced37af08 Mon Sep 17 00:00:00 2001
From: Murray Campbell <murray@sonology.net>
Date: Sun, 26 Apr 2015 13:49:01 -0700
Subject: Change ModuleTree Node to carry PackageKey and SourcePackageId to
 resolve #385

Signed-off-by: Austin Seipp <aseipp@pobox.com>
(cherry picked from commit 2380f07c430c525b205ce2eae6dab23c8388d899)
---
 haddock-api/src/Haddock/Backends/Xhtml.hs |  4 +--
 haddock-api/src/Haddock/ModuleTree.hs     | 41 +++++++++++++++++--------------
 2 files changed, 24 insertions(+), 21 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 948ef641..90cb9fa4 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -288,7 +288,7 @@ mkNodeList qual ss p ts = case ts of
 
 
 mkNode :: Qualification -> [String] -> String -> ModuleTree -> Html
-mkNode qual ss p (Node s leaf pkg short ts) =
+mkNode qual ss p (Node s leaf pkg srcPkg short ts) =
   htmlModule <+> shortDescr +++ htmlPkg +++ subtree
   where
     modAttrs = case (ts, leaf) of
@@ -312,7 +312,7 @@ mkNode qual ss p (Node s leaf pkg short ts) =
     mdl = intercalate "." (reverse (s:ss))
 
     shortDescr = maybe noHtml (origDocToHtml qual) short
-    htmlPkg = maybe noHtml (thespan ! [theclass "package"] <<) pkg
+    htmlPkg = maybe noHtml (thespan ! [theclass "package"] <<) srcPkg
 
     subtree = mkNodeList qual (s:ss) p ts ! collapseSection p True ""
 
diff --git a/haddock-api/src/Haddock/ModuleTree.hs b/haddock-api/src/Haddock/ModuleTree.hs
index eec1342e..2f731214 100644
--- a/haddock-api/src/Haddock/ModuleTree.hs
+++ b/haddock-api/src/Haddock/ModuleTree.hs
@@ -15,41 +15,44 @@ module Haddock.ModuleTree ( ModuleTree(..), mkModuleTree ) where
 import Haddock.Types ( MDoc )
 
 import GHC           ( Name )
-import Module        ( Module, moduleNameString, moduleName, modulePackageKey )
+import Module        ( Module, moduleNameString, moduleName, modulePackageKey, packageKeyString )
 import DynFlags      ( DynFlags )
 import Packages      ( lookupPackage )
 import PackageConfig ( sourcePackageIdString )
 
 
-data ModuleTree = Node String Bool (Maybe String) (Maybe (MDoc Name)) [ModuleTree]
+data ModuleTree = Node String Bool (Maybe String) (Maybe String) (Maybe (MDoc Name)) [ModuleTree]
 
 
 mkModuleTree :: DynFlags -> Bool -> [(Module, Maybe (MDoc Name))] -> [ModuleTree]
 mkModuleTree dflags showPkgs mods =
-  foldr fn [] [ (splitModule mdl, modPkg mdl, short) | (mdl, short) <- mods ]
+  foldr fn [] [ (splitModule mdl, modPkg mdl, modSrcPkg mdl, short) | (mdl, short) <- mods ]
   where
-    modPkg mod_ | showPkgs = fmap sourcePackageIdString
-                                  (lookupPackage dflags (modulePackageKey mod_))
+    modPkg mod_ | showPkgs = Just (packageKeyString (modulePackageKey mod_))
                 | otherwise = Nothing
-    fn (mod_,pkg,short) = addToTrees mod_ pkg short
-
-
-addToTrees :: [String] -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree] -> [ModuleTree]
-addToTrees [] _ _ ts = ts
-addToTrees ss pkg short [] = mkSubTree ss pkg short
-addToTrees (s1:ss) pkg short (t@(Node s2 leaf node_pkg node_short subs) : ts)
-  | s1 >  s2  = t : addToTrees (s1:ss) pkg short ts
-  | s1 == s2  = Node s2 (leaf || null ss) this_pkg this_short (addToTrees ss pkg short subs) : ts
-  | otherwise = mkSubTree (s1:ss) pkg short ++ t : ts
+    modSrcPkg mod_ | showPkgs = fmap sourcePackageIdString
+                                     (lookupPackage dflags (modulePackageKey mod_))
+                   | otherwise = Nothing
+    fn (mod_,pkg,srcPkg,short) = addToTrees mod_ pkg srcPkg short
+
+
+addToTrees :: [String] -> Maybe String -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree] -> [ModuleTree]
+addToTrees [] _ _ _ ts = ts
+addToTrees ss pkg srcPkg short [] = mkSubTree ss pkg srcPkg short
+addToTrees (s1:ss) pkg srcPkg short (t@(Node s2 leaf node_pkg node_srcPkg node_short subs) : ts)
+  | s1 >  s2  = t : addToTrees (s1:ss) pkg srcPkg short ts
+  | s1 == s2  = Node s2 (leaf || null ss) this_pkg this_srcPkg this_short (addToTrees ss pkg srcPkg short subs) : ts
+  | otherwise = mkSubTree (s1:ss) pkg srcPkg short ++ t : ts
  where
   this_pkg = if null ss then pkg else node_pkg
+  this_srcPkg = if null ss then srcPkg else node_srcPkg
   this_short = if null ss then short else node_short
 
 
-mkSubTree :: [String] -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree]
-mkSubTree []     _   _     = []
-mkSubTree [s]    pkg short = [Node s True pkg short []]
-mkSubTree (s:ss) pkg short = [Node s (null ss) Nothing Nothing (mkSubTree ss pkg short)]
+mkSubTree :: [String] -> Maybe String -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree]
+mkSubTree []     _   _      _     = []
+mkSubTree [s]    pkg srcPkg short = [Node s True pkg srcPkg short []]
+mkSubTree (s:ss) pkg srcPkg short = [Node s (null ss) Nothing Nothing Nothing (mkSubTree ss pkg srcPkg short)]
 
 
 splitModule :: Module -> [String]
-- 
cgit v1.2.3


From a7c6a56b1ec1481250b962ecf603a10b0720b1c7 Mon Sep 17 00:00:00 2001
From: Bartosz Nitka <bnitka@fb.com>
Date: Sat, 6 Jun 2015 08:12:18 -0700
Subject: Fix haddock: internal error: spliceURL UnhelpfulSpan (#207)

Inferred type signatures don't have SrcSpans, so let's use the one from
the declaration.

I've tested this manually on the test-case from #207, but I got stuck at
trying to run the test-suite.
---
 haddock-api/src/Haddock/Interface/Create.hs | 16 +++++++++++-----
 1 file changed, 11 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 9ef3d1b1..7491a01e 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -517,7 +517,7 @@ mkExportItems
       case findDecl t of
         ([L l (ValD _)], (doc, _)) -> do
           -- Top-level binding without type signature
-          export <- hiValExportItem dflags t doc (l `elem` splices) $ M.lookup t fixMap
+          export <- hiValExportItem dflags t l doc (l `elem` splices) $ M.lookup t fixMap
           return [export]
         (ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds ->
           let declNames = getMainDeclBinder (unL decl)
@@ -620,13 +620,19 @@ hiDecl dflags t = do
                    O.text "-- Please report this on Haddock issue tracker!"
       bugWarn = O.showSDoc dflags . warnLine
 
-hiValExportItem :: DynFlags -> Name -> DocForDecl Name -> Bool -> Maybe Fixity -> ErrMsgGhc (ExportItem Name)
-hiValExportItem dflags name doc splice fixity = do
+-- | This function is called for top-level bindings without type signatures.
+-- It gets the type signature from GHC and that means it's not going to
+-- have a meaningful 'SrcSpan'. So we pass down 'SrcSpan' for the
+-- declaration and use it instead - 'nLoc' here.
+hiValExportItem :: DynFlags -> Name -> SrcSpan -> DocForDecl Name -> Bool
+                -> Maybe Fixity -> ErrMsgGhc (ExportItem Name)
+hiValExportItem dflags name nLoc doc splice fixity = do
   mayDecl <- hiDecl dflags name
   case mayDecl of
     Nothing -> return (ExportNoDecl name [])
-    Just decl -> return (ExportDecl 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
       Just f  -> [(name, f)]
       Nothing -> []
@@ -737,7 +743,7 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap
       | name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap =
           -- Top-level binding without type signature.
           let (doc, _) = lookupDocs name warnings docMap argMap subMap in
-          fmap Just (hiValExportItem dflags name doc (l `elem` splices) $ M.lookup name fixMap)
+          fmap Just (hiValExportItem dflags name l doc (l `elem` splices) $ M.lookup name fixMap)
       | otherwise = return Nothing
     mkExportItem decl@(L l (InstD d))
       | Just name <- M.lookup (getInstLoc d) instMap =
-- 
cgit v1.2.3


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

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

(limited to 'haddock-api/src')

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


From a476b251e363b3b0ed30c75cf72a19fc275d6440 Mon Sep 17 00:00:00 2001
From: Phil Ruffwind <rf@rufflewind.com>
Date: Fri, 12 Jun 2015 12:59:24 -0400
Subject: Fix alignment of Source links in instance table in Firefox

Due to a Firefox bug [1], a combination of 'whitespace: nowrap' on the
parent element with 'float: right' on the inner element can cause the
floated element to be displaced downwards for no apparent reason.

To work around this, the left side is wrapped in its own <span> and set
to 'float: left'.  As a precautionary measure to prevent the parent
element from collapsing entirely, we also add the classic "clearfix"
hack.  The latter is not strictly needed but it helps prevent bugs if
the layout is altered again in the future.

Fixes #384.

Remark: line 159 of src/Haddock/Backends/Xhtml/Layout.hs was indented to
        prevent confusion over the operator precedence of (<+>) vs (<<).

[1]: https://bugzilla.mozilla.org/show_bug.cgi?id=488725
---
 haddock-api/resources/html/Ocean.std-theme/ocean.css | 13 +++++++++++++
 haddock-api/src/Haddock/Backends/Xhtml/Layout.hs     |  5 +++--
 2 files changed, 16 insertions(+), 2 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 ef652a21..1110b407 100644
--- a/haddock-api/resources/html/Ocean.std-theme/ocean.css
+++ b/haddock-api/resources/html/Ocean.std-theme/ocean.css
@@ -416,6 +416,14 @@ div#style-menu-holder {
   margin-top: 0.8em;
 }
 
+.clearfix:after {
+  clear: both;
+  content: " ";
+  display: block;
+  height: 0;
+  visibility: hidden;
+}
+
 .subs dl {
   margin: 0;
 }
@@ -455,6 +463,11 @@ div#style-menu-holder {
   margin-left: 1em;
 }
 
+/* Workaround for bug in Firefox (issue #384) */
+.inst-left {
+  float: left;
+}
+
 .top p.src {
   border-top: 1px solid #ccc;
 }
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
index e686d648..914a7a7e 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
@@ -154,8 +154,9 @@ subTableSrc _ _  _ [] = Nothing
 subTableSrc qual lnks splice decls = Just $ table << aboves (concatMap subRow decls)
   where
     subRow ((decl, mdoc, subs),L loc dn) =
-      (td ! [theclass "src"] << decl
-      <+> linkHtml loc dn
+      (td ! [theclass "src clearfix"] <<
+        (thespan ! [theclass "inst-left"] << decl)
+        <+> linkHtml loc dn
       <->
       docElement td << fmap (docToHtml Nothing qual) mdoc
       )
-- 
cgit v1.2.3


From ce0237fa8f482a64dc8ea3ec409a1482ac89e6ac Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Thu, 4 Jun 2015 19:27:34 +0200
Subject: Create scaffolding for Haskell source parser module.

---
 haddock-api/haddock-api.cabal                      |  1 +
 .../src/Haddock/Backends/Hyperlinker/Parser.hs     | 36 ++++++++++++++++++++++
 2 files changed, 37 insertions(+)
 create mode 100644 haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs

(limited to 'haddock-api/src')

diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal
index 3bc22263..b90e3bff 100644
--- a/haddock-api/haddock-api.cabal
+++ b/haddock-api/haddock-api.cabal
@@ -79,6 +79,7 @@ library
     Haddock.Backends.LaTeX
     Haddock.Backends.HaddockDB
     Haddock.Backends.Hoogle
+    Haddock.Backends.Hyperlinker.Parser
     Haddock.ModuleTree
     Haddock.Types
     Haddock.Doc
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
new file mode 100644
index 00000000..11a92b57
--- /dev/null
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -0,0 +1,36 @@
+module Haddock.Backends.Hyperlinker.Parser (parse) where
+
+data Token = Token
+    { tkType :: TokenType
+    , tkValue :: String
+    , tkSpan :: Span
+    }
+
+data Position = Position
+    { posRow :: !Int
+    , posCol :: !Int
+    }
+
+data Span = Span
+    { spStart :: Position
+    , spEnd :: Position
+    }
+
+data TokenType
+    = Identifier
+    | Comment
+    | Whitespace
+    | Operator
+    | Symbol
+
+parse :: String -> [Token]
+parse = tokenize . tag . chunk
+
+chunk :: String -> [String]
+chunk = undefined
+
+tag :: [String] -> [(Span, String)]
+tag = undefined
+
+tokenize :: [(Span, String)] -> [Token]
+tokenize = undefined
-- 
cgit v1.2.3


From e17f62506ecf20d61781c610d6fbb5f3c8cd132e Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Thu, 4 Jun 2015 19:59:27 +0200
Subject: Implement function for tagging parsed chunks with source spans.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 9 ++++++++-
 1 file changed, 8 insertions(+), 1 deletion(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index 11a92b57..4bcc0c8a 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -30,7 +30,14 @@ chunk :: String -> [String]
 chunk = undefined
 
 tag :: [String] -> [(Span, String)]
-tag = undefined
+tag =
+    reverse . snd . foldl aux (Position 1 1, [])
+  where
+    aux (pos, cs) c =
+        let pos' = if c == "\n"
+                   then pos { posRow = posRow pos + 1, posCol = 1 }
+                   else pos { posCol = posCol pos + length c }
+        in (pos', (Span pos pos', c):cs)
 
 tokenize :: [(Span, String)] -> [Token]
 tokenize = undefined
-- 
cgit v1.2.3


From 413f7f322cd174e2ba4116dbf53c1b3c0d6a4f77 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Thu, 4 Jun 2015 21:10:26 +0200
Subject: Implement simple string chunking based on HsColour library.

---
 .../src/Haddock/Backends/Hyperlinker/Parser.hs     | 28 +++++++++++++++++++++-
 1 file changed, 27 insertions(+), 1 deletion(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index 4bcc0c8a..4e0d7382 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -1,5 +1,8 @@
 module Haddock.Backends.Hyperlinker.Parser (parse) where
 
+import Data.Char
+import Data.List
+
 data Token = Token
     { tkType :: TokenType
     , tkValue :: String
@@ -27,7 +30,30 @@ parse :: String -> [Token]
 parse = tokenize . tag . chunk
 
 chunk :: String -> [String]
-chunk = undefined
+chunk [] = []
+chunk str@(c:_)
+    | isSpace c = chunk' $ span isSpace str
+chunk str
+    | "--" `isPrefixOf` str = chunk' $ span (not . (== '\n')) str
+    | "{-" `isPrefixOf` str = chunk' $ chunkComment 0 str
+    | otherwise = chunk' $ head $ lex str
+
+chunk' :: (String, String) -> [String]
+chunk' (c, rest) = c:(chunk rest)
+
+chunkComment :: Int -> String -> (String, String)
+chunkComment _ [] = ("", "")
+chunkComment depth ('{':'-':str) =
+    let (c, rest) = chunkComment (depth + 1) str
+    in ("{-" ++ c, rest)
+chunkComment depth ('-':'}':str)
+    | depth == 1 = ("-}", str)
+    | otherwise =
+        let (c, rest) = chunkComment (depth - 1) str
+        in ("-}" ++ c, rest)
+chunkComment depth (e:str) =
+    let (c, rest) = chunkComment depth str
+    in (e:c, rest)
 
 tag :: [String] -> [(Span, String)]
 tag =
-- 
cgit v1.2.3


From 6fb8d5abbcc92f5155fdc9596ca1c87fe87f6187 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Thu, 4 Jun 2015 23:21:17 +0200
Subject: Create basic token classification method.

---
 .../src/Haddock/Backends/Hyperlinker/Parser.hs     | 104 +++++++++++++++++++--
 1 file changed, 98 insertions(+), 6 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index 4e0d7382..be6b7ce5 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -20,11 +20,18 @@ data Span = Span
     }
 
 data TokenType
-    = Identifier
-    | Comment
-    | Whitespace
-    | Operator
-    | Symbol
+    = TkIdentifier
+    | TkKeyword
+    | TkString
+    | TkChar
+    | TkNumber
+    | TkOperator
+    | TkGlyph
+    | TkSpecial
+    | TkSpace
+    | TkComment
+    | TkCpp
+    | TkUnknown
 
 parse :: String -> [Token]
 parse = tokenize . tag . chunk
@@ -66,4 +73,89 @@ tag =
         in (pos', (Span pos pos', c):cs)
 
 tokenize :: [(Span, String)] -> [Token]
-tokenize = undefined
+tokenize =
+    map aux
+  where
+    aux (sp, str) = Token
+        { tkType = classify str
+        , tkValue = str
+        , tkSpan = sp
+        }
+
+classify :: String -> TokenType
+classify (c:_)
+    | isSpace c = TkSpace
+    | isDigit c = TkNumber
+    | c `elem` special = TkSpecial
+    | c == '#' = TkCpp
+    | c == '"' = TkString
+    | c == '\'' = TkChar
+classify str
+    | str `elem` keywords = TkKeyword
+    | str `elem` glyphs = TkGlyph
+    | all (`elem` symbols) str = TkOperator
+    | "--" `isPrefixOf` str = TkComment
+    | "{-" `isPrefixOf` str = TkComment
+    | isIdentifier str = TkIdentifier
+    | otherwise = TkUnknown
+
+keywords :: [String]
+keywords =
+    [ "as"
+    , "case"
+    , "class"
+    , "data"
+    , "default"
+    , "deriving"
+    , "do"
+    , "else"
+    , "hiding"
+    , "if"
+    , "import"
+    , "in"
+    , "infix"
+    , "infixl"
+    , "infixr"
+    , "instance"
+    , "let"
+    , "module"
+    , "newtype"
+    , "of"
+    , "qualified"
+    , "then"
+    , "type"
+    , "where"
+    , "forall"
+    , "mdo"
+    ]
+
+glyphs :: [String]
+glyphs =
+    [ ".."
+    , ":"
+    , "::"
+    , "="
+    , "\\"
+    , "|"
+    , "<-"
+    , "->"
+    , "@"
+    , "~"
+    , "~#"
+    , "=>"
+    , "-"
+    , "!"
+    ]
+
+special :: [Char]
+special = "()[]{},;`"
+
+-- TODO: Add support for any Unicode symbol or punctuation.
+-- source: http://stackoverflow.com/questions/10548170/what-characters-are-permitted-for-haskell-operators
+symbols :: [Char]
+symbols = "!#$%&*+./<=>?@\\^|-~:"
+
+isIdentifier :: String -> Bool
+isIdentifier (c:str)
+    | isLetter c = all (\c' -> isAlphaNum c' || c == '\'') str
+isIdentifier _ = False
-- 
cgit v1.2.3


From 57d4c9cff1d60f7dd0f8dafae5537218b63da90f Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Fri, 5 Jun 2015 00:07:52 +0200
Subject: Adapt source span tagging to work with current whitespace handling.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 11 +++++++----
 1 file changed, 7 insertions(+), 4 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index be6b7ce5..53ff1f65 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -67,10 +67,13 @@ tag =
     reverse . snd . foldl aux (Position 1 1, [])
   where
     aux (pos, cs) c =
-        let pos' = if c == "\n"
-                   then pos { posRow = posRow pos + 1, posCol = 1 }
-                   else pos { posCol = posCol pos + length c }
-        in (pos', (Span pos pos', c):cs)
+        let pos' = move pos c
+        in (pos', ((Span pos pos', c):cs))
+    move pos str@(c:_)
+        | isSpace c = foldl move' pos str
+    move pos str = pos { posCol = posCol pos + length str }
+    move' pos '\n' = pos { posRow = posRow pos + 1, posCol = 1 }
+    move' pos _ = pos { posCol = posCol pos + 1 }
 
 tokenize :: [(Span, String)] -> [Token]
 tokenize =
-- 
cgit v1.2.3


From c7ecc590090d7f1a4ce8e6d0233c41350202a4bd Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Fri, 5 Jun 2015 00:16:15 +0200
Subject: Add record accessors to exports of hyperlinker parser module.

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

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index 53ff1f65..4130ab6c 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -1,4 +1,9 @@
-module Haddock.Backends.Hyperlinker.Parser (parse) where
+module Haddock.Backends.Hyperlinker.Parser
+    ( parse
+    , tkType, tkValue, tkSpan
+    , posRow, posCol
+    , spStart, spEnd
+    ) where
 
 import Data.Char
 import Data.List
-- 
cgit v1.2.3


From 7b607883d0cea7a795275a2484a33bd89a3b4fc6 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Fri, 5 Jun 2015 11:56:01 +0200
Subject: Make parser module export all types and associated accessors.

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

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index 4130ab6c..7a162f6d 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -1,8 +1,7 @@
 module Haddock.Backends.Hyperlinker.Parser
     ( parse
-    , tkType, tkValue, tkSpan
-    , posRow, posCol
-    , spStart, spEnd
+    , Token(..), TokenType(..)
+    , Position(..), Span(..)
     ) where
 
 import Data.Char
-- 
cgit v1.2.3


From 5e904cb1c3d769d5b99d459838b4b5368c8c1fb7 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Fri, 5 Jun 2015 12:59:10 +0200
Subject: Create simple HTML renderer for parsed source file.

---
 haddock-api/haddock-api.cabal                      |  3 ++-
 .../src/Haddock/Backends/Hyperlinker/Renderer.hs   | 26 ++++++++++++++++++++++
 2 files changed, 28 insertions(+), 1 deletion(-)
 create mode 100644 haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs

(limited to 'haddock-api/src')

diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal
index b90e3bff..6c6dc810 100644
--- a/haddock-api/haddock-api.cabal
+++ b/haddock-api/haddock-api.cabal
@@ -57,6 +57,8 @@ library
 
   exposed-modules:
     Documentation.Haddock
+    Haddock.Backends.Hyperlinker.Parser
+    Haddock.Backends.Hyperlinker.Renderer
 
   other-modules:
     Haddock
@@ -79,7 +81,6 @@ library
     Haddock.Backends.LaTeX
     Haddock.Backends.HaddockDB
     Haddock.Backends.Hoogle
-    Haddock.Backends.Hyperlinker.Parser
     Haddock.ModuleTree
     Haddock.Types
     Haddock.Doc
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
new file mode 100644
index 00000000..eaf5b37b
--- /dev/null
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -0,0 +1,26 @@
+module Haddock.Backends.Hyperlinker.Renderer where
+
+import Haddock.Backends.Hyperlinker.Parser
+
+import Data.Monoid
+import Text.XHtml
+
+render :: [Token] -> Html
+render = body . pre . foldr (<>) noHtml . map renderToken
+
+renderToken :: Token -> Html
+renderToken (Token t v _) = thespan (toHtml v) ! tokenAttrs t
+
+tokenAttrs :: TokenType -> [HtmlAttr]
+tokenAttrs TkIdentifier = [theclass "hs-identifier"]
+tokenAttrs TkKeyword = [theclass "hs-keyword"]
+tokenAttrs TkString = [theclass "hs-string"]
+tokenAttrs TkChar = [theclass "hs-char"]
+tokenAttrs TkNumber = [theclass "hs-number"]
+tokenAttrs TkOperator = [theclass "hs-operator"]
+tokenAttrs TkGlyph = [theclass "hs-glyph"]
+tokenAttrs TkSpecial = [theclass "hs-special"]
+tokenAttrs TkSpace = []
+tokenAttrs TkComment = [theclass "hs-comment"]
+tokenAttrs TkCpp = [theclass "hs-cpp"]
+tokenAttrs TkUnknown = []
-- 
cgit v1.2.3


From 1a43f35e2dacc9837f9762fd211d63ae6cc7b4a3 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Fri, 5 Jun 2015 13:58:47 +0200
Subject: Add support for specifying the CSS file path in HTML source renderer.

---
 .../src/Haddock/Backends/Hyperlinker/Renderer.hs   | 45 ++++++++++++++--------
 1 file changed, 30 insertions(+), 15 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index eaf5b37b..9ebb8707 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -3,24 +3,39 @@ module Haddock.Backends.Hyperlinker.Renderer where
 import Haddock.Backends.Hyperlinker.Parser
 
 import Data.Monoid
-import Text.XHtml
+import Text.XHtml (Html, HtmlAttr, (!))
+import qualified Text.XHtml as Html
 
-render :: [Token] -> Html
-render = body . pre . foldr (<>) noHtml . map renderToken
+render :: Maybe FilePath -> [Token] -> Html
+render css tokens = header css <> body tokens
 
-renderToken :: Token -> Html
-renderToken (Token t v _) = thespan (toHtml v) ! tokenAttrs t
+body :: [Token] -> Html
+body = Html.body . Html.pre . mconcat . map token
+
+header :: Maybe FilePath -> Html
+header Nothing = Html.noHtml
+header (Just css) =
+    Html.header $ Html.thelink Html.noHtml ! attrs
+  where
+    attrs =
+        [ Html.rel "stylesheet"
+        , Html.href css
+        , Html.thetype "text/css"
+        ]
+
+token :: Token -> Html
+token (Token t v _) = Html.thespan (Html.toHtml v) ! tokenAttrs t
 
 tokenAttrs :: TokenType -> [HtmlAttr]
-tokenAttrs TkIdentifier = [theclass "hs-identifier"]
-tokenAttrs TkKeyword = [theclass "hs-keyword"]
-tokenAttrs TkString = [theclass "hs-string"]
-tokenAttrs TkChar = [theclass "hs-char"]
-tokenAttrs TkNumber = [theclass "hs-number"]
-tokenAttrs TkOperator = [theclass "hs-operator"]
-tokenAttrs TkGlyph = [theclass "hs-glyph"]
-tokenAttrs TkSpecial = [theclass "hs-special"]
+tokenAttrs TkIdentifier = [Html.theclass "hs-identifier"]
+tokenAttrs TkKeyword = [Html.theclass "hs-keyword"]
+tokenAttrs TkString = [Html.theclass "hs-string"]
+tokenAttrs TkChar = [Html.theclass "hs-char"]
+tokenAttrs TkNumber = [Html.theclass "hs-number"]
+tokenAttrs TkOperator = [Html.theclass "hs-operator"]
+tokenAttrs TkGlyph = [Html.theclass "hs-glyph"]
+tokenAttrs TkSpecial = [Html.theclass "hs-special"]
 tokenAttrs TkSpace = []
-tokenAttrs TkComment = [theclass "hs-comment"]
-tokenAttrs TkCpp = [theclass "hs-cpp"]
+tokenAttrs TkComment = [Html.theclass "hs-comment"]
+tokenAttrs TkCpp = [Html.theclass "hs-cpp"]
 tokenAttrs TkUnknown = []
-- 
cgit v1.2.3


From 01a2e7c5ab873c0041624a6ec0b0a54eb7da60cc Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Fri, 5 Jun 2015 14:39:28 +0200
Subject: Fix identifier recognition in Haskell source parser.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 7 +++++--
 1 file changed, 5 insertions(+), 2 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index 7a162f6d..9d58728f 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -163,6 +163,9 @@ symbols :: [Char]
 symbols = "!#$%&*+./<=>?@\\^|-~:"
 
 isIdentifier :: String -> Bool
-isIdentifier (c:str)
-    | isLetter c = all (\c' -> isAlphaNum c' || c == '\'') str
+isIdentifier (s:str)
+    | (isLower' s || isUpper s) && all isAlphaNum' str = True
+  where
+    isLower' c = isLower c || c == '_'
+    isAlphaNum' c = isAlphaNum c || c == '_' || c == '\''
 isIdentifier _ = False
-- 
cgit v1.2.3


From ffd0e8028f15f3616f1b3eaaf98459c0c75c6313 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Fri, 5 Jun 2015 14:56:59 +0200
Subject: Fix comment recognition in Haskell source parser.

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

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index 9d58728f..29edb4c3 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -90,6 +90,9 @@ tokenize =
         }
 
 classify :: String -> TokenType
+classify str
+    | "--" `isPrefixOf` str = TkComment
+    | "{-" `isPrefixOf` str = TkComment
 classify (c:_)
     | isSpace c = TkSpace
     | isDigit c = TkNumber
@@ -101,8 +104,6 @@ classify str
     | str `elem` keywords = TkKeyword
     | str `elem` glyphs = TkGlyph
     | all (`elem` symbols) str = TkOperator
-    | "--" `isPrefixOf` str = TkComment
-    | "{-" `isPrefixOf` str = TkComment
     | isIdentifier str = TkIdentifier
     | otherwise = TkUnknown
 
-- 
cgit v1.2.3


From e5bd5d39550692f936c973637f8ec8d314919359 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Fri, 5 Jun 2015 15:12:40 +0200
Subject: Add support for recognizing compiler pragmas in source parser.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs   | 2 ++
 haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs | 1 +
 2 files changed, 3 insertions(+)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index 29edb4c3..0e1ad5b2 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -35,6 +35,7 @@ data TokenType
     | TkSpace
     | TkComment
     | TkCpp
+    | TkPragma
     | TkUnknown
 
 parse :: String -> [Token]
@@ -92,6 +93,7 @@ tokenize =
 classify :: String -> TokenType
 classify str
     | "--" `isPrefixOf` str = TkComment
+    | "{-#" `isPrefixOf` str = TkPragma
     | "{-" `isPrefixOf` str = TkComment
 classify (c:_)
     | isSpace c = TkSpace
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index 9ebb8707..39d7d183 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -38,4 +38,5 @@ tokenAttrs TkSpecial = [Html.theclass "hs-special"]
 tokenAttrs TkSpace = []
 tokenAttrs TkComment = [Html.theclass "hs-comment"]
 tokenAttrs TkCpp = [Html.theclass "hs-cpp"]
+tokenAttrs TkPragma = [Html.theclass "hs-pragma"]
 tokenAttrs TkUnknown = []
-- 
cgit v1.2.3


From d275f87c4cfa1e8da042f70659331121afa9a15c Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Sat, 6 Jun 2015 19:27:37 +0200
Subject: Create scaffolding of module for associating tokens with AST names.

---
 haddock-api/haddock-api.cabal                       |  1 +
 haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 20 ++++++++++++++++++++
 2 files changed, 21 insertions(+)
 create mode 100644 haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs

(limited to 'haddock-api/src')

diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal
index 6c6dc810..109e5f95 100644
--- a/haddock-api/haddock-api.cabal
+++ b/haddock-api/haddock-api.cabal
@@ -59,6 +59,7 @@ library
     Documentation.Haddock
     Haddock.Backends.Hyperlinker.Parser
     Haddock.Backends.Hyperlinker.Renderer
+    Haddock.Backends.Hyperlinker.Ast
 
   other-modules:
     Haddock
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
new file mode 100644
index 00000000..abd3ca2b
--- /dev/null
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -0,0 +1,20 @@
+module Haddock.Backends.Hyperlinker.Ast where
+
+import qualified GHC
+
+import Haddock.Backends.Hyperlinker.Parser
+
+data RichToken = RichToken
+    { rtkToken :: Token
+    , rtkName :: Maybe GHC.Name
+    }
+
+enrich :: GHC.RenamedSource -> [Token] -> [RichToken]
+enrich src =
+    map $ \token -> RichToken
+        { rtkToken = token
+        , rtkName = lookupName src $ tkSpan token
+        }
+
+lookupName :: GHC.RenamedSource -> Span -> Maybe GHC.Name
+lookupName = undefined
-- 
cgit v1.2.3


From 74de0021815f0642a89017fbb1fbdf18064cb5ea Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Sat, 6 Jun 2015 19:36:53 +0200
Subject: Implement utility method for extracting variable identifiers from
 AST.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 16 ++++++++++++++++
 1 file changed, 16 insertions(+)

(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 abd3ca2b..62c0d439 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -1,6 +1,10 @@
+{-# LANGUAGE RankNTypes #-}
+
 module Haddock.Backends.Hyperlinker.Ast where
 
 import qualified GHC
+import Data.Data
+import Control.Applicative
 
 import Haddock.Backends.Hyperlinker.Parser
 
@@ -18,3 +22,15 @@ enrich src =
 
 lookupName :: GHC.RenamedSource -> Span -> Maybe GHC.Name
 lookupName = undefined
+
+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)
+
+variables :: GHC.RenamedSource -> [(GHC.SrcSpan, GHC.Name)]
+variables =
+    everything (<|>) var
+  where
+    var term = case cast term of
+        (Just (GHC.L sspan (GHC.HsVar sid))) -> pure (sspan, sid)
+        _ -> empty
-- 
cgit v1.2.3


From d06a2b502e7909dff517a7c825e772b493bade24 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Sat, 6 Jun 2015 20:04:02 +0200
Subject: Create simple mechanism for associating tokens with AST names.

---
 .../src/Haddock/Backends/Hyperlinker/Ast.hs        | 30 +++++++++++++++++-----
 1 file changed, 23 insertions(+), 7 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 62c0d439..031ddd5c 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -2,11 +2,13 @@
 
 module Haddock.Backends.Hyperlinker.Ast where
 
+import Haddock.Backends.Hyperlinker.Parser
+
 import qualified GHC
-import Data.Data
-import Control.Applicative
 
-import Haddock.Backends.Hyperlinker.Parser
+import Control.Applicative
+import Data.Data
+import Data.Maybe
 
 data RichToken = RichToken
     { rtkToken :: Token
@@ -17,20 +19,34 @@ enrich :: GHC.RenamedSource -> [Token] -> [RichToken]
 enrich src =
     map $ \token -> RichToken
         { rtkToken = token
-        , rtkName = lookupName src $ tkSpan token
+        , rtkName = lookupBySpan (tkSpan token) nameMap
         }
+  where
+    nameMap = variables src
+
+type NameMap = [(GHC.SrcSpan, GHC.Name)]
 
-lookupName :: GHC.RenamedSource -> Span -> Maybe GHC.Name
-lookupName = undefined
+lookupBySpan :: Span -> NameMap -> Maybe GHC.Name
+lookupBySpan tspan = listToMaybe . map snd . filter (matches tspan . fst)
 
 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)
 
-variables :: GHC.RenamedSource -> [(GHC.SrcSpan, GHC.Name)]
+variables :: GHC.RenamedSource -> NameMap
 variables =
     everything (<|>) var
   where
     var term = case cast term of
         (Just (GHC.L sspan (GHC.HsVar sid))) -> pure (sspan, sid)
         _ -> empty
+
+matches :: Span -> GHC.SrcSpan -> Bool
+matches tspan (GHC.RealSrcSpan aspan)
+    | rs && cs && re && ce = True
+  where
+    rs = (posRow . spStart) tspan == GHC.srcSpanStartLine aspan
+    cs = (posCol . spStart) tspan == GHC.srcSpanStartCol aspan
+    re = (posRow . spEnd) tspan == GHC.srcSpanEndLine aspan
+    ce = (posCol . spEnd) tspan == GHC.srcSpanStartLine aspan
+matches _ _ = False
-- 
cgit v1.2.3


From cb3ece1a493eb444ccb61b6ad3c74e922184b63e Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Sat, 6 Jun 2015 21:43:15 +0200
Subject: Add dummy support for hyperlinking named tokens.

---
 .../src/Haddock/Backends/Hyperlinker/Renderer.hs   | 23 +++++++++++++++++++---
 1 file changed, 20 insertions(+), 3 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index 39d7d183..32d2c863 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -1,16 +1,20 @@
 module Haddock.Backends.Hyperlinker.Renderer where
 
 import Haddock.Backends.Hyperlinker.Parser
+import Haddock.Backends.Hyperlinker.Ast
+
+import qualified GHC
+import qualified Name as GHC
 
 import Data.Monoid
 import Text.XHtml (Html, HtmlAttr, (!))
 import qualified Text.XHtml as Html
 
-render :: Maybe FilePath -> [Token] -> Html
+render :: Maybe FilePath -> [RichToken] -> Html
 render css tokens = header css <> body tokens
 
-body :: [Token] -> Html
-body = Html.body . Html.pre . mconcat . map token
+body :: [RichToken] -> Html
+body = Html.body . Html.pre . mconcat . map richToken
 
 header :: Maybe FilePath -> Html
 header Nothing = Html.noHtml
@@ -23,6 +27,10 @@ header (Just css) =
         , Html.thetype "text/css"
         ]
 
+richToken :: RichToken -> Html
+richToken (RichToken t Nothing) = token t
+richToken (RichToken t (Just name)) = Html.anchor (token t) ! nameAttrs name
+
 token :: Token -> Html
 token (Token t v _) = Html.thespan (Html.toHtml v) ! tokenAttrs t
 
@@ -40,3 +48,12 @@ tokenAttrs TkComment = [Html.theclass "hs-comment"]
 tokenAttrs TkCpp = [Html.theclass "hs-cpp"]
 tokenAttrs TkPragma = [Html.theclass "hs-pragma"]
 tokenAttrs TkUnknown = []
+
+nameAttrs :: GHC.Name -> [HtmlAttr]
+nameAttrs name =
+    [ Html.href (maybe "" id mmod ++ "#" ++ ident)
+    , Html.theclass "varid-reference"
+    ]
+  where
+    mmod = GHC.moduleNameString . GHC.moduleName <$> GHC.nameModule_maybe name
+    ident = GHC.occNameString . GHC.nameOccName $ name
-- 
cgit v1.2.3


From 7d43b8a8c9538692beb91a4c3a485e82b40559ab Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Sat, 6 Jun 2015 22:37:28 +0200
Subject: Fix span matcher bug causing wrong items being hyperlinked.

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

(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 031ddd5c..7d88b7fb 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -48,5 +48,5 @@ matches tspan (GHC.RealSrcSpan aspan)
     rs = (posRow . spStart) tspan == GHC.srcSpanStartLine aspan
     cs = (posCol . spStart) tspan == GHC.srcSpanStartCol aspan
     re = (posRow . spEnd) tspan == GHC.srcSpanEndLine aspan
-    ce = (posCol . spEnd) tspan == GHC.srcSpanStartLine aspan
+    ce = (posCol . spEnd) tspan == GHC.srcSpanEndCol aspan
 matches _ _ = False
-- 
cgit v1.2.3


From 9a51a6d3f686736354e26137363ea979a5e38076 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Sat, 6 Jun 2015 23:40:36 +0200
Subject: Constrain elements exported by hyperlinker modules.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs      | 5 ++++-
 haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs | 2 +-
 2 files changed, 5 insertions(+), 2 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 7d88b7fb..a24945ea 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -1,6 +1,9 @@
 {-# LANGUAGE RankNTypes #-}
 
-module Haddock.Backends.Hyperlinker.Ast where
+module Haddock.Backends.Hyperlinker.Ast
+    ( enrich
+    , RichToken(..)
+    ) where
 
 import Haddock.Backends.Hyperlinker.Parser
 
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index 32d2c863..3c6fe14f 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -1,4 +1,4 @@
-module Haddock.Backends.Hyperlinker.Renderer where
+module Haddock.Backends.Hyperlinker.Renderer (render) where
 
 import Haddock.Backends.Hyperlinker.Parser
 import Haddock.Backends.Hyperlinker.Ast
-- 
cgit v1.2.3


From 666af8d2f29c05d22bb5930d115c42509528bb90 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Sun, 7 Jun 2015 21:35:55 +0200
Subject: Add support for type token recognition.

---
 .../src/Haddock/Backends/Hyperlinker/Ast.hs        | 35 +++++++++---
 .../src/Haddock/Backends/Hyperlinker/Renderer.hs   | 64 ++++++++++++++--------
 2 files changed, 68 insertions(+), 31 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 a24945ea..0ccf010b 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -2,7 +2,7 @@
 
 module Haddock.Backends.Hyperlinker.Ast
     ( enrich
-    , RichToken(..)
+    , RichToken(..), RichTokenType(..), TokenDetails(..)
     ) where
 
 import Haddock.Backends.Hyperlinker.Parser
@@ -15,33 +15,52 @@ import Data.Maybe
 
 data RichToken = RichToken
     { rtkToken :: Token
-    , rtkName :: Maybe GHC.Name
+    , rtkDetails :: Maybe TokenDetails
     }
 
+data TokenDetails = TokenDetails
+    { rtkType :: RichTokenType
+    , rtkName :: GHC.Name
+    }
+
+data RichTokenType
+    = RtkVar
+    | RtkType
+
 enrich :: GHC.RenamedSource -> [Token] -> [RichToken]
 enrich src =
     map $ \token -> RichToken
         { rtkToken = token
-        , rtkName = lookupBySpan (tkSpan token) nameMap
+        , rtkDetails = lookupBySpan (tkSpan token) detailsMap
         }
   where
-    nameMap = variables src
+    detailsMap = variables src ++ types src
 
-type NameMap = [(GHC.SrcSpan, GHC.Name)]
+type DetailsMap = [(GHC.SrcSpan, TokenDetails)]
 
-lookupBySpan :: Span -> NameMap -> Maybe GHC.Name
+lookupBySpan :: Span -> DetailsMap -> Maybe TokenDetails
 lookupBySpan tspan = listToMaybe . map snd . filter (matches tspan . fst)
 
 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)
 
-variables :: GHC.RenamedSource -> NameMap
+variables :: GHC.RenamedSource -> DetailsMap
 variables =
     everything (<|>) var
   where
     var term = case cast term of
-        (Just (GHC.L sspan (GHC.HsVar sid))) -> pure (sspan, sid)
+        (Just (GHC.L sspan (GHC.HsVar name))) ->
+            pure (sspan, TokenDetails RtkVar name)
+        _ -> empty
+
+types :: GHC.RenamedSource -> DetailsMap
+types =
+    everything (<|>) ty
+  where
+    ty term = case cast term of
+        (Just (GHC.L sspan (GHC.HsTyVar name))) ->
+            pure (sspan, TokenDetails RtkType name)
         _ -> empty
 
 matches :: Span -> GHC.SrcSpan -> Bool
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index 3c6fe14f..c2bca438 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -6,10 +6,14 @@ import Haddock.Backends.Hyperlinker.Ast
 import qualified GHC
 import qualified Name as GHC
 
+import Data.List
 import Data.Monoid
+
 import Text.XHtml (Html, HtmlAttr, (!))
 import qualified Text.XHtml as Html
 
+type StyleClass = String
+
 render :: Maybe FilePath -> [RichToken] -> Html
 render css tokens = header css <> body tokens
 
@@ -28,29 +32,43 @@ header (Just css) =
         ]
 
 richToken :: RichToken -> Html
-richToken (RichToken t Nothing) = token t
-richToken (RichToken t (Just name)) = Html.anchor (token t) ! nameAttrs name
-
-token :: Token -> Html
-token (Token t v _) = Html.thespan (Html.toHtml v) ! tokenAttrs t
-
-tokenAttrs :: TokenType -> [HtmlAttr]
-tokenAttrs TkIdentifier = [Html.theclass "hs-identifier"]
-tokenAttrs TkKeyword = [Html.theclass "hs-keyword"]
-tokenAttrs TkString = [Html.theclass "hs-string"]
-tokenAttrs TkChar = [Html.theclass "hs-char"]
-tokenAttrs TkNumber = [Html.theclass "hs-number"]
-tokenAttrs TkOperator = [Html.theclass "hs-operator"]
-tokenAttrs TkGlyph = [Html.theclass "hs-glyph"]
-tokenAttrs TkSpecial = [Html.theclass "hs-special"]
-tokenAttrs TkSpace = []
-tokenAttrs TkComment = [Html.theclass "hs-comment"]
-tokenAttrs TkCpp = [Html.theclass "hs-cpp"]
-tokenAttrs TkPragma = [Html.theclass "hs-pragma"]
-tokenAttrs TkUnknown = []
-
-nameAttrs :: GHC.Name -> [HtmlAttr]
-nameAttrs name =
+richToken (RichToken tok Nothing) =
+    tokenSpan tok ! attrs
+  where
+    attrs = [ multiclass . tokenStyle . tkType $ tok ]
+richToken (RichToken tok (Just det)) =
+    Html.anchor content ! (anchorAttrs . rtkName) det
+  where
+    content = tokenSpan tok ! [ multiclass style]
+    style = (tokenStyle . tkType) tok ++ (richTokenStyle . rtkType) det
+
+tokenSpan :: Token -> Html
+tokenSpan = Html.thespan . Html.toHtml . tkValue
+
+richTokenStyle :: RichTokenType -> [StyleClass]
+richTokenStyle RtkVar = ["hs-var"]
+richTokenStyle RtkType = ["hs-type"]
+
+tokenStyle :: TokenType -> [StyleClass]
+tokenStyle TkIdentifier = ["hs-identifier"]
+tokenStyle TkKeyword = ["hs-keyword"]
+tokenStyle TkString = ["hs-string"]
+tokenStyle TkChar = ["hs-char"]
+tokenStyle TkNumber = ["hs-number"]
+tokenStyle TkOperator = ["hs-operator"]
+tokenStyle TkGlyph = ["hs-glyph"]
+tokenStyle TkSpecial = ["hs-special"]
+tokenStyle TkSpace = []
+tokenStyle TkComment = ["hs-comment"]
+tokenStyle TkCpp = ["hs-cpp"]
+tokenStyle TkPragma = ["hs-pragma"]
+tokenStyle TkUnknown = []
+
+multiclass :: [StyleClass] -> HtmlAttr
+multiclass = Html.theclass . intercalate " "
+
+anchorAttrs :: GHC.Name -> [HtmlAttr]
+anchorAttrs name =
     [ Html.href (maybe "" id mmod ++ "#" ++ ident)
     , Html.theclass "varid-reference"
     ]
-- 
cgit v1.2.3


From 70656933ca6935bde0a00310f37440e02c3f21ff Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Mon, 8 Jun 2015 00:13:12 +0200
Subject: Add support for binding token recognition.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs  | 20 +++++++++++++++++++-
 .../src/Haddock/Backends/Hyperlinker/Renderer.hs     |  1 +
 2 files changed, 20 insertions(+), 1 deletion(-)

(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 0ccf010b..19ebbe77 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module Haddock.Backends.Hyperlinker.Ast
     ( enrich
@@ -26,6 +27,7 @@ data TokenDetails = TokenDetails
 data RichTokenType
     = RtkVar
     | RtkType
+    | RtkBind
 
 enrich :: GHC.RenamedSource -> [Token] -> [RichToken]
 enrich src =
@@ -34,7 +36,7 @@ enrich src =
         , rtkDetails = lookupBySpan (tkSpan token) detailsMap
         }
   where
-    detailsMap = variables src ++ types src
+    detailsMap = variables src ++ types src ++ binds src
 
 type DetailsMap = [(GHC.SrcSpan, TokenDetails)]
 
@@ -45,6 +47,9 @@ 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)
 
+combine :: Alternative f => (forall a. Data a => a -> f r) -> (forall a. Data a => a -> f r) -> (forall a. Data a => a -> f r)
+combine f g x = f x <|> g x
+
 variables :: GHC.RenamedSource -> DetailsMap
 variables =
     everything (<|>) var
@@ -63,6 +68,19 @@ types =
             pure (sspan, TokenDetails RtkType name)
         _ -> empty
 
+binds :: GHC.RenamedSource -> DetailsMap
+binds =
+    everything (<|>) (fun `combine` pat)
+  where
+    fun term = case cast term of
+        (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name)) ->
+            pure (sspan, TokenDetails RtkBind name)
+        _ -> empty
+    pat term = case cast term of
+        (Just (GHC.L sspan (GHC.VarPat name))) ->
+            pure (sspan, TokenDetails RtkBind name)
+        _ -> empty
+
 matches :: Span -> GHC.SrcSpan -> Bool
 matches tspan (GHC.RealSrcSpan aspan)
     | rs && cs && re && ce = True
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index c2bca438..57851c22 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -48,6 +48,7 @@ tokenSpan = Html.thespan . Html.toHtml . tkValue
 richTokenStyle :: RichTokenType -> [StyleClass]
 richTokenStyle RtkVar = ["hs-var"]
 richTokenStyle RtkType = ["hs-type"]
+richTokenStyle RtkBind = ["hs-bind"]
 
 tokenStyle :: TokenType -> [StyleClass]
 tokenStyle TkIdentifier = ["hs-identifier"]
-- 
cgit v1.2.3


From 21984e4cfcc076ce8cbee934028a1b37aaca930b Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Mon, 8 Jun 2015 00:54:58 +0200
Subject: Implement go-to-definition mechanism for local bindings.

---
 .../src/Haddock/Backends/Hyperlinker/Renderer.hs   | 30 +++++++++++++++++-----
 1 file changed, 23 insertions(+), 7 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index 57851c22..995e24e6 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -5,6 +5,7 @@ import Haddock.Backends.Hyperlinker.Ast
 
 import qualified GHC
 import qualified Name as GHC
+import qualified Unique as GHC
 
 import Data.List
 import Data.Monoid
@@ -37,7 +38,7 @@ richToken (RichToken tok Nothing) =
   where
     attrs = [ multiclass . tokenStyle . tkType $ tok ]
 richToken (RichToken tok (Just det)) =
-    Html.anchor content ! (anchorAttrs . rtkName) det
+    internalAnchor det . hyperlink det $ content
   where
     content = tokenSpan tok ! [ multiclass style]
     style = (tokenStyle . tkType) tok ++ (richTokenStyle . rtkType) det
@@ -48,7 +49,7 @@ tokenSpan = Html.thespan . Html.toHtml . tkValue
 richTokenStyle :: RichTokenType -> [StyleClass]
 richTokenStyle RtkVar = ["hs-var"]
 richTokenStyle RtkType = ["hs-type"]
-richTokenStyle RtkBind = ["hs-bind"]
+richTokenStyle RtkBind = []
 
 tokenStyle :: TokenType -> [StyleClass]
 tokenStyle TkIdentifier = ["hs-identifier"]
@@ -68,11 +69,26 @@ tokenStyle TkUnknown = []
 multiclass :: [StyleClass] -> HtmlAttr
 multiclass = Html.theclass . intercalate " "
 
-anchorAttrs :: GHC.Name -> [HtmlAttr]
-anchorAttrs name =
-    [ Html.href (maybe "" id mmod ++ "#" ++ ident)
-    , Html.theclass "varid-reference"
-    ]
+internalAnchor :: TokenDetails -> Html -> Html
+internalAnchor (TokenDetails RtkBind name) content =
+    Html.anchor content ! [ Html.name $ internalAnchorIdent name ]
+internalAnchor _ content = content
+
+internalAnchorIdent :: GHC.Name -> String
+internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique
+
+hyperlink :: TokenDetails -> Html -> Html
+hyperlink (TokenDetails _ name) = if GHC.isInternalName name
+    then internalHyperlink name
+    else externalHyperlink name
+
+internalHyperlink :: GHC.Name -> Html -> Html
+internalHyperlink name content =
+    Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ]
+
+externalHyperlink :: GHC.Name -> Html -> Html
+externalHyperlink name content =
+    Html.anchor content ! [ Html.href $ maybe "" id mmod ++ "#" ++ ident ]
   where
     mmod = GHC.moduleNameString . GHC.moduleName <$> GHC.nameModule_maybe name
     ident = GHC.occNameString . GHC.nameOccName $ name
-- 
cgit v1.2.3


From c84a3ef8ebca5fb396ee9dc8cb2654f7891f5c0e Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Mon, 8 Jun 2015 14:12:58 +0200
Subject: Implement module export- and import-list item hyperlinking.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 20 +++++++++++++++++++-
 1 file changed, 19 insertions(+), 1 deletion(-)

(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 19ebbe77..2325aa21 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -36,7 +36,12 @@ enrich src =
         , rtkDetails = lookupBySpan (tkSpan token) detailsMap
         }
   where
-    detailsMap = variables src ++ types src ++ binds src
+    detailsMap = concat
+        [ variables src
+        , types src
+        , binds src
+        , imports src
+        ]
 
 type DetailsMap = [(GHC.SrcSpan, TokenDetails)]
 
@@ -81,6 +86,19 @@ binds =
             pure (sspan, TokenDetails RtkBind name)
         _ -> empty
 
+imports :: GHC.RenamedSource -> DetailsMap
+imports =
+    everything (<|>) ie
+  where
+    ie term = case cast term of
+        (Just (GHC.IEVar v)) -> pure $ var v
+        (Just (GHC.IEThingAbs t)) -> pure $ typ t
+        (Just (GHC.IEThingAll t)) -> pure $ typ t
+        (Just (GHC.IEThingWith t vs)) -> [typ t] ++ map var vs
+        _ -> empty
+    typ (GHC.L sspan name) = (sspan, TokenDetails RtkType name)
+    var (GHC.L sspan name) = (sspan, TokenDetails RtkVar name)
+
 matches :: Span -> GHC.SrcSpan -> Bool
 matches tspan (GHC.RealSrcSpan aspan)
     | rs && cs && re && ce = True
-- 
cgit v1.2.3


From fab61bb80c2d8059e91aece7677cf349cd34a8db Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Mon, 8 Jun 2015 15:05:35 +0200
Subject: Fix span matching to allow parenthesized operators hyperlinking.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 10 +++++-----
 1 file changed, 5 insertions(+), 5 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 2325aa21..05d6a52e 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -101,10 +101,10 @@ imports =
 
 matches :: Span -> GHC.SrcSpan -> Bool
 matches tspan (GHC.RealSrcSpan aspan)
-    | rs && cs && re && ce = True
+    | saspan <= stspan && etspan <= easpan = True
   where
-    rs = (posRow . spStart) tspan == GHC.srcSpanStartLine aspan
-    cs = (posCol . spStart) tspan == GHC.srcSpanStartCol aspan
-    re = (posRow . spEnd) tspan == GHC.srcSpanEndLine aspan
-    ce = (posCol . spEnd) tspan == GHC.srcSpanEndCol aspan
+    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
-- 
cgit v1.2.3


From b31513dbacb48102b4c5d2fd6de1982161d81fae Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Mon, 8 Jun 2015 15:16:06 +0200
Subject: Fix weird hyperlinking of parenthesized operators.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs    | 7 ++++++-
 haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 1 +
 2 files changed, 7 insertions(+), 1 deletion(-)

(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 05d6a52e..2749096e 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -33,7 +33,7 @@ enrich :: GHC.RenamedSource -> [Token] -> [RichToken]
 enrich src =
     map $ \token -> RichToken
         { rtkToken = token
-        , rtkDetails = lookupBySpan (tkSpan token) detailsMap
+        , rtkDetails = enrichToken token detailsMap
         }
   where
     detailsMap = concat
@@ -45,6 +45,11 @@ enrich src =
 
 type DetailsMap = [(GHC.SrcSpan, TokenDetails)]
 
+enrichToken :: Token -> DetailsMap -> Maybe TokenDetails
+enrichToken (Token typ _ spn) dm
+    | typ `elem` [TkIdentifier, TkOperator] = lookupBySpan spn dm
+enrichToken _ _ = Nothing
+
 lookupBySpan :: Span -> DetailsMap -> Maybe TokenDetails
 lookupBySpan tspan = listToMaybe . map snd . filter (matches tspan . fst)
 
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index 0e1ad5b2..70a69279 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -37,6 +37,7 @@ data TokenType
     | TkCpp
     | TkPragma
     | TkUnknown
+    deriving (Eq)
 
 parse :: String -> [Token]
 parse = tokenize . tag . chunk
-- 
cgit v1.2.3


From 162b02ed6f50709ea203bf7706eee5804e455419 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Fri, 12 Jun 2015 01:03:13 +0200
Subject: Add support for type declaration anchors.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 21 ++++++++++++++++-----
 .../src/Haddock/Backends/Hyperlinker/Renderer.hs    | 14 +++++++++++---
 2 files changed, 27 insertions(+), 8 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 2749096e..39bbacf5 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -28,6 +28,7 @@ data RichTokenType
     = RtkVar
     | RtkType
     | RtkBind
+    | RtkDecl
 
 enrich :: GHC.RenamedSource -> [Token] -> [RichToken]
 enrich src =
@@ -36,11 +37,12 @@ enrich src =
         , rtkDetails = enrichToken token detailsMap
         }
   where
-    detailsMap = concat
-        [ variables src
-        , types src
-        , binds src
-        , imports src
+    detailsMap = concatMap ($ src)
+        [ variables
+        , types
+        , binds
+        , imports
+        , decls
         ]
 
 type DetailsMap = [(GHC.SrcSpan, TokenDetails)]
@@ -91,6 +93,15 @@ binds =
             pure (sspan, TokenDetails RtkBind name)
         _ -> empty
 
+decls :: GHC.RenamedSource -> DetailsMap
+decls (group, _, _, _) = concatMap ($ group)
+    [ map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds
+    ]
+  where
+    typ (GHC.L _ t) =
+        let (GHC.L sspan name) = GHC.tcdLName t
+        in (sspan, TokenDetails RtkDecl name)
+
 imports :: GHC.RenamedSource -> DetailsMap
 imports =
     everything (<|>) ie
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index 995e24e6..b7cc5aeb 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -38,7 +38,7 @@ richToken (RichToken tok Nothing) =
   where
     attrs = [ multiclass . tokenStyle . tkType $ tok ]
 richToken (RichToken tok (Just det)) =
-    internalAnchor det . hyperlink det $ content
+    externalAnchor det . internalAnchor det . hyperlink det $ content
   where
     content = tokenSpan tok ! [ multiclass style]
     style = (tokenStyle . tkType) tok ++ (richTokenStyle . rtkType) det
@@ -49,7 +49,7 @@ tokenSpan = Html.thespan . Html.toHtml . tkValue
 richTokenStyle :: RichTokenType -> [StyleClass]
 richTokenStyle RtkVar = ["hs-var"]
 richTokenStyle RtkType = ["hs-type"]
-richTokenStyle RtkBind = []
+richTokenStyle _ = []
 
 tokenStyle :: TokenType -> [StyleClass]
 tokenStyle TkIdentifier = ["hs-identifier"]
@@ -69,11 +69,19 @@ tokenStyle TkUnknown = []
 multiclass :: [StyleClass] -> HtmlAttr
 multiclass = Html.theclass . intercalate " "
 
+externalAnchor :: TokenDetails -> Html -> Html
+externalAnchor (TokenDetails RtkDecl name) content =
+    Html.anchor content ! [ Html.name $ externalAnchorIdent name ]
+externalAnchor _ content = content
+
 internalAnchor :: TokenDetails -> Html -> Html
 internalAnchor (TokenDetails RtkBind name) content =
     Html.anchor content ! [ Html.name $ internalAnchorIdent name ]
 internalAnchor _ content = content
 
+externalAnchorIdent :: GHC.Name -> String
+externalAnchorIdent = GHC.occNameString . GHC.nameOccName
+
 internalAnchorIdent :: GHC.Name -> String
 internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique
 
@@ -91,4 +99,4 @@ externalHyperlink name content =
     Html.anchor content ! [ Html.href $ maybe "" id mmod ++ "#" ++ ident ]
   where
     mmod = GHC.moduleNameString . GHC.moduleName <$> GHC.nameModule_maybe name
-    ident = GHC.occNameString . GHC.nameOccName $ name
+    ident = externalAnchorIdent name
-- 
cgit v1.2.3


From c6786894f71809ecfa377a44beab0771a3bc7985 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Fri, 12 Jun 2015 01:36:49 +0200
Subject: Add support for top-level function declaration anchors.

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

(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 39bbacf5..cb9508ef 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -40,9 +40,9 @@ enrich src =
     detailsMap = concatMap ($ src)
         [ variables
         , types
+        , decls
         , binds
         , imports
-        , decls
         ]
 
 type DetailsMap = [(GHC.SrcSpan, TokenDetails)]
@@ -96,11 +96,16 @@ binds =
 decls :: GHC.RenamedSource -> DetailsMap
 decls (group, _, _, _) = concatMap ($ group)
     [ map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds
+    , everything (<|>) fun
     ]
   where
     typ (GHC.L _ t) =
         let (GHC.L sspan name) = GHC.tcdLName t
         in (sspan, TokenDetails RtkDecl name)
+    fun term = case cast term of
+        (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name))
+            | GHC.isExternalName name -> pure (sspan, TokenDetails RtkDecl name)
+        _ -> empty
 
 imports :: GHC.RenamedSource -> DetailsMap
 imports =
-- 
cgit v1.2.3


From 1064953c6590c05303c6cbd2230b9e13d3ba1376 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Fri, 12 Jun 2015 10:57:30 +0200
Subject: Fix external anchors to contain HTML file extension.

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

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index b7cc5aeb..99a0f337 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -96,7 +96,7 @@ internalHyperlink name content =
 
 externalHyperlink :: GHC.Name -> Html -> Html
 externalHyperlink name content =
-    Html.anchor content ! [ Html.href $ maybe "" id mmod ++ "#" ++ ident ]
+    Html.anchor content ! [ Html.href $ maybe "" id mmod ++ ".html#" ++ ident ]
   where
     mmod = GHC.moduleNameString . GHC.moduleName <$> GHC.nameModule_maybe name
     ident = externalAnchorIdent name
-- 
cgit v1.2.3


From 60db14903e01f4c26f179230c7b6190a7b99fb51 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Wed, 17 Jun 2015 21:49:46 +0200
Subject: Refactor the way AST names are handled within detailed tokens.

---
 .../src/Haddock/Backends/Hyperlinker/Ast.hs        | 37 +++++++++++-----------
 .../src/Haddock/Backends/Hyperlinker/Renderer.hs   | 17 ++++++----
 2 files changed, 29 insertions(+), 25 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 cb9508ef..3c07ff3c 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -3,7 +3,7 @@
 
 module Haddock.Backends.Hyperlinker.Ast
     ( enrich
-    , RichToken(..), RichTokenType(..), TokenDetails(..)
+    , RichToken(..), TokenDetails(..), rtkName
     ) where
 
 import Haddock.Backends.Hyperlinker.Parser
@@ -19,16 +19,17 @@ data RichToken = RichToken
     , rtkDetails :: Maybe TokenDetails
     }
 
-data TokenDetails = TokenDetails
-    { rtkType :: RichTokenType
-    , rtkName :: GHC.Name
-    }
+data TokenDetails
+    = RtkVar GHC.Name
+    | RtkType GHC.Name
+    | RtkBind GHC.Name
+    | RtkDecl GHC.Name
 
-data RichTokenType
-    = RtkVar
-    | RtkType
-    | RtkBind
-    | RtkDecl
+rtkName :: TokenDetails -> GHC.Name
+rtkName (RtkVar name) = name
+rtkName (RtkType name) = name
+rtkName (RtkBind name) = name
+rtkName (RtkDecl name) = name
 
 enrich :: GHC.RenamedSource -> [Token] -> [RichToken]
 enrich src =
@@ -68,7 +69,7 @@ variables =
   where
     var term = case cast term of
         (Just (GHC.L sspan (GHC.HsVar name))) ->
-            pure (sspan, TokenDetails RtkVar name)
+            pure (sspan, RtkVar name)
         _ -> empty
 
 types :: GHC.RenamedSource -> DetailsMap
@@ -77,7 +78,7 @@ types =
   where
     ty term = case cast term of
         (Just (GHC.L sspan (GHC.HsTyVar name))) ->
-            pure (sspan, TokenDetails RtkType name)
+            pure (sspan, RtkType name)
         _ -> empty
 
 binds :: GHC.RenamedSource -> DetailsMap
@@ -86,11 +87,11 @@ binds =
   where
     fun term = case cast term of
         (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name)) ->
-            pure (sspan, TokenDetails RtkBind name)
+            pure (sspan, RtkBind name)
         _ -> empty
     pat term = case cast term of
         (Just (GHC.L sspan (GHC.VarPat name))) ->
-            pure (sspan, TokenDetails RtkBind name)
+            pure (sspan, RtkBind name)
         _ -> empty
 
 decls :: GHC.RenamedSource -> DetailsMap
@@ -101,10 +102,10 @@ decls (group, _, _, _) = concatMap ($ group)
   where
     typ (GHC.L _ t) =
         let (GHC.L sspan name) = GHC.tcdLName t
-        in (sspan, TokenDetails RtkDecl name)
+        in (sspan, RtkDecl name)
     fun term = case cast term of
         (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name))
-            | GHC.isExternalName name -> pure (sspan, TokenDetails RtkDecl name)
+            | GHC.isExternalName name -> pure (sspan, RtkDecl name)
         _ -> empty
 
 imports :: GHC.RenamedSource -> DetailsMap
@@ -117,8 +118,8 @@ imports =
         (Just (GHC.IEThingAll t)) -> pure $ typ t
         (Just (GHC.IEThingWith t vs)) -> [typ t] ++ map var vs
         _ -> empty
-    typ (GHC.L sspan name) = (sspan, TokenDetails RtkType name)
-    var (GHC.L sspan name) = (sspan, TokenDetails RtkVar name)
+    typ (GHC.L sspan name) = (sspan, RtkType name)
+    var (GHC.L sspan name) = (sspan, RtkVar name)
 
 matches :: Span -> GHC.SrcSpan -> Bool
 matches tspan (GHC.RealSrcSpan aspan)
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index 99a0f337..e08d8974 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -41,14 +41,14 @@ richToken (RichToken tok (Just det)) =
     externalAnchor det . internalAnchor det . hyperlink det $ content
   where
     content = tokenSpan tok ! [ multiclass style]
-    style = (tokenStyle . tkType) tok ++ (richTokenStyle . rtkType) det
+    style = (tokenStyle . tkType) tok ++ richTokenStyle det
 
 tokenSpan :: Token -> Html
 tokenSpan = Html.thespan . Html.toHtml . tkValue
 
-richTokenStyle :: RichTokenType -> [StyleClass]
-richTokenStyle RtkVar = ["hs-var"]
-richTokenStyle RtkType = ["hs-type"]
+richTokenStyle :: TokenDetails -> [StyleClass]
+richTokenStyle (RtkVar _) = ["hs-var"]
+richTokenStyle (RtkType _) = ["hs-type"]
 richTokenStyle _ = []
 
 tokenStyle :: TokenType -> [StyleClass]
@@ -70,12 +70,12 @@ multiclass :: [StyleClass] -> HtmlAttr
 multiclass = Html.theclass . intercalate " "
 
 externalAnchor :: TokenDetails -> Html -> Html
-externalAnchor (TokenDetails RtkDecl name) content =
+externalAnchor (RtkDecl name) content =
     Html.anchor content ! [ Html.name $ externalAnchorIdent name ]
 externalAnchor _ content = content
 
 internalAnchor :: TokenDetails -> Html -> Html
-internalAnchor (TokenDetails RtkBind name) content =
+internalAnchor (RtkBind name) content =
     Html.anchor content ! [ Html.name $ internalAnchorIdent name ]
 internalAnchor _ content = content
 
@@ -86,9 +86,12 @@ internalAnchorIdent :: GHC.Name -> String
 internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique
 
 hyperlink :: TokenDetails -> Html -> Html
-hyperlink (TokenDetails _ name) = if GHC.isInternalName name
+hyperlink details =
+    if GHC.isInternalName $ name
     then internalHyperlink name
     else externalHyperlink name
+  where
+    name = rtkName details
 
 internalHyperlink :: GHC.Name -> Html -> Html
 internalHyperlink name content =
-- 
cgit v1.2.3


From a85224a68b51b70035446ad8e5565d571c4a10d4 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Wed, 17 Jun 2015 22:22:49 +0200
Subject: Implement hyperlinking of imported module names.

---
 .../src/Haddock/Backends/Hyperlinker/Ast.hs        | 19 +++++++++------
 .../src/Haddock/Backends/Hyperlinker/Renderer.hs   | 28 +++++++++++++---------
 2 files changed, 29 insertions(+), 18 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 3c07ff3c..10389958 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -24,12 +24,14 @@ data TokenDetails
     | RtkType GHC.Name
     | RtkBind GHC.Name
     | RtkDecl GHC.Name
+    | RtkModule GHC.ModuleName
 
-rtkName :: TokenDetails -> GHC.Name
-rtkName (RtkVar name) = name
-rtkName (RtkType name) = name
-rtkName (RtkBind name) = name
-rtkName (RtkDecl name) = name
+rtkName :: TokenDetails -> Either GHC.Name GHC.ModuleName
+rtkName (RtkVar name) = Left name
+rtkName (RtkType name) = Left name
+rtkName (RtkBind name) = Left name
+rtkName (RtkDecl name) = Left name
+rtkName (RtkModule name) = Right name
 
 enrich :: GHC.RenamedSource -> [Token] -> [RichToken]
 enrich src =
@@ -109,8 +111,8 @@ decls (group, _, _, _) = concatMap ($ group)
         _ -> empty
 
 imports :: GHC.RenamedSource -> DetailsMap
-imports =
-    everything (<|>) ie
+imports src@(_, imps, _, _) =
+    everything (<|>) ie src ++ map (imp . GHC.unLoc) imps
   where
     ie term = case cast term of
         (Just (GHC.IEVar v)) -> pure $ var v
@@ -120,6 +122,9 @@ imports =
         _ -> empty
     typ (GHC.L sspan name) = (sspan, RtkType name)
     var (GHC.L sspan name) = (sspan, RtkVar name)
+    imp idecl =
+        let (GHC.L sspan name) = GHC.ideclName idecl
+        in (sspan, RtkModule name)
 
 matches :: Span -> GHC.SrcSpan -> Bool
 matches tspan (GHC.RealSrcSpan aspan)
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index e08d8974..70524759 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -8,6 +8,7 @@ import qualified Name as GHC
 import qualified Unique as GHC
 
 import Data.List
+import Data.Maybe
 import Data.Monoid
 
 import Text.XHtml (Html, HtmlAttr, (!))
@@ -86,20 +87,25 @@ internalAnchorIdent :: GHC.Name -> String
 internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique
 
 hyperlink :: TokenDetails -> Html -> Html
-hyperlink details =
-    if GHC.isInternalName $ name
-    then internalHyperlink name
-    else externalHyperlink name
-  where
-    name = rtkName details
+hyperlink details = case rtkName details of
+    Left name ->
+        if GHC.isInternalName name
+        then internalHyperlink name
+        else externalHyperlink mname (Just name)
+      where
+        mname = GHC.moduleName <$> GHC.nameModule_maybe name
+    Right name -> externalHyperlink (Just name) Nothing
 
 internalHyperlink :: GHC.Name -> Html -> Html
 internalHyperlink name content =
     Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ]
 
-externalHyperlink :: GHC.Name -> Html -> Html
-externalHyperlink name content =
-    Html.anchor content ! [ Html.href $ maybe "" id mmod ++ ".html#" ++ ident ]
+externalHyperlink :: Maybe GHC.ModuleName -> Maybe GHC.Name -> Html -> Html
+externalHyperlink mmname miname content =
+    Html.anchor content ! [ Html.href $ path ++ anchor ]
   where
-    mmod = GHC.moduleNameString . GHC.moduleName <$> GHC.nameModule_maybe name
-    ident = externalAnchorIdent name
+    path = fromMaybe "" $ modulePath <$> mmname
+    anchor = fromMaybe "" $ ("#" ++) . externalAnchorIdent <$> miname
+
+modulePath :: GHC.ModuleName -> String
+modulePath name = GHC.moduleNameString name ++ ".html"
-- 
cgit v1.2.3


From ebd60c5cd0c3642c2d5542c0e126be0a4ec111d9 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Wed, 17 Jun 2015 23:43:31 +0200
Subject: Fix parsing of single line comments with broken up newlines.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 12 +++++++++++-
 1 file changed, 11 insertions(+), 1 deletion(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index 70a69279..3ecfc7e7 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -47,13 +47,23 @@ chunk [] = []
 chunk str@(c:_)
     | isSpace c = chunk' $ span isSpace str
 chunk str
-    | "--" `isPrefixOf` str = chunk' $ span (not . (== '\n')) str
+    | "--" `isPrefixOf` str = chunk' $ spanToNewline str
     | "{-" `isPrefixOf` str = chunk' $ chunkComment 0 str
     | otherwise = chunk' $ head $ lex str
 
 chunk' :: (String, String) -> [String]
 chunk' (c, rest) = c:(chunk rest)
 
+spanToNewline :: String -> (String, String)
+spanToNewline [] = ([], [])
+spanToNewline ('\\':'\n':str) =
+    let (str', rest) = spanToNewline str
+    in ('\\':'\n':str', rest)
+spanToNewline ('\n':str) = ("\n", str)
+spanToNewline (c:str) =
+    let (str', rest) = spanToNewline str
+    in (c:str', rest)
+
 chunkComment :: Int -> String -> (String, String)
 chunkComment _ [] = ("", "")
 chunkComment depth ('{':'-':str) =
-- 
cgit v1.2.3


From a7888aefa4011d919b887ff31fcf8651af5632be Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Thu, 18 Jun 2015 00:25:56 +0200
Subject: Fix bug with improper newline handling.

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

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index 3ecfc7e7..bfee4a7f 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -59,7 +59,7 @@ spanToNewline [] = ([], [])
 spanToNewline ('\\':'\n':str) =
     let (str', rest) = spanToNewline str
     in ('\\':'\n':str', rest)
-spanToNewline ('\n':str) = ("\n", str)
+spanToNewline str@('\n':_) = ("", str)
 spanToNewline (c:str) =
     let (str', rest) = spanToNewline str
     in (c:str', rest)
-- 
cgit v1.2.3


From 45cc27fe79492a7b921574796a7ea8fdac4c5af2 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Thu, 18 Jun 2015 14:29:59 +0200
Subject: Fix issues with escaped newlines in comments.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 13 +++++--------
 1 file changed, 5 insertions(+), 8 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index bfee4a7f..fa5a58b3 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -82,14 +82,11 @@ tag :: [String] -> [(Span, String)]
 tag =
     reverse . snd . foldl aux (Position 1 1, [])
   where
-    aux (pos, cs) c =
-        let pos' = move pos c
-        in (pos', ((Span pos pos', c):cs))
-    move pos str@(c:_)
-        | isSpace c = foldl move' pos str
-    move pos str = pos { posCol = posCol pos + length str }
-    move' pos '\n' = pos { posRow = posRow pos + 1, posCol = 1 }
-    move' pos _ = pos { posCol = posCol pos + 1 }
+    aux (pos, cs) str =
+        let pos' = foldl move pos str
+        in (pos', (Span pos pos', str):cs)
+    move pos '\n' = pos { posRow = posRow pos + 1, posCol = 1 }
+    move pos _ = pos { posCol = posCol pos + 1 }
 
 tokenize :: [(Span, String)] -> [Token]
 tokenize =
-- 
cgit v1.2.3


From 61942ce564edcb3c0a64051042c8ed850f2090bd Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Thu, 18 Jun 2015 15:19:59 +0200
Subject: Add support for parsing C preprocessor macros.

---
 .../src/Haddock/Backends/Hyperlinker/Parser.hs       | 20 ++++++++++++++++----
 1 file changed, 16 insertions(+), 4 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index fa5a58b3..7f408165 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -6,6 +6,7 @@ module Haddock.Backends.Hyperlinker.Parser
 
 import Data.Char
 import Data.List
+import Data.Maybe
 
 data Token = Token
     { tkType :: TokenType
@@ -45,14 +46,15 @@ parse = tokenize . tag . chunk
 chunk :: String -> [String]
 chunk [] = []
 chunk str@(c:_)
-    | isSpace c = chunk' $ span isSpace str
+    | isSpace c =
+        let (space, mcpp, rest) = spanSpaceOrCpp str
+        in [space] ++ maybeToList mcpp ++ chunk rest
 chunk str
     | "--" `isPrefixOf` str = chunk' $ spanToNewline str
     | "{-" `isPrefixOf` str = chunk' $ chunkComment 0 str
     | otherwise = chunk' $ head $ lex str
-
-chunk' :: (String, String) -> [String]
-chunk' (c, rest) = c:(chunk rest)
+  where
+    chunk' (c, rest) = c:(chunk rest)
 
 spanToNewline :: String -> (String, String)
 spanToNewline [] = ([], [])
@@ -64,6 +66,16 @@ spanToNewline (c:str) =
     let (str', rest) = spanToNewline str
     in (c:str', rest)
 
+spanSpaceOrCpp :: String -> (String, Maybe String, String)
+spanSpaceOrCpp ('\n':'#':str) =
+    let (str', rest) = spanToNewline str
+    in ("\n", Just $ '#':str', rest)
+spanSpaceOrCpp (c:str')
+    | isSpace c =
+        let (space, mcpp, rest) = spanSpaceOrCpp str'
+        in (c:space, mcpp, rest)
+spanSpaceOrCpp str = ("", Nothing, str)
+
 chunkComment :: Int -> String -> (String, String)
 chunkComment _ [] = ("", "")
 chunkComment depth ('{':'-':str) =
-- 
cgit v1.2.3


From 416c384a981593005c9c6bf87ac27b7c2f9b8695 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Sun, 21 Jun 2015 23:48:03 +0200
Subject: Add some documentation for parser module of source hyperlinker.

---
 .../src/Haddock/Backends/Hyperlinker/Parser.hs     | 39 ++++++++++++++++++++++
 1 file changed, 39 insertions(+)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index 7f408165..6e195dba 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -40,9 +40,20 @@ data TokenType
     | TkUnknown
     deriving (Eq)
 
+-- | Turn source code string into a stream of more descriptive tokens.
+--
+-- Result should retain original file layout (including comments, whitespace,
+-- etc.), i.e. the following "law" should hold:
+--
+-- @concat . map 'tkValue' . 'parse' = id@
 parse :: String -> [Token]
 parse = tokenize . tag . chunk
 
+-- | Split raw source string to more meaningful chunks.
+--
+-- This is the initial stage of tokenization process. Each chunk is either
+-- a comment (including comment delimiters), a whitespace string, preprocessor
+-- macro (and all its content until the end of a line) or valid Haskell lexeme.
 chunk :: String -> [String]
 chunk [] = []
 chunk str@(c:_)
@@ -56,6 +67,11 @@ chunk str
   where
     chunk' (c, rest) = c:(chunk rest)
 
+-- | Split input to "first line" string and the rest of it.
+--
+-- Ideally, this should be done simply with @'break' (== '\n')@. However,
+-- Haskell also allows line-unbreaking (or whatever it is called) so things
+-- are not as simple and this function deals with that.
 spanToNewline :: String -> (String, String)
 spanToNewline [] = ([], [])
 spanToNewline ('\\':'\n':str) =
@@ -66,6 +82,16 @@ spanToNewline (c:str) =
     let (str', rest) = spanToNewline str
     in (c:str', rest)
 
+-- | Split input to whitespace string, (optional) preprocessor directive and
+-- the rest of it.
+--
+-- Again, using something like @'span' 'isSpace'@ would be nice to chunk input
+-- to whitespace. The problem is with /#/ symbol - if it is placed at the very
+-- beginning of a line, it should be recognized as preprocessor macro. In any
+-- other case, it is ordinary Haskell symbol and can be used to declare
+-- operators. Hence, while dealing with whitespace we also check whether there
+-- happens to be /#/ symbol just after a newline character - if that is the
+-- case, we begin treating the whole line as preprocessor macro.
 spanSpaceOrCpp :: String -> (String, Maybe String, String)
 spanSpaceOrCpp ('\n':'#':str) =
     let (str', rest) = spanToNewline str
@@ -76,6 +102,10 @@ spanSpaceOrCpp (c:str')
         in (c:space, mcpp, rest)
 spanSpaceOrCpp str = ("", Nothing, str)
 
+-- | Split input to comment content (including delimiters) and the rest.
+--
+-- Again, some more logic than simple 'span' is required because of Haskell
+-- comment nesting policy.
 chunkComment :: Int -> String -> (String, String)
 chunkComment _ [] = ("", "")
 chunkComment depth ('{':'-':str) =
@@ -90,6 +120,7 @@ chunkComment depth (e:str) =
     let (c, rest) = chunkComment depth str
     in (e:c, rest)
 
+-- | Assign source location for each chunk in given stream.
 tag :: [String] -> [(Span, String)]
 tag =
     reverse . snd . foldl aux (Position 1 1, [])
@@ -100,6 +131,7 @@ tag =
     move pos '\n' = pos { posRow = posRow pos + 1, posCol = 1 }
     move pos _ = pos { posCol = posCol pos + 1 }
 
+-- | Turn unrecognised chunk stream to more descriptive token stream.
 tokenize :: [(Span, String)] -> [Token]
 tokenize =
     map aux
@@ -110,6 +142,13 @@ tokenize =
         , tkSpan = sp
         }
 
+-- | Classify given string as appropriate Haskell token.
+--
+-- This method is based on Haskell 98 Report lexical structure description:
+-- https://www.haskell.org/onlinereport/lexemes.html
+--
+-- However, this is probably far from being perfect and most probably does not
+-- handle correctly all corner cases.
 classify :: String -> TokenType
 classify str
     | "--" `isPrefixOf` str = TkComment
-- 
cgit v1.2.3


From 937a6011d253a77cda98ec112a839cd08ac7e7ca Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Mon, 22 Jun 2015 00:20:44 +0200
Subject: Add some documentation for AST module of source hyperlinker.

---
 .../src/Haddock/Backends/Hyperlinker/Ast.hs        | 56 ++++++++++++++++++----
 1 file changed, 46 insertions(+), 10 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 10389958..275f10e9 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -33,6 +33,7 @@ rtkName (RtkBind name) = Left name
 rtkName (RtkDecl name) = Left name
 rtkName (RtkModule name) = Right name
 
+-- | Add more detailed information to token stream using GHC API.
 enrich :: GHC.RenamedSource -> [Token] -> [RichToken]
 enrich src =
     map $ \token -> RichToken
@@ -48,23 +49,24 @@ enrich src =
         , imports
         ]
 
+-- | 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)]
 
+lookupBySpan :: Span -> DetailsMap -> Maybe TokenDetails
+lookupBySpan tspan = listToMaybe . map snd . filter (matches tspan . fst)
+
 enrichToken :: Token -> DetailsMap -> Maybe TokenDetails
 enrichToken (Token typ _ spn) dm
     | typ `elem` [TkIdentifier, TkOperator] = lookupBySpan spn dm
 enrichToken _ _ = Nothing
 
-lookupBySpan :: Span -> DetailsMap -> Maybe TokenDetails
-lookupBySpan tspan = listToMaybe . map snd . filter (matches tspan . fst)
-
-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)
-
-combine :: Alternative f => (forall a. Data a => a -> f r) -> (forall a. Data a => a -> f r) -> (forall a. Data a => a -> f r)
-combine f g x = f x <|> g x
-
+-- | Obtain details map for variables ("normally" used identifiers).
 variables :: GHC.RenamedSource -> DetailsMap
 variables =
     everything (<|>) var
@@ -74,6 +76,7 @@ variables =
             pure (sspan, RtkVar name)
         _ -> empty
 
+-- | Obtain details map for types.
 types :: GHC.RenamedSource -> DetailsMap
 types =
     everything (<|>) ty
@@ -83,6 +86,11 @@ types =
             pure (sspan, RtkType name)
         _ -> empty
 
+-- | Obtain details map for identifier bindings.
+--
+-- 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)
@@ -96,6 +104,7 @@ binds =
             pure (sspan, RtkBind name)
         _ -> empty
 
+-- | Obtain details map for top-level declarations.
 decls :: GHC.RenamedSource -> DetailsMap
 decls (group, _, _, _) = concatMap ($ group)
     [ map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds
@@ -110,6 +119,10 @@ decls (group, _, _, _) = concatMap ($ group)
             | GHC.isExternalName name -> pure (sspan, RtkDecl name)
         _ -> empty
 
+-- | Obtain details map for import declarations.
+--
+-- This map also includes type and variable details for items in export and
+-- import lists.
 imports :: GHC.RenamedSource -> DetailsMap
 imports src@(_, imps, _, _) =
     everything (<|>) ie src ++ map (imp . GHC.unLoc) imps
@@ -126,6 +139,15 @@ imports src@(_, imps, _, _) =
         let (GHC.L sspan name) = GHC.ideclName idecl
         in (sspan, RtkModule name)
 
+-- | 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
@@ -135,3 +157,17 @@ matches tspan (GHC.RealSrcSpan aspan)
     saspan = (GHC.srcSpanStartLine aspan, GHC.srcSpanStartCol aspan)
     easpan = (GHC.srcSpanEndLine aspan, GHC.srcSpanEndCol aspan)
 matches _ _ = False
+
+-- | 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)
+           -> (forall a. Data a => a -> r)
+everything k f x = foldl k (f x) (gmapQ (everything k f) x)
+
+-- | Combine two queries into one using alternative combinator.
+combine :: Alternative f => (forall a. Data a => a -> f r)
+                         -> (forall a. Data a => a -> f r)
+                         -> (forall a. Data a => a -> f r)
+combine f g x = f x <|> g x
-- 
cgit v1.2.3


From ce4b5607f84506e5aafd1994e02300c2e3ee475d Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Mon, 22 Jun 2015 12:27:55 +0200
Subject: Add command line option for generating hyperlinked source.

---
 haddock-api/src/Haddock/Options.hs | 3 +++
 1 file changed, 3 insertions(+)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs
index e847333e..c9d5688c 100644
--- a/haddock-api/src/Haddock/Options.hs
+++ b/haddock-api/src/Haddock/Options.hs
@@ -66,6 +66,7 @@ data Flag
   | Flag_WikiEntityURL String
   | Flag_LaTeX
   | Flag_LaTeXStyle String
+  | Flag_HyperlinkedSource
   | Flag_Help
   | Flag_Verbosity String
   | Flag_Version
@@ -116,6 +117,8 @@ options backwardsCompat =
     Option ['U'] ["use-unicode"] (NoArg Flag_UseUnicode) "use Unicode in HTML output",
     Option []  ["hoogle"]     (NoArg Flag_Hoogle)
       "output for Hoogle; you may want --package-name and --package-version too",
+    Option [] ["hyperlinked-source"] (NoArg Flag_HyperlinkedSource)
+      "generate highlighted and hyperlinked source code (for use with --html)",
     Option []  ["source-base"]   (ReqArg Flag_SourceBaseURL "URL")
       "URL for a source code link on the contents\nand index pages",
     Option ['s'] (if backwardsCompat then ["source", "source-module"] else ["source-module"])
-- 
cgit v1.2.3


From 3eb96a6bbc1f61b81c20df882e243c4d9f4a9404 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Mon, 22 Jun 2015 12:51:49 +0200
Subject: Extend module interface with rich source token stream field.

---
 haddock-api/src/Haddock/Interface/Create.hs | 1 +
 haddock-api/src/Haddock/Types.hs            | 5 +++++
 2 files changed, 6 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 7491a01e..63d44366 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -145,6 +145,7 @@ createInterface tm flags modMap instIfaceMap = do
   , ifaceFamInstances    = fam_instances
   , ifaceHaddockCoverage = coverage
   , ifaceWarningMap      = warningMap
+  , ifaceTokenizedSrc    = Nothing
   }
 
 mkAliasMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 14995098..fbb5f44c 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -35,6 +35,7 @@ import DynFlags (ExtensionFlag, Language)
 import OccName
 import Outputable
 import Control.Monad (ap)
+import Haddock.Backends.Hyperlinker.Ast
 
 -----------------------------------------------------------------------------
 -- * Convenient synonyms
@@ -125,6 +126,10 @@ data Interface = Interface
 
     -- | Warnings for things defined in this module.
   , ifaceWarningMap :: !WarningMap
+
+    -- | Tokenized source code of module (avaliable if Haddock is invoked with
+    -- source generation flag).
+  , ifaceTokenizedSrc :: !(Maybe [RichToken])
   }
 
 type WarningMap = Map Name (Doc Name)
-- 
cgit v1.2.3


From 4190a05c4abc710d253212017fb4a654ebde1862 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Mon, 22 Jun 2015 14:04:41 +0200
Subject: Implement source tokenization during interface creation process.

---
 haddock-api/src/Haddock/Interface/Create.hs | 30 ++++++++++++++++++++++++++++-
 1 file changed, 29 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 63d44366..59f7076f 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -21,6 +21,8 @@ import Haddock.GhcUtils
 import Haddock.Utils
 import Haddock.Convert
 import Haddock.Interface.LexParseRn
+import Haddock.Backends.Hyperlinker.Ast as Hyperlinker
+import Haddock.Backends.Hyperlinker.Parser as Hyperlinker
 
 import qualified Data.Map as M
 import Data.Map (Map)
@@ -122,6 +124,8 @@ createInterface tm flags modMap instIfaceMap = do
         mkAliasMap dflags $ tm_renamed_source tm
       modWarn = moduleWarning dflags gre warnings
 
+  tokenizedSrc <- mkMaybeTokenizedSrc flags tm
+
   return $! Interface {
     ifaceMod             = mdl
   , ifaceOrigFilename    = msHsFilePath ms
@@ -145,7 +149,7 @@ createInterface tm flags modMap instIfaceMap = do
   , ifaceFamInstances    = fam_instances
   , ifaceHaddockCoverage = coverage
   , ifaceWarningMap      = warningMap
-  , ifaceTokenizedSrc    = Nothing
+  , ifaceTokenizedSrc    = tokenizedSrc
   }
 
 mkAliasMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName
@@ -862,6 +866,30 @@ seqList :: [a] -> ()
 seqList [] = ()
 seqList (x : xs) = x `seq` seqList xs
 
+mkMaybeTokenizedSrc :: [Flag] -> TypecheckedModule
+                    -> ErrMsgGhc (Maybe [RichToken])
+mkMaybeTokenizedSrc flags tm
+    | Flag_HyperlinkedSource `elem` flags = case renamedSource tm of
+        Just src -> do
+            tokens <- liftGhcToErrMsgGhc . liftIO $ mkTokenizedSrc summary src
+            return $ Just tokens
+        Nothing -> do
+            liftErrMsg . tell . pure $ concat
+                [ "Warning: Cannot hyperlink module \""
+                , moduleNameString . ms_mod_name $ summary
+                , "\" because renamed source is not available"
+                ]
+            return Nothing
+    | otherwise = return Nothing
+  where
+    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
+
 -- | Find a stand-alone documentation comment by its name.
 findNamedDoc :: String -> [HsDecl Name] -> ErrMsgM (Maybe HsDocString)
 findNamedDoc name = search
-- 
cgit v1.2.3


From 62d44cd1d37d83fa93d169c2e5b5b758fcc231d6 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Mon, 22 Jun 2015 16:09:54 +0200
Subject: Create hyperlinker module and plug it into the Haddock pipeline.

---
 haddock-api/haddock-api.cabal                   |  1 +
 haddock-api/src/Haddock.hs                      |  4 ++++
 haddock-api/src/Haddock/Backends/Hyperlinker.hs | 25 +++++++++++++++++++++++++
 haddock.cabal                                   |  1 +
 4 files changed, 31 insertions(+)
 create mode 100644 haddock-api/src/Haddock/Backends/Hyperlinker.hs

(limited to 'haddock-api/src')

diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal
index 109e5f95..6ffde976 100644
--- a/haddock-api/haddock-api.cabal
+++ b/haddock-api/haddock-api.cabal
@@ -82,6 +82,7 @@ library
     Haddock.Backends.LaTeX
     Haddock.Backends.HaddockDB
     Haddock.Backends.Hoogle
+    Haddock.Backends.Hyperlinker
     Haddock.ModuleTree
     Haddock.Types
     Haddock.Doc
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 3e58aba3..e45456ab 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -30,6 +30,7 @@ import Haddock.Backends.Xhtml
 import Haddock.Backends.Xhtml.Themes (getThemes)
 import Haddock.Backends.LaTeX
 import Haddock.Backends.Hoogle
+import Haddock.Backends.Hyperlinker
 import Haddock.Interface
 import Haddock.Parser
 import Haddock.Types
@@ -308,6 +309,9 @@ render dflags flags qual ifaces installedIfaces srcMap = do
     ppLaTeX title pkgStr visibleIfaces odir (fmap _doc prologue) opt_latex_style
                   libDir
 
+  when (Flag_HyperlinkedSource `elem` flags) $ do
+    ppHyperlinkedSource odir libDir Nothing visibleIfaces
+
 -- | From GHC 7.10, this function has a potential to crash with a
 -- nasty message such as @expectJust getPackageDetails@ because
 -- package name and versions can no longer reliably be extracted in
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
new file mode 100644
index 00000000..88619474
--- /dev/null
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
@@ -0,0 +1,25 @@
+module Haddock.Backends.Hyperlinker (ppHyperlinkedSource) where
+
+import Haddock.Types
+import Haddock.Backends.Hyperlinker.Renderer
+
+import GHC
+import Text.XHtml hiding ((</>))
+import System.Directory
+import System.FilePath
+
+ppHyperlinkedSource :: FilePath -> FilePath -> Maybe FilePath -> [Interface]
+                    -> IO ()
+ppHyperlinkedSource outdir libdir mstyle ifaces = do
+    createDirectoryIfMissing True (outdir </> "src")
+    mapM_ (ppHyperlinkedModuleSource outdir mstyle) ifaces
+
+ppHyperlinkedModuleSource :: FilePath -> Maybe FilePath -> Interface -> IO ()
+ppHyperlinkedModuleSource outdir mstyle iface = case ifaceTokenizedSrc iface of
+    Just tokens -> writeFile path $ showHtml . render mstyle $ tokens
+    Nothing -> return ()
+  where
+    path = outdir </> "src" </> moduleSourceFile (ifaceMod iface)
+
+moduleSourceFile :: Module -> FilePath
+moduleSourceFile = (++ ".html") . moduleNameString . moduleName
diff --git a/haddock.cabal b/haddock.cabal
index ed570f53..0aebefd8 100644
--- a/haddock.cabal
+++ b/haddock.cabal
@@ -101,6 +101,7 @@ executable haddock
       Haddock.Backends.LaTeX
       Haddock.Backends.HaddockDB
       Haddock.Backends.Hoogle
+      Haddock.Backends.Hyperlinker
       Haddock.ModuleTree
       Haddock.Types
       Haddock.Doc
-- 
cgit v1.2.3


From 6f16398a26a12d58b3ba7f1924e2b6b00e68f5f7 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Mon, 22 Jun 2015 17:20:37 +0200
Subject: Add support for providing custom CSS files for hyperlinked source.

---
 haddock-api/haddock-api.cabal                   |  1 +
 haddock-api/resources/html/solarized.css        | 55 +++++++++++++++++++++++++
 haddock-api/src/Haddock.hs                      |  3 +-
 haddock-api/src/Haddock/Backends/Hyperlinker.hs | 26 +++++++++---
 haddock-api/src/Haddock/Options.hs              |  6 +++
 5 files changed, 84 insertions(+), 7 deletions(-)
 create mode 100644 haddock-api/resources/html/solarized.css

(limited to 'haddock-api/src')

diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal
index 6ffde976..14656994 100644
--- a/haddock-api/haddock-api.cabal
+++ b/haddock-api/haddock-api.cabal
@@ -18,6 +18,7 @@ stability:            experimental
 data-dir:
   resources
 data-files:
+  html/solarized.css
   html/frames.html
   html/haddock-util.js
   html/Classic.theme/haskell_icon.gif
diff --git a/haddock-api/resources/html/solarized.css b/haddock-api/resources/html/solarized.css
new file mode 100644
index 00000000..e4bff385
--- /dev/null
+++ b/haddock-api/resources/html/solarized.css
@@ -0,0 +1,55 @@
+body {
+	background-color: #fdf6e3;
+}
+
+.hs-identifier {
+	color: #073642;
+}
+
+.hs-identifier.hs-var {
+}
+
+.hs-identifier.hs-type {
+	color: #5f5faf;
+}
+
+.hs-keyword {
+	color: #af005f;
+}
+
+.hs-string, .hs-char {
+	color: #cb4b16;
+}
+
+.hs-number {
+	color: #268bd2;
+}
+
+.hs-operator {
+	color: #d33682;
+}
+
+.hs-glyph, .hs-special {
+	color: #dc322f;
+}
+
+.hs-comment {
+	color: #8a8a8a;
+}
+
+.hs-pragma {
+	color: #2aa198;
+}
+
+.hs-cpp {
+	color: #859900;
+}
+
+a:link, a:visited {
+	text-decoration: none;
+	border-bottom: 1px solid #eee8d5;
+}
+
+a:hover {
+	background-color: #eee8d5;
+}
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index e45456ab..698122e3 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -244,6 +244,7 @@ render dflags flags qual ifaces installedIfaces srcMap = do
     opt_index_url        = optIndexUrl       flags
     odir                 = outputDir         flags
     opt_latex_style      = optLaTeXStyle     flags
+    opt_source_css       = optSourceCssFile  flags
 
     visibleIfaces    = [ i | i <- ifaces, OptHide `notElem` ifaceOptions i ]
 
@@ -310,7 +311,7 @@ render dflags flags qual ifaces installedIfaces srcMap = do
                   libDir
 
   when (Flag_HyperlinkedSource `elem` flags) $ do
-    ppHyperlinkedSource odir libDir Nothing visibleIfaces
+    ppHyperlinkedSource odir libDir opt_source_css visibleIfaces
 
 -- | From GHC 7.10, this function has a potential to crash with a
 -- nasty message such as @expectJust getPackageDetails@ because
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
index 88619474..66392a67 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
@@ -5,21 +5,35 @@ import Haddock.Backends.Hyperlinker.Renderer
 
 import GHC
 import Text.XHtml hiding ((</>))
+
+import Data.Maybe
 import System.Directory
 import System.FilePath
 
 ppHyperlinkedSource :: FilePath -> FilePath -> Maybe FilePath -> [Interface]
                     -> IO ()
 ppHyperlinkedSource outdir libdir mstyle ifaces = do
-    createDirectoryIfMissing True (outdir </> "src")
-    mapM_ (ppHyperlinkedModuleSource outdir mstyle) ifaces
+    createDirectoryIfMissing True $ srcPath outdir
+    let cssFile = fromMaybe (defaultCssFile libdir) mstyle
+    copyFile cssFile $ srcPath outdir </> srcCssFile
+    mapM_ (ppHyperlinkedModuleSource outdir) ifaces
 
-ppHyperlinkedModuleSource :: FilePath -> Maybe FilePath -> Interface -> IO ()
-ppHyperlinkedModuleSource outdir mstyle iface = case ifaceTokenizedSrc iface of
-    Just tokens -> writeFile path $ showHtml . render mstyle $ tokens
+ppHyperlinkedModuleSource :: FilePath -> Interface -> IO ()
+ppHyperlinkedModuleSource outdir iface = case ifaceTokenizedSrc iface of
+    Just tokens -> writeFile path $ showHtml . render mSrcCssFile $ tokens
     Nothing -> return ()
   where
-    path = outdir </> "src" </> moduleSourceFile (ifaceMod iface)
+    mSrcCssFile = Just $ srcCssFile
+    path = srcPath outdir </> moduleSourceFile (ifaceMod iface)
 
 moduleSourceFile :: Module -> FilePath
 moduleSourceFile = (++ ".html") . moduleNameString . moduleName
+
+srcPath :: FilePath -> FilePath
+srcPath outdir = outdir </> "src"
+
+srcCssFile :: FilePath
+srcCssFile = "style.css"
+
+defaultCssFile :: FilePath -> FilePath
+defaultCssFile libdir = libdir </> "html" </> "solarized.css"
diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs
index c9d5688c..f84989ef 100644
--- a/haddock-api/src/Haddock/Options.hs
+++ b/haddock-api/src/Haddock/Options.hs
@@ -21,6 +21,7 @@ module Haddock.Options (
   optContentsUrl,
   optIndexUrl,
   optCssFile,
+  optSourceCssFile,
   sourceUrls,
   wikiUrls,
   optDumpInterfaceFile,
@@ -67,6 +68,7 @@ data Flag
   | Flag_LaTeX
   | Flag_LaTeXStyle String
   | Flag_HyperlinkedSource
+  | Flag_SourceCss String
   | Flag_Help
   | Flag_Verbosity String
   | Flag_Version
@@ -119,6 +121,8 @@ options backwardsCompat =
       "output for Hoogle; you may want --package-name and --package-version too",
     Option [] ["hyperlinked-source"] (NoArg Flag_HyperlinkedSource)
       "generate highlighted and hyperlinked source code (for use with --html)",
+    Option [] ["source-css"] (ReqArg Flag_SourceCss "FILE")
+      "use custom CSS file instead of default one in hyperlinked source",
     Option []  ["source-base"]   (ReqArg Flag_SourceBaseURL "URL")
       "URL for a source code link on the contents\nand index pages",
     Option ['s'] (if backwardsCompat then ["source", "source-module"] else ["source-module"])
@@ -242,6 +246,8 @@ optIndexUrl flags = optLast [ url | Flag_UseIndex url <- flags ]
 optCssFile :: [Flag] -> Maybe FilePath
 optCssFile flags = optLast [ str | Flag_CSS str <- flags ]
 
+optSourceCssFile :: [Flag] -> Maybe FilePath
+optSourceCssFile flags = optLast [ str | Flag_SourceCss str <- flags ]
 
 sourceUrls :: [Flag] -> (Maybe String, Maybe String, Maybe String, Maybe String)
 sourceUrls flags =
-- 
cgit v1.2.3


From a6bd86a8550d5d7e8bdb12e1d09036b9f88eed73 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Mon, 22 Jun 2015 17:41:31 +0200
Subject: Add support for fancy highlighting upon hovering over identifier.

---
 haddock-api/haddock-api.cabal                      |  1 +
 haddock-api/resources/html/highlight.js            | 46 ++++++++++++++++++++++
 haddock-api/src/Haddock/Backends/Hyperlinker.hs    | 10 ++++-
 .../src/Haddock/Backends/Hyperlinker/Renderer.hs   | 23 +++++++----
 4 files changed, 70 insertions(+), 10 deletions(-)
 create mode 100644 haddock-api/resources/html/highlight.js

(limited to 'haddock-api/src')

diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal
index 14656994..216627cc 100644
--- a/haddock-api/haddock-api.cabal
+++ b/haddock-api/haddock-api.cabal
@@ -21,6 +21,7 @@ data-files:
   html/solarized.css
   html/frames.html
   html/haddock-util.js
+  html/highlight.js
   html/Classic.theme/haskell_icon.gif
   html/Classic.theme/minus.gif
   html/Classic.theme/plus.gif
diff --git a/haddock-api/resources/html/highlight.js b/haddock-api/resources/html/highlight.js
new file mode 100644
index 00000000..639cf5d5
--- /dev/null
+++ b/haddock-api/resources/html/highlight.js
@@ -0,0 +1,46 @@
+
+var styleForRule = function (rule) {
+	var sheets = document.styleSheets;
+	for (var s = 0; s < sheets.length; s++) {
+		var rules = sheets[s].cssRules;
+		for (var r = 0; r < rules.length; r++) {
+			if (rules[r].selectorText == rule) {
+				return rules[r].style;
+			}
+		}
+	}
+};
+
+var highlight = function () {
+	var color = styleForRule("a:hover")["background-color"];
+	var links = document.getElementsByTagName('a');
+	for (var i = 0; i < links.length; i++) {
+		var that = links[i];
+		if (this.href == that.href) {
+			that.style["background-color"] = color;
+		}
+	}
+};
+
+/*
+ * I have no idea what is the proper antonym for "highlight" in this
+ * context. "Diminish"? "Unhighlight"? "Lowlight" sounds ridiculously
+ * so I like it.
+ */
+var lowlight = function () {
+	var links = document.getElementsByTagName('a');
+	for (var i = 0; i < links.length; i++) {
+		var that = links[i];
+		if (this.href == that.href) {
+			that.style["background-color"] = "";
+		}
+	}
+};
+
+window.onload = function () {
+	var links = document.getElementsByTagName('a');
+	for (var i = 0; i < links.length; i++) {
+		links[i].onmouseover = highlight;
+		links[i].onmouseout = lowlight;
+	}
+};
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
index 66392a67..9337307c 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
@@ -16,14 +16,17 @@ ppHyperlinkedSource outdir libdir mstyle ifaces = do
     createDirectoryIfMissing True $ srcPath outdir
     let cssFile = fromMaybe (defaultCssFile libdir) mstyle
     copyFile cssFile $ srcPath outdir </> srcCssFile
+    copyFile (libdir </> "html" </> highlightScript) $
+        srcPath outdir </> highlightScript
     mapM_ (ppHyperlinkedModuleSource outdir) ifaces
 
 ppHyperlinkedModuleSource :: FilePath -> Interface -> IO ()
 ppHyperlinkedModuleSource outdir iface = case ifaceTokenizedSrc iface of
-    Just tokens -> writeFile path $ showHtml . render mSrcCssFile $ tokens
+    Just tokens -> writeFile path $ showHtml . render mCssFile mJsFile $ tokens
     Nothing -> return ()
   where
-    mSrcCssFile = Just $ srcCssFile
+    mCssFile = Just $ srcCssFile
+    mJsFile = Just $ highlightScript
     path = srcPath outdir </> moduleSourceFile (ifaceMod iface)
 
 moduleSourceFile :: Module -> FilePath
@@ -35,5 +38,8 @@ srcPath outdir = outdir </> "src"
 srcCssFile :: FilePath
 srcCssFile = "style.css"
 
+highlightScript :: FilePath
+highlightScript = "highlight.js"
+
 defaultCssFile :: FilePath -> FilePath
 defaultCssFile libdir = libdir </> "html" </> "solarized.css"
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index 70524759..6d6d2012 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -16,21 +16,28 @@ import qualified Text.XHtml as Html
 
 type StyleClass = String
 
-render :: Maybe FilePath -> [RichToken] -> Html
-render css tokens = header css <> body tokens
+render :: Maybe FilePath -> Maybe FilePath -> [RichToken] -> Html
+render mcss mjs tokens = header mcss mjs <> body tokens
 
 body :: [RichToken] -> Html
 body = Html.body . Html.pre . mconcat . map richToken
 
-header :: Maybe FilePath -> Html
-header Nothing = Html.noHtml
-header (Just css) =
-    Html.header $ Html.thelink Html.noHtml ! attrs
+header :: Maybe FilePath -> Maybe FilePath -> Html
+header mcss mjs
+    | isNothing mcss && isNothing mjs = Html.noHtml
+header mcss mjs =
+    Html.header $ css mcss <> js mjs
   where
-    attrs =
+    css Nothing = Html.noHtml
+    css (Just cssFile) = Html.thelink Html.noHtml !
         [ Html.rel "stylesheet"
-        , Html.href css
         , Html.thetype "text/css"
+        , Html.href cssFile
+        ]
+    js Nothing = Html.noHtml
+    js (Just jsFile) = Html.script Html.noHtml !
+        [ Html.thetype "text/javascript"
+        , Html.src jsFile
         ]
 
 richToken :: RichToken -> Html
-- 
cgit v1.2.3


From affd889d1b192d2cb9787c92202317b9e9401922 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Fri, 26 Jun 2015 21:13:12 +0200
Subject: Make source hyperlinker generate output in apropriate directory.

---
 haddock-api/src/Haddock.hs                      | 10 ++++--
 haddock-api/src/Haddock/Backends/Hyperlinker.hs | 41 +++++++++++++++----------
 haddock-api/src/Haddock/Utils.hs                |  5 +++
 3 files changed, 38 insertions(+), 18 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 698122e3..01e4cd45 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -258,10 +258,16 @@ render dflags flags qual ifaces installedIfaces srcMap = do
     pkgNameVer       = modulePackageInfo dflags flags pkgMod
 
     (srcBase, srcModule, srcEntity, srcLEntity) = sourceUrls flags
+
+    srcModule'
+      | isJust srcModule = srcModule
+      | Flag_HyperlinkedSource `elem` flags = Just defaultModuleSourceUrl
+      | otherwise = Nothing
+
     srcMap' = maybe srcMap (\path -> Map.insert pkgKey path srcMap) srcEntity
     -- TODO: Get these from the interface files as with srcMap
     srcLMap' = maybe Map.empty (\path -> Map.singleton pkgKey path) srcLEntity
-    sourceUrls' = (srcBase, srcModule, srcMap', srcLMap')
+    sourceUrls' = (srcBase, srcModule', srcMap', srcLMap')
 
   libDir   <- getHaddockLibDir flags
   prologue <- getPrologue dflags flags
@@ -311,7 +317,7 @@ render dflags flags qual ifaces installedIfaces srcMap = do
                   libDir
 
   when (Flag_HyperlinkedSource `elem` flags) $ do
-    ppHyperlinkedSource odir libDir opt_source_css visibleIfaces
+    ppHyperlinkedSource odir libDir opt_source_css sourceUrls' visibleIfaces
 
 -- | From GHC 7.10, this function has a potential to crash with a
 -- nasty message such as @expectJust getPackageDetails@ because
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
index 9337307c..2ed4dbdd 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
@@ -1,45 +1,54 @@
 module Haddock.Backends.Hyperlinker (ppHyperlinkedSource) where
 
 import Haddock.Types
+import Haddock.Utils
+import Haddock.Backends.Xhtml.Types
+import Haddock.Backends.Xhtml.Utils
 import Haddock.Backends.Hyperlinker.Renderer
 
-import GHC
 import Text.XHtml hiding ((</>))
 
 import Data.Maybe
 import System.Directory
 import System.FilePath
 
-ppHyperlinkedSource :: FilePath -> FilePath -> Maybe FilePath -> [Interface]
+ppHyperlinkedSource :: FilePath -> FilePath
+                    -> Maybe FilePath
+                    -> SourceURLs
+                    -> [Interface]
                     -> IO ()
-ppHyperlinkedSource outdir libdir mstyle ifaces = do
-    createDirectoryIfMissing True $ srcPath outdir
+ppHyperlinkedSource outdir libdir mstyle urls ifaces = do
+    createDirectoryIfMissing True srcdir
     let cssFile = fromMaybe (defaultCssFile libdir) mstyle
-    copyFile cssFile $ srcPath outdir </> srcCssFile
+    copyFile cssFile $ srcdir </> srcCssFile
     copyFile (libdir </> "html" </> highlightScript) $
-        srcPath outdir </> highlightScript
-    mapM_ (ppHyperlinkedModuleSource outdir) ifaces
+        srcdir </> highlightScript
+    mapM_ (ppHyperlinkedModuleSource outdir urls) ifaces
+  where
+    srcdir = srcPath outdir urls
 
-ppHyperlinkedModuleSource :: FilePath -> Interface -> IO ()
-ppHyperlinkedModuleSource outdir iface = case ifaceTokenizedSrc iface of
+ppHyperlinkedModuleSource :: FilePath -> SourceURLs -> Interface -> IO ()
+ppHyperlinkedModuleSource outdir urls iface = case ifaceTokenizedSrc iface of
     Just tokens -> writeFile path $ showHtml . render mCssFile mJsFile $ tokens
     Nothing -> return ()
   where
     mCssFile = Just $ srcCssFile
     mJsFile = Just $ highlightScript
-    path = srcPath outdir </> moduleSourceFile (ifaceMod iface)
-
-moduleSourceFile :: Module -> FilePath
-moduleSourceFile = (++ ".html") . moduleNameString . moduleName
+    srcFile = spliceURL Nothing (Just $ ifaceMod iface) Nothing Nothing $
+        srcModUrl urls
+    path = outdir </> srcFile
 
-srcPath :: FilePath -> FilePath
-srcPath outdir = outdir </> "src"
+srcPath :: FilePath -> SourceURLs -> FilePath
+srcPath outdir urls = outdir </> takeDirectory (srcModUrl urls)
 
 srcCssFile :: FilePath
-srcCssFile = "style.css"
+srcCssFile = "srcstyle.css"
 
 highlightScript :: FilePath
 highlightScript = "highlight.js"
 
 defaultCssFile :: FilePath -> FilePath
 defaultCssFile libdir = libdir </> "html" </> "solarized.css"
+
+srcModUrl :: SourceURLs -> String
+srcModUrl (_, mModSrcUrl, _, _) = fromMaybe defaultModuleSourceUrl mModSrcUrl
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index 4fed3a1e..78c78aca 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -29,6 +29,7 @@ module Haddock.Utils (
   moduleNameUrl, moduleNameUrl', moduleUrl,
   nameAnchorId,
   makeAnchorId,
+  defaultModuleSourceUrl,
 
   -- * Miscellaneous utilities
   getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr,
@@ -277,6 +278,10 @@ makeAnchorId (f:r) = escape isAlpha f ++ concatMap (escape isLegal) r
        -- NB: '-' is legal in IDs, but we use it as the escape char
 
 
+defaultModuleSourceUrl :: String
+defaultModuleSourceUrl = "src/%{MODULE}.html"
+
+
 -------------------------------------------------------------------------------
 -- * Files we need to copy from our $libdir
 -------------------------------------------------------------------------------
-- 
cgit v1.2.3


From 844c09d0c1d724e0f0f0698654f2f85f5f58be19 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Fri, 26 Jun 2015 22:24:57 +0200
Subject: Create module with hyperlinker utility functions.

---
 haddock-api/haddock-api.cabal                         |  1 +
 haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs | 18 ++++++++++++++++++
 2 files changed, 19 insertions(+)
 create mode 100644 haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs

(limited to 'haddock-api/src')

diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal
index 216627cc..7670f888 100644
--- a/haddock-api/haddock-api.cabal
+++ b/haddock-api/haddock-api.cabal
@@ -85,6 +85,7 @@ library
     Haddock.Backends.HaddockDB
     Haddock.Backends.Hoogle
     Haddock.Backends.Hyperlinker
+    Haddock.Backends.Hyperlinker.Utils
     Haddock.ModuleTree
     Haddock.Types
     Haddock.Doc
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
new file mode 100644
index 00000000..25ed942b
--- /dev/null
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
@@ -0,0 +1,18 @@
+module Haddock.Backends.Hyperlinker.Utils
+    ( srcModUrl
+    , srcNameUrlMap
+    ) where
+
+import Haddock.Utils
+import Haddock.Backends.Xhtml.Types
+
+import GHC
+
+import Data.Maybe
+import Data.Map (Map)
+
+srcModUrl :: SourceURLs -> String
+srcModUrl (_, mModUrl, _, _) = fromMaybe defaultModuleSourceUrl mModUrl
+
+srcNameUrlMap :: SourceURLs -> Map PackageKey FilePath
+srcNameUrlMap (_, _, nameUrlMap, _) = nameUrlMap
-- 
cgit v1.2.3


From d58bcf24dfa4333e7893935eb86c036be28125b1 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Fri, 26 Jun 2015 22:41:07 +0200
Subject: Make external hyperlinks point to locations specified by source URLs.

---
 haddock-api/src/Haddock.hs                         |  7 ++-
 haddock-api/src/Haddock/Backends/Hyperlinker.hs    |  8 ++--
 .../src/Haddock/Backends/Hyperlinker/Renderer.hs   | 52 +++++++++++++---------
 haddock-api/src/Haddock/Utils.hs                   |  5 ++-
 4 files changed, 44 insertions(+), 28 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 01e4cd45..3105edf5 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -264,7 +264,12 @@ render dflags flags qual ifaces installedIfaces srcMap = do
       | Flag_HyperlinkedSource `elem` flags = Just defaultModuleSourceUrl
       | otherwise = Nothing
 
-    srcMap' = maybe srcMap (\path -> Map.insert pkgKey path srcMap) srcEntity
+    srcMap'
+      | Just srcNameUrl <- srcEntity = Map.insert pkgKey srcNameUrl srcMap
+      | Flag_HyperlinkedSource `elem` flags =
+          Map.insert pkgKey defaultNameSourceUrl srcMap
+      | otherwise = srcMap
+
     -- TODO: Get these from the interface files as with srcMap
     srcLMap' = maybe Map.empty (\path -> Map.singleton pkgKey path) srcLEntity
     sourceUrls' = (srcBase, srcModule', srcMap', srcLMap')
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
index 2ed4dbdd..6c66e0c6 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
@@ -1,10 +1,10 @@
 module Haddock.Backends.Hyperlinker (ppHyperlinkedSource) where
 
 import Haddock.Types
-import Haddock.Utils
 import Haddock.Backends.Xhtml.Types
 import Haddock.Backends.Xhtml.Utils
 import Haddock.Backends.Hyperlinker.Renderer
+import Haddock.Backends.Hyperlinker.Utils
 
 import Text.XHtml hiding ((</>))
 
@@ -29,7 +29,8 @@ ppHyperlinkedSource outdir libdir mstyle urls ifaces = do
 
 ppHyperlinkedModuleSource :: FilePath -> SourceURLs -> Interface -> IO ()
 ppHyperlinkedModuleSource outdir urls iface = case ifaceTokenizedSrc iface of
-    Just tokens -> writeFile path $ showHtml . render mCssFile mJsFile $ tokens
+    Just tokens ->
+        writeFile path $ showHtml . render mCssFile mJsFile urls $ tokens
     Nothing -> return ()
   where
     mCssFile = Just $ srcCssFile
@@ -49,6 +50,3 @@ highlightScript = "highlight.js"
 
 defaultCssFile :: FilePath -> FilePath
 defaultCssFile libdir = libdir </> "html" </> "solarized.css"
-
-srcModUrl :: SourceURLs -> String
-srcModUrl (_, mModSrcUrl, _, _) = fromMaybe defaultModuleSourceUrl mModSrcUrl
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index 6d6d2012..2df62938 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -2,12 +2,16 @@ module Haddock.Backends.Hyperlinker.Renderer (render) where
 
 import Haddock.Backends.Hyperlinker.Parser
 import Haddock.Backends.Hyperlinker.Ast
+import Haddock.Backends.Hyperlinker.Utils
+import Haddock.Backends.Xhtml.Types
+import Haddock.Backends.Xhtml.Utils
 
 import qualified GHC
 import qualified Name as GHC
 import qualified Unique as GHC
 
 import Data.List
+import qualified Data.Map as Map
 import Data.Maybe
 import Data.Monoid
 
@@ -16,11 +20,11 @@ import qualified Text.XHtml as Html
 
 type StyleClass = String
 
-render :: Maybe FilePath -> Maybe FilePath -> [RichToken] -> Html
-render mcss mjs tokens = header mcss mjs <> body tokens
+render :: Maybe FilePath -> Maybe FilePath -> SourceURLs -> [RichToken] -> Html
+render mcss mjs urls tokens = header mcss mjs <> body urls tokens
 
-body :: [RichToken] -> Html
-body = Html.body . Html.pre . mconcat . map richToken
+body :: SourceURLs -> [RichToken] -> Html
+body urls = Html.body . Html.pre . mconcat . map (richToken urls)
 
 header :: Maybe FilePath -> Maybe FilePath -> Html
 header mcss mjs
@@ -40,13 +44,13 @@ header mcss mjs =
         , Html.src jsFile
         ]
 
-richToken :: RichToken -> Html
-richToken (RichToken tok Nothing) =
+richToken :: SourceURLs -> RichToken -> Html
+richToken _ (RichToken tok Nothing) =
     tokenSpan tok ! attrs
   where
     attrs = [ multiclass . tokenStyle . tkType $ tok ]
-richToken (RichToken tok (Just det)) =
-    externalAnchor det . internalAnchor det . hyperlink det $ content
+richToken urls (RichToken tok (Just det)) =
+    externalAnchor det . internalAnchor det . hyperlink urls det $ content
   where
     content = tokenSpan tok ! [ multiclass style]
     style = (tokenStyle . tkType) tok ++ richTokenStyle det
@@ -93,26 +97,32 @@ externalAnchorIdent = GHC.occNameString . GHC.nameOccName
 internalAnchorIdent :: GHC.Name -> String
 internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique
 
-hyperlink :: TokenDetails -> Html -> Html
-hyperlink details = case rtkName details of
+hyperlink :: SourceURLs -> TokenDetails -> Html -> Html
+hyperlink urls details = case rtkName details of
     Left name ->
         if GHC.isInternalName name
         then internalHyperlink name
-        else externalHyperlink mname (Just name)
-      where
-        mname = GHC.moduleName <$> GHC.nameModule_maybe name
-    Right name -> externalHyperlink (Just name) Nothing
+        else externalNameHyperlink urls name
+    Right name -> externalModHyperlink name
 
 internalHyperlink :: GHC.Name -> Html -> Html
 internalHyperlink name content =
     Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ]
 
-externalHyperlink :: Maybe GHC.ModuleName -> Maybe GHC.Name -> Html -> Html
-externalHyperlink mmname miname content =
-    Html.anchor content ! [ Html.href $ path ++ anchor ]
+externalNameHyperlink :: SourceURLs -> GHC.Name -> Html -> Html
+externalNameHyperlink urls name =
+    case Map.lookup key $ srcNameUrlMap urls of
+        Just url -> externalNameHyperlink' url name
+        Nothing -> id
   where
-    path = fromMaybe "" $ modulePath <$> mmname
-    anchor = fromMaybe "" $ ("#" ++) . externalAnchorIdent <$> miname
+    key = GHC.modulePackageKey . GHC.nameModule $ name
 
-modulePath :: GHC.ModuleName -> String
-modulePath name = GHC.moduleNameString name ++ ".html"
+externalNameHyperlink' :: String -> GHC.Name -> Html -> Html
+externalNameHyperlink' url name content =
+    Html.anchor content ! [ Html.href $ href ]
+  where
+    mdl = GHC.nameModule name
+    href = spliceURL Nothing (Just mdl) (Just name) Nothing url
+
+externalModHyperlink :: GHC.ModuleName -> Html -> Html
+externalModHyperlink _ = id -- TODO
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index 78c78aca..047d9fd0 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -29,7 +29,7 @@ module Haddock.Utils (
   moduleNameUrl, moduleNameUrl', moduleUrl,
   nameAnchorId,
   makeAnchorId,
-  defaultModuleSourceUrl,
+  defaultModuleSourceUrl, defaultNameSourceUrl,
 
   -- * Miscellaneous utilities
   getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr,
@@ -281,6 +281,9 @@ makeAnchorId (f:r) = escape isAlpha f ++ concatMap (escape isLegal) r
 defaultModuleSourceUrl :: String
 defaultModuleSourceUrl = "src/%{MODULE}.html"
 
+defaultNameSourceUrl :: String
+defaultNameSourceUrl = defaultModuleSourceUrl ++ "#%{NAME}"
+
 
 -------------------------------------------------------------------------------
 -- * Files we need to copy from our $libdir
-- 
cgit v1.2.3


From ab070206d67748232995a262b533957a5a7b9315 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Sat, 27 Jun 2015 18:03:56 +0200
Subject: Rewrite source generation to fixed links and directory structure.

---
 haddock-api/src/Haddock.hs                         | 11 +++--
 haddock-api/src/Haddock/Backends/Hyperlinker.hs    | 29 +++++-------
 .../src/Haddock/Backends/Hyperlinker/Renderer.hs   | 52 +++++++++-------------
 .../src/Haddock/Backends/Hyperlinker/Utils.hs      | 48 +++++++++++++++-----
 haddock-api/src/Haddock/Backends/Xhtml/Utils.hs    | 14 +++---
 haddock-api/src/Haddock/Utils.hs                   |  8 ----
 6 files changed, 85 insertions(+), 77 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 3105edf5..d596c075 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -260,14 +260,13 @@ render dflags flags qual ifaces installedIfaces srcMap = do
     (srcBase, srcModule, srcEntity, srcLEntity) = sourceUrls flags
 
     srcModule'
-      | isJust srcModule = srcModule
-      | Flag_HyperlinkedSource `elem` flags = Just defaultModuleSourceUrl
-      | otherwise = Nothing
+      | Flag_HyperlinkedSource `elem` flags = Just hypSrcModuleUrlFormat
+      | otherwise = srcModule
 
     srcMap'
-      | Just srcNameUrl <- srcEntity = Map.insert pkgKey srcNameUrl srcMap
       | Flag_HyperlinkedSource `elem` flags =
-          Map.insert pkgKey defaultNameSourceUrl srcMap
+          Map.insert pkgKey hypSrcModuleNameUrlFormat srcMap
+      | Just srcNameUrl <- srcEntity = Map.insert pkgKey srcNameUrl srcMap
       | otherwise = srcMap
 
     -- TODO: Get these from the interface files as with srcMap
@@ -322,7 +321,7 @@ render dflags flags qual ifaces installedIfaces srcMap = do
                   libDir
 
   when (Flag_HyperlinkedSource `elem` flags) $ do
-    ppHyperlinkedSource odir libDir opt_source_css sourceUrls' visibleIfaces
+    ppHyperlinkedSource odir libDir opt_source_css visibleIfaces
 
 -- | From GHC 7.10, this function has a potential to crash with a
 -- nasty message such as @expectJust getPackageDetails@ because
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
index 6c66e0c6..f197eaa3 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
@@ -1,8 +1,9 @@
-module Haddock.Backends.Hyperlinker (ppHyperlinkedSource) where
+module Haddock.Backends.Hyperlinker
+    ( ppHyperlinkedSource
+    , module Haddock.Backends.Hyperlinker.Utils
+    ) where
 
 import Haddock.Types
-import Haddock.Backends.Xhtml.Types
-import Haddock.Backends.Xhtml.Utils
 import Haddock.Backends.Hyperlinker.Renderer
 import Haddock.Backends.Hyperlinker.Utils
 
@@ -14,36 +15,30 @@ import System.FilePath
 
 ppHyperlinkedSource :: FilePath -> FilePath
                     -> Maybe FilePath
-                    -> SourceURLs
                     -> [Interface]
                     -> IO ()
-ppHyperlinkedSource outdir libdir mstyle urls ifaces = do
+ppHyperlinkedSource outdir libdir mstyle ifaces = do
     createDirectoryIfMissing True srcdir
     let cssFile = fromMaybe (defaultCssFile libdir) mstyle
     copyFile cssFile $ srcdir </> srcCssFile
     copyFile (libdir </> "html" </> highlightScript) $
         srcdir </> highlightScript
-    mapM_ (ppHyperlinkedModuleSource outdir urls) ifaces
+    mapM_ (ppHyperlinkedModuleSource srcdir) ifaces
   where
-    srcdir = srcPath outdir urls
+    srcdir = outdir </> hypSrcDir
 
-ppHyperlinkedModuleSource :: FilePath -> SourceURLs -> Interface -> IO ()
-ppHyperlinkedModuleSource outdir urls iface = case ifaceTokenizedSrc iface of
+ppHyperlinkedModuleSource :: FilePath -> Interface -> IO ()
+ppHyperlinkedModuleSource srcdir iface = case ifaceTokenizedSrc iface of
     Just tokens ->
-        writeFile path $ showHtml . render mCssFile mJsFile urls $ tokens
+        writeFile path $ showHtml . render mCssFile mJsFile $ tokens
     Nothing -> return ()
   where
     mCssFile = Just $ srcCssFile
     mJsFile = Just $ highlightScript
-    srcFile = spliceURL Nothing (Just $ ifaceMod iface) Nothing Nothing $
-        srcModUrl urls
-    path = outdir </> srcFile
-
-srcPath :: FilePath -> SourceURLs -> FilePath
-srcPath outdir urls = outdir </> takeDirectory (srcModUrl urls)
+    path = srcdir </> hypSrcModuleFile (ifaceMod iface)
 
 srcCssFile :: FilePath
-srcCssFile = "srcstyle.css"
+srcCssFile = "style.css"
 
 highlightScript :: FilePath
 highlightScript = "highlight.js"
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index 2df62938..d8ea5ec7 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -3,15 +3,12 @@ module Haddock.Backends.Hyperlinker.Renderer (render) where
 import Haddock.Backends.Hyperlinker.Parser
 import Haddock.Backends.Hyperlinker.Ast
 import Haddock.Backends.Hyperlinker.Utils
-import Haddock.Backends.Xhtml.Types
-import Haddock.Backends.Xhtml.Utils
 
 import qualified GHC
 import qualified Name as GHC
 import qualified Unique as GHC
 
 import Data.List
-import qualified Data.Map as Map
 import Data.Maybe
 import Data.Monoid
 
@@ -20,11 +17,11 @@ import qualified Text.XHtml as Html
 
 type StyleClass = String
 
-render :: Maybe FilePath -> Maybe FilePath -> SourceURLs -> [RichToken] -> Html
-render mcss mjs urls tokens = header mcss mjs <> body urls tokens
+render :: Maybe FilePath -> Maybe FilePath -> [RichToken] -> Html
+render mcss mjs tokens = header mcss mjs <> body tokens
 
-body :: SourceURLs -> [RichToken] -> Html
-body urls = Html.body . Html.pre . mconcat . map (richToken urls)
+body :: [RichToken] -> Html
+body = Html.body . Html.pre . mconcat . map richToken
 
 header :: Maybe FilePath -> Maybe FilePath -> Html
 header mcss mjs
@@ -39,18 +36,18 @@ header mcss mjs =
         , Html.href cssFile
         ]
     js Nothing = Html.noHtml
-    js (Just jsFile) = Html.script Html.noHtml !
+    js (Just scriptFile) = Html.script Html.noHtml !
         [ Html.thetype "text/javascript"
-        , Html.src jsFile
+        , Html.src scriptFile
         ]
 
-richToken :: SourceURLs -> RichToken -> Html
-richToken _ (RichToken tok Nothing) =
+richToken :: RichToken -> Html
+richToken (RichToken tok Nothing) =
     tokenSpan tok ! attrs
   where
     attrs = [ multiclass . tokenStyle . tkType $ tok ]
-richToken urls (RichToken tok (Just det)) =
-    externalAnchor det . internalAnchor det . hyperlink urls det $ content
+richToken (RichToken tok (Just det)) =
+    externalAnchor det . internalAnchor det . hyperlink det $ content
   where
     content = tokenSpan tok ! [ multiclass style]
     style = (tokenStyle . tkType) tok ++ richTokenStyle det
@@ -92,37 +89,30 @@ internalAnchor (RtkBind name) content =
 internalAnchor _ content = content
 
 externalAnchorIdent :: GHC.Name -> String
-externalAnchorIdent = GHC.occNameString . GHC.nameOccName
+externalAnchorIdent = hypSrcNameUrl
 
 internalAnchorIdent :: GHC.Name -> String
 internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique
 
-hyperlink :: SourceURLs -> TokenDetails -> Html -> Html
-hyperlink urls details = case rtkName details of
+hyperlink :: TokenDetails -> Html -> Html
+hyperlink details = case rtkName details of
     Left name ->
         if GHC.isInternalName name
         then internalHyperlink name
-        else externalNameHyperlink urls name
+        else externalNameHyperlink name
     Right name -> externalModHyperlink name
 
 internalHyperlink :: GHC.Name -> Html -> Html
 internalHyperlink name content =
     Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ]
 
-externalNameHyperlink :: SourceURLs -> GHC.Name -> Html -> Html
-externalNameHyperlink urls name =
-    case Map.lookup key $ srcNameUrlMap urls of
-        Just url -> externalNameHyperlink' url name
-        Nothing -> id
+externalNameHyperlink :: GHC.Name -> Html -> Html
+externalNameHyperlink name content =
+    Html.anchor content ! [ Html.href href ]
   where
-    key = GHC.modulePackageKey . GHC.nameModule $ name
-
-externalNameHyperlink' :: String -> GHC.Name -> Html -> Html
-externalNameHyperlink' url name content =
-    Html.anchor content ! [ Html.href $ href ]
-  where
-    mdl = GHC.nameModule name
-    href = spliceURL Nothing (Just mdl) (Just name) Nothing url
+    href = hypSrcModuleNameUrl (GHC.nameModule name) name
 
 externalModHyperlink :: GHC.ModuleName -> Html -> Html
-externalModHyperlink _ = id -- TODO
+externalModHyperlink mdl content =
+    Html.anchor content ! [ Html.href $ hypSrcModuleUrl' mdl ]
+
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
index 25ed942b..9ba8446d 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
@@ -1,18 +1,46 @@
 module Haddock.Backends.Hyperlinker.Utils
-    ( srcModUrl
-    , srcNameUrlMap
+    ( hypSrcDir, hypSrcModuleFile, hypSrcModuleFile'
+    , hypSrcModuleUrl, hypSrcModuleUrl', hypSrcNameUrl, hypSrcModuleNameUrl
+    , hypSrcModuleUrlFormat, hypSrcModuleNameUrlFormat,
     ) where
 
-import Haddock.Utils
-import Haddock.Backends.Xhtml.Types
+import Haddock.Backends.Xhtml.Utils
 
 import GHC
+import System.FilePath.Posix ((</>))
 
-import Data.Maybe
-import Data.Map (Map)
 
-srcModUrl :: SourceURLs -> String
-srcModUrl (_, mModUrl, _, _) = fromMaybe defaultModuleSourceUrl mModUrl
+hypSrcDir :: FilePath
+hypSrcDir = "src"
 
-srcNameUrlMap :: SourceURLs -> Map PackageKey FilePath
-srcNameUrlMap (_, _, nameUrlMap, _) = nameUrlMap
+hypSrcModuleFile :: Module -> FilePath
+hypSrcModuleFile = hypSrcModuleFile' . moduleName
+
+hypSrcModuleFile' :: ModuleName -> FilePath
+hypSrcModuleFile' mdl = spliceURL'
+    Nothing (Just mdl) Nothing Nothing moduleFormat
+
+hypSrcModuleUrl :: Module -> String
+hypSrcModuleUrl = hypSrcModuleFile
+
+hypSrcModuleUrl' :: ModuleName -> String
+hypSrcModuleUrl' = hypSrcModuleFile'
+
+hypSrcNameUrl :: Name -> String
+hypSrcNameUrl name = spliceURL
+    Nothing Nothing (Just name) Nothing nameFormat
+
+hypSrcModuleNameUrl :: Module -> Name -> String
+hypSrcModuleNameUrl mdl name = hypSrcModuleUrl mdl ++ "#" ++ hypSrcNameUrl name
+
+hypSrcModuleUrlFormat :: String
+hypSrcModuleUrlFormat = hypSrcDir </> moduleFormat
+
+hypSrcModuleNameUrlFormat :: String
+hypSrcModuleNameUrlFormat = hypSrcModuleUrlFormat ++ "#" ++ nameFormat
+
+moduleFormat :: String
+moduleFormat = "%{MODULE}.html"
+
+nameFormat :: String
+nameFormat = "%{NAME}"
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
index cbcbbd6d..36ecf863 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
@@ -14,7 +14,7 @@ module Haddock.Backends.Xhtml.Utils (
   renderToString,
 
   namedAnchor, linkedAnchor,
-  spliceURL,
+  spliceURL, spliceURL',
   groupId,
 
   (<+>), (<=>), char,
@@ -29,7 +29,6 @@ module Haddock.Backends.Xhtml.Utils (
 ) where
 
 
-import Haddock.GhcUtils
 import Haddock.Utils
 
 import Data.Maybe
@@ -38,18 +37,23 @@ import Text.XHtml hiding ( name, title, p, quote )
 import qualified Text.XHtml as XHtml
 
 import GHC      ( SrcSpan(..), srcSpanStartLine, Name )
-import Module   ( Module )
+import Module   ( Module, ModuleName, moduleName, moduleNameString )
 import Name     ( getOccString, nameOccName, isValOcc )
 
 
 spliceURL :: Maybe FilePath -> Maybe Module -> Maybe GHC.Name ->
              Maybe SrcSpan -> String -> String
-spliceURL maybe_file maybe_mod maybe_name maybe_loc = run
+spliceURL mfile mmod = spliceURL' mfile (moduleName <$> mmod)
+
+
+spliceURL' :: Maybe FilePath -> Maybe ModuleName -> Maybe GHC.Name ->
+              Maybe SrcSpan -> String -> String
+spliceURL' maybe_file maybe_mod maybe_name maybe_loc = run
  where
   file = fromMaybe "" maybe_file
   mdl = case maybe_mod of
           Nothing           -> ""
-          Just m -> moduleString m
+          Just m -> moduleNameString m
 
   (name, kind) =
     case maybe_name of
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index 047d9fd0..4fed3a1e 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -29,7 +29,6 @@ module Haddock.Utils (
   moduleNameUrl, moduleNameUrl', moduleUrl,
   nameAnchorId,
   makeAnchorId,
-  defaultModuleSourceUrl, defaultNameSourceUrl,
 
   -- * Miscellaneous utilities
   getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr,
@@ -278,13 +277,6 @@ makeAnchorId (f:r) = escape isAlpha f ++ concatMap (escape isLegal) r
        -- NB: '-' is legal in IDs, but we use it as the escape char
 
 
-defaultModuleSourceUrl :: String
-defaultModuleSourceUrl = "src/%{MODULE}.html"
-
-defaultNameSourceUrl :: String
-defaultNameSourceUrl = defaultModuleSourceUrl ++ "#%{NAME}"
-
-
 -------------------------------------------------------------------------------
 -- * Files we need to copy from our $libdir
 -------------------------------------------------------------------------------
-- 
cgit v1.2.3


From a6eb5a19b13bc4dfa79d0e55e5992dfa403aa3c3 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Sun, 28 Jun 2015 21:00:55 +0200
Subject: Add basic support for cross-package hyperlink generation.

---
 haddock-api/src/Haddock.hs                         |  2 +-
 haddock-api/src/Haddock/Backends/Hyperlinker.hs    | 25 ++++++-------
 .../src/Haddock/Backends/Hyperlinker/Renderer.hs   | 42 +++++++++++++---------
 3 files changed, 40 insertions(+), 29 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index d596c075..caaa1eef 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -321,7 +321,7 @@ render dflags flags qual ifaces installedIfaces srcMap = do
                   libDir
 
   when (Flag_HyperlinkedSource `elem` flags) $ do
-    ppHyperlinkedSource odir libDir opt_source_css visibleIfaces
+    ppHyperlinkedSource odir libDir opt_source_css pkgKey srcMap visibleIfaces
 
 -- | From GHC 7.10, this function has a potential to crash with a
 -- nasty message such as @expectJust getPackageDetails@ because
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
index f197eaa3..f2caa2c1 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
@@ -8,33 +8,34 @@ import Haddock.Backends.Hyperlinker.Renderer
 import Haddock.Backends.Hyperlinker.Utils
 
 import Text.XHtml hiding ((</>))
+import GHC
 
 import Data.Maybe
 import System.Directory
 import System.FilePath
 
-ppHyperlinkedSource :: FilePath -> FilePath
-                    -> Maybe FilePath
-                    -> [Interface]
+ppHyperlinkedSource :: FilePath -> FilePath -> Maybe FilePath
+                    -> PackageKey -> SrcMap -> [Interface]
                     -> IO ()
-ppHyperlinkedSource outdir libdir mstyle ifaces = do
+ppHyperlinkedSource outdir libdir mstyle pkg srcs ifaces = do
     createDirectoryIfMissing True srcdir
     let cssFile = fromMaybe (defaultCssFile libdir) mstyle
     copyFile cssFile $ srcdir </> srcCssFile
     copyFile (libdir </> "html" </> highlightScript) $
         srcdir </> highlightScript
-    mapM_ (ppHyperlinkedModuleSource srcdir) ifaces
+    mapM_ (ppHyperlinkedModuleSource srcdir pkg srcs) ifaces
   where
     srcdir = outdir </> hypSrcDir
 
-ppHyperlinkedModuleSource :: FilePath -> Interface -> IO ()
-ppHyperlinkedModuleSource srcdir iface = case ifaceTokenizedSrc iface of
-    Just tokens ->
-        writeFile path $ showHtml . render mCssFile mJsFile $ tokens
-    Nothing -> return ()
+ppHyperlinkedModuleSource :: FilePath
+                          -> PackageKey -> SrcMap -> Interface
+                          -> IO ()
+ppHyperlinkedModuleSource srcdir pkg srcs iface =
+    case ifaceTokenizedSrc iface of
+        Just tokens -> writeFile path . showHtml . render' $ tokens
+        Nothing -> return ()
   where
-    mCssFile = Just $ srcCssFile
-    mJsFile = Just $ highlightScript
+    render' = render (Just srcCssFile) (Just highlightScript) pkg srcs
     path = srcdir </> hypSrcModuleFile (ifaceMod iface)
 
 srcCssFile :: FilePath
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index d8ea5ec7..b05a5b8a 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -1,5 +1,6 @@
 module Haddock.Backends.Hyperlinker.Renderer (render) where
 
+import Haddock.Types
 import Haddock.Backends.Hyperlinker.Parser
 import Haddock.Backends.Hyperlinker.Ast
 import Haddock.Backends.Hyperlinker.Utils
@@ -8,20 +9,25 @@ import qualified GHC
 import qualified Name as GHC
 import qualified Unique as GHC
 
+import System.FilePath.Posix ((</>))
+
 import Data.List
 import Data.Maybe
 import Data.Monoid
+import qualified Data.Map as Map
 
 import Text.XHtml (Html, HtmlAttr, (!))
 import qualified Text.XHtml as Html
 
 type StyleClass = String
 
-render :: Maybe FilePath -> Maybe FilePath -> [RichToken] -> Html
-render mcss mjs tokens = header mcss mjs <> body tokens
+render :: Maybe FilePath -> Maybe FilePath
+       -> GHC.PackageKey -> SrcMap -> [RichToken]
+       -> Html
+render mcss mjs pkg srcs tokens = header mcss mjs <> body pkg srcs tokens
 
-body :: [RichToken] -> Html
-body = Html.body . Html.pre . mconcat . map richToken
+body :: GHC.PackageKey -> SrcMap -> [RichToken] -> Html
+body pkg srcs = Html.body . Html.pre . mconcat . map (richToken pkg srcs)
 
 header :: Maybe FilePath -> Maybe FilePath -> Html
 header mcss mjs
@@ -41,13 +47,13 @@ header mcss mjs =
         , Html.src scriptFile
         ]
 
-richToken :: RichToken -> Html
-richToken (RichToken tok Nothing) =
+richToken :: GHC.PackageKey -> SrcMap -> RichToken -> Html
+richToken _ _ (RichToken tok Nothing) =
     tokenSpan tok ! attrs
   where
     attrs = [ multiclass . tokenStyle . tkType $ tok ]
-richToken (RichToken tok (Just det)) =
-    externalAnchor det . internalAnchor det . hyperlink det $ content
+richToken pkg srcs (RichToken tok (Just det)) =
+    externalAnchor det . internalAnchor det . hyperlink pkg srcs det $ content
   where
     content = tokenSpan tok ! [ multiclass style]
     style = (tokenStyle . tkType) tok ++ richTokenStyle det
@@ -94,25 +100,29 @@ externalAnchorIdent = hypSrcNameUrl
 internalAnchorIdent :: GHC.Name -> String
 internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique
 
-hyperlink :: TokenDetails -> Html -> Html
-hyperlink details = case rtkName details of
+hyperlink :: GHC.PackageKey -> SrcMap -> TokenDetails -> Html -> Html
+hyperlink pkg srcs details = case rtkName details of
     Left name ->
         if GHC.isInternalName name
         then internalHyperlink name
-        else externalNameHyperlink name
+        else externalNameHyperlink pkg srcs name
     Right name -> externalModHyperlink name
 
 internalHyperlink :: GHC.Name -> Html -> Html
 internalHyperlink name content =
     Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ]
 
-externalNameHyperlink :: GHC.Name -> Html -> Html
-externalNameHyperlink name content =
-    Html.anchor content ! [ Html.href href ]
+externalNameHyperlink :: GHC.PackageKey -> SrcMap -> GHC.Name -> Html -> Html
+externalNameHyperlink pkg srcs name content
+    | namePkg == pkg = Html.anchor content !
+        [ Html.href $ hypSrcModuleNameUrl mdl name ]
+    | Just path <- Map.lookup namePkg srcs = Html.anchor content !
+        [ Html.href $ path </> hypSrcModuleNameUrl mdl name ]
+    | otherwise = content
   where
-    href = hypSrcModuleNameUrl (GHC.nameModule name) name
+    mdl = GHC.nameModule name
+    namePkg = GHC.modulePackageKey mdl
 
 externalModHyperlink :: GHC.ModuleName -> Html -> Html
 externalModHyperlink mdl content =
     Html.anchor content ! [ Html.href $ hypSrcModuleUrl' mdl ]
-
-- 
cgit v1.2.3


From 98cb99c2398a2e2b4467da0a1755d24422384f14 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Sun, 28 Jun 2015 21:33:03 +0200
Subject: Disable generating hyperlinks for module references.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs | 11 +++++++++--
 1 file changed, 9 insertions(+), 2 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index b05a5b8a..89d9b60d 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -123,6 +123,13 @@ externalNameHyperlink pkg srcs name content
     mdl = GHC.nameModule name
     namePkg = GHC.modulePackageKey mdl
 
+-- TODO: Implement module hyperlinks.
+--
+-- Unfortunately, 'ModuleName' is not enough to provide viable cross-package
+-- hyperlink. And the problem is that GHC AST does not have other information
+-- on imported modules, so for the time being, we do not provide such reference
+-- either.
 externalModHyperlink :: GHC.ModuleName -> Html -> Html
-externalModHyperlink mdl content =
-    Html.anchor content ! [ Html.href $ hypSrcModuleUrl' mdl ]
+externalModHyperlink _ content =
+    content
+    --Html.anchor content ! [ Html.href $ hypSrcModuleUrl' mdl ]
-- 
cgit v1.2.3


From 4a6b6c18dbb6542b64f13e4f51cc0447df15a175 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Sun, 28 Jun 2015 21:45:29 +0200
Subject: Make Haddock generate source for all interfaces (also hidden ones).

---
 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 caaa1eef..c76966fc 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -321,7 +321,7 @@ render dflags flags qual ifaces installedIfaces srcMap = do
                   libDir
 
   when (Flag_HyperlinkedSource `elem` flags) $ do
-    ppHyperlinkedSource odir libDir opt_source_css pkgKey srcMap visibleIfaces
+    ppHyperlinkedSource odir libDir opt_source_css pkgKey srcMap ifaces
 
 -- | From GHC 7.10, this function has a potential to crash with a
 -- nasty message such as @expectJust getPackageDetails@ because
-- 
cgit v1.2.3


From 311b3cc529097ef83a8212439dafcabb86534c62 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Sun, 28 Jun 2015 22:28:00 +0200
Subject: Prevent source parser from throwing exception when lexing fails.

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

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index 6e195dba..bab5ba0a 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -63,7 +63,9 @@ chunk str@(c:_)
 chunk str
     | "--" `isPrefixOf` str = chunk' $ spanToNewline str
     | "{-" `isPrefixOf` str = chunk' $ chunkComment 0 str
-    | otherwise = chunk' $ head $ lex str
+    | otherwise = case lex str of
+        (tok:_) -> chunk' tok
+        [] -> [str]
   where
     chunk' (c, rest) = c:(chunk rest)
 
-- 
cgit v1.2.3


From 5a86381db3d73b4b68fdaae5c150a84e91e80c09 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Mon, 29 Jun 2015 16:10:03 +0200
Subject: Make hyperlinker generate correct anchors for data constructors.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 13 +++++++++----
 1 file changed, 9 insertions(+), 4 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 275f10e9..c32bb722 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -107,17 +107,22 @@ binds =
 -- | Obtain details map for top-level declarations.
 decls :: GHC.RenamedSource -> DetailsMap
 decls (group, _, _, _) = concatMap ($ group)
-    [ map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds
+    [ concat . map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds
     , everything (<|>) fun
     ]
   where
-    typ (GHC.L _ t) =
-        let (GHC.L sspan name) = GHC.tcdLName t
-        in (sspan, RtkDecl name)
+    typ (GHC.L _ t) = case t of
+        GHC.DataDecl (GHC.L sspan name) _ defn _ ->
+            [(sspan, RtkDecl name)] ++ concatMap con (GHC.dd_cons defn)
+        _ ->
+            let (GHC.L sspan name) = GHC.tcdLName t
+            in pure (sspan, RtkDecl name)
     fun term = case cast term of
         (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name))
             | GHC.isExternalName name -> pure (sspan, RtkDecl name)
         _ -> empty
+    con (GHC.L _ t) = flip map (GHC.con_names t) $
+        \(GHC.L sspan name) -> (sspan, RtkDecl name)
 
 -- | Obtain details map for import declarations.
 --
-- 
cgit v1.2.3


From 46b1520fcc8ef56825bd42ecf1c1fa8ec899ee58 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Mon, 29 Jun 2015 17:33:59 +0200
Subject: Make hyperlinker generate anchors for record field declarations.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 16 +++++++++-------
 1 file changed, 9 insertions(+), 7 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 c32bb722..5efcd2ed 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -112,17 +112,19 @@ decls (group, _, _, _) = concatMap ($ group)
     ]
   where
     typ (GHC.L _ t) = case t of
-        GHC.DataDecl (GHC.L sspan name) _ defn _ ->
-            [(sspan, RtkDecl name)] ++ concatMap con (GHC.dd_cons defn)
-        _ ->
-            let (GHC.L sspan name) = GHC.tcdLName t
-            in pure (sspan, RtkDecl name)
+        GHC.DataDecl name _ defn _ ->
+            [decl name] ++ concatMap con (GHC.dd_cons defn)
+        _ -> pure . decl $ GHC.tcdLName t
     fun term = case cast term of
         (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name))
             | GHC.isExternalName name -> pure (sspan, RtkDecl name)
         _ -> empty
-    con (GHC.L _ t) = flip map (GHC.con_names t) $
-        \(GHC.L sspan name) -> (sspan, RtkDecl name)
+    con (GHC.L _ t) =
+        map decl (GHC.con_names t) ++ everything (<|>) fld t
+    fld term = case cast term of
+        Just field -> map decl $ GHC.cd_fld_names field
+        Nothing -> empty
+    decl (GHC.L sspan name) = (sspan, RtkDecl name)
 
 -- | Obtain details map for import declarations.
 --
-- 
cgit v1.2.3


From d6cfd266b30066a5452514b26e50b740104a982b Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Mon, 29 Jun 2015 23:00:54 +0200
Subject: Add support for hyperlinking constructor names in patters.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 2 ++
 1 file changed, 2 insertions(+)

(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 5efcd2ed..fd3f2f1e 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -102,6 +102,8 @@ binds =
     pat term = case cast term of
         (Just (GHC.L sspan (GHC.VarPat name))) ->
             pure (sspan, RtkBind name)
+        (Just (GHC.L _ (GHC.ConPatIn (GHC.L sspan name) _))) ->
+            pure (sspan, RtkVar name)
         _ -> empty
 
 -- | Obtain details map for top-level declarations.
-- 
cgit v1.2.3


From a1d3cb1d86340cd670e50f88e1cb8bf4a4e64f7b Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Mon, 29 Jun 2015 23:15:26 +0200
Subject: Add support for hyperlinking field names in record patterns.

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

(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 fd3f2f1e..3b0e0f44 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -102,7 +102,11 @@ binds =
     pat term = case cast term of
         (Just (GHC.L sspan (GHC.VarPat name))) ->
             pure (sspan, RtkBind name)
-        (Just (GHC.L _ (GHC.ConPatIn (GHC.L sspan name) _))) ->
+        (Just (GHC.L _ (GHC.ConPatIn (GHC.L sspan name) recs))) ->
+            [(sspan, RtkVar name)] ++ everything (<|>) rec recs
+        _ -> empty
+    rec term = case cast term of
+        (Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LPat GHC.Name) _)) ->
             pure (sspan, RtkVar name)
         _ -> empty
 
-- 
cgit v1.2.3


From 7d269444ea9c55a2b364ead45fe06d435fa078b2 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Mon, 29 Jun 2015 23:41:10 +0200
Subject: Add support for hyperlinking field names in record expressions.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 8 +++++++-
 1 file changed, 7 insertions(+), 1 deletion(-)

(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 3b0e0f44..c41b5e5f 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -69,11 +69,17 @@ enrichToken _ _ = Nothing
 -- | Obtain details map for variables ("normally" used identifiers).
 variables :: GHC.RenamedSource -> DetailsMap
 variables =
-    everything (<|>) var
+    everything (<|>) (var `combine` rec)
   where
     var term = case cast term of
         (Just (GHC.L sspan (GHC.HsVar name))) ->
             pure (sspan, RtkVar name)
+        (Just (GHC.L _ (GHC.RecordCon (GHC.L sspan name) _ _))) ->
+            pure (sspan, RtkVar name)
+        _ -> empty
+    rec term = case cast term of
+        Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LHsExpr GHC.Name) _) ->
+            pure (sspan, RtkVar name)
         _ -> empty
 
 -- | Obtain details map for types.
-- 
cgit v1.2.3


From 6bebd572bc673d10ed68096f935cdc5a9d1839b5 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Tue, 30 Jun 2015 21:58:08 +0200
Subject: Make hyperlinker respect pretty-printer flag and add documentation.

---
 haddock-api/src/Haddock.hs                      |  2 +-
 haddock-api/src/Haddock/Backends/Hyperlinker.hs | 30 +++++++++++++++++++------
 2 files changed, 24 insertions(+), 8 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index c76966fc..02e19531 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -321,7 +321,7 @@ render dflags flags qual ifaces installedIfaces srcMap = do
                   libDir
 
   when (Flag_HyperlinkedSource `elem` flags) $ do
-    ppHyperlinkedSource odir libDir opt_source_css pkgKey srcMap ifaces
+    ppHyperlinkedSource odir libDir opt_source_css pretty pkgKey srcMap ifaces
 
 -- | From GHC 7.10, this function has a potential to crash with a
 -- nasty message such as @expectJust getPackageDetails@ because
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
index f2caa2c1..1fadef49 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
@@ -14,35 +14,51 @@ import Data.Maybe
 import System.Directory
 import System.FilePath
 
-ppHyperlinkedSource :: FilePath -> FilePath -> Maybe FilePath
-                    -> PackageKey -> SrcMap -> [Interface]
+
+-- | Generate hyperlinked source for given interfaces.
+--
+-- Note that list of interfaces should also contain interfaces normally hidden
+-- when generating documentation. Otherwise this could lead to dead links in
+-- produced source.
+ppHyperlinkedSource :: FilePath -- ^ Output directory
+                    -> FilePath -- ^ Resource directory
+                    -> Maybe FilePath -- ^ Custom CSS file path
+                    -> Bool -- ^ Flag indicating whether to pretty-print HTML
+                    -> PackageKey -- ^ Package for which we create source
+                    -> SrcMap -- ^ Paths to external sources
+                    -> [Interface] -- ^ Interfaces for which we create source
                     -> IO ()
-ppHyperlinkedSource outdir libdir mstyle pkg srcs ifaces = do
+ppHyperlinkedSource outdir libdir mstyle pretty pkg srcs ifaces = do
     createDirectoryIfMissing True srcdir
     let cssFile = fromMaybe (defaultCssFile libdir) mstyle
     copyFile cssFile $ srcdir </> srcCssFile
     copyFile (libdir </> "html" </> highlightScript) $
         srcdir </> highlightScript
-    mapM_ (ppHyperlinkedModuleSource srcdir pkg srcs) ifaces
+    mapM_ (ppHyperlinkedModuleSource srcdir pretty pkg srcs) ifaces
   where
     srcdir = outdir </> hypSrcDir
 
-ppHyperlinkedModuleSource :: FilePath
+-- | Generate hyperlinked source for particular interface.
+ppHyperlinkedModuleSource :: FilePath -> Bool
                           -> PackageKey -> SrcMap -> Interface
                           -> IO ()
-ppHyperlinkedModuleSource srcdir pkg srcs iface =
+ppHyperlinkedModuleSource srcdir pretty pkg srcs iface =
     case ifaceTokenizedSrc iface of
-        Just tokens -> writeFile path . showHtml . render' $ tokens
+        Just tokens -> writeFile path . html . render' $ tokens
         Nothing -> return ()
   where
     render' = render (Just srcCssFile) (Just highlightScript) pkg srcs
+    html = if pretty then renderHtml else showHtml
     path = srcdir </> hypSrcModuleFile (ifaceMod iface)
 
+-- | Name of CSS file in output directory.
 srcCssFile :: FilePath
 srcCssFile = "style.css"
 
+-- | Name of highlight script in output and resource directory.
 highlightScript :: FilePath
 highlightScript = "highlight.js"
 
+-- | Path to default CSS file.
 defaultCssFile :: FilePath -> FilePath
 defaultCssFile libdir = libdir </> "html" </> "solarized.css"
-- 
cgit v1.2.3


From f3d1f3cbd6e99f5d477a78e05c13b65b9e8b3fae Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Sun, 28 Jun 2015 00:49:17 +0200
Subject: Add basic tests related to comment parsing.

---
 .../src/Haddock/Backends/Hyperlinker/Parser.hs     |  2 +-
 .../Haddock/Backends/Hyperlinker/ParserSpec.hs     | 37 +++++++++++++++++++++-
 2 files changed, 37 insertions(+), 2 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index bab5ba0a..019075a1 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -38,7 +38,7 @@ data TokenType
     | TkCpp
     | TkPragma
     | TkUnknown
-    deriving (Eq)
+    deriving (Show, Eq)
 
 -- | Turn source code string into a stream of more descriptive tokens.
 --
diff --git a/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs b/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs
index c85fa47e..d5964224 100644
--- a/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs
+++ b/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs
@@ -9,9 +9,44 @@ import Haddock.Backends.Hyperlinker.Parser
 main :: IO ()
 main = hspec spec
 
+
 spec :: Spec
 spec = do
     describe "parse" parseSpec
 
+
 parseSpec :: Spec
-parseSpec = return ()
+parseSpec = do
+
+    context "when parsing single-line comments" $ do
+
+        it "should ignore content until the end of line" $
+            "-- some very simple comment\nidentifier"
+            `shouldParseTo`
+            [TkComment, TkSpace, TkIdentifier]
+
+        it "should allow endline escaping" $
+            "-- first line\\\nsecond line\\\nand another one"
+            `shouldParseTo`
+            [TkComment]
+
+    context "when parsing multi-line comments" $ do
+
+        it "should support nested comments" $
+            "{- comment {- nested -} still comment -} {- next comment -}"
+            `shouldParseTo`
+            [TkComment, TkSpace, TkComment]
+
+        it "should distinguish compiler pragma" $
+            "{- comment -}{-# LANGUAGE GADTs #-}{- comment -}"
+            `shouldParseTo`
+            [TkComment, TkPragma, TkComment]
+
+    it "should recognize preprocessor directives" $ do
+        "\n#define foo bar" `shouldParseTo` [TkSpace, TkCpp]
+        "x # y" `shouldParseTo`
+            [TkIdentifier, TkSpace, TkCpp, TkSpace,TkIdentifier]
+
+
+shouldParseTo :: String -> [TokenType] -> Expectation
+str `shouldParseTo` tokens = map tkType (parse str) `shouldBe` tokens
-- 
cgit v1.2.3


From b91ee2f4f0869d1c1076813019ce858c53738042 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Wed, 1 Jul 2015 18:32:19 +0200
Subject: Add support for hyperlinking synonyms in patterns.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 2 ++
 1 file changed, 2 insertions(+)

(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 c41b5e5f..8777e26d 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -110,6 +110,8 @@ binds =
             pure (sspan, RtkBind name)
         (Just (GHC.L _ (GHC.ConPatIn (GHC.L sspan name) recs))) ->
             [(sspan, RtkVar name)] ++ everything (<|>) rec recs
+        (Just (GHC.L _ (GHC.AsPat (GHC.L sspan name) _))) ->
+            pure (sspan, RtkBind name)
         _ -> empty
     rec term = case cast term of
         (Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LPat GHC.Name) _)) ->
-- 
cgit v1.2.3


From dd781d18eca0d8c28350093d78926d4a9b474827 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Wed, 1 Jul 2015 19:06:04 +0200
Subject: Add support for hyperlinking universally quantified type variables.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 8 +++++++-
 1 file changed, 7 insertions(+), 1 deletion(-)

(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 8777e26d..79e31db7 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -99,7 +99,7 @@ types =
 -- clauses).
 binds :: GHC.RenamedSource -> DetailsMap
 binds =
-    everything (<|>) (fun `combine` pat)
+    everything (<|>) (fun `combine` pat `combine` tvar)
   where
     fun term = case cast term of
         (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name)) ->
@@ -117,6 +117,12 @@ binds =
         (Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LPat GHC.Name) _)) ->
             pure (sspan, RtkVar name)
         _ -> empty
+    tvar term = case cast term of
+        (Just (GHC.L sspan (GHC.UserTyVar name))) ->
+            pure (sspan, RtkBind name)
+        (Just (GHC.L _ (GHC.KindedTyVar (GHC.L sspan name) _))) ->
+            pure (sspan, RtkBind name)
+        _ -> empty
 
 -- | Obtain details map for top-level declarations.
 decls :: GHC.RenamedSource -> DetailsMap
-- 
cgit v1.2.3


From 980664b29a588eef44d8048d4beedce4d2a96b09 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Wed, 1 Jul 2015 21:01:42 +0200
Subject: Document some functions in XHTML utlity module.

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

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
index 36ecf863..5166549a 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
@@ -41,11 +41,19 @@ import Module   ( Module, ModuleName, moduleName, moduleNameString )
 import Name     ( getOccString, nameOccName, isValOcc )
 
 
+-- | Replace placeholder string elements with provided values.
+--
+-- Used to generate URL for customized external paths, usually provided with
+-- @--source-module@, @--source-entity@ and related command-line arguments.
+--
+-- >>> spliceURL Nothing mmod mname Nothing "output/%{MODULE}.hs#%{NAME}"
+-- "output/Foo.hs#foo"
 spliceURL :: Maybe FilePath -> Maybe Module -> Maybe GHC.Name ->
              Maybe SrcSpan -> String -> String
 spliceURL mfile mmod = spliceURL' mfile (moduleName <$> mmod)
 
 
+-- | Same as 'spliceURL' but takes 'ModuleName' instead of 'Module'.
 spliceURL' :: Maybe FilePath -> Maybe ModuleName -> Maybe GHC.Name ->
               Maybe SrcSpan -> String -> String
 spliceURL' maybe_file maybe_mod maybe_name maybe_loc = run
-- 
cgit v1.2.3


From 868248d5e847e29ffede5b6c7d20f08a3ec7eb47 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Wed, 1 Jul 2015 22:25:21 +0200
Subject: Make hyperlinker render qualified names as one entity.

---
 .../src/Haddock/Backends/Hyperlinker/Ast.hs        |  1 +
 .../src/Haddock/Backends/Hyperlinker/Renderer.hs   | 50 +++++++++++++++++++---
 2 files changed, 46 insertions(+), 5 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 79e31db7..decb1206 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -25,6 +25,7 @@ data TokenDetails
     | RtkBind GHC.Name
     | RtkDecl GHC.Name
     | RtkModule GHC.ModuleName
+    deriving (Eq)
 
 rtkName :: TokenDetails -> Either GHC.Name GHC.ModuleName
 rtkName (RtkVar name) = Left name
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index 89d9b60d..ddb2e5b9 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -19,15 +19,46 @@ import qualified Data.Map as Map
 import Text.XHtml (Html, HtmlAttr, (!))
 import qualified Text.XHtml as Html
 
+
 type StyleClass = String
 
+
 render :: Maybe FilePath -> Maybe FilePath
        -> GHC.PackageKey -> SrcMap -> [RichToken]
        -> Html
 render mcss mjs pkg srcs tokens = header mcss mjs <> body pkg srcs tokens
 
+
+data TokenGroup
+    = GrpNormal Token
+    | GrpRich TokenDetails [Token]
+
+
+-- | Group consecutive tokens pointing to the same element.
+--
+-- We want to render qualified identifiers as one entity. For example,
+-- @Bar.Baz.foo@ consists of 5 tokens (@Bar@, @.@, @Baz@, @.@, @foo@) but for
+-- better user experience when highlighting and clicking links, these tokens
+-- should be regarded as one identifier. Therefore, before rendering we must
+-- group consecutive elements pointing to the same 'GHC.Name' (note that even
+-- dot token has it if it is part of qualified name).
+groupTokens :: [RichToken] -> [TokenGroup]
+groupTokens [] = []
+groupTokens ((RichToken tok Nothing):rest) = (GrpNormal tok):(groupTokens rest)
+groupTokens ((RichToken tok (Just det)):rest) =
+    let (grp, rest') = span same rest
+    in (GrpRich det (tok:(map rtkToken grp))):(groupTokens rest')
+  where
+    same (RichToken _ (Just det')) = det == det'
+    same _ = False
+
+
 body :: GHC.PackageKey -> SrcMap -> [RichToken] -> Html
-body pkg srcs = Html.body . Html.pre . mconcat . map (richToken pkg srcs)
+body pkg srcs tokens =
+    Html.body . Html.pre $ hypsrc
+  where
+    hypsrc = mconcat . map (tokenGroup pkg srcs) . groupTokens $ tokens
+
 
 header :: Maybe FilePath -> Maybe FilePath -> Html
 header mcss mjs
@@ -47,20 +78,29 @@ header mcss mjs =
         , Html.src scriptFile
         ]
 
-richToken :: GHC.PackageKey -> SrcMap -> RichToken -> Html
-richToken _ _ (RichToken tok Nothing) =
+
+tokenGroup :: GHC.PackageKey -> SrcMap -> TokenGroup -> Html
+tokenGroup _ _ (GrpNormal tok) =
     tokenSpan tok ! attrs
   where
     attrs = [ multiclass . tokenStyle . tkType $ tok ]
-richToken pkg srcs (RichToken tok (Just det)) =
+tokenGroup pkg srcs (GrpRich det tokens) =
     externalAnchor det . internalAnchor det . hyperlink pkg srcs det $ content
   where
-    content = tokenSpan tok ! [ multiclass style]
+    content = mconcat . map (richToken det) $ tokens
+
+
+richToken :: TokenDetails -> Token -> Html
+richToken det tok =
+    tokenSpan tok ! [ multiclass style ]
+  where
     style = (tokenStyle . tkType) tok ++ richTokenStyle det
 
+
 tokenSpan :: Token -> Html
 tokenSpan = Html.thespan . Html.toHtml . tkValue
 
+
 richTokenStyle :: TokenDetails -> [StyleClass]
 richTokenStyle (RtkVar _) = ["hs-var"]
 richTokenStyle (RtkType _) = ["hs-type"]
-- 
cgit v1.2.3


From 0d0550cdcf3fa7ceff88e2572f7ffb341b9f760d Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Thu, 2 Jul 2015 12:32:59 +0200
Subject: Fix crash happening when hyperlinking type family declarations.

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

(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 decb1206..c12ac35a 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -135,6 +135,7 @@ decls (group, _, _, _) = concatMap ($ group)
     typ (GHC.L _ t) = case t of
         GHC.DataDecl name _ defn _ ->
             [decl name] ++ concatMap con (GHC.dd_cons defn)
+        GHC.FamDecl fam -> pure . decl $ GHC.fdLName fam
         _ -> pure . decl $ GHC.tcdLName t
     fun term = case cast term of
         (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name))
-- 
cgit v1.2.3


From 5c01af0e605c2bd16382cbd0de7102f1fbc2f361 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Thu, 2 Jul 2015 12:47:03 +0200
Subject: Add support for anchoring data family constructor declarations.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 11 ++++++-----
 1 file changed, 6 insertions(+), 5 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 c12ac35a..b592326d 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -129,20 +129,21 @@ binds =
 decls :: GHC.RenamedSource -> DetailsMap
 decls (group, _, _, _) = concatMap ($ group)
     [ concat . map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds
-    , everything (<|>) fun
+    , everything (<|>) (fun `combine` con)
     ]
   where
     typ (GHC.L _ t) = case t of
-        GHC.DataDecl name _ defn _ ->
-            [decl name] ++ concatMap con (GHC.dd_cons defn)
+        GHC.DataDecl name _ _ _ -> pure . decl $ name
         GHC.FamDecl fam -> pure . decl $ GHC.fdLName fam
         _ -> pure . decl $ GHC.tcdLName t
     fun term = case cast term of
         (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name))
             | GHC.isExternalName name -> pure (sspan, RtkDecl name)
         _ -> empty
-    con (GHC.L _ t) =
-        map decl (GHC.con_names t) ++ everything (<|>) fld t
+    con term = case cast term of
+        (Just cdcl) ->
+            map decl (GHC.con_names cdcl) ++ everything (<|>) fld cdcl
+        Nothing -> empty
     fld term = case cast term of
         Just field -> map decl $ GHC.cd_fld_names field
         Nothing -> empty
-- 
cgit v1.2.3


From 28e93ceec440d0d1ed053bbf3c20e4bdcd6d5f4e Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Thu, 2 Jul 2015 13:31:05 +0200
Subject: Improve support for hyperlinking type families.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs    | 8 +++++++-
 haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 1 +
 2 files changed, 8 insertions(+), 1 deletion(-)

(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 b592326d..4b60ca37 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -129,7 +129,7 @@ binds =
 decls :: GHC.RenamedSource -> DetailsMap
 decls (group, _, _, _) = concatMap ($ group)
     [ concat . map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds
-    , everything (<|>) (fun `combine` con)
+    , everything (<|>) (fun `combine` con `combine` ins)
     ]
   where
     typ (GHC.L _ t) = case t of
@@ -144,10 +144,16 @@ decls (group, _, _, _) = concatMap ($ group)
         (Just cdcl) ->
             map decl (GHC.con_names cdcl) ++ everything (<|>) fld cdcl
         Nothing -> empty
+    ins term = case cast term of
+        (Just (GHC.DataFamInstD inst)) -> pure . tyref $ GHC.dfid_tycon inst
+        (Just (GHC.TyFamInstD (GHC.TyFamInstDecl (GHC.L _ eqn) _))) ->
+            pure . tyref $ GHC.tfe_tycon eqn
+        _ -> empty
     fld term = case cast term of
         Just field -> map decl $ GHC.cd_fld_names field
         Nothing -> empty
     decl (GHC.L sspan name) = (sspan, RtkDecl name)
+    tyref (GHC.L sspan name) = (sspan, RtkType name)
 
 -- | Obtain details map for import declarations.
 --
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index 019075a1..37cc5377 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -197,6 +197,7 @@ keywords =
     , "type"
     , "where"
     , "forall"
+    , "family"
     , "mdo"
     ]
 
-- 
cgit v1.2.3


From aa6c6deba47af1c21765ed09dc0317825aa1d78d Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Thu, 2 Jul 2015 13:41:38 +0200
Subject: Fix issue with operators being recognized as preprocessor directives.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 6 +++---
 hypsrc-test/src/Operators.hs                           | 4 ++++
 2 files changed, 7 insertions(+), 3 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index 37cc5377..d927aa08 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -156,17 +156,17 @@ classify str
     | "--" `isPrefixOf` str = TkComment
     | "{-#" `isPrefixOf` str = TkPragma
     | "{-" `isPrefixOf` str = TkComment
-classify (c:_)
+classify str@(c:_)
     | isSpace c = TkSpace
     | isDigit c = TkNumber
     | c `elem` special = TkSpecial
+    | str `elem` glyphs = TkGlyph
+    | all (`elem` symbols) str = TkOperator
     | c == '#' = TkCpp
     | c == '"' = TkString
     | c == '\'' = TkChar
 classify str
     | str `elem` keywords = TkKeyword
-    | str `elem` glyphs = TkGlyph
-    | all (`elem` symbols) str = TkOperator
     | isIdentifier str = TkIdentifier
     | otherwise = TkUnknown
 
diff --git a/hypsrc-test/src/Operators.hs b/hypsrc-test/src/Operators.hs
index bc76c2d3..8e86ab0b 100644
--- a/hypsrc-test/src/Operators.hs
+++ b/hypsrc-test/src/Operators.hs
@@ -16,3 +16,7 @@ a */\* b = concatMap (*** b) a
 
 (**/\**) :: [[a]] -> [[a]] -> [[a]]
 a **/\** b = zipWith (*/\*) [a +++ b] (a $$$ b)
+
+
+(#.#) :: a -> b -> (c -> (a, b))
+a #.# b = const $ (a, b)
-- 
cgit v1.2.3


From d761512f239b17f8e9824629595d75aa46e55554 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Thu, 2 Jul 2015 18:53:28 +0200
Subject: Add support for anchoring signatures in type class declarations.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 5 +++++
 1 file changed, 5 insertions(+)

(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 4b60ca37..98c9770f 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -1,5 +1,7 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RecordWildCards #-}
+
 
 module Haddock.Backends.Hyperlinker.Ast
     ( enrich
@@ -135,6 +137,7 @@ decls (group, _, _, _) = concatMap ($ group)
     typ (GHC.L _ t) = case t of
         GHC.DataDecl name _ _ _ -> pure . decl $ name
         GHC.FamDecl fam -> pure . decl $ GHC.fdLName fam
+        GHC.ClassDecl{..} -> [decl tcdLName] ++ concatMap sig tcdSigs
         _ -> pure . decl $ GHC.tcdLName t
     fun term = case cast term of
         (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name))
@@ -152,6 +155,8 @@ decls (group, _, _, _) = concatMap ($ group)
     fld term = case cast term of
         Just field -> map decl $ GHC.cd_fld_names field
         Nothing -> empty
+    sig (GHC.L _ (GHC.TypeSig names _ _)) = map decl names
+    sig _ = []
     decl (GHC.L sspan name) = (sspan, RtkDecl name)
     tyref (GHC.L sspan name) = (sspan, RtkType name)
 
-- 
cgit v1.2.3


From ef3b8691ea607bd4f67d5dc77bb226cf57ec4c30 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Thu, 2 Jul 2015 19:04:47 +0200
Subject: Make hyperlinker generate anchors only to top-level value bindings.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

(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 98c9770f..1e121c2e 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -131,7 +131,8 @@ binds =
 decls :: GHC.RenamedSource -> DetailsMap
 decls (group, _, _, _) = concatMap ($ group)
     [ concat . map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds
-    , everything (<|>) (fun `combine` con `combine` ins)
+    , everything (<|>) fun . GHC.hs_valds
+    , everything (<|>) (con `combine` ins)
     ]
   where
     typ (GHC.L _ t) = case t of
-- 
cgit v1.2.3


From a86147030e0f8fe33ebd4b358ac04d3beb45c3f8 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Sat, 4 Jul 2015 17:15:26 +0200
Subject: Remove potentially dangerous record access in hyperlinker AST module.

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

(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 1e121c2e..9d5c127d 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -137,9 +137,9 @@ decls (group, _, _, _) = concatMap ($ group)
   where
     typ (GHC.L _ t) = case t of
         GHC.DataDecl name _ _ _ -> pure . decl $ name
+        GHC.SynDecl name _ _ _ -> pure . decl $ name
         GHC.FamDecl fam -> pure . decl $ GHC.fdLName fam
         GHC.ClassDecl{..} -> [decl tcdLName] ++ concatMap sig tcdSigs
-        _ -> pure . decl $ GHC.tcdLName t
     fun term = case cast term of
         (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name))
             | GHC.isExternalName name -> pure (sspan, RtkDecl name)
-- 
cgit v1.2.3


From cab1191dfb7738c020a1eef9e9d4efe6c4f27a51 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Sat, 4 Jul 2015 17:40:10 +0200
Subject: Make Haddock generate warnings about potential misuse of hyperlinker.

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

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 02e19531..5a1c6abe 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -159,6 +159,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do
           _ -> return flags
 
   unless (Flag_NoWarnings `elem` flags) $ do
+    hypSrcWarnings flags
     forM_ (warnings args) $ \warning -> do
       hPutStrLn stderr warning
 
@@ -491,6 +492,35 @@ shortcutFlags flags = do
       ++ "Ported to use the GHC API by David Waern 2006-2008\n"
 
 
+-- | Generate some warnings about potential misuse of @--hyperlinked-source@.
+hypSrcWarnings :: [Flag] -> IO ()
+hypSrcWarnings flags = do
+
+    when (hypSrc && any isSourceUrlFlag flags) $
+        hPutStrLn stderr $ concat
+            [ "Warning: "
+            , "--source-* options are ignored when "
+            , "--hyperlinked-source is enabled."
+            ]
+
+    when (not hypSrc && any isSourceCssFlag flags) $
+        hPutStrLn stderr $ concat
+            [ "Warning: "
+            , "source CSS file is specified but "
+            , "--hyperlinked-source is disabled."
+            ]
+
+  where
+    hypSrc = Flag_HyperlinkedSource `elem` flags
+    isSourceUrlFlag (Flag_SourceBaseURL _) = True
+    isSourceUrlFlag (Flag_SourceModuleURL _) = True
+    isSourceUrlFlag (Flag_SourceEntityURL _) = True
+    isSourceUrlFlag (Flag_SourceLEntityURL _) = True
+    isSourceUrlFlag _ = False
+    isSourceCssFlag (Flag_SourceCss _) = True
+    isSourceCssFlag _ = False
+
+
 updateHTMLXRefs :: [(DocPaths, InterfaceFile)] -> IO ()
 updateHTMLXRefs packages = do
   writeIORef html_xrefs_ref (Map.fromList mapping)
-- 
cgit v1.2.3


From 99980dcc63d696c7912ff1f0d2faadcce169f184 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Sun, 5 Jul 2015 17:06:36 +0200
Subject: Refactor source path mapping to use modules as indices.

---
 haddock-api/src/Haddock.hs                         | 27 ++++++++++------
 haddock-api/src/Haddock/Backends/Hyperlinker.hs    | 15 ++++-----
 .../src/Haddock/Backends/Hyperlinker/Renderer.hs   | 36 ++++++++++------------
 haddock-api/src/Haddock/InterfaceFile.hs           | 11 ++++---
 haddock-api/src/Haddock/Types.hs                   |  9 +++++-
 5 files changed, 55 insertions(+), 43 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 5a1c6abe..5c48d28b 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -46,6 +46,7 @@ import Data.List (isPrefixOf)
 import Control.Exception
 import Data.Maybe
 import Data.IORef
+import Data.Map (Map)
 import qualified Data.Map as Map
 import System.IO
 import System.Exit
@@ -228,13 +229,14 @@ renderStep dflags flags qual pkgs interfaces = do
   let
     ifaceFiles = map snd pkgs
     installedIfaces = concatMap ifInstalledIfaces ifaceFiles
-    srcMap = Map.fromList [ (ifPackageKey if_, x) | ((_, Just x), if_) <- pkgs ]
-  render dflags flags qual interfaces installedIfaces srcMap
+    extSrcMap = Map.fromList
+      [ (ifModule ifile, path) | ((_, Just path), ifile) <- pkgs ]
+  render dflags flags qual interfaces installedIfaces extSrcMap
 
 
 -- | Render the interfaces with whatever backend is specified in the flags.
-render :: DynFlags -> [Flag] -> QualOption -> [Interface] -> [InstalledInterface] -> SrcMap -> IO ()
-render dflags flags qual ifaces installedIfaces srcMap = do
+render :: DynFlags -> [Flag] -> QualOption -> [Interface] -> [InstalledInterface] -> Map Module FilePath -> IO ()
+render dflags flags qual ifaces installedIfaces extSrcMap = do
 
   let
     title                = fromMaybe "" (optTitle flags)
@@ -264,15 +266,20 @@ render dflags flags qual ifaces installedIfaces srcMap = do
       | Flag_HyperlinkedSource `elem` flags = Just hypSrcModuleUrlFormat
       | otherwise = srcModule
 
-    srcMap'
+    srcMap = Map.union
+      (Map.map SrcExternal extSrcMap)
+      (Map.fromList [ (ifaceMod iface, SrcLocal) | iface <- ifaces ])
+
+    pkgSrcMap = Map.mapKeys modulePackageKey extSrcMap
+    pkgSrcMap'
       | Flag_HyperlinkedSource `elem` flags =
-          Map.insert pkgKey hypSrcModuleNameUrlFormat srcMap
-      | Just srcNameUrl <- srcEntity = Map.insert pkgKey srcNameUrl srcMap
-      | otherwise = srcMap
+          Map.insert pkgKey hypSrcModuleNameUrlFormat pkgSrcMap
+      | Just srcNameUrl <- srcEntity = Map.insert pkgKey srcNameUrl pkgSrcMap
+      | otherwise = pkgSrcMap
 
     -- TODO: Get these from the interface files as with srcMap
     srcLMap' = maybe Map.empty (\path -> Map.singleton pkgKey path) srcLEntity
-    sourceUrls' = (srcBase, srcModule', srcMap', srcLMap')
+    sourceUrls' = (srcBase, srcModule', pkgSrcMap', srcLMap')
 
   libDir   <- getHaddockLibDir flags
   prologue <- getPrologue dflags flags
@@ -322,7 +329,7 @@ render dflags flags qual ifaces installedIfaces srcMap = do
                   libDir
 
   when (Flag_HyperlinkedSource `elem` flags) $ do
-    ppHyperlinkedSource odir libDir opt_source_css pretty pkgKey srcMap ifaces
+    ppHyperlinkedSource odir libDir opt_source_css pretty srcMap ifaces
 
 -- | From GHC 7.10, this function has a potential to crash with a
 -- nasty message such as @expectJust getPackageDetails@ because
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
index 1fadef49..f007f970 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
@@ -8,7 +8,6 @@ import Haddock.Backends.Hyperlinker.Renderer
 import Haddock.Backends.Hyperlinker.Utils
 
 import Text.XHtml hiding ((</>))
-import GHC
 
 import Data.Maybe
 import System.Directory
@@ -24,30 +23,28 @@ ppHyperlinkedSource :: FilePath -- ^ Output directory
                     -> FilePath -- ^ Resource directory
                     -> Maybe FilePath -- ^ Custom CSS file path
                     -> Bool -- ^ Flag indicating whether to pretty-print HTML
-                    -> PackageKey -- ^ Package for which we create source
-                    -> SrcMap -- ^ Paths to external sources
+                    -> SrcMap -- ^ Paths to sources
                     -> [Interface] -- ^ Interfaces for which we create source
                     -> IO ()
-ppHyperlinkedSource outdir libdir mstyle pretty pkg srcs ifaces = do
+ppHyperlinkedSource outdir libdir mstyle pretty srcs ifaces = do
     createDirectoryIfMissing True srcdir
     let cssFile = fromMaybe (defaultCssFile libdir) mstyle
     copyFile cssFile $ srcdir </> srcCssFile
     copyFile (libdir </> "html" </> highlightScript) $
         srcdir </> highlightScript
-    mapM_ (ppHyperlinkedModuleSource srcdir pretty pkg srcs) ifaces
+    mapM_ (ppHyperlinkedModuleSource srcdir pretty srcs) ifaces
   where
     srcdir = outdir </> hypSrcDir
 
 -- | Generate hyperlinked source for particular interface.
-ppHyperlinkedModuleSource :: FilePath -> Bool
-                          -> PackageKey -> SrcMap -> Interface
+ppHyperlinkedModuleSource :: FilePath -> Bool -> SrcMap -> Interface
                           -> IO ()
-ppHyperlinkedModuleSource srcdir pretty pkg srcs iface =
+ppHyperlinkedModuleSource srcdir pretty srcs iface =
     case ifaceTokenizedSrc iface of
         Just tokens -> writeFile path . html . render' $ tokens
         Nothing -> return ()
   where
-    render' = render (Just srcCssFile) (Just highlightScript) pkg srcs
+    render' = render (Just srcCssFile) (Just highlightScript) srcs
     html = if pretty then renderHtml else showHtml
     path = srcdir </> hypSrcModuleFile (ifaceMod iface)
 
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index ddb2e5b9..a4d7bc2d 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -23,10 +23,9 @@ import qualified Text.XHtml as Html
 type StyleClass = String
 
 
-render :: Maybe FilePath -> Maybe FilePath
-       -> GHC.PackageKey -> SrcMap -> [RichToken]
+render :: Maybe FilePath -> Maybe FilePath -> SrcMap -> [RichToken]
        -> Html
-render mcss mjs pkg srcs tokens = header mcss mjs <> body pkg srcs tokens
+render mcss mjs srcs tokens = header mcss mjs <> body srcs tokens
 
 
 data TokenGroup
@@ -53,11 +52,11 @@ groupTokens ((RichToken tok (Just det)):rest) =
     same _ = False
 
 
-body :: GHC.PackageKey -> SrcMap -> [RichToken] -> Html
-body pkg srcs tokens =
+body :: SrcMap -> [RichToken] -> Html
+body srcs tokens =
     Html.body . Html.pre $ hypsrc
   where
-    hypsrc = mconcat . map (tokenGroup pkg srcs) . groupTokens $ tokens
+    hypsrc = mconcat . map (tokenGroup srcs) . groupTokens $ tokens
 
 
 header :: Maybe FilePath -> Maybe FilePath -> Html
@@ -79,13 +78,13 @@ header mcss mjs =
         ]
 
 
-tokenGroup :: GHC.PackageKey -> SrcMap -> TokenGroup -> Html
-tokenGroup _ _ (GrpNormal tok) =
+tokenGroup :: SrcMap -> TokenGroup -> Html
+tokenGroup _ (GrpNormal tok) =
     tokenSpan tok ! attrs
   where
     attrs = [ multiclass . tokenStyle . tkType $ tok ]
-tokenGroup pkg srcs (GrpRich det tokens) =
-    externalAnchor det . internalAnchor det . hyperlink pkg srcs det $ content
+tokenGroup srcs (GrpRich det tokens) =
+    externalAnchor det . internalAnchor det . hyperlink srcs det $ content
   where
     content = mconcat . map (richToken det) $ tokens
 
@@ -140,28 +139,27 @@ externalAnchorIdent = hypSrcNameUrl
 internalAnchorIdent :: GHC.Name -> String
 internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique
 
-hyperlink :: GHC.PackageKey -> SrcMap -> TokenDetails -> Html -> Html
-hyperlink pkg srcs details = case rtkName details of
+hyperlink :: SrcMap -> TokenDetails -> Html -> Html
+hyperlink srcs details = case rtkName details of
     Left name ->
         if GHC.isInternalName name
         then internalHyperlink name
-        else externalNameHyperlink pkg srcs name
+        else externalNameHyperlink srcs name
     Right name -> externalModHyperlink name
 
 internalHyperlink :: GHC.Name -> Html -> Html
 internalHyperlink name content =
     Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ]
 
-externalNameHyperlink :: GHC.PackageKey -> SrcMap -> GHC.Name -> Html -> Html
-externalNameHyperlink pkg srcs name content
-    | namePkg == pkg = Html.anchor content !
+externalNameHyperlink :: SrcMap -> GHC.Name -> Html -> Html
+externalNameHyperlink srcs name content = case Map.lookup mdl srcs of
+    Just SrcLocal -> Html.anchor content !
         [ Html.href $ hypSrcModuleNameUrl mdl name ]
-    | Just path <- Map.lookup namePkg srcs = Html.anchor content !
+    Just (SrcExternal path) -> Html.anchor content !
         [ Html.href $ path </> hypSrcModuleNameUrl mdl name ]
-    | otherwise = content
+    Nothing -> content
   where
     mdl = GHC.nameModule name
-    namePkg = GHC.modulePackageKey mdl
 
 -- TODO: Implement module hyperlinks.
 --
diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs
index 4b39d315..d5762ce8 100644
--- a/haddock-api/src/Haddock/InterfaceFile.hs
+++ b/haddock-api/src/Haddock/InterfaceFile.hs
@@ -14,7 +14,7 @@
 -- Reading and writing the .haddock interface file
 -----------------------------------------------------------------------------
 module Haddock.InterfaceFile (
-  InterfaceFile(..), ifPackageKey,
+  InterfaceFile(..), ifModule, ifPackageKey,
   readInterfaceFile, nameCacheFromGhc, freshNameCache, NameCacheAccessor,
   writeInterfaceFile, binaryInterfaceVersion, binaryInterfaceVersionCompatibility
 ) where
@@ -51,11 +51,14 @@ data InterfaceFile = InterfaceFile {
 }
 
 
-ifPackageKey :: InterfaceFile -> PackageKey
-ifPackageKey if_ =
+ifModule :: InterfaceFile -> Module
+ifModule if_ =
   case ifInstalledIfaces if_ of
     [] -> error "empty InterfaceFile"
-    iface:_ -> modulePackageKey $ instMod iface
+    iface:_ -> instMod iface
+
+ifPackageKey :: InterfaceFile -> PackageKey
+ifPackageKey = modulePackageKey . ifModule
 
 
 binaryInterfaceMagic :: Word32
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index fbb5f44c..da4b3eec 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -50,7 +50,7 @@ type SubMap        = Map Name [Name]
 type DeclMap       = Map Name [LHsDecl Name]
 type InstMap       = Map SrcSpan Name
 type FixMap        = Map Name Fixity
-type SrcMap        = Map PackageKey FilePath
+type SrcMap        = Map Module SrcPath
 type DocPaths      = (FilePath, Maybe FilePath) -- paths to HTML and sources
 
 
@@ -271,6 +271,13 @@ unrenameDocForDecl (doc, fnArgsDoc) =
 -- | Type of environment used to cross-reference identifiers in the syntax.
 type LinkEnv = Map Name Module
 
+-- | Path for making cross-package hyperlinks in generated sources.
+--
+-- Used in 'SrcMap' to determine whether module originates in current package
+-- or in an external package.
+data SrcPath
+  = SrcExternal FilePath
+  | SrcLocal
 
 -- | Extends 'Name' with cross-reference information.
 data DocName
-- 
cgit v1.2.3


From 5927bfd4737532e7f1282672a96c2a2cb83c847f Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Sun, 5 Jul 2015 17:47:34 +0200
Subject: Fix bug where not all module interfaces were added to source mapping.

---
 haddock-api/src/Haddock.hs | 6 ++++--
 1 file changed, 4 insertions(+), 2 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 5c48d28b..d4d8e3e6 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -229,8 +229,10 @@ renderStep dflags flags qual pkgs interfaces = do
   let
     ifaceFiles = map snd pkgs
     installedIfaces = concatMap ifInstalledIfaces ifaceFiles
-    extSrcMap = Map.fromList
-      [ (ifModule ifile, path) | ((_, Just path), ifile) <- pkgs ]
+    extSrcMap = Map.fromList $ do
+      ((_, Just path), ifile) <- pkgs
+      iface <- ifInstalledIfaces ifile
+      return (instMod iface, path)
   render dflags flags qual interfaces installedIfaces extSrcMap
 
 
-- 
cgit v1.2.3


From fcaa46b054fc3b5a5535a748d3c3283629e3eadf Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Mon, 6 Jul 2015 16:39:57 +0200
Subject: Extract main hyperlinker types to separate module.

---
 haddock-api/haddock-api.cabal                      |  1 +
 haddock-api/src/Haddock/Backends/Hyperlinker.hs    |  1 +
 .../src/Haddock/Backends/Hyperlinker/Ast.hs        | 27 ++--------
 .../src/Haddock/Backends/Hyperlinker/Parser.hs     | 40 ++-------------
 .../src/Haddock/Backends/Hyperlinker/Renderer.hs   |  4 +-
 .../src/Haddock/Backends/Hyperlinker/Types.hs      | 59 ++++++++++++++++++++++
 .../src/Haddock/Backends/Hyperlinker/Utils.hs      |  1 +
 haddock-api/src/Haddock/Interface/Create.hs        |  1 +
 haddock-api/src/Haddock/Types.hs                   |  3 +-
 haddock.cabal                                      |  5 ++
 10 files changed, 79 insertions(+), 63 deletions(-)
 create mode 100644 haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs

(limited to 'haddock-api/src')

diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal
index 11567f99..3838c3d8 100644
--- a/haddock-api/haddock-api.cabal
+++ b/haddock-api/haddock-api.cabal
@@ -85,6 +85,7 @@ library
     Haddock.Backends.Hyperlinker.Ast
     Haddock.Backends.Hyperlinker.Parser
     Haddock.Backends.Hyperlinker.Renderer
+    Haddock.Backends.Hyperlinker.Types
     Haddock.Backends.Hyperlinker.Utils
     Haddock.ModuleTree
     Haddock.Types
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
index f007f970..4b58190c 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
@@ -3,6 +3,7 @@ module Haddock.Backends.Hyperlinker
     , module Haddock.Backends.Hyperlinker.Utils
     ) where
 
+
 import Haddock.Types
 import Haddock.Backends.Hyperlinker.Renderer
 import Haddock.Backends.Hyperlinker.Utils
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index 9d5c127d..28fdc3f5 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -3,12 +3,10 @@
 {-# LANGUAGE RecordWildCards #-}
 
 
-module Haddock.Backends.Hyperlinker.Ast
-    ( enrich
-    , RichToken(..), TokenDetails(..), rtkName
-    ) where
+module Haddock.Backends.Hyperlinker.Ast (enrich) where
 
-import Haddock.Backends.Hyperlinker.Parser
+
+import Haddock.Backends.Hyperlinker.Types
 
 import qualified GHC
 
@@ -16,25 +14,6 @@ import Control.Applicative
 import Data.Data
 import Data.Maybe
 
-data RichToken = RichToken
-    { rtkToken :: Token
-    , rtkDetails :: Maybe TokenDetails
-    }
-
-data TokenDetails
-    = RtkVar GHC.Name
-    | RtkType GHC.Name
-    | RtkBind GHC.Name
-    | RtkDecl GHC.Name
-    | RtkModule GHC.ModuleName
-    deriving (Eq)
-
-rtkName :: TokenDetails -> Either GHC.Name GHC.ModuleName
-rtkName (RtkVar name) = Left name
-rtkName (RtkType name) = Left name
-rtkName (RtkBind name) = Left name
-rtkName (RtkDecl name) = Left name
-rtkName (RtkModule name) = Right name
 
 -- | Add more detailed information to token stream using GHC API.
 enrich :: GHC.RenamedSource -> [Token] -> [RichToken]
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index d927aa08..e206413e 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -1,44 +1,12 @@
-module Haddock.Backends.Hyperlinker.Parser
-    ( parse
-    , Token(..), TokenType(..)
-    , Position(..), Span(..)
-    ) where
+module Haddock.Backends.Hyperlinker.Parser (parse) where
+
 
 import Data.Char
 import Data.List
 import Data.Maybe
 
-data Token = Token
-    { tkType :: TokenType
-    , tkValue :: String
-    , tkSpan :: Span
-    }
-
-data Position = Position
-    { posRow :: !Int
-    , posCol :: !Int
-    }
-
-data Span = Span
-    { spStart :: Position
-    , spEnd :: Position
-    }
-
-data TokenType
-    = TkIdentifier
-    | TkKeyword
-    | TkString
-    | TkChar
-    | TkNumber
-    | TkOperator
-    | TkGlyph
-    | TkSpecial
-    | TkSpace
-    | TkComment
-    | TkCpp
-    | TkPragma
-    | TkUnknown
-    deriving (Show, Eq)
+import Haddock.Backends.Hyperlinker.Types
+
 
 -- | Turn source code string into a stream of more descriptive tokens.
 --
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index a4d7bc2d..add1465b 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -1,8 +1,8 @@
 module Haddock.Backends.Hyperlinker.Renderer (render) where
 
+
 import Haddock.Types
-import Haddock.Backends.Hyperlinker.Parser
-import Haddock.Backends.Hyperlinker.Ast
+import Haddock.Backends.Hyperlinker.Types
 import Haddock.Backends.Hyperlinker.Utils
 
 import qualified GHC
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs
new file mode 100644
index 00000000..19cc5288
--- /dev/null
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs
@@ -0,0 +1,59 @@
+module Haddock.Backends.Hyperlinker.Types where
+
+
+import qualified GHC
+
+
+data Token = Token
+    { tkType :: TokenType
+    , tkValue :: String
+    , tkSpan :: Span
+    }
+
+data Position = Position
+    { posRow :: !Int
+    , posCol :: !Int
+    }
+
+data Span = Span
+    { spStart :: Position
+    , spEnd :: Position
+    }
+
+data TokenType
+    = TkIdentifier
+    | TkKeyword
+    | TkString
+    | TkChar
+    | TkNumber
+    | TkOperator
+    | TkGlyph
+    | TkSpecial
+    | TkSpace
+    | TkComment
+    | TkCpp
+    | TkPragma
+    | TkUnknown
+    deriving (Show, Eq)
+
+
+data RichToken = RichToken
+    { rtkToken :: Token
+    , rtkDetails :: Maybe TokenDetails
+    }
+
+data TokenDetails
+    = RtkVar GHC.Name
+    | RtkType GHC.Name
+    | RtkBind GHC.Name
+    | RtkDecl GHC.Name
+    | RtkModule GHC.ModuleName
+    deriving (Eq)
+
+
+rtkName :: TokenDetails -> Either GHC.Name GHC.ModuleName
+rtkName (RtkVar name) = Left name
+rtkName (RtkType name) = Left name
+rtkName (RtkBind name) = Left name
+rtkName (RtkDecl name) = Left name
+rtkName (RtkModule name) = Right name
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
index 9ba8446d..db2bfc76 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
@@ -4,6 +4,7 @@ module Haddock.Backends.Hyperlinker.Utils
     , hypSrcModuleUrlFormat, hypSrcModuleNameUrlFormat,
     ) where
 
+
 import Haddock.Backends.Xhtml.Utils
 
 import GHC
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 59f7076f..0599151e 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -21,6 +21,7 @@ import Haddock.GhcUtils
 import Haddock.Utils
 import Haddock.Convert
 import Haddock.Interface.LexParseRn
+import Haddock.Backends.Hyperlinker.Types
 import Haddock.Backends.Hyperlinker.Ast as Hyperlinker
 import Haddock.Backends.Hyperlinker.Parser as Hyperlinker
 
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index da4b3eec..90dbb4d4 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -35,7 +35,8 @@ import DynFlags (ExtensionFlag, Language)
 import OccName
 import Outputable
 import Control.Monad (ap)
-import Haddock.Backends.Hyperlinker.Ast
+
+import Haddock.Backends.Hyperlinker.Types
 
 -----------------------------------------------------------------------------
 -- * Convenient synonyms
diff --git a/haddock.cabal b/haddock.cabal
index 2a1caee7..8fa9f33d 100644
--- a/haddock.cabal
+++ b/haddock.cabal
@@ -104,6 +104,11 @@ executable haddock
       Haddock.Backends.HaddockDB
       Haddock.Backends.Hoogle
       Haddock.Backends.Hyperlinker
+      Haddock.Backends.Hyperlinker.Ast
+      Haddock.Backends.Hyperlinker.Parser
+      Haddock.Backends.Hyperlinker.Renderer
+      Haddock.Backends.Hyperlinker.Types
+      Haddock.Backends.Hyperlinker.Utils
       Haddock.ModuleTree
       Haddock.Types
       Haddock.Doc
-- 
cgit v1.2.3


From 13254609062a16e010d1c5a24e571dfe98ab6f69 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Mon, 6 Jul 2015 16:52:13 +0200
Subject: Move source paths types to hyperlinker types module.

---
 haddock-api/src/Haddock/Backends/Hyperlinker.hs          |  2 ++
 haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs |  1 -
 haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs    | 13 +++++++++++++
 haddock-api/src/Haddock/Types.hs                         |  9 ---------
 4 files changed, 15 insertions(+), 10 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
index 4b58190c..248a8a54 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
@@ -1,11 +1,13 @@
 module Haddock.Backends.Hyperlinker
     ( ppHyperlinkedSource
+    , module Haddock.Backends.Hyperlinker.Types
     , module Haddock.Backends.Hyperlinker.Utils
     ) where
 
 
 import Haddock.Types
 import Haddock.Backends.Hyperlinker.Renderer
+import Haddock.Backends.Hyperlinker.Types
 import Haddock.Backends.Hyperlinker.Utils
 
 import Text.XHtml hiding ((</>))
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index add1465b..1065897d 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -1,7 +1,6 @@
 module Haddock.Backends.Hyperlinker.Renderer (render) where
 
 
-import Haddock.Types
 import Haddock.Backends.Hyperlinker.Types
 import Haddock.Backends.Hyperlinker.Utils
 
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs
index 19cc5288..ecb51a07 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs
@@ -3,6 +3,8 @@ module Haddock.Backends.Hyperlinker.Types where
 
 import qualified GHC
 
+import Data.Map (Map)
+
 
 data Token = Token
     { tkType :: TokenType
@@ -57,3 +59,14 @@ rtkName (RtkType name) = Left name
 rtkName (RtkBind name) = Left name
 rtkName (RtkDecl name) = Left name
 rtkName (RtkModule name) = Right name
+
+
+-- | Path for making cross-package hyperlinks in generated sources.
+--
+-- Used in 'SrcMap' to determine whether module originates in current package
+-- or in an external package.
+data SrcPath
+  = SrcExternal FilePath
+  | SrcLocal
+
+type SrcMap = Map GHC.Module SrcPath
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 90dbb4d4..6dd64506 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -51,7 +51,6 @@ type SubMap        = Map Name [Name]
 type DeclMap       = Map Name [LHsDecl Name]
 type InstMap       = Map SrcSpan Name
 type FixMap        = Map Name Fixity
-type SrcMap        = Map Module SrcPath
 type DocPaths      = (FilePath, Maybe FilePath) -- paths to HTML and sources
 
 
@@ -272,14 +271,6 @@ unrenameDocForDecl (doc, fnArgsDoc) =
 -- | Type of environment used to cross-reference identifiers in the syntax.
 type LinkEnv = Map Name Module
 
--- | Path for making cross-package hyperlinks in generated sources.
---
--- Used in 'SrcMap' to determine whether module originates in current package
--- or in an external package.
-data SrcPath
-  = SrcExternal FilePath
-  | SrcLocal
-
 -- | Extends 'Name' with cross-reference information.
 data DocName
   = Documented Name Module
-- 
cgit v1.2.3


From bbd036ad309c95ce70affa5aa0a77a61aa5569c8 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Mon, 6 Jul 2015 17:06:19 +0200
Subject: Add support for hyperlinking modules in import lists.

---
 haddock-api/src/Haddock.hs                          |  2 +-
 .../src/Haddock/Backends/Hyperlinker/Renderer.hs    | 21 +++++++++------------
 .../src/Haddock/Backends/Hyperlinker/Types.hs       | 10 +++++++---
 3 files changed, 17 insertions(+), 16 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index d4d8e3e6..350a73ea 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -268,7 +268,7 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do
       | Flag_HyperlinkedSource `elem` flags = Just hypSrcModuleUrlFormat
       | otherwise = srcModule
 
-    srcMap = Map.union
+    srcMap = mkSrcMap $ Map.union
       (Map.map SrcExternal extSrcMap)
       (Map.fromList [ (ifaceMod iface, SrcLocal) | iface <- ifaces ])
 
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index 1065897d..5037421a 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -144,14 +144,14 @@ hyperlink srcs details = case rtkName details of
         if GHC.isInternalName name
         then internalHyperlink name
         else externalNameHyperlink srcs name
-    Right name -> externalModHyperlink name
+    Right name -> externalModHyperlink srcs name
 
 internalHyperlink :: GHC.Name -> Html -> Html
 internalHyperlink name content =
     Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ]
 
 externalNameHyperlink :: SrcMap -> GHC.Name -> Html -> Html
-externalNameHyperlink srcs name content = case Map.lookup mdl srcs of
+externalNameHyperlink (srcs, _) name content = case Map.lookup mdl srcs of
     Just SrcLocal -> Html.anchor content !
         [ Html.href $ hypSrcModuleNameUrl mdl name ]
     Just (SrcExternal path) -> Html.anchor content !
@@ -160,13 +160,10 @@ externalNameHyperlink srcs name content = case Map.lookup mdl srcs of
   where
     mdl = GHC.nameModule name
 
--- TODO: Implement module hyperlinks.
---
--- Unfortunately, 'ModuleName' is not enough to provide viable cross-package
--- hyperlink. And the problem is that GHC AST does not have other information
--- on imported modules, so for the time being, we do not provide such reference
--- either.
-externalModHyperlink :: GHC.ModuleName -> Html -> Html
-externalModHyperlink _ content =
-    content
-    --Html.anchor content ! [ Html.href $ hypSrcModuleUrl' mdl ]
+externalModHyperlink :: SrcMap -> GHC.ModuleName -> Html -> Html
+externalModHyperlink (_, srcs) name content = case Map.lookup name srcs of
+    Just SrcLocal -> Html.anchor content !
+        [ Html.href $ hypSrcModuleUrl' name ]
+    Just (SrcExternal path) -> Html.anchor content !
+        [ Html.href $ path </> hypSrcModuleUrl' name ]
+    Nothing -> content
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs
index ecb51a07..c3954dc9 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs
@@ -4,6 +4,7 @@ module Haddock.Backends.Hyperlinker.Types where
 import qualified GHC
 
 import Data.Map (Map)
+import qualified Data.Map as Map
 
 
 data Token = Token
@@ -66,7 +67,10 @@ rtkName (RtkModule name) = Right name
 -- Used in 'SrcMap' to determine whether module originates in current package
 -- or in an external package.
 data SrcPath
-  = SrcExternal FilePath
-  | SrcLocal
+    = SrcExternal FilePath
+    | SrcLocal
 
-type SrcMap = Map GHC.Module SrcPath
+type SrcMap = (Map GHC.Module SrcPath, Map GHC.ModuleName SrcPath)
+
+mkSrcMap :: Map GHC.Module SrcPath -> SrcMap
+mkSrcMap srcs = (srcs, Map.mapKeys GHC.moduleName srcs)
-- 
cgit v1.2.3


From b6e9968643bc0ab6c61289ecee7205e4d7bc421a Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Mon, 6 Jul 2015 17:26:49 +0200
Subject: Add short documentation for hyperlinker source map type.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs | 9 +++++++++
 1 file changed, 9 insertions(+)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs
index c3954dc9..5f4dbc8c 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs
@@ -70,6 +70,15 @@ data SrcPath
     = SrcExternal FilePath
     | SrcLocal
 
+-- | Mapping from modules to cross-package source paths.
+--
+-- This mapping is actually a pair of maps instead of just one map. The reason
+-- for this is because when hyperlinking modules in import lists we have no
+-- 'GHC.Module' available. On the other hand, we can't just use map with
+-- 'GHC.ModuleName' as indices because certain modules may have common name
+-- but originate in different packages. Hence, we use both /rich/ and /poor/
+-- versions, where the /poor/ is just projection of /rich/ one cached in pair
+-- for better performance.
 type SrcMap = (Map GHC.Module SrcPath, Map GHC.ModuleName SrcPath)
 
 mkSrcMap :: Map GHC.Module SrcPath -> SrcMap
-- 
cgit v1.2.3


From 0e1cad7c38ed1a771794d9332233f784a52d2c1a Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Mon, 6 Jul 2015 18:07:20 +0200
Subject: Fix bug with module name being hyperlinked to `Prelude`.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs         | 7 ++++---
 haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs | 1 +
 2 files changed, 5 insertions(+), 3 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 28fdc3f5..71b73663 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -146,7 +146,7 @@ decls (group, _, _, _) = concatMap ($ group)
 -- import lists.
 imports :: GHC.RenamedSource -> DetailsMap
 imports src@(_, imps, _, _) =
-    everything (<|>) ie src ++ map (imp . GHC.unLoc) imps
+    everything (<|>) ie src ++ mapMaybe (imp . GHC.unLoc) imps
   where
     ie term = case cast term of
         (Just (GHC.IEVar v)) -> pure $ var v
@@ -156,9 +156,10 @@ imports src@(_, imps, _, _) =
         _ -> empty
     typ (GHC.L sspan name) = (sspan, RtkType name)
     var (GHC.L sspan name) = (sspan, RtkVar name)
-    imp idecl =
+    imp idecl | not . GHC.ideclImplicit $ idecl =
         let (GHC.L sspan name) = GHC.ideclName idecl
-        in (sspan, RtkModule name)
+        in Just (sspan, RtkModule name)
+    imp _ = Nothing
 
 -- | Check whether token stream span matches GHC source span.
 --
diff --git a/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs b/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs
index a76bdcdc..8cd2690e 100644
--- a/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs
+++ b/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs
@@ -5,6 +5,7 @@ import Test.Hspec
 import Test.QuickCheck
 
 import Haddock.Backends.Hyperlinker.Parser
+import Haddock.Backends.Hyperlinker.Types
 
 
 main :: IO ()
-- 
cgit v1.2.3


From 06e675167cc217d5346d706e0d52af0726710e3d Mon Sep 17 00:00:00 2001
From: Mateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk>
Date: Tue, 7 Jul 2015 23:58:52 +0100
Subject: Delete trailing whitespace

---
 haddock-api/resources/html/frames.html          |  2 +-
 haddock-api/resources/html/haddock-util.js      | 22 +++++++++++-----------
 haddock-api/src/Haddock/Backends/HaddockDB.hs   | 18 +++++++++---------
 haddock-api/src/Haddock/Backends/Xhtml/Utils.hs |  2 +-
 haddock-api/src/Haddock/Version.hs              |  2 +-
 haddock-library/LICENSE                         |  4 ++--
 html-test/README.markdown                       |  2 +-
 html-test/ref/frames.html                       |  2 +-
 html-test/ref/haddock-util.js                   | 22 +++++++++++-----------
 html-test/src/Bugs.hs                           |  2 +-
 hypsrc-test/ref/src/Classes.html                |  2 +-
 hypsrc-test/src/Classes.hs                      |  2 +-
 12 files changed, 41 insertions(+), 41 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/resources/html/frames.html b/haddock-api/resources/html/frames.html
index 1b4e38d4..e86edb66 100644
--- a/haddock-api/resources/html/frames.html
+++ b/haddock-api/resources/html/frames.html
@@ -1,4 +1,4 @@
-<!DOCTYPE html 
+<!DOCTYPE html
      PUBLIC "-//W3C//DTD XHTML 1.0 Frameset//EN"
      "http://www.w3.org/TR/xhtml1/DTD/xhtml1-frameset.dtd">
 <html xmlns="http://www.w3.org/1999/xhtml">
diff --git a/haddock-api/resources/html/haddock-util.js b/haddock-api/resources/html/haddock-util.js
index 9a6fccf7..ba574356 100644
--- a/haddock-api/resources/html/haddock-util.js
+++ b/haddock-api/resources/html/haddock-util.js
@@ -131,11 +131,11 @@ 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));
@@ -166,7 +166,7 @@ function perform_search(full)
         status.innerHTML = "";
     }
 
-    
+
     function setclass(first, last, status)
     {
         for (var i = first; i <= last; i++)
@@ -174,8 +174,8 @@ function perform_search(full)
             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)
@@ -201,9 +201,9 @@ function perform_search(full)
             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)
@@ -212,8 +212,8 @@ function perform_search(full)
         if (s == text) return 0;
         else return (s > text ? -1 : 1);
     }
-    
-    
+
+
     // from an index, get its string
     // this abstracts over alternates
     function getitem(i)
@@ -250,7 +250,7 @@ function addMenuItem(html) {
 
 function adjustForFrames() {
   var bodyCls;
-  
+
   if (parent.location.href == window.location.href) {
     // not in frames, so add Frames button
     addMenuItem("<a href='#' onclick='reframe();return true;'>Frames</a>");
diff --git a/haddock-api/src/Haddock/Backends/HaddockDB.hs b/haddock-api/src/Haddock/Backends/HaddockDB.hs
index 1c248bfb..0bdc9057 100644
--- a/haddock-api/src/Haddock/Backends/HaddockDB.hs
+++ b/haddock-api/src/Haddock/Backends/HaddockDB.hs
@@ -40,7 +40,7 @@ ppIfaces mods
   where
      do_mod (Module mod, iface)
         =  text "<sect1 id=\"sec-" <> text mod <> text "\">"
-        $$ text "<title><literal>" 
+        $$ text "<title><literal>"
 	   <> text mod
 	   <> text "</literal></title>"
 	$$ text "<indexterm><primary><literal>"
@@ -50,10 +50,10 @@ ppIfaces mods
 	$$ vcat (map (do_export mod) (eltsFM (iface_decls iface)))
 	$$ text "</variablelist>"
 	$$ text "</sect1>"
- 
+
      do_export mod decl | (nm:_) <- declBinders decl
 	=  text "<varlistentry id=" <> ppLinkId mod nm <> char '>'
-	$$ text "<term><literal>" 
+	$$ text "<term><literal>"
 		<> do_decl decl
 		<> text "</literal></term>"
 	$$ text "<listitem>"
@@ -63,11 +63,11 @@ ppIfaces mods
 	$$ text "</varlistentry>"
      do_export _ _ = empty
 
-     do_decl (HsTypeSig _ [nm] ty _) 
+     do_decl (HsTypeSig _ [nm] ty _)
 	=  ppHsName nm <> text " :: " <> ppHsType ty
      do_decl (HsTypeDecl _ nm args ty _)
 	=  hsep ([text "type", ppHsName nm ]
-		 ++ map ppHsName args 
+		 ++ map ppHsName args
 		 ++ [equals, ppHsType ty])
      do_decl (HsNewTypeDecl loc ctx nm args con drv _)
 	= hsep ([text "data", ppHsName nm] -- data, not newtype
@@ -87,7 +87,7 @@ ppHsConstr :: HsConDecl -> Doc
 ppHsConstr (HsRecDecl pos name tvs ctxt fieldList maybe_doc) =
 	 ppHsName name
 	 <> (braces . hsep . punctuate comma . map ppField $ fieldList)
-ppHsConstr (HsConDecl pos name tvs ctxt typeList maybe_doc) = 
+ppHsConstr (HsConDecl pos name tvs ctxt typeList maybe_doc) =
 	 hsep (ppHsName name : map ppHsBangType typeList)
 
 ppField (HsFieldDecl ns ty doc)
@@ -100,7 +100,7 @@ ppHsBangType (HsUnBangedTy ty) = ppHsType ty
 
 ppHsContext :: HsContext -> Doc
 ppHsContext []      = empty
-ppHsContext context = parenList (map (\ (a,b) -> ppHsQName a <+> 
+ppHsContext context = parenList (map (\ (a,b) -> ppHsQName a <+>
 					 hsep (map ppHsAType b)) context)
 
 ppHsType :: HsType -> Doc
@@ -109,7 +109,7 @@ ppHsType (HsForAllType Nothing context htype) =
 ppHsType (HsForAllType (Just tvs) [] htype) =
      hsep (text "forall" : map ppHsName tvs ++ text "." : [ppHsType htype])
 ppHsType (HsForAllType (Just tvs) context htype) =
-     hsep (text "forall" : map ppHsName tvs ++ text "." : 
+     hsep (text "forall" : map ppHsName tvs ++ text "." :
 	   ppHsContext context : text "=>" : [ppHsType htype])
 ppHsType (HsTyFun a b) = fsep [ppHsBType a, text "-&gt;", ppHsType b]
 ppHsType (HsTyIP n t)  = fsep [(char '?' <> ppHsName n), text "::", ppHsType t]
@@ -135,7 +135,7 @@ ppHsQName (UnQual str)			= ppHsName str
 ppHsQName n@(Qual (Module mod) str)
 	 | n == unit_con_name		= ppHsName str
 	 | isSpecial str 		= ppHsName str
-	 | otherwise 
+	 | otherwise
 		=  text "<link linkend=" <> ppLinkId mod str <> char '>'
 		<> ppHsName str
 		<> text "</link>"
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
index 5166549a..26bcbf6d 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
@@ -215,7 +215,7 @@ collapseSection id_ state classes = [ identifier sid, theclass cs ]
 collapseToggle :: String -> [HtmlAttr]
 collapseToggle id_ = [ strAttr "onclick" js ]
   where js = "toggleSection('" ++ id_ ++ "')";
-  
+
 -- | Attributes for an area that toggles a collapsed area,
 -- and displays a control.
 collapseControl :: String -> Bool -> String -> [HtmlAttr]
diff --git a/haddock-api/src/Haddock/Version.hs b/haddock-api/src/Haddock/Version.hs
index 2ef3a257..4e9a581a 100644
--- a/haddock-api/src/Haddock/Version.hs
+++ b/haddock-api/src/Haddock/Version.hs
@@ -9,7 +9,7 @@
 -- Stability   :  experimental
 -- Portability :  portable
 -----------------------------------------------------------------------------
-module Haddock.Version ( 
+module Haddock.Version (
   projectName, projectVersion, projectUrl
 ) where
 
diff --git a/haddock-library/LICENSE b/haddock-library/LICENSE
index 1636bfcd..460decfc 100644
--- a/haddock-library/LICENSE
+++ b/haddock-library/LICENSE
@@ -5,11 +5,11 @@ modification, are permitted provided that the following conditions are met:
 
 - Redistributions of source code must retain the above copyright notice,
 this list of conditions and the following disclaimer.
- 
+
 - Redistributions in binary form must reproduce the above copyright notice,
 this list of conditions and the following disclaimer in the documentation
 and/or other materials provided with the distribution.
- 
+
 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY
 EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
 IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
diff --git a/html-test/README.markdown b/html-test/README.markdown
index 8d57acab..717bac5c 100644
--- a/html-test/README.markdown
+++ b/html-test/README.markdown
@@ -1,7 +1,7 @@
 This is a testsuite for Haddock that uses the concept of "golden files". That
 is, it compares output files against a set of reference files.
 
-To add a new test: 
+To add a new test:
 
  1. Create a module in the `html-test/src` directory.
 
diff --git a/html-test/ref/frames.html b/html-test/ref/frames.html
index 1b4e38d4..e86edb66 100644
--- a/html-test/ref/frames.html
+++ b/html-test/ref/frames.html
@@ -1,4 +1,4 @@
-<!DOCTYPE html 
+<!DOCTYPE html
      PUBLIC "-//W3C//DTD XHTML 1.0 Frameset//EN"
      "http://www.w3.org/TR/xhtml1/DTD/xhtml1-frameset.dtd">
 <html xmlns="http://www.w3.org/1999/xhtml">
diff --git a/html-test/ref/haddock-util.js b/html-test/ref/haddock-util.js
index 9a6fccf7..ba574356 100644
--- a/html-test/ref/haddock-util.js
+++ b/html-test/ref/haddock-util.js
@@ -131,11 +131,11 @@ 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));
@@ -166,7 +166,7 @@ function perform_search(full)
         status.innerHTML = "";
     }
 
-    
+
     function setclass(first, last, status)
     {
         for (var i = first; i <= last; i++)
@@ -174,8 +174,8 @@ function perform_search(full)
             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)
@@ -201,9 +201,9 @@ function perform_search(full)
             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)
@@ -212,8 +212,8 @@ function perform_search(full)
         if (s == text) return 0;
         else return (s > text ? -1 : 1);
     }
-    
-    
+
+
     // from an index, get its string
     // this abstracts over alternates
     function getitem(i)
@@ -250,7 +250,7 @@ function addMenuItem(html) {
 
 function adjustForFrames() {
   var bodyCls;
-  
+
   if (parent.location.href == window.location.href) {
     // not in frames, so add Frames button
     addMenuItem("<a href='#' onclick='reframe();return true;'>Frames</a>");
diff --git a/html-test/src/Bugs.hs b/html-test/src/Bugs.hs
index 8e1f0079..e60bbe8f 100644
--- a/html-test/src/Bugs.hs
+++ b/html-test/src/Bugs.hs
@@ -1,3 +1,3 @@
 module Bugs where
 
-data A a = A a (a -> Int) 
+data A a = A a (a -> Int)
diff --git a/hypsrc-test/ref/src/Classes.html b/hypsrc-test/ref/src/Classes.html
index a5a3d243..13c8389a 100644
--- a/hypsrc-test/ref/src/Classes.html
+++ b/hypsrc-test/ref/src/Classes.html
@@ -408,7 +408,7 @@
       ><span class="hs-special"
       >]</span
       ><span class=""
-      > 
+      >
 
     </span
       ><a name="norf"
diff --git a/hypsrc-test/src/Classes.hs b/hypsrc-test/src/Classes.hs
index bddb9939..b3c3f785 100644
--- a/hypsrc-test/src/Classes.hs
+++ b/hypsrc-test/src/Classes.hs
@@ -16,7 +16,7 @@ instance Foo [a] where
 
 class Foo a => Foo' a where
     quux :: (a, a) -> a
-    quux (x, y) = norf [x, y] 
+    quux (x, y) = norf [x, y]
 
     norf :: [a] -> a
     norf = quux . baz . sum . map bar
-- 
cgit v1.2.3


From 06e0766810779180dbc52d15c0df5a2eaaf1881e Mon Sep 17 00:00:00 2001
From: Mateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk>
Date: Sat, 11 Jul 2015 14:23:05 +0100
Subject: Fix expansion icon for user-collapsible sections

Closes #412
---
 CHANGES                                             | 2 ++
 haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs | 5 +++--
 html-test/ref/Bug335.html                           | 6 +++---
 3 files changed, 8 insertions(+), 5 deletions(-)

(limited to 'haddock-api/src')

diff --git a/CHANGES b/CHANGES
index ff49b6f5..be829adf 100644
--- a/CHANGES
+++ b/CHANGES
@@ -23,6 +23,8 @@ Changes in version 2.16.1
 
  * Generate hyperlinked source ourselves (#410, part of GSOC 2015)
 
+ * Fix expansion icon for user-collapsible sections (#412)
+
 Changes in version 2.16.0
 
  * Experimental collapsible header support (#335)
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
index c23f3f08..3fe74a82 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
@@ -161,8 +161,9 @@ hackMarkup fmt' h' =
       UntouchedDoc d -> (markup fmt $ _doc d, [_meta d])
       CollapsingHeader (Header lvl titl) par n nm ->
         let id_ = makeAnchorId $ "ch:" ++ fromMaybe "noid:" nm ++ show n
-            col' = collapseControl id_ True "caption"
-            instTable = (thediv ! collapseSection id_ False [] <<)
+            expanded = False
+            col' = collapseControl id_ expanded "caption"
+            instTable = (thediv ! collapseSection id_ expanded [] <<)
             lvs = zip [1 .. ] [h1, h2, h3, h4, h5, h6]
             getHeader = fromMaybe caption (lookup lvl lvs)
             subCaption = getHeader ! col' << markup fmt titl
diff --git a/html-test/ref/Bug335.html b/html-test/ref/Bug335.html
index 6f3d3820..dbe97422 100644
--- a/html-test/ref/Bug335.html
+++ b/html-test/ref/Bug335.html
@@ -64,7 +64,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Bug335.html");};
 	    >f</a
 	    > :: ()</p
 	  ><div class="doc"
-	  ><h3 id="control.ch:f0" class="caption collapser" onclick="toggleSection('ch:f0')"
+	  ><h3 id="control.ch:f0" class="caption expander" onclick="toggleSection('ch:f0')"
 	    >ExF:</h3
 	    ><div id="section.ch:f0" class="hide"
 	    ><p
@@ -78,7 +78,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Bug335.html");};
 	    >g</a
 	    > :: ()</p
 	  ><div class="doc"
-	  ><h3 id="control.ch:g0" class="caption collapser" onclick="toggleSection('ch:g0')"
+	  ><h3 id="control.ch:g0" class="caption expander" onclick="toggleSection('ch:g0')"
 	    >ExG:</h3
 	    ><div id="section.ch:g0" class="hide"
 	    ><pre class="screen"
@@ -118,7 +118,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Bug335.html");};
     ><p
       >Produced by <a href=""
 	>Haddock</a
-	> version 2.16.0</p
+	> version 2.16.1</p
       ></div
     ></body
   ></html
-- 
cgit v1.2.3


From ecabf4e16d72818d39d0a18c9a64cb1d464b87b5 Mon Sep 17 00:00:00 2001
From: Phil Ruffwind <rf@rufflewind.com>
Date: Mon, 15 Jun 2015 00:06:08 -0400
Subject: Link to the definitions to themselves

Currently, the definitions already have an anchor tag that allows URLs
with fragment identifiers to locate them, but it is rather inconvenient
to obtain such a URL (so-called "permalink") as it would require finding
the a link to the corresponding item in the Synopsis or elsewhere.  This
commit adds hyperlinks to the definitions themselves, allowing users to
obtain links to them easily.

To preserve the original aesthetics of the definitions, we alter the
color of the link so as to be identical to what it was, except it now
has a hover effect indicating that it is clickable.

Additionally, the anchor now uses the 'id' attribute instead of the
(obsolete) 'name' attribute.

Closes #407
---
 .../resources/html/Ocean.std-theme/ocean.css        |  3 +++
 haddock-api/src/Haddock/Backends/Xhtml/Names.hs     | 21 +++++++++++++--------
 2 files changed, 16 insertions(+), 8 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 1110b407..1cc55cb6 100644
--- a/haddock-api/resources/html/Ocean.std-theme/ocean.css
+++ b/haddock-api/resources/html/Ocean.std-theme/ocean.css
@@ -41,6 +41,9 @@ a[href]:link { color: rgb(196,69,29); }
 a[href]:visited { color: rgb(171,105,84); }
 a[href]:hover { text-decoration:underline; }
 
+a[href].def:link, a[href].def:visited { color: black; }
+a[href].def:hover { color: rgb(78, 98, 114); }
+
 /* @end */
 
 /* @group Fonts & Sizes */
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
index cf12da40..c69710d1 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
@@ -110,16 +110,21 @@ ppName notation name = wrapInfix notation (getOccName name) $ toHtml (getOccStri
 
 
 ppBinder :: Bool -> OccName -> Html
--- The Bool indicates whether we are generating the summary, in which case
--- the binder will be a link to the full definition.
-ppBinder True n = linkedAnchor (nameAnchorId n) << ppBinder' Prefix n
-ppBinder False n = namedAnchor (nameAnchorId n) ! [theclass "def"]
-                        << ppBinder' Prefix n
+ppBinder = ppBinderWith Prefix
 
 ppBinderInfix :: Bool -> OccName -> Html
-ppBinderInfix True n = linkedAnchor (nameAnchorId n) << ppBinder' Infix n
-ppBinderInfix False n = namedAnchor (nameAnchorId n) ! [theclass "def"]
-                             << ppBinder' Infix n
+ppBinderInfix = ppBinderWith Infix
+
+ppBinderWith :: Notation -> Bool -> OccName -> Html
+-- 'isRef' indicates whether this is merely a reference from another part of
+-- the documentation or is the actual definition; in the latter case, we also
+-- set the 'id' and 'class' attributes.
+ppBinderWith notation isRef n =
+  linkedAnchor name ! attributes << ppBinder' notation n
+  where
+    name = nameAnchorId n
+    attributes | isRef     = []
+               | otherwise = [identifier name, theclass "def"]
 
 ppBinder' :: Notation -> OccName -> Html
 ppBinder' notation n = wrapInfix notation n $ ppOccName n
-- 
cgit v1.2.3


From e190efe089a0bd038c7de41c1c52ef580e52712c Mon Sep 17 00:00:00 2001
From: Phil Ruffwind <rf@rufflewind.com>
Date: Sun, 14 Jun 2015 22:47:13 -0400
Subject: Fix typo in Haddock.Backends.Xhtml.Layout: divSynposis -> divSynopsis

Closes #408
---
 haddock-api/src/Haddock/Backends/Xhtml.hs        | 2 +-
 haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 6 +++---
 2 files changed, 4 insertions(+), 4 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 90cb9fa4..e5e4db3f 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -546,7 +546,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual
     synopsis
       | no_doc_at_all = noHtml
       | otherwise
-      = divSynposis $
+      = divSynopsis $
             paragraph ! collapseControl "syn" False "caption" << "Synopsis" +++
             shortDeclList (
                 mapMaybe (processExport True linksInfo unicode qual) exports
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
index 914a7a7e..e79c2c3d 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
@@ -14,7 +14,7 @@ module Haddock.Backends.Xhtml.Layout (
   miniBody,
 
   divPackageHeader, divContent, divModuleHeader, divFooter,
-  divTableOfContents, divDescription, divSynposis, divInterface,
+  divTableOfContents, divDescription, divSynopsis, divInterface,
   divIndex, divAlphabet, divModuleList,
 
   sectionName,
@@ -76,7 +76,7 @@ nonEmptySectionName c
 
 
 divPackageHeader, divContent, divModuleHeader, divFooter,
-  divTableOfContents, divDescription, divSynposis, divInterface,
+  divTableOfContents, divDescription, divSynopsis, divInterface,
   divIndex, divAlphabet, divModuleList
     :: Html -> Html
 
@@ -86,7 +86,7 @@ divModuleHeader     = sectionDiv "module-header"
 divFooter           = sectionDiv "footer"
 divTableOfContents  = sectionDiv "table-of-contents"
 divDescription      = sectionDiv "description"
-divSynposis         = sectionDiv "synopsis"
+divSynopsis         = sectionDiv "synopsis"
 divInterface        = sectionDiv "interface"
 divIndex            = sectionDiv "index"
 divAlphabet         = sectionDiv "alphabet"
-- 
cgit v1.2.3


From c274363d5d868c838c382a52428c667090514f86 Mon Sep 17 00:00:00 2001
From: Phil Ruffwind <rf@rufflewind.com>
Date: Mon, 27 Jul 2015 05:58:58 -0400
Subject: Fix record field alignment when name is too long

Change <dl> to <ul> and use display:table rather than floats to layout
the record fields.  This avoids bug #301 that occurs whenever the field
name gets too long.

Slight aesthetic change: the entire cell of the field's source code is
now shaded gray rather than just the area where text exists.

Fixes #301. Closes #421
---
 .../resources/html/Ocean.std-theme/ocean.css       | 29 +++++++++++-----------
 haddock-api/src/Haddock/Backends/Xhtml/Layout.hs   | 10 +++-----
 2 files changed, 19 insertions(+), 20 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 1cc55cb6..9ad9f9d2 100644
--- a/haddock-api/resources/html/Ocean.std-theme/ocean.css
+++ b/haddock-api/resources/html/Ocean.std-theme/ocean.css
@@ -427,30 +427,31 @@ div#style-menu-holder {
   visibility: hidden;
 }
 
-.subs dl {
+.subs ul {
+  list-style: none;
+  display: table;
   margin: 0;
 }
 
-.subs dt {
-  float: left;
-  clear: left;
-  display: block;
+.subs ul li {
+  display: table-row;
+}
+
+.subs ul li dfn {
+  display: table-cell;
+  font-style: normal;
+  font-weight: bold;
   margin: 1px 0;
+  white-space: nowrap;
 }
 
-.subs dd {
-  float: right;
-  width: 90%;
-  display: block;
+.subs ul li > .doc {
+  display: table-cell;
   padding-left: 0.5em;
   margin-bottom: 0.5em;
 }
 
-.subs dd.empty {
-  display: none;
-}
-
-.subs dd p {
+.subs ul li > .doc p {
   margin: 0;
 }
 
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
index e79c2c3d..4714c1b6 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
@@ -127,14 +127,12 @@ divSubDecls cssClass captionName = maybe noHtml wrap
 
 subDlist :: Qualification -> [SubDecl] -> Maybe Html
 subDlist _ [] = Nothing
-subDlist qual decls = Just $ dlist << map subEntry decls +++ clearDiv
+subDlist qual decls = Just $ ulist << map subEntry decls
   where
     subEntry (decl, mdoc, subs) =
-      dterm ! [theclass "src"] << decl
-      +++
-      docElement ddef << (fmap (docToHtml Nothing qual) mdoc +++ subs)
-
-    clearDiv = thediv ! [ theclass "clear" ] << noHtml
+      li <<
+        (define ! [theclass "src"] << decl +++
+         docElement thediv << (fmap (docToHtml Nothing qual) mdoc +++ subs))
 
 
 subTable :: Qualification -> [SubDecl] -> Maybe Html
-- 
cgit v1.2.3


From 7e8330944666064f12f067970de2936b58589785 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Sat, 25 Jul 2015 18:54:30 +0200
Subject: Add some utility definitions for generating line anchors.

---
 .../src/Haddock/Backends/Hyperlinker/Utils.hs      | 25 ++++++++++++++++++++--
 1 file changed, 23 insertions(+), 2 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
index db2bfc76..9de4a03d 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
@@ -1,13 +1,18 @@
 module Haddock.Backends.Hyperlinker.Utils
     ( hypSrcDir, hypSrcModuleFile, hypSrcModuleFile'
-    , hypSrcModuleUrl, hypSrcModuleUrl', hypSrcNameUrl, hypSrcModuleNameUrl
-    , hypSrcModuleUrlFormat, hypSrcModuleNameUrlFormat,
+    , hypSrcModuleUrl, hypSrcModuleUrl'
+    , hypSrcNameUrl
+    , hypSrcLineUrl
+    , hypSrcModuleNameUrl, hypSrcModuleLineUrl
+    , hypSrcModuleUrlFormat
+    , hypSrcModuleNameUrlFormat, hypSrcModuleLineUrlFormat
     ) where
 
 
 import Haddock.Backends.Xhtml.Utils
 
 import GHC
+import FastString
 import System.FilePath.Posix ((</>))
 
 
@@ -31,17 +36,33 @@ hypSrcNameUrl :: Name -> String
 hypSrcNameUrl name = spliceURL
     Nothing Nothing (Just name) Nothing nameFormat
 
+hypSrcLineUrl :: Int -> String
+hypSrcLineUrl line = spliceURL
+    Nothing Nothing Nothing (Just spn) lineFormat
+  where
+    loc = mkSrcLoc nilFS line 1
+    spn = mkSrcSpan loc loc
+
 hypSrcModuleNameUrl :: Module -> Name -> String
 hypSrcModuleNameUrl mdl name = hypSrcModuleUrl mdl ++ "#" ++ hypSrcNameUrl name
 
+hypSrcModuleLineUrl :: Module -> Int -> String
+hypSrcModuleLineUrl mdl line = hypSrcModuleUrl mdl ++ "#" ++ hypSrcLineUrl line
+
 hypSrcModuleUrlFormat :: String
 hypSrcModuleUrlFormat = hypSrcDir </> moduleFormat
 
 hypSrcModuleNameUrlFormat :: String
 hypSrcModuleNameUrlFormat = hypSrcModuleUrlFormat ++ "#" ++ nameFormat
 
+hypSrcModuleLineUrlFormat :: String
+hypSrcModuleLineUrlFormat = hypSrcModuleUrlFormat ++ "#" ++ lineFormat
+
 moduleFormat :: String
 moduleFormat = "%{MODULE}.html"
 
 nameFormat :: String
 nameFormat = "%{NAME}"
+
+lineFormat :: String
+lineFormat = "line-%{LINE}"
-- 
cgit v1.2.3


From 241346e4e275bdde2d28f90df3225057f4a09cfc Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Sat, 25 Jul 2015 19:48:08 +0200
Subject: Make hyperlinked source renderer generate line anchors.

---
 .../src/Haddock/Backends/Hyperlinker/Renderer.hs   | 26 +++++++++++++++++++---
 1 file changed, 23 insertions(+), 3 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index 5037421a..15793f0c 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -1,3 +1,6 @@
+{-# LANGUAGE RecordWildCards #-}
+
+
 module Haddock.Backends.Hyperlinker.Renderer (render) where
 
 
@@ -78,10 +81,11 @@ header mcss mjs =
 
 
 tokenGroup :: SrcMap -> TokenGroup -> Html
-tokenGroup _ (GrpNormal tok) =
-    tokenSpan tok ! attrs
+tokenGroup _ (GrpNormal tok@(Token { .. }))
+    | tkType == TkSpace = renderSpace (posRow . spStart $ tkSpan) tkValue
+    | otherwise = tokenSpan tok ! attrs
   where
-    attrs = [ multiclass . tokenStyle . tkType $ tok ]
+    attrs = [ multiclass . tokenStyle $ tkType ]
 tokenGroup srcs (GrpRich det tokens) =
     externalAnchor det . internalAnchor det . hyperlink srcs det $ content
   where
@@ -167,3 +171,19 @@ externalModHyperlink (_, srcs) name content = case Map.lookup name srcs of
     Just (SrcExternal path) -> Html.anchor content !
         [ Html.href $ path </> hypSrcModuleUrl' name ]
     Nothing -> content
+
+
+renderSpace :: Int -> String -> Html
+renderSpace _ [] = Html.noHtml
+renderSpace line ('\n':rest) = mconcat
+    [ Html.thespan . Html.toHtml $ "\n"
+    , lineAnchor (line + 1)
+    , renderSpace (line + 1) rest
+    ]
+renderSpace line space =
+    let (hspace, rest) = span (/= '\n') space
+    in (Html.thespan . Html.toHtml) hspace <> renderSpace line rest
+
+
+lineAnchor :: Int -> Html
+lineAnchor line = Html.anchor Html.noHtml ! [ Html.name $ hypSrcLineUrl line ]
-- 
cgit v1.2.3


From 3be46a2ec472c4f220f1eac1bd029690086b8c18 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Sat, 25 Jul 2015 20:49:17 +0200
Subject: Override source line flags when source hyperlinker is enabled.

---
 haddock-api/src/Haddock.hs | 9 +++++++--
 1 file changed, 7 insertions(+), 2 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 350a73ea..8f327b09 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -280,8 +280,13 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do
       | otherwise = pkgSrcMap
 
     -- TODO: Get these from the interface files as with srcMap
-    srcLMap' = maybe Map.empty (\path -> Map.singleton pkgKey path) srcLEntity
-    sourceUrls' = (srcBase, srcModule', pkgSrcMap', srcLMap')
+    pkgSrcLMap'
+      | Flag_HyperlinkedSource `elem` flags =
+          Map.singleton pkgKey hypSrcModuleLineUrlFormat
+      | Just path <- srcLEntity = Map.singleton pkgKey path
+      | otherwise = Map.empty
+
+    sourceUrls' = (srcBase, srcModule', pkgSrcMap', pkgSrcLMap')
 
   libDir   <- getHaddockLibDir flags
   prologue <- getPrologue dflags flags
-- 
cgit v1.2.3


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

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

(limited to 'haddock-api/src')

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


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

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

(limited to 'haddock-api/src')

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


From e9d61b79faf40200d8f9806d83a05ece272cd7d3 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Fri, 10 Jul 2015 11:42:18 +0200
Subject: Move SYB utilities to standalone module.

---
 haddock-api/haddock-api.cabal                      |  1 +
 .../src/Haddock/Backends/Hyperlinker/Ast.hs        | 15 +------------
 haddock-api/src/Haddock/Syb.hs                     | 26 ++++++++++++++++++++++
 haddock.cabal                                      |  1 +
 4 files changed, 29 insertions(+), 14 deletions(-)
 create mode 100644 haddock-api/src/Haddock/Syb.hs

(limited to 'haddock-api/src')

diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal
index 4db05de8..bfdb2179 100644
--- a/haddock-api/haddock-api.cabal
+++ b/haddock-api/haddock-api.cabal
@@ -94,6 +94,7 @@ library
     Haddock.InterfaceFile
     Haddock.Options
     Haddock.GhcUtils
+    Haddock.Syb
     Haddock.Convert
     Paths_haddock_api
 
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index 71b73663..5eca973e 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -6,6 +6,7 @@
 module Haddock.Backends.Hyperlinker.Ast (enrich) where
 
 
+import Haddock.Syb
 import Haddock.Backends.Hyperlinker.Types
 
 import qualified GHC
@@ -179,17 +180,3 @@ matches tspan (GHC.RealSrcSpan aspan)
     saspan = (GHC.srcSpanStartLine aspan, GHC.srcSpanStartCol aspan)
     easpan = (GHC.srcSpanEndLine aspan, GHC.srcSpanEndCol aspan)
 matches _ _ = False
-
--- | 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)
-           -> (forall a. Data a => a -> r)
-everything k f x = foldl k (f x) (gmapQ (everything k f) x)
-
--- | Combine two queries into one using alternative combinator.
-combine :: Alternative f => (forall a. Data a => a -> f r)
-                         -> (forall a. Data a => a -> f r)
-                         -> (forall a. Data a => a -> f r)
-combine f g x = f x <|> g x
diff --git a/haddock-api/src/Haddock/Syb.hs b/haddock-api/src/Haddock/Syb.hs
new file mode 100644
index 00000000..dd7ffc1b
--- /dev/null
+++ b/haddock-api/src/Haddock/Syb.hs
@@ -0,0 +1,26 @@
+{-# LANGUAGE Rank2Types #-}
+
+
+module Haddock.Syb
+    ( everything
+    , combine
+    ) where
+
+
+import Data.Data
+import Control.Applicative
+
+
+-- | 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)
+           -> (forall a. Data a => a -> r)
+everything k f x = foldl k (f x) (gmapQ (everything k f) x)
+
+-- | Combine two queries into one using alternative combinator.
+combine :: Alternative f => (forall a. Data a => a -> f r)
+                         -> (forall a. Data a => a -> f r)
+                         -> (forall a. Data a => a -> f r)
+combine f g x = f x <|> g x
diff --git a/haddock.cabal b/haddock.cabal
index 27ae8967..b0c6c34f 100644
--- a/haddock.cabal
+++ b/haddock.cabal
@@ -116,6 +116,7 @@ executable haddock
       Haddock.InterfaceFile
       Haddock.Options
       Haddock.GhcUtils
+      Haddock.Syb
       Haddock.Convert
   else
     build-depends:  haddock-api == 2.16.*
-- 
cgit v1.2.3


From f7d377ee238d3b44240a4537986a7561e822f79f Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Fri, 10 Jul 2015 11:49:02 +0200
Subject: Implement `everywhere` transformation in SYB module.

---
 haddock-api/src/Haddock/Syb.hs | 8 +++++++-
 1 file changed, 7 insertions(+), 1 deletion(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Syb.hs b/haddock-api/src/Haddock/Syb.hs
index dd7ffc1b..3cec724e 100644
--- a/haddock-api/src/Haddock/Syb.hs
+++ b/haddock-api/src/Haddock/Syb.hs
@@ -2,7 +2,7 @@
 
 
 module Haddock.Syb
-    ( everything
+    ( everything, everywhere
     , combine
     ) where
 
@@ -19,6 +19,12 @@ 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)
 
+-- | Apply transformation on each level of a tree.
+--
+-- Just like 'everything', this is stolen from SYB package.
+everywhere :: (forall a. Data a => a -> a) -> (forall a. Data a => a -> a)
+everywhere f = f . gmapT (everywhere f)
+
 -- | Combine two queries into one using alternative combinator.
 combine :: Alternative f => (forall a. Data a => a -> f r)
                          -> (forall a. Data a => a -> f r)
-- 
cgit v1.2.3


From dc25b7099a0d54c03bdf51dfb9a4e286942d9c31 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Fri, 10 Jul 2015 12:24:12 +0200
Subject: Implement generic transformation constructor.

---
 haddock-api/src/Haddock/Syb.hs | 9 +++++++++
 1 file changed, 9 insertions(+)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Syb.hs b/haddock-api/src/Haddock/Syb.hs
index 3cec724e..2016b74c 100644
--- a/haddock-api/src/Haddock/Syb.hs
+++ b/haddock-api/src/Haddock/Syb.hs
@@ -3,6 +3,7 @@
 
 module Haddock.Syb
     ( everything, everywhere
+    , mkT
     , combine
     ) where
 
@@ -25,6 +26,14 @@ everything k f x = foldl k (f x) (gmapQ (everything k f) x)
 everywhere :: (forall a. Data a => a -> a) -> (forall a. Data a => a -> a)
 everywhere f = f . gmapT (everywhere f)
 
+-- | Create generic transformation.
+--
+-- Another function stolen from SYB package.
+mkT :: (Typeable a, Typeable b) => (b -> b) -> (a -> a)
+mkT f = case cast f of
+    Just f' -> f'
+    Nothing -> id
+
 -- | Combine two queries into one using alternative combinator.
 combine :: Alternative f => (forall a. Data a => a -> f r)
                          -> (forall a. Data a => a -> f r)
-- 
cgit v1.2.3


From e4740dd872d1110247557eb7b20124c22e427789 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Fri, 10 Jul 2015 16:23:15 +0200
Subject: Create simple utility module for type specialization.

---
 haddock-api/haddock-api.cabal                       |  1 +
 .../src/Haddock/Backends/Xhtml/Specialize.hs        | 21 +++++++++++++++++++++
 haddock.cabal                                       |  1 +
 3 files changed, 23 insertions(+)
 create mode 100644 haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs

(limited to 'haddock-api/src')

diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal
index bfdb2179..abe5adbe 100644
--- a/haddock-api/haddock-api.cabal
+++ b/haddock-api/haddock-api.cabal
@@ -75,6 +75,7 @@ library
     Haddock.Backends.Xhtml.DocMarkup
     Haddock.Backends.Xhtml.Layout
     Haddock.Backends.Xhtml.Names
+    Haddock.Backends.Xhtml.Specialize
     Haddock.Backends.Xhtml.Themes
     Haddock.Backends.Xhtml.Types
     Haddock.Backends.Xhtml.Utils
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
new file mode 100644
index 00000000..a0d64c0f
--- /dev/null
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
@@ -0,0 +1,21 @@
+{-# LANGUAGE FlexibleContexts #-}
+
+
+module Haddock.Backends.Xhtml.Specialize (specialize) where
+
+
+import Haddock.Syb
+
+import GHC
+
+import Data.Data
+
+
+specialize :: (Eq name, Data (HsType name))
+           => name -> HsType name -> HsType name -> HsType name
+specialize name details = everywhere (mkT $ specialize' name details)
+
+specialize' :: Eq name => name -> HsType name -> HsType name -> HsType name
+specialize' name details (HsTyVar name') | name == name' = details
+specialize' _ _ typ = typ
+ 
\ No newline at end of file
diff --git a/haddock.cabal b/haddock.cabal
index b0c6c34f..4ea2a82a 100644
--- a/haddock.cabal
+++ b/haddock.cabal
@@ -97,6 +97,7 @@ executable haddock
       Haddock.Backends.Xhtml.DocMarkup
       Haddock.Backends.Xhtml.Layout
       Haddock.Backends.Xhtml.Names
+      Haddock.Backends.Xhtml.Specialize
       Haddock.Backends.Xhtml.Themes
       Haddock.Backends.Xhtml.Types
       Haddock.Backends.Xhtml.Utils
-- 
cgit v1.2.3


From 79f475a93be3de376bc264c53d2ba8eb61ffea42 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Fri, 10 Jul 2015 16:30:11 +0200
Subject: Make type of type specialization function more general.

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

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
index a0d64c0f..e8e80da1 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
@@ -11,11 +11,11 @@ import GHC
 import Data.Data
 
 
-specialize :: (Eq name, Data (HsType name))
-           => name -> HsType name -> HsType name -> HsType name
+specialize :: (Eq name, Typeable name)
+           => Data a
+           => name -> HsType name -> a -> a
 specialize name details = everywhere (mkT $ specialize' name details)
 
 specialize' :: Eq name => name -> HsType name -> HsType name -> HsType name
 specialize' name details (HsTyVar name') | name == name' = details
 specialize' _ _ typ = typ
- 
\ No newline at end of file
-- 
cgit v1.2.3


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

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

(limited to 'haddock-api/src')

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


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

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

(limited to 'haddock-api/src')

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


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

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

(limited to 'haddock-api/src')

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


From 0a02b70bea9781e4c1d03e88bcfe404934e4e2c6 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Wed, 15 Jul 2015 18:21:05 +0200
Subject: Move dummy post-family instances for `DocName` to `Types` module.

---
 haddock-api/src/Haddock/Interface/Rename.hs | 12 ------------
 haddock-api/src/Haddock/Types.hs            | 17 +++++++++++++++--
 2 files changed, 15 insertions(+), 14 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index d222c6d2..44635318 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE RecordWildCards #-}
 ----------------------------------------------------------------------------
 -- |
@@ -22,8 +21,6 @@ import Haddock.Types
 import Bag (emptyBag)
 import GHC hiding (NoLink)
 import Name
-import NameSet
-import Coercion
 
 import Control.Applicative
 import Control.Monad hiding (mapM)
@@ -526,12 +523,3 @@ renameSub (n,doc) = do
   n' <- rename n
   doc' <- renameDocForDecl doc
   return (n', doc')
-
-type instance PostRn DocName NameSet  = PlaceHolder
-type instance PostRn DocName Fixity   = PlaceHolder
-type instance PostRn DocName Bool     = PlaceHolder
-type instance PostRn DocName [Name]   = PlaceHolder
-
-type instance PostTc DocName Kind     = PlaceHolder
-type instance PostTc DocName Type     = PlaceHolder
-type instance PostTc DocName Coercion = PlaceHolder
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index d9ae6cab..5a03af66 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving #-}
+{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving, TypeFamilies #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 -----------------------------------------------------------------------------
 -- |
@@ -27,11 +27,15 @@ import Control.Arrow hiding ((<+>))
 import Control.DeepSeq
 import Data.Typeable
 import Data.Map (Map)
+import Data.Data (Data)
 import qualified Data.Map as Map
 import Documentation.Haddock.Types
 import BasicTypes (Fixity(..))
+
 import GHC hiding (NoLink)
 import DynFlags (ExtensionFlag, Language)
+import Coercion
+import NameSet
 import OccName
 import Outputable
 import Control.Monad (ap)
@@ -280,7 +284,16 @@ data DocName
   | Undocumented Name
      -- ^ This thing is not part of the (existing or resulting)
      -- documentation, as far as Haddock knows.
-  deriving Eq
+  deriving (Eq, Data)
+
+type instance PostRn DocName NameSet  = PlaceHolder
+type instance PostRn DocName Fixity   = PlaceHolder
+type instance PostRn DocName Bool     = PlaceHolder
+type instance PostRn DocName [Name]   = PlaceHolder
+
+type instance PostTc DocName Kind     = PlaceHolder
+type instance PostTc DocName Type     = PlaceHolder
+type instance PostTc DocName Coercion = PlaceHolder
 
 
 instance NamedThing DocName where
-- 
cgit v1.2.3


From 6fc527b41b1ba80c706a375420f40e6eed8c81c8 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Wed, 15 Jul 2015 18:25:36 +0200
Subject: Create convenience functions for type specialization module.

---
 .../src/Haddock/Backends/Xhtml/Specialize.hs       | 31 ++++++++++++++++++----
 1 file changed, 26 insertions(+), 5 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
index e8e80da1..fa5ba536 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
@@ -1,7 +1,10 @@
 {-# LANGUAGE FlexibleContexts #-}
 
 
-module Haddock.Backends.Xhtml.Specialize (specialize) where
+module Haddock.Backends.Xhtml.Specialize
+    ( specialize, specialize'
+    , specializeTyVarBndrs
+    ) where
 
 
 import Haddock.Syb
@@ -14,8 +17,26 @@ import Data.Data
 specialize :: (Eq name, Typeable name)
            => Data a
            => name -> HsType name -> a -> a
-specialize name details = everywhere (mkT $ specialize' name details)
+specialize name details = everywhere (mkT $ specializeStep name details)
 
-specialize' :: Eq name => name -> HsType name -> HsType name -> HsType name
-specialize' name details (HsTyVar name') | name == name' = details
-specialize' _ _ typ = typ
+
+specialize' :: (Eq name, Typeable name)
+            => Data a
+            => [(name, HsType name)] -> a -> a
+specialize' = flip $ foldr (uncurry specialize)
+
+
+specializeStep :: Eq name => name -> HsType name -> HsType name -> HsType name
+specializeStep name details (HsTyVar name') | name == name' = details
+specializeStep _ _ typ = typ
+
+
+specializeTyVarBndrs :: (Eq name, Typeable name, DataId name)
+                     => LHsTyVarBndrs name -> [HsType name]
+                     -> HsType name -> HsType name
+specializeTyVarBndrs bndrs typs =
+    specialize' $ zip bndrs' typs
+  where
+    bndrs' = map (bname . unLoc) . hsq_tvs $ bndrs
+    bname (UserTyVar name) = name
+    bname (KindedTyVar (L _ name) _) = name
-- 
cgit v1.2.3


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

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

(limited to 'haddock-api/src')

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


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

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

(limited to 'haddock-api/src')

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


From 3f31e24656d42bc6c50f441e055b7ecc4fdec8d0 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Wed, 15 Jul 2015 19:31:15 +0200
Subject: Implement list syntax sugaring logic for specialized types.

---
 haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs | 19 ++++++++++++++++---
 1 file changed, 16 insertions(+), 3 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
index c10c7e6e..30501a13 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
@@ -1,4 +1,6 @@
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 
 module Haddock.Backends.Xhtml.Specialize
@@ -11,6 +13,7 @@ module Haddock.Backends.Xhtml.Specialize
 import Haddock.Syb
 
 import GHC
+import Name
 
 import Data.Data
 
@@ -43,12 +46,22 @@ specializeTyVarBndrs bndrs typs =
     bname (KindedTyVar (L _ name) _) = name
 
 
-sugar :: HsType name -> HsType name
+sugar :: (NamedThing name, DataId name) => HsType name -> HsType name
 sugar = sugarTuples . sugarLists
 
 
-sugarLists :: HsType name -> HsType name
-sugarLists = id
+sugarLists :: forall name. (NamedThing name, DataId name)
+           => HsType name -> HsType name
+sugarLists = everywhere $ mkT (sugarListsStep :: HsType name -> HsType name)
+
+
+sugarListsStep :: NamedThing name => HsType name -> HsType name
+sugarListsStep (HsAppTy (L _ (HsTyVar name)) ltyp)
+    | isBuiltInSyntax name' && strName == "[]" = HsListTy ltyp
+  where
+    name' = getName name
+    strName = occNameString . nameOccName $ name'
+sugarListsStep typ = typ
 
 
 sugarTuples :: HsType name -> HsType name
-- 
cgit v1.2.3


From 060b986c641cd496395b2d13dc316fc84462a7a4 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Wed, 15 Jul 2015 20:25:41 +0200
Subject: Implement tuple syntax sugaring logic for specialized types.

---
 .../src/Haddock/Backends/Xhtml/Specialize.hs       | 36 ++++++++++++++++++++--
 1 file changed, 34 insertions(+), 2 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
index 30501a13..a2cb8799 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
@@ -15,6 +15,7 @@ import Haddock.Syb
 import GHC
 import Name
 
+import Control.Monad
 import Data.Data
 
 
@@ -64,5 +65,36 @@ sugarListsStep (HsAppTy (L _ (HsTyVar name)) ltyp)
 sugarListsStep typ = typ
 
 
-sugarTuples :: HsType name -> HsType name
-sugarTuples = id
+sugarTuples :: forall name. (NamedThing name, DataId name)
+            => HsType name -> HsType name
+sugarTuples = everywhere $
+    mkT (sugarTuplesStep :: HsType name -> HsType name)
+
+
+sugarTuplesStep :: NamedThing name => HsType name -> HsType name
+sugarTuplesStep typ =
+    aux [] typ
+  where
+    aux apps (HsAppTy (L _ ftyp) atyp) = aux (atyp:apps) ftyp
+    aux apps (HsParTy (L _ typ')) = aux apps typ'
+    aux apps (HsTyVar name)
+        | isBuiltInSyntax name' && suitable = HsTupleTy HsBoxedTuple apps
+      where
+        name' = getName name
+        strName = occNameString . nameOccName $ name'
+        suitable = case parseTupleArity strName of
+            Just arity -> arity == length apps
+            Nothing -> False
+    aux _ _ = typ
+
+
+parseTupleArity :: String -> Maybe Int
+parseTupleArity ('(':commas) = do
+    n <- parseCommas commas
+    guard $ n /= 0
+    return $ n + 1
+  where
+    parseCommas (',':rest) = (+ 1) <$> parseCommas rest
+    parseCommas ")" = Just 0
+    parseCommas _ = Nothing
+parseTupleArity _ = Nothing
-- 
cgit v1.2.3


From 6be6ca76e9163569ad3bed1441cb9fcfa7df0cec Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Wed, 15 Jul 2015 20:31:48 +0200
Subject: Get rid of code duplication in type specialization module.

---
 .../src/Haddock/Backends/Xhtml/Specialize.hs       | 30 +++++++++-------------
 1 file changed, 12 insertions(+), 18 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
index a2cb8799..50cce3d5 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
@@ -47,32 +47,26 @@ specializeTyVarBndrs bndrs typs =
     bname (KindedTyVar (L _ name) _) = name
 
 
-sugar :: (NamedThing name, DataId name) => HsType name -> HsType name
-sugar = sugarTuples . sugarLists
-
-
-sugarLists :: forall name. (NamedThing name, DataId name)
-           => HsType name -> HsType name
-sugarLists = everywhere $ mkT (sugarListsStep :: HsType name -> HsType name)
+sugar :: forall name. (NamedThing name, DataId name)
+      => HsType name -> HsType name
+sugar =
+    everywhere $ mkT step
+  where
+    step :: HsType name -> HsType name
+    step = sugarTuples . sugarLists
 
 
-sugarListsStep :: NamedThing name => HsType name -> HsType name
-sugarListsStep (HsAppTy (L _ (HsTyVar name)) ltyp)
+sugarLists :: NamedThing name => HsType name -> HsType name
+sugarLists (HsAppTy (L _ (HsTyVar name)) ltyp)
     | isBuiltInSyntax name' && strName == "[]" = HsListTy ltyp
   where
     name' = getName name
     strName = occNameString . nameOccName $ name'
-sugarListsStep typ = typ
-
-
-sugarTuples :: forall name. (NamedThing name, DataId name)
-            => HsType name -> HsType name
-sugarTuples = everywhere $
-    mkT (sugarTuplesStep :: HsType name -> HsType name)
+sugarLists typ = typ
 
 
-sugarTuplesStep :: NamedThing name => HsType name -> HsType name
-sugarTuplesStep typ =
+sugarTuples :: NamedThing name => HsType name -> HsType name
+sugarTuples typ =
     aux [] typ
   where
     aux apps (HsAppTy (L _ ftyp) atyp) = aux (atyp:apps) ftyp
-- 
cgit v1.2.3


From 9edfaa67b6e4c80df43497f24133530d9a822dc6 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Fri, 17 Jul 2015 13:57:28 +0200
Subject: Create scaffolding of a framework for renaming specialized types.

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

(limited to 'haddock-api/src')

diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal
index abe5adbe..2090c53e 100644
--- a/haddock-api/haddock-api.cabal
+++ b/haddock-api/haddock-api.cabal
@@ -43,6 +43,7 @@ library
     , filepath
     , directory
     , containers
+    , transformers
     , deepseq
     , array
     , xhtml >= 3000.2 && < 3000.3
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
index 50cce3d5..1a8446ee 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
@@ -6,7 +6,7 @@
 module Haddock.Backends.Xhtml.Specialize
     ( specialize, specialize'
     , specializeTyVarBndrs
-    , sugar
+    , sugar, rename
     ) where
 
 
@@ -16,7 +16,13 @@ import GHC
 import Name
 
 import Control.Monad
+import Control.Monad.Trans.RWS
+
 import Data.Data
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Set (Set)
+import qualified Data.Set as Set
 
 
 specialize :: (Eq name, Typeable name)
@@ -92,3 +98,92 @@ parseTupleArity ('(':commas) = do
     parseCommas ")" = Just 0
     parseCommas _ = Nothing
 parseTupleArity _ = Nothing
+
+
+rename :: Ord name => HsType name -> HsType name
+rename = fst . evalRWS undefined Map.empty . renameType -- TODO.
+
+
+type Rename name a = RWS (Set name) () (Map name name) a
+
+
+renameType :: Ord name => HsType name -> Rename name (HsType name)
+renameType (HsForAllTy ex mspan lbndrs lctx lt) = do
+    lbndrs' <- renameLTyVarBndrs lbndrs
+    HsForAllTy
+        <$> pure ex
+        <*> pure mspan
+        <*> pure lbndrs'
+        <*> located renameContext lctx
+        <*> renameLType lt
+renameType (HsTyVar name) = HsTyVar <$> renameName name
+renameType (HsAppTy lf la) = HsAppTy <$> renameLType lf <*> renameLType la
+renameType (HsFunTy la lr) = HsFunTy <$> renameLType la <*> renameLType lr
+renameType (HsListTy lt) = HsListTy <$> renameLType lt
+renameType (HsPArrTy lt) = HsPArrTy <$> renameLType lt
+renameType (HsTupleTy srt lt) = HsTupleTy srt <$> mapM renameLType lt
+renameType (HsOpTy la lop lb) = HsOpTy
+    <$> renameLType la
+    <*> pure lop -- TODO.
+    <*> renameLType lb
+renameType (HsParTy lt) = HsParTy <$> renameLType lt
+renameType (HsIParamTy ip lt) = HsIParamTy ip <$> renameLType lt
+renameType (HsEqTy la lb) = HsEqTy <$> renameLType la <*> renameLType lb
+renameType (HsKindSig lt lk) = HsKindSig <$> renameLType lt <*> pure lk
+renameType t@(HsQuasiQuoteTy _) = pure t -- TODO.
+renameType t@(HsSpliceTy _ _) = pure t -- TODO.
+renameType t@(HsDocTy _ _) = pure t -- TODO.
+renameType (HsBangTy bang lt) = HsBangTy bang <$> renameLType lt
+renameType t@(HsRecTy _) = pure t -- TODO.
+renameType t@(HsCoreTy _) = pure t
+renameType t@(HsExplicitListTy _ _) = pure t -- TODO.
+renameType t@(HsExplicitTupleTy _ _) = pure t -- TODO.
+renameType t@(HsTyLit _) = pure t
+renameType (HsWrapTy wrap t) = HsWrapTy wrap <$> renameType t
+renameType HsWildcardTy = pure HsWildcardTy
+renameType t@(HsNamedWildcardTy _) = pure t -- TODO.
+
+
+renameLType :: Ord name => LHsType name -> Rename name (LHsType name)
+renameLType = located renameType
+
+
+renameLTyVarBndrs :: Ord name => LHsTyVarBndrs name -> Rename name (LHsTyVarBndrs name)
+renameLTyVarBndrs lbndrs = do
+    tys' <- mapM (located renameTyVarBndr) $ hsq_tvs lbndrs
+    pure $ lbndrs { hsq_tvs = tys' }
+
+
+renameContext :: Ord name => HsContext name -> Rename name (HsContext name)
+renameContext = mapM $ located renameType
+
+
+renameTyVarBndr :: Ord name => HsTyVarBndr name -> Rename name (HsTyVarBndr name)
+renameTyVarBndr (UserTyVar name) =
+    UserTyVar <$> renameNameBndr name
+renameTyVarBndr (KindedTyVar name kinds) =
+    KindedTyVar <$> located renameNameBndr name <*> pure kinds
+
+
+renameNameBndr :: Ord name => name -> Rename name name
+renameNameBndr name = do
+    fv <- ask
+    when (name `Set.member` fv) $
+        freshName name
+    renameName name
+
+
+renameName :: Ord name => name -> Rename name name
+renameName name = do
+    rnmap <- get
+    pure $ case Map.lookup name rnmap of
+        Just name' -> name'
+        Nothing -> name
+
+
+freshName :: Ord name => name -> Rename name ()
+freshName _ = pure () -- TODO.
+
+
+located :: Functor f => (a -> f b) -> Located a -> f (Located b)
+located f (L loc e) = L loc <$> f e
-- 
cgit v1.2.3


From 51e145b013380965db7fe2a9983a3064cde57eb9 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Fri, 17 Jul 2015 18:47:03 +0200
Subject: Fill in missing cases in specialized type renaming function.

---
 .../src/Haddock/Backends/Xhtml/Specialize.hs       | 26 +++++++++++++---------
 1 file changed, 15 insertions(+), 11 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
index 1a8446ee..c59dd2c8 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
@@ -122,26 +122,26 @@ renameType (HsFunTy la lr) = HsFunTy <$> renameLType la <*> renameLType lr
 renameType (HsListTy lt) = HsListTy <$> renameLType lt
 renameType (HsPArrTy lt) = HsPArrTy <$> renameLType lt
 renameType (HsTupleTy srt lt) = HsTupleTy srt <$> mapM renameLType lt
-renameType (HsOpTy la lop lb) = HsOpTy
-    <$> renameLType la
-    <*> pure lop -- TODO.
-    <*> renameLType lb
+renameType (HsOpTy la lop lb) =
+    HsOpTy <$> renameLType la <*> renameLTyOp lop <*> renameLType lb
 renameType (HsParTy lt) = HsParTy <$> renameLType lt
 renameType (HsIParamTy ip lt) = HsIParamTy ip <$> renameLType lt
 renameType (HsEqTy la lb) = HsEqTy <$> renameLType la <*> renameLType lb
 renameType (HsKindSig lt lk) = HsKindSig <$> renameLType lt <*> pure lk
-renameType t@(HsQuasiQuoteTy _) = pure t -- TODO.
-renameType t@(HsSpliceTy _ _) = pure t -- TODO.
-renameType t@(HsDocTy _ _) = pure t -- TODO.
+renameType t@(HsQuasiQuoteTy _) = pure t
+renameType t@(HsSpliceTy _ _) = pure t
+renameType (HsDocTy lt doc) = HsDocTy <$> renameLType lt <*> pure doc
 renameType (HsBangTy bang lt) = HsBangTy bang <$> renameLType lt
-renameType t@(HsRecTy _) = pure t -- TODO.
+renameType t@(HsRecTy _) = pure t
 renameType t@(HsCoreTy _) = pure t
-renameType t@(HsExplicitListTy _ _) = pure t -- TODO.
-renameType t@(HsExplicitTupleTy _ _) = pure t -- TODO.
+renameType (HsExplicitListTy ph ltys) =
+    HsExplicitListTy ph <$> mapM renameLType ltys
+renameType (HsExplicitTupleTy phs ltys) =
+    HsExplicitTupleTy phs <$> mapM renameLType ltys
 renameType t@(HsTyLit _) = pure t
 renameType (HsWrapTy wrap t) = HsWrapTy wrap <$> renameType t
 renameType HsWildcardTy = pure HsWildcardTy
-renameType t@(HsNamedWildcardTy _) = pure t -- TODO.
+renameType (HsNamedWildcardTy name) = HsNamedWildcardTy <$> renameName name
 
 
 renameLType :: Ord name => LHsType name -> Rename name (LHsType name)
@@ -165,6 +165,10 @@ renameTyVarBndr (KindedTyVar name kinds) =
     KindedTyVar <$> located renameNameBndr name <*> pure kinds
 
 
+renameLTyOp :: Ord name => LHsTyOp name -> Rename name (LHsTyOp name)
+renameLTyOp (wrap, lname) = (,) wrap <$> located renameName lname
+
+
 renameNameBndr :: Ord name => name -> Rename name name
 renameNameBndr name = do
     fv <- ask
-- 
cgit v1.2.3


From 1633853280a22aa1ddf682465eedaa1cf3b6905a Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Fri, 17 Jul 2015 18:51:04 +0200
Subject: Remove code duplication in specialized type renamer.

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

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
index c59dd2c8..a7b7a561 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
@@ -135,9 +135,9 @@ renameType (HsBangTy bang lt) = HsBangTy bang <$> renameLType lt
 renameType t@(HsRecTy _) = pure t
 renameType t@(HsCoreTy _) = pure t
 renameType (HsExplicitListTy ph ltys) =
-    HsExplicitListTy ph <$> mapM renameLType ltys
+    HsExplicitListTy ph <$> renameLTypes ltys
 renameType (HsExplicitTupleTy phs ltys) =
-    HsExplicitTupleTy phs <$> mapM renameLType ltys
+    HsExplicitTupleTy phs <$> renameLTypes ltys
 renameType t@(HsTyLit _) = pure t
 renameType (HsWrapTy wrap t) = HsWrapTy wrap <$> renameType t
 renameType HsWildcardTy = pure HsWildcardTy
@@ -148,16 +148,20 @@ renameLType :: Ord name => LHsType name -> Rename name (LHsType name)
 renameLType = located renameType
 
 
+renameLTypes :: Ord name => [LHsType name] -> Rename name [LHsType name]
+renameLTypes = mapM renameLType
+
+
+renameContext :: Ord name => HsContext name -> Rename name (HsContext name)
+renameContext = renameLTypes
+
+
 renameLTyVarBndrs :: Ord name => LHsTyVarBndrs name -> Rename name (LHsTyVarBndrs name)
 renameLTyVarBndrs lbndrs = do
     tys' <- mapM (located renameTyVarBndr) $ hsq_tvs lbndrs
     pure $ lbndrs { hsq_tvs = tys' }
 
 
-renameContext :: Ord name => HsContext name -> Rename name (HsContext name)
-renameContext = mapM $ located renameType
-
-
 renameTyVarBndr :: Ord name => HsTyVarBndr name -> Rename name (HsTyVarBndr name)
 renameTyVarBndr (UserTyVar name) =
     UserTyVar <$> renameNameBndr name
-- 
cgit v1.2.3


From 4b352b94f07436d45dfcce8070c2f8301218b9ac Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Sat, 18 Jul 2015 19:05:46 +0200
Subject: Change state of the type renaming monad.

---
 .../src/Haddock/Backends/Xhtml/Specialize.hs       | 30 ++++++++++++----------
 1 file changed, 16 insertions(+), 14 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
index a7b7a561..d2a51fac 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
@@ -100,14 +100,14 @@ parseTupleArity ('(':commas) = do
 parseTupleArity _ = Nothing
 
 
-rename :: Ord name => HsType name -> HsType name
+rename :: NamedThing name => HsType name -> HsType name
 rename = fst . evalRWS undefined Map.empty . renameType -- TODO.
 
 
-type Rename name a = RWS (Set name) () (Map name name) a
+type Rename name a = RWS (Set OccName) () (Map Name name) a
 
 
-renameType :: Ord name => HsType name -> Rename name (HsType name)
+renameType :: NamedThing name => HsType name -> Rename name (HsType name)
 renameType (HsForAllTy ex mspan lbndrs lctx lt) = do
     lbndrs' <- renameLTyVarBndrs lbndrs
     HsForAllTy
@@ -144,52 +144,54 @@ renameType HsWildcardTy = pure HsWildcardTy
 renameType (HsNamedWildcardTy name) = HsNamedWildcardTy <$> renameName name
 
 
-renameLType :: Ord name => LHsType name -> Rename name (LHsType name)
+renameLType :: NamedThing name => LHsType name -> Rename name (LHsType name)
 renameLType = located renameType
 
 
-renameLTypes :: Ord name => [LHsType name] -> Rename name [LHsType name]
+renameLTypes :: NamedThing name => [LHsType name] -> Rename name [LHsType name]
 renameLTypes = mapM renameLType
 
 
-renameContext :: Ord name => HsContext name -> Rename name (HsContext name)
+renameContext :: NamedThing name => HsContext name
+              -> Rename name (HsContext name)
 renameContext = renameLTypes
 
 
-renameLTyVarBndrs :: Ord name => LHsTyVarBndrs name -> Rename name (LHsTyVarBndrs name)
+renameLTyVarBndrs :: NamedThing name => LHsTyVarBndrs name -> Rename name (LHsTyVarBndrs name)
 renameLTyVarBndrs lbndrs = do
     tys' <- mapM (located renameTyVarBndr) $ hsq_tvs lbndrs
     pure $ lbndrs { hsq_tvs = tys' }
 
 
-renameTyVarBndr :: Ord name => HsTyVarBndr name -> Rename name (HsTyVarBndr name)
+renameTyVarBndr :: NamedThing name => HsTyVarBndr name
+                -> Rename name (HsTyVarBndr name)
 renameTyVarBndr (UserTyVar name) =
     UserTyVar <$> renameNameBndr name
 renameTyVarBndr (KindedTyVar name kinds) =
     KindedTyVar <$> located renameNameBndr name <*> pure kinds
 
 
-renameLTyOp :: Ord name => LHsTyOp name -> Rename name (LHsTyOp name)
+renameLTyOp :: NamedThing name => LHsTyOp name -> Rename name (LHsTyOp name)
 renameLTyOp (wrap, lname) = (,) wrap <$> located renameName lname
 
 
-renameNameBndr :: Ord name => name -> Rename name name
+renameNameBndr :: NamedThing name => name -> Rename name name
 renameNameBndr name = do
     fv <- ask
-    when (name `Set.member` fv) $
+    when (getOccName name `Set.member` fv) $
         freshName name
     renameName name
 
 
-renameName :: Ord name => name -> Rename name name
+renameName :: NamedThing name => name -> Rename name name
 renameName name = do
     rnmap <- get
-    pure $ case Map.lookup name rnmap of
+    pure $ case Map.lookup (getName name) rnmap of
         Just name' -> name'
         Nothing -> name
 
 
-freshName :: Ord name => name -> Rename name ()
+freshName :: NamedThing name => name -> Rename name ()
 freshName _ = pure () -- TODO.
 
 
-- 
cgit v1.2.3


From d508387d8bca5cdc7e29127ac859f170b66f81df Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Sat, 18 Jul 2015 20:48:48 +0200
Subject: Implement simple mechanism for generating new type names.

---
 .../src/Haddock/Backends/Xhtml/Specialize.hs       | 29 +++++++++++++++++++---
 1 file changed, 26 insertions(+), 3 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
index d2a51fac..2c4c8498 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
@@ -19,6 +19,8 @@ import Control.Monad
 import Control.Monad.Trans.RWS
 
 import Data.Data
+import qualified Data.List as List
+import Data.Maybe
 import Data.Map (Map)
 import qualified Data.Map as Map
 import Data.Set (Set)
@@ -185,14 +187,35 @@ renameNameBndr name = do
 
 renameName :: NamedThing name => name -> Rename name name
 renameName name = do
-    rnmap <- get
-    pure $ case Map.lookup (getName name) rnmap of
+    env <- get
+    pure $ case Map.lookup (getName name) env of
         Just name' -> name'
         Nothing -> name
 
 
 freshName :: NamedThing name => name -> Rename name ()
-freshName _ = pure () -- TODO.
+freshName name = do
+    fv <- ask
+    env <- get
+    let taken = Set.union fv (Set.fromList . map getOccName . Map.keys $ env)
+    let name' = undefined $ findFreshName taken occ
+    put $ Map.insert (getName name) name' env
+  where
+    occ = getOccName name
+
+
+findFreshName :: Set OccName -> OccName -> OccName
+findFreshName taken =
+    fromJust . List.find isFresh . alternativeNames
+  where
+    isFresh = not . flip Set.member taken
+
+
+alternativeNames :: OccName -> [OccName]
+alternativeNames name =
+    [ mkVarOcc $ str ++ show i | i :: Int <- [0..] ]
+  where
+    str = occNameString name
 
 
 located :: Functor f => (a -> f b) -> Located a -> f (Located b)
-- 
cgit v1.2.3


From 0495d71981573cf95f28468c7167b96ffd48ac11 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Sat, 18 Jul 2015 21:02:07 +0200
Subject: Fill in stub behaviour with actual environment renaming.

---
 .../src/Haddock/Backends/Xhtml/Specialize.hs       | 42 ++++++++++++++--------
 1 file changed, 28 insertions(+), 14 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
index 2c4c8498..a9c46463 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
@@ -102,14 +102,27 @@ parseTupleArity ('(':commas) = do
 parseTupleArity _ = Nothing
 
 
-rename :: NamedThing name => HsType name -> HsType name
+class NamedThing name => SetName name where
+
+    setName :: Name -> name -> name
+
+
+setInternalOccName :: SetName name => OccName -> name -> name
+setInternalOccName occ name =
+    setName nname' name
+  where
+    nname = getName name
+    nname' = mkInternalName (nameUnique nname) occ (nameSrcSpan nname)
+
+
+rename :: SetName name => HsType name -> HsType name
 rename = fst . evalRWS undefined Map.empty . renameType -- TODO.
 
 
 type Rename name a = RWS (Set OccName) () (Map Name name) a
 
 
-renameType :: NamedThing name => HsType name -> Rename name (HsType name)
+renameType :: SetName name => HsType name -> Rename name (HsType name)
 renameType (HsForAllTy ex mspan lbndrs lctx lt) = do
     lbndrs' <- renameLTyVarBndrs lbndrs
     HsForAllTy
@@ -146,26 +159,26 @@ renameType HsWildcardTy = pure HsWildcardTy
 renameType (HsNamedWildcardTy name) = HsNamedWildcardTy <$> renameName name
 
 
-renameLType :: NamedThing name => LHsType name -> Rename name (LHsType name)
+renameLType :: SetName name => LHsType name -> Rename name (LHsType name)
 renameLType = located renameType
 
 
-renameLTypes :: NamedThing name => [LHsType name] -> Rename name [LHsType name]
+renameLTypes :: SetName name => [LHsType name] -> Rename name [LHsType name]
 renameLTypes = mapM renameLType
 
 
-renameContext :: NamedThing name => HsContext name
+renameContext :: SetName name => HsContext name
               -> Rename name (HsContext name)
 renameContext = renameLTypes
 
 
-renameLTyVarBndrs :: NamedThing name => LHsTyVarBndrs name -> Rename name (LHsTyVarBndrs name)
+renameLTyVarBndrs :: SetName name => LHsTyVarBndrs name -> Rename name (LHsTyVarBndrs name)
 renameLTyVarBndrs lbndrs = do
     tys' <- mapM (located renameTyVarBndr) $ hsq_tvs lbndrs
     pure $ lbndrs { hsq_tvs = tys' }
 
 
-renameTyVarBndr :: NamedThing name => HsTyVarBndr name
+renameTyVarBndr :: SetName name => HsTyVarBndr name
                 -> Rename name (HsTyVarBndr name)
 renameTyVarBndr (UserTyVar name) =
     UserTyVar <$> renameNameBndr name
@@ -173,11 +186,11 @@ renameTyVarBndr (KindedTyVar name kinds) =
     KindedTyVar <$> located renameNameBndr name <*> pure kinds
 
 
-renameLTyOp :: NamedThing name => LHsTyOp name -> Rename name (LHsTyOp name)
+renameLTyOp :: SetName name => LHsTyOp name -> Rename name (LHsTyOp name)
 renameLTyOp (wrap, lname) = (,) wrap <$> located renameName lname
 
 
-renameNameBndr :: NamedThing name => name -> Rename name name
+renameNameBndr :: SetName name => name -> Rename name name
 renameNameBndr name = do
     fv <- ask
     when (getOccName name `Set.member` fv) $
@@ -185,7 +198,7 @@ renameNameBndr name = do
     renameName name
 
 
-renameName :: NamedThing name => name -> Rename name name
+renameName :: SetName name => name -> Rename name name
 renameName name = do
     env <- get
     pure $ case Map.lookup (getName name) env of
@@ -193,15 +206,16 @@ renameName name = do
         Nothing -> name
 
 
-freshName :: NamedThing name => name -> Rename name ()
+freshName :: SetName name => name -> Rename name ()
 freshName name = do
     fv <- ask
     env <- get
     let taken = Set.union fv (Set.fromList . map getOccName . Map.keys $ env)
-    let name' = undefined $ findFreshName taken occ
-    put $ Map.insert (getName name) name' env
+    let name' = setInternalOccName (findFreshName taken occ) name
+    put $ Map.insert nname name' env
   where
-    occ = getOccName name
+    nname = getName name
+    occ = nameOccName nname
 
 
 findFreshName :: Set OccName -> OccName -> OccName
-- 
cgit v1.2.3


From 2c94f5a7804ecf84f818a64ba41ca5829621323c Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Sun, 19 Jul 2015 15:57:10 +0200
Subject: Fix logic behind binder type renaming.

---
 haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs | 11 +++++++----
 1 file changed, 7 insertions(+), 4 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
index a9c46463..6a149719 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
@@ -193,9 +193,11 @@ renameLTyOp (wrap, lname) = (,) wrap <$> located renameName lname
 renameNameBndr :: SetName name => name -> Rename name name
 renameNameBndr name = do
     fv <- ask
-    when (getOccName name `Set.member` fv) $
-        freshName name
-    renameName name
+    env <- get
+    case Map.lookup (getName name) env of
+        Just name' -> pure name'
+        Nothing | getOccName name `Set.member` fv -> freshName name
+        Nothing -> pure name
 
 
 renameName :: SetName name => name -> Rename name name
@@ -206,13 +208,14 @@ renameName name = do
         Nothing -> name
 
 
-freshName :: SetName name => name -> Rename name ()
+freshName :: SetName name => name -> Rename name name
 freshName name = do
     fv <- ask
     env <- get
     let taken = Set.union fv (Set.fromList . map getOccName . Map.keys $ env)
     let name' = setInternalOccName (findFreshName taken occ) name
     put $ Map.insert nname name' env
+    return name'
   where
     nname = getName name
     occ = nameOccName nname
-- 
cgit v1.2.3


From d5700e1427f7171db0e0e9393aedb734b554459f Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Sun, 19 Jul 2015 18:16:11 +0200
Subject: Add SYB-like utility function for performing stateful queries.

---
 haddock-api/src/Haddock/Syb.hs | 16 +++++++++++++++-
 1 file changed, 15 insertions(+), 1 deletion(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Syb.hs b/haddock-api/src/Haddock/Syb.hs
index 2016b74c..4847e486 100644
--- a/haddock-api/src/Haddock/Syb.hs
+++ b/haddock-api/src/Haddock/Syb.hs
@@ -2,7 +2,7 @@
 
 
 module Haddock.Syb
-    ( everything, everywhere
+    ( everything, everythingWithState, everywhere
     , mkT
     , combine
     ) where
@@ -20,6 +20,20 @@ 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)
 
+
+-- | Perform a query with state on each level of a tree.
+--
+-- This is the same as 'everything' but allows for stateful computations. In
+-- SYB it is called @everythingWithContext@ but I find this name somewhat
+-- nicer.
+everythingWithState :: s -> (r -> r -> r)
+                    -> (forall a. Data a => a -> s -> (r, s))
+                    -> (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)
+
+
 -- | Apply transformation on each level of a tree.
 --
 -- Just like 'everything', this is stolen from SYB package.
-- 
cgit v1.2.3


From 77b628b79bd179e7dde83d44bbea5acb4c0cb043 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Sun, 19 Jul 2015 20:30:06 +0200
Subject: Create function for retrieving free variables from given type.

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

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
index 6a149719..7e568933 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
@@ -159,6 +159,21 @@ renameType HsWildcardTy = pure HsWildcardTy
 renameType (HsNamedWildcardTy name) = HsNamedWildcardTy <$> renameName name
 
 
+freeVariables :: forall name. (NamedThing name, Data (HsType name))
+              => HsType name -> Set OccName
+freeVariables =
+    everythingWithState Set.empty Set.union query
+  where
+    query term ctx = case cast term :: Maybe (HsType name) of
+        Just (HsForAllTy _ _ bndrs _ _) ->
+            (Set.empty, Set.union ctx (bndrsNames bndrs))
+        Just (HsTyVar name)
+            | getName name `Set.member` ctx -> (Set.empty, ctx)
+            | otherwise -> (Set.singleton $ getOccName name, ctx)
+        _ -> (Set.empty, ctx)
+    bndrsNames = Set.fromList . map (getName . tyVarName . unLoc) . hsq_tvs
+
+
 renameLType :: SetName name => LHsType name -> Rename name (LHsType name)
 renameLType = located renameType
 
@@ -237,3 +252,8 @@ alternativeNames name =
 
 located :: Functor f => (a -> f b) -> Located a -> f (Located b)
 located f (L loc e) = L loc <$> f e
+
+
+tyVarName :: HsTyVarBndr name -> name
+tyVarName (UserTyVar name) = name
+tyVarName (KindedTyVar (L _ name) _) = name
-- 
cgit v1.2.3


From 532478bcee19cf465a6a0ad24e05c6a571213c05 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Mon, 20 Jul 2015 12:50:31 +0200
Subject: Fix compilation error caused by incorrect type signature.

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

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
index 7e568933..37632ee7 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
@@ -159,7 +159,7 @@ renameType HsWildcardTy = pure HsWildcardTy
 renameType (HsNamedWildcardTy name) = HsNamedWildcardTy <$> renameName name
 
 
-freeVariables :: forall name. (NamedThing name, Data (HsType name))
+freeVariables :: forall name. (NamedThing name, DataId name)
               => HsType name -> Set OccName
 freeVariables =
     everythingWithState Set.empty Set.union query
-- 
cgit v1.2.3


From 8135ce02b26385a610587abb26775055c5323b31 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Mon, 20 Jul 2015 13:52:21 +0200
Subject: Move `SetName` class definition to types module.

---
 haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs |  6 +-----
 haddock-api/src/Haddock/Types.hs                     | 17 +++++++++++++++++
 2 files changed, 18 insertions(+), 5 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
index 37632ee7..4e68cb7b 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
@@ -11,6 +11,7 @@ module Haddock.Backends.Xhtml.Specialize
 
 
 import Haddock.Syb
+import Haddock.Types
 
 import GHC
 import Name
@@ -102,11 +103,6 @@ parseTupleArity ('(':commas) = do
 parseTupleArity _ = Nothing
 
 
-class NamedThing name => SetName name where
-
-    setName :: Name -> name -> name
-
-
 setInternalOccName :: SetName name => OccName -> name -> name
 setInternalOccName occ name =
     setName nname' name
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 76164b5e..c5ca31c0 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -301,6 +301,23 @@ instance NamedThing DocName where
   getName (Undocumented name) = name
 
 
+class NamedThing name => SetName name where
+
+    setName :: Name -> name -> name
+
+
+instance SetName Name where
+
+    setName name' _ = name'
+
+
+instance SetName DocName where
+
+    setName name' (Documented _ mdl) = Documented name' mdl
+    setName name' (Undocumented _) = Undocumented name'
+
+
+
 -----------------------------------------------------------------------------
 -- * Instances
 -----------------------------------------------------------------------------
-- 
cgit v1.2.3


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

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

(limited to 'haddock-api/src')

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


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

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

(limited to 'haddock-api/src')

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


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

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

(limited to 'haddock-api/src')

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


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

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

(limited to 'haddock-api/src')

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


From f0edea1969cdc06d0299c606debf533d7ece77f0 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Tue, 21 Jul 2015 19:22:30 +0200
Subject: Improve placement of instance methods expander button.

---
 haddock-api/resources/html/Ocean.std-theme/ocean.css | 14 ++++++++++----
 haddock-api/src/Haddock/Backends/Xhtml/Layout.hs     |  6 +++---
 2 files changed, 13 insertions(+), 7 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 9ad9f9d2..428040bc 100644
--- a/haddock-api/resources/html/Ocean.std-theme/ocean.css
+++ b/haddock-api/resources/html/Ocean.std-theme/ocean.css
@@ -146,15 +146,21 @@ ul.links li a {
   background-image: url(plus.gif);
   background-repeat: no-repeat;
 }
-p.caption.collapser,
-p.caption.expander {
-  background-position: 0 0.4em;
-}
 .collapser, .expander {
   padding-left: 14px;
   margin-left: -14px;
   cursor: pointer;
 }
+p.caption.collapser,
+p.caption.expander {
+  background-position: 0 0.4em;
+}
+
+.instance.collapser, .instance.expander {
+  margin-left: 0px;
+  background-position: left center;
+}
+
 
 pre {
   padding: 0.25em;
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
index d971b0e5..460cc6d7 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
@@ -207,11 +207,11 @@ subClsInstance :: String -- ^ Section unique id
                -> [Html] -- ^ Method contents (pretty-printed signatures)
                -> Html
 subClsInstance sid hdr mets =
-    hdrDiv <+> methodDiv
+    (hdrDiv << hdr) <+> (methodDiv << subBlock mets)
   where
     anchorId = makeAnchorId $ "i:" ++ sid
-    hdrDiv = thediv ! collapseControl anchorId False "instance" << hdr
-    methodDiv = thediv ! collapseSection anchorId False [] << subBlock mets
+    hdrDiv = thediv ! collapseControl anchorId False "instance"
+    methodDiv = thediv ! collapseSection anchorId False "methods"
 
 
 subMethods :: [Html] -> Html
-- 
cgit v1.2.3


From aec90be7b95b2116e3c436b91b7c35aec026f6cc Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Tue, 21 Jul 2015 19:44:33 +0200
Subject: Make type renamer first try single-letter names as  alternatives.

---
 haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs | 10 +++++++++-
 1 file changed, 9 insertions(+), 1 deletion(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
index 3b3d95b9..c127ebbd 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
@@ -241,7 +241,15 @@ findFreshName taken =
 
 
 alternativeNames :: OccName -> [OccName]
-alternativeNames name =
+alternativeNames name
+    | [_] <- occNameString name = letterNames ++ alternativeNames' name
+  where
+    letterNames = map (mkVarOcc . pure) ['a'..'z']
+alternativeNames name = alternativeNames' name
+
+
+alternativeNames' :: OccName -> [OccName]
+alternativeNames' name =
     [ mkVarOcc $ str ++ show i | i :: Int <- [0..] ]
   where
     str = occNameString name
-- 
cgit v1.2.3


From 08e592eb55c4f4f86fe824e572517be7e44b2cb8 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Wed, 22 Jul 2015 00:09:10 +0200
Subject: Fix type renamer bug with incorrect names being generated.

---
 .../src/Haddock/Backends/Xhtml/Specialize.hs       | 45 ++++++++++++++--------
 1 file changed, 30 insertions(+), 15 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
index c127ebbd..fccdaa95 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
@@ -16,6 +16,7 @@ import Haddock.Types
 
 import GHC
 import Name
+import FastString
 
 import Control.Monad
 import Control.Monad.Trans.RWS
@@ -104,6 +105,20 @@ parseTupleArity ('(':commas) = do
 parseTupleArity _ = Nothing
 
 
+type NameRep = FastString
+
+getNameRep :: NamedThing name => name -> NameRep
+getNameRep = occNameFS . getOccName
+
+nameRepString :: NameRep -> String
+nameRepString = unpackFS
+
+stringNameRep :: String -> NameRep
+stringNameRep = mkFastString
+
+setInternalNameRep :: SetName name => NameRep -> name -> name
+setInternalNameRep = setInternalOccName . mkVarOccFS
+
 setInternalOccName :: SetName name => OccName -> name -> name
 setInternalOccName occ name =
     setName nname' name
@@ -112,11 +127,11 @@ setInternalOccName occ name =
     nname' = mkInternalName (nameUnique nname) occ (nameSrcSpan nname)
 
 
-rename :: SetName name => Set OccName -> HsType name -> HsType name
+rename :: SetName name => Set NameRep -> HsType name -> HsType name
 rename fv typ = fst $ evalRWS (renameType typ) fv Map.empty
 
 
-type Rename name a = RWS (Set OccName) () (Map Name name) a
+type Rename name a = RWS (Set NameRep) () (Map Name name) a
 
 
 renameType :: SetName name => HsType name -> Rename name (HsType name)
@@ -157,7 +172,7 @@ renameType (HsNamedWildcardTy name) = HsNamedWildcardTy <$> renameName name
 
 
 freeVariables :: forall name. (NamedThing name, DataId name)
-              => HsType name -> Set OccName
+              => HsType name -> Set NameRep
 freeVariables =
     everythingWithState Set.empty Set.union query
   where
@@ -166,7 +181,7 @@ freeVariables =
             (Set.empty, Set.union ctx (bndrsNames bndrs))
         Just (HsTyVar name)
             | getName name `Set.member` ctx -> (Set.empty, ctx)
-            | otherwise -> (Set.singleton $ getOccName name, ctx)
+            | otherwise -> (Set.singleton $ getNameRep name, ctx)
         _ -> (Set.empty, ctx)
     bndrsNames = Set.fromList . map (getName . tyVarName . unLoc) . hsq_tvs
 
@@ -208,7 +223,7 @@ renameNameBndr name = do
     env <- get
     case Map.lookup (getName name) env of
         Just name' -> pure name'
-        Nothing | getOccName name `Set.member` fv -> freshName name
+        Nothing | getNameRep name `Set.member` fv -> freshName name
         Nothing -> pure name
 
 
@@ -224,35 +239,35 @@ freshName :: SetName name => name -> Rename name name
 freshName name = do
     fv <- ask
     env <- get
-    let taken = Set.union fv (Set.fromList . map getOccName . Map.keys $ env)
-    let name' = setInternalOccName (findFreshName taken occ) name
+    let taken = Set.union fv (Set.fromList . map getNameRep . Map.keys $ env)
+    let name' = setInternalNameRep (findFreshName taken occ) name
     put $ Map.insert nname name' env
     return name'
   where
     nname = getName name
-    occ = nameOccName nname
+    occ = getNameRep nname
 
 
-findFreshName :: Set OccName -> OccName -> OccName
+findFreshName :: Set NameRep -> NameRep -> NameRep
 findFreshName taken =
     fromJust . List.find isFresh . alternativeNames
   where
     isFresh = not . flip Set.member taken
 
 
-alternativeNames :: OccName -> [OccName]
+alternativeNames :: NameRep -> [NameRep]
 alternativeNames name
-    | [_] <- occNameString name = letterNames ++ alternativeNames' name
+    | [_] <- nameRepString name = letterNames ++ alternativeNames' name
   where
-    letterNames = map (mkVarOcc . pure) ['a'..'z']
+    letterNames = map (stringNameRep . pure) ['a'..'z']
 alternativeNames name = alternativeNames' name
 
 
-alternativeNames' :: OccName -> [OccName]
+alternativeNames' :: NameRep -> [NameRep]
 alternativeNames' name =
-    [ mkVarOcc $ str ++ show i | i :: Int <- [0..] ]
+    [ stringNameRep $ str ++ show i | i :: Int <- [0..] ]
   where
-    str = occNameString name
+    str = nameRepString name
 
 
 located :: Functor f => (a -> f b) -> Located a -> f (Located b)
-- 
cgit v1.2.3


From 0e3a90b9a1935a69b48dfb5906c346dd12c43ec1 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Wed, 22 Jul 2015 15:55:59 +0200
Subject: Add some documentation and refactor type specialization module.

---
 .../src/Haddock/Backends/Xhtml/Specialize.hs       | 95 +++++++++++++++++-----
 1 file changed, 74 insertions(+), 21 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
index fccdaa95..1da089d9 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
@@ -30,23 +30,31 @@ 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 $ specializeStep name details)
+specialize name details =
+    everywhere $ mkT step
+  where
+    step (HsTyVar name') | name == name' = details
+    step typ = typ
 
 
+-- | Instantiate all occurrences of given names with corresponding types.
+--
+-- It is just a convenience function wrapping 'specialize' that supports more
+-- that one specialization.
 specialize' :: (Eq name, Typeable name)
             => Data a
             => [(name, HsType name)] -> a -> a
 specialize' = flip $ foldr (uncurry specialize)
 
 
-specializeStep :: Eq name => name -> HsType name -> HsType name -> HsType name
-specializeStep name details (HsTyVar name') | name == name' = details
-specializeStep _ _ typ = typ
-
-
+-- | Instantiate given binders with corresponding types.
+--
+-- Again, it is just a convenience function around 'specialize'. Note that
+-- length of type list should be the same as the number of binders.
 specializeTyVarBndrs :: (Eq name, Typeable name, DataId name)
                      => LHsTyVarBndrs name -> [HsType name]
                      -> HsType name -> HsType name
@@ -58,6 +66,12 @@ specializeTyVarBndrs bndrs typs =
     bname (KindedTyVar (L _ name) _) = name
 
 
+-- | Make given type use tuple and list literals where appropriate.
+--
+-- After applying 'specialize' function some terms may not use idiomatic list
+-- and tuple literals resulting in types like @[] a@ or @(,,) a b c@. This
+-- can be fixed using 'sugar' function, that will turn such types into @[a]@
+-- and @(a, b, c)@.
 sugar :: forall name. (NamedThing name, DataId name)
       => HsType name -> HsType name
 sugar =
@@ -93,6 +107,19 @@ sugarTuples typ =
     aux _ _ = typ
 
 
+-- | Compute arity of given tuple operator.
+--
+-- >>> parseTupleArity "(,,)"
+-- Just 3
+--
+-- >>> parseTupleArity "(,,,,)"
+-- Just 5
+--
+-- >>> parseTupleArity "abc"
+-- Nothing
+--
+-- >>> parseTupleArity "()"
+-- Nothing
 parseTupleArity :: String -> Maybe Int
 parseTupleArity ('(':commas) = do
     n <- parseCommas commas
@@ -105,6 +132,17 @@ parseTupleArity ('(':commas) = do
 parseTupleArity _ = Nothing
 
 
+-- | Haskell AST type representation.
+--
+-- This type is used for renaming (more below), essentially the ambiguous (!)
+-- version of 'Name'. So, why is this 'FastString' instead of 'OccName'? Well,
+-- it was 'OccName' before, but turned out that 'OccName' sometimes also
+-- contains namespace information, differentiating visually same types.
+--
+-- And 'FastString' is used because it is /visual/ part of 'OccName' - it is
+-- not converted to 'String' or alike to avoid new allocations. Additionally,
+-- since it is stored mostly in 'Set', fast comparison of 'FastString' is also
+-- quite nice.
 type NameRep = FastString
 
 getNameRep :: NamedThing name => name -> NameRep
@@ -127,10 +165,39 @@ setInternalOccName occ name =
     nname' = mkInternalName (nameUnique nname) occ (nameSrcSpan nname)
 
 
+-- | Compute set of free variables of given type.
+freeVariables :: forall name. (NamedThing name, DataId name)
+              => HsType name -> Set NameRep
+freeVariables =
+    everythingWithState Set.empty Set.union query
+  where
+    query term ctx = case cast term :: Maybe (HsType name) of
+        Just (HsForAllTy _ _ bndrs _ _) ->
+            (Set.empty, Set.union ctx (bndrsNames bndrs))
+        Just (HsTyVar name)
+            | getName name `Set.member` ctx -> (Set.empty, ctx)
+            | otherwise -> (Set.singleton $ getNameRep name, ctx)
+        _ -> (Set.empty, ctx)
+    bndrsNames = Set.fromList . map (getName . tyVarName . unLoc) . hsq_tvs
+
+
+-- | Make given type visually unambiguous.
+--
+-- After applying 'specialize' method, some free type variables may become
+-- visually ambiguous - for example, having @a -> b@ and specializing @a@ to
+-- @(a -> b)@ we get @(a -> b) -> b@ where first occurrence of @b@ refers to
+-- different type variable than latter one. Applying 'rename' function
+-- will fix that type to be visually unambiguous again (making it something
+-- like @(a -> c) -> b@).
 rename :: SetName name => Set NameRep -> HsType name -> HsType name
 rename fv typ = fst $ evalRWS (renameType typ) fv Map.empty
 
 
+-- | Renaming monad.
+--
+-- This is just a simple RWS instance, where /reader/ part consists of names
+-- that are initially taken and cannot change, /state/ part is just context
+-- with name bindings and /writer/ part is not used.
 type Rename name a = RWS (Set NameRep) () (Map Name name) a
 
 
@@ -171,21 +238,6 @@ renameType HsWildcardTy = pure HsWildcardTy
 renameType (HsNamedWildcardTy name) = HsNamedWildcardTy <$> renameName name
 
 
-freeVariables :: forall name. (NamedThing name, DataId name)
-              => HsType name -> Set NameRep
-freeVariables =
-    everythingWithState Set.empty Set.union query
-  where
-    query term ctx = case cast term :: Maybe (HsType name) of
-        Just (HsForAllTy _ _ bndrs _ _) ->
-            (Set.empty, Set.union ctx (bndrsNames bndrs))
-        Just (HsTyVar name)
-            | getName name `Set.member` ctx -> (Set.empty, ctx)
-            | otherwise -> (Set.singleton $ getNameRep name, ctx)
-        _ -> (Set.empty, ctx)
-    bndrsNames = Set.fromList . map (getName . tyVarName . unLoc) . hsq_tvs
-
-
 renameLType :: SetName name => LHsType name -> Rename name (LHsType name)
 renameLType = located renameType
 
@@ -235,6 +287,7 @@ renameName name = do
         Nothing -> name
 
 
+-- | Generate fresh occurrence name, put it into context and return.
 freshName :: SetName name => name -> Rename name name
 freshName name = do
     fv <- ask
-- 
cgit v1.2.3


From dfb697b2d41319a6c14134edcd89da2fa49ecd99 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Wed, 22 Jul 2015 17:20:28 +0200
Subject: Fix another bug where type renamer was generating incorrect names.

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

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
index 1da089d9..47a96b34 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
@@ -292,7 +292,7 @@ freshName :: SetName name => name -> Rename name name
 freshName name = do
     fv <- ask
     env <- get
-    let taken = Set.union fv (Set.fromList . map getNameRep . Map.keys $ env)
+    let taken = Set.union fv (Set.fromList . map getNameRep . Map.elems $ env)
     let name' = setInternalNameRep (findFreshName taken occ) name
     put $ Map.insert nname name' env
     return name'
-- 
cgit v1.2.3


From 3f404ba3c1b36212ae7507874aefb1e8cc107dd8 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Wed, 22 Jul 2015 18:46:10 +0200
Subject: Refactor type renamer to rebinding and pure renaming phases.

---
 .../src/Haddock/Backends/Xhtml/Specialize.hs       | 105 ++++++++++++---------
 1 file changed, 60 insertions(+), 45 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
index 47a96b34..69cd939b 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE Rank2Types #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RecordWildCards #-}
 
 
 module Haddock.Backends.Xhtml.Specialize
@@ -19,7 +20,8 @@ import Name
 import FastString
 
 import Control.Monad
-import Control.Monad.Trans.RWS
+import Control.Monad.Trans.Reader
+import Control.Monad.Trans.State
 
 import Data.Data
 import qualified Data.List as List
@@ -190,20 +192,26 @@ freeVariables =
 -- 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 = fst $ evalRWS (renameType typ) fv Map.empty
+rename fv typ = runReader (renameType typ) $ RenameEnv
+    { rneFV = fv
+    , rneCtx = Map.empty
+    }
 
 
 -- | Renaming monad.
---
--- This is just a simple RWS instance, where /reader/ part consists of names
--- that are initially taken and cannot change, /state/ part is just context
--- with name bindings and /writer/ part is not used.
-type Rename name a = RWS (Set NameRep) () (Map Name name) a
+type Rename name = Reader (RenameEnv name)
+
+-- | Binding generation monad.
+type Rebind name = State (RenameEnv name)
+
+data RenameEnv name = RenameEnv
+    { rneFV :: Set NameRep
+    , rneCtx :: Map Name name
+    }
 
 
 renameType :: SetName name => HsType name -> Rename name (HsType name)
-renameType (HsForAllTy ex mspan lbndrs lctx lt) = do
-    lbndrs' <- renameLTyVarBndrs lbndrs
+renameType (HsForAllTy ex mspan lbndrs lctx lt) = rebind lbndrs $ \lbndrs' ->
     HsForAllTy
         <$> pure ex
         <*> pure mspan
@@ -246,66 +254,73 @@ renameLTypes :: SetName name => [LHsType name] -> Rename name [LHsType name]
 renameLTypes = mapM renameLType
 
 
-renameContext :: SetName name => HsContext name
-              -> Rename name (HsContext name)
+renameContext :: SetName name => HsContext name -> Rename name (HsContext name)
 renameContext = renameLTypes
 
 
-renameLTyVarBndrs :: SetName name => LHsTyVarBndrs name -> Rename name (LHsTyVarBndrs name)
-renameLTyVarBndrs lbndrs = do
-    tys' <- mapM (located renameTyVarBndr) $ hsq_tvs lbndrs
-    pure $ lbndrs { hsq_tvs = tys' }
-
-
-renameTyVarBndr :: SetName name => HsTyVarBndr name
-                -> Rename name (HsTyVarBndr name)
-renameTyVarBndr (UserTyVar name) =
-    UserTyVar <$> renameNameBndr name
-renameTyVarBndr (KindedTyVar name kinds) =
-    KindedTyVar <$> located renameNameBndr name <*> pure kinds
-
-
 renameLTyOp :: SetName name => LHsTyOp name -> Rename name (LHsTyOp name)
 renameLTyOp (wrap, lname) = (,) wrap <$> located renameName lname
 
 
-renameNameBndr :: SetName name => name -> Rename name name
-renameNameBndr name = do
-    fv <- ask
-    env <- get
-    case Map.lookup (getName name) env of
-        Just name' -> pure name'
-        Nothing | getNameRep name `Set.member` fv -> freshName name
-        Nothing -> pure name
-
-
 renameName :: SetName name => name -> Rename name name
 renameName name = do
-    env <- get
-    pure $ case Map.lookup (getName name) env of
+    RenameEnv { rneCtx = ctx } <- ask
+    pure $ case Map.lookup (getName name) ctx of
         Just name' -> name'
         Nothing -> name
 
 
+rebind :: SetName name
+       => LHsTyVarBndrs name -> (LHsTyVarBndrs name -> Rename name a)
+       -> Rename name a
+rebind lbndrs action = do
+    (lbndrs', env') <- runState (rebindLTyVarBndrs lbndrs) <$> ask
+    local (const env') (action lbndrs')
+
+
+rebindLTyVarBndrs :: SetName name
+                  => LHsTyVarBndrs name -> Rebind name (LHsTyVarBndrs name)
+rebindLTyVarBndrs lbndrs = do
+    tys' <- mapM (located rebindTyVarBndr) $ hsq_tvs lbndrs
+    pure $ lbndrs { hsq_tvs = tys' }
+
+
+rebindTyVarBndr :: SetName name
+                => HsTyVarBndr name -> Rebind name (HsTyVarBndr name)
+rebindTyVarBndr (UserTyVar name) =
+    UserTyVar <$> rebindName name
+rebindTyVarBndr (KindedTyVar name kinds) =
+    KindedTyVar <$> located rebindName name <*> pure kinds
+
+
+rebindName :: SetName name => name -> Rebind name name
+rebindName name = do
+    RenameEnv { .. } <- get
+    case Map.lookup (getName name) rneCtx of
+        Just name' -> pure name'
+        Nothing | getNameRep name `Set.member` rneFV -> freshName name
+        Nothing -> pure name
+
+
 -- | Generate fresh occurrence name, put it into context and return.
-freshName :: SetName name => name -> Rename name name
+freshName :: SetName name => name -> Rebind name name
 freshName name = do
-    fv <- ask
-    env <- get
-    let taken = Set.union fv (Set.fromList . map getNameRep . Map.elems $ env)
-    let name' = setInternalNameRep (findFreshName taken occ) name
-    put $ Map.insert nname name' env
+    env@RenameEnv { .. } <- get
+    let taken = Set.union rneFV (elems' rneCtx)
+    let name' = setInternalNameRep (findFreshName taken rep) name
+    put $ env { rneCtx = Map.insert nname name' rneCtx }
     return name'
   where
+    elems' = Set.fromList . map getNameRep . Map.elems
     nname = getName name
-    occ = getNameRep nname
+    rep = getNameRep nname
 
 
 findFreshName :: Set NameRep -> NameRep -> NameRep
 findFreshName taken =
     fromJust . List.find isFresh . alternativeNames
   where
-    isFresh = not . flip Set.member taken
+    isFresh = not . Set.member taken
 
 
 alternativeNames :: NameRep -> [NameRep]
-- 
cgit v1.2.3


From bea9253315b8b5beb6f66896eaceda92800ab32f Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Wed, 22 Jul 2015 19:21:27 +0200
Subject: Fix unwitting compilation bug.

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

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
index 69cd939b..78af98b8 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
@@ -320,7 +320,7 @@ findFreshName :: Set NameRep -> NameRep -> NameRep
 findFreshName taken =
     fromJust . List.find isFresh . alternativeNames
   where
-    isFresh = not . Set.member taken
+    isFresh = not . flip Set.member taken
 
 
 alternativeNames :: NameRep -> [NameRep]
-- 
cgit v1.2.3


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

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

(limited to 'haddock-api/src')

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


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

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

(limited to 'haddock-api/src')

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


From 17b91bbf8eea72548e58952f4969606b5cb7b73f Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Thu, 23 Jul 2015 19:42:08 +0200
Subject: Fix declaration converter to use more appropriate mode for methods.

---
 haddock-api/src/Haddock/Convert.hs | 22 ++++++++++++----------
 1 file changed, 12 insertions(+), 10 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 3479780a..2c88dca6 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -391,16 +391,18 @@ synifyKindSig k = synifyType WithinType k
 
 synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead Name
 synifyInstHead (tyvars, preds, cls, types) = InstHead
-  { ihdClsName = getName cls
-  , ihdKinds = map (unLoc . synifyType WithinType) ks
-  , ihdTypes = map (unLoc . synifyType WithinType) ts
-  , ihdInstType = ClassInst
-      { clsiCtx = map (unLoc . synifyType WithinType) preds
-      , clsiTyVars = synifyTyVars tyvars
-      , clsiSigs = map (synifyIdSig WithinType) $ classMethods cls
-      }
-  }
-  where (ks,ts) = break (not . isKind) types
+    { ihdClsName = getName cls
+    , ihdKinds = map (unLoc . synifyType WithinType) ks
+    , ihdTypes = map (unLoc . synifyType WithinType) ts
+    , ihdInstType = ClassInst
+        { clsiCtx = map (unLoc . synifyType WithinType) preds
+        , clsiTyVars = synifyTyVars tyvars
+        , clsiSigs = map synifyClsIdSig $ classMethods cls
+        }
+    }
+  where
+    (ks,ts) = break (not . isKind) types
+    synifyClsIdSig = synifyIdSig DeleteTopLevelQuantification
 
 -- Convert a family instance, this could be a type family or data family
 synifyFamInst :: FamInst -> Bool -> Either ErrMsg (InstHead Name)
-- 
cgit v1.2.3


From 351eea4c53c23258d1628c91ac42d9f82e1f9c94 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Fri, 24 Jul 2015 14:51:32 +0200
Subject: Fix bug with types not being specialized at all.

---
 haddock-api/src/Haddock/Convert.hs | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 2c88dca6..00a90e97 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -390,13 +390,13 @@ synifyKindSig :: Kind -> LHsKind Name
 synifyKindSig k = synifyType WithinType k
 
 synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead Name
-synifyInstHead (tyvars, preds, cls, types) = InstHead
+synifyInstHead (_, preds, cls, types) = InstHead
     { ihdClsName = getName cls
     , ihdKinds = map (unLoc . synifyType WithinType) ks
     , ihdTypes = map (unLoc . synifyType WithinType) ts
     , ihdInstType = ClassInst
         { clsiCtx = map (unLoc . synifyType WithinType) preds
-        , clsiTyVars = synifyTyVars tyvars
+        , clsiTyVars = synifyTyVars $ classTyVars cls
         , clsiSigs = map synifyClsIdSig $ classMethods cls
         }
     }
-- 
cgit v1.2.3


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

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

(limited to 'haddock-api/src')

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


From a66852d67fa3a035eaa255880fb82f6f499d7e39 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Fri, 24 Jul 2015 18:40:48 +0200
Subject: Fix another type renamer bug where not all names were rebound.

---
 haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs | 9 ++++++++-
 1 file changed, 8 insertions(+), 1 deletion(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
index 78af98b8..38ec7d44 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
@@ -299,7 +299,7 @@ rebindName name = do
     case Map.lookup (getName name) rneCtx of
         Just name' -> pure name'
         Nothing | getNameRep name `Set.member` rneFV -> freshName name
-        Nothing -> pure name
+        Nothing -> reuseName name
 
 
 -- | Generate fresh occurrence name, put it into context and return.
@@ -316,6 +316,13 @@ freshName name = do
     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
+
+
 findFreshName :: Set NameRep -> NameRep -> NameRep
 findFreshName taken =
     fromJust . List.find isFresh . alternativeNames
-- 
cgit v1.2.3


From fb62902d37e9467364bbbafc9e06128be89a7277 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Fri, 24 Jul 2015 19:32:22 +0200
Subject: Fix yet another renamer bug where some names were not unique.

---
 haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs | 14 +++++++++++---
 1 file changed, 11 insertions(+), 3 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
index 38ec7d44..a8a4e8ec 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
@@ -296,9 +296,10 @@ rebindTyVarBndr (KindedTyVar name kinds) =
 rebindName :: SetName name => name -> Rebind name name
 rebindName name = do
     RenameEnv { .. } <- get
+    taken <- takenNames
     case Map.lookup (getName name) rneCtx of
         Just name' -> pure name'
-        Nothing | getNameRep name `Set.member` rneFV -> freshName name
+        Nothing | getNameRep name `Set.member` taken -> freshName name
         Nothing -> reuseName name
 
 
@@ -306,12 +307,11 @@ rebindName name = do
 freshName :: SetName name => name -> Rebind name name
 freshName name = do
     env@RenameEnv { .. } <- get
-    let taken = Set.union rneFV (elems' rneCtx)
+    taken <- takenNames
     let name' = setInternalNameRep (findFreshName taken rep) name
     put $ env { rneCtx = Map.insert nname name' rneCtx }
     return name'
   where
-    elems' = Set.fromList . map getNameRep . Map.elems
     nname = getName name
     rep = getNameRep nname
 
@@ -323,6 +323,14 @@ reuseName name = do
     return name
 
 
+takenNames :: NamedThing name => Rebind name (Set NameRep)
+takenNames = do
+    RenameEnv { .. } <- get
+    return $ Set.union rneFV (ctxElems rneCtx)
+  where
+    ctxElems = Set.fromList . map getNameRep . Map.elems
+
+
 findFreshName :: Set NameRep -> NameRep -> NameRep
 findFreshName taken =
     fromJust . List.find isFresh . alternativeNames
-- 
cgit v1.2.3


From f0a5efd72072b37a2150efd281eb158033e67585 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Tue, 28 Jul 2015 23:34:03 +0200
Subject: Split instance subsection layout method to top-level declarations.

---
 haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 27 +++++++++++++++++++-----
 1 file changed, 22 insertions(+), 5 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
index 460cc6d7..da03985e 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
@@ -206,12 +206,29 @@ subClsInstance :: String -- ^ Section unique id
                -> Html -- ^ Header contents (instance name and type)
                -> [Html] -- ^ Method contents (pretty-printed signatures)
                -> Html
-subClsInstance sid hdr mets =
-    (hdrDiv << hdr) <+> (methodDiv << subBlock mets)
+subClsInstance iid hdr mets = subInstHead iid hdr <+> subInstMethods iid mets
+
+
+subInstHead :: String -- ^ Instance unique id (for anchor generation)
+            -> Html -- ^ Header content (instance name and type)
+            -> Html
+subInstHead iid hdr =
+    expander << hdr
   where
-    anchorId = makeAnchorId $ "i:" ++ sid
-    hdrDiv = thediv ! collapseControl anchorId False "instance"
-    methodDiv = thediv ! collapseSection anchorId False "methods"
+    expander = thediv ! collapseControl (instAnchorId iid) False "instance"
+
+
+subInstMethods :: String -- ^ Instance unique id (for anchor generation)
+               -> [Html] -- ^ Method contents (pretty-printed signatures)
+               -> Html
+subInstMethods iid mets =
+    section << subBlock mets
+  where
+    section = thediv ! collapseSection (instAnchorId iid) False "methods"
+
+
+instAnchorId :: String -> String
+instAnchorId iid = makeAnchorId $ "i:" ++ iid
 
 
 subMethods :: [Html] -> Html
-- 
cgit v1.2.3


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

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

(limited to 'haddock-api/src')

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


From 17e6df0835457035c7837e6d3f149bb3d448e5d7 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Wed, 29 Jul 2015 00:01:56 +0200
Subject: Get rid of no longer used layout method.

---
 haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 12 ++----------
 1 file changed, 2 insertions(+), 10 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
index 0b09e220..a1c54c99 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
@@ -31,7 +31,7 @@ module Haddock.Backends.Xhtml.Layout (
   subConstructors,
   subEquations,
   subFields,
-  subInstances, subClsInstance, subInstHead, subInstMethods,
+  subInstances, subInstHead, subInstMethods,
   subMethods,
   subMinimal,
 
@@ -200,15 +200,7 @@ subInstances qual nm lnks splice = maybe noHtml wrap . instTable
     subCaption = paragraph ! collapseControl id_ True "caption" << "Instances"
     id_ = makeAnchorId $ "i:" ++ nm
 
-
--- | Generate class instance div with specialized methods.
-subClsInstance :: String -- ^ Section unique id
-               -> Html -- ^ Header contents (instance name and type)
-               -> [Html] -- ^ Method contents (pretty-printed signatures)
-               -> Html
-subClsInstance iid hdr mets = subInstHead iid hdr <+> subInstMethods iid mets
-
-
+ 
 subInstHead :: String -- ^ Instance unique id (for anchor generation)
             -> Html -- ^ Header content (instance name and type)
             -> Html
-- 
cgit v1.2.3


From 467b07ecf9b22e3492b014dbae64f2f7d9b73f02 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Wed, 29 Jul 2015 00:23:36 +0200
Subject: Attach section title to the instance methods block.

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

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
index a1c54c99..117f8fc8 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
@@ -214,7 +214,7 @@ subInstMethods :: String -- ^ Instance unique id (for anchor generation)
                -> [Html] -- ^ Method contents (pretty-printed signatures)
                -> Html
 subInstMethods iid mets =
-    section << subBlock mets
+    section << subMethods mets
   where
     section = thediv ! collapseSection (instAnchorId iid) False "methods"
 
-- 
cgit v1.2.3


From 0c34ec0ae515d88437e04a49ca0131205be096e5 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Wed, 29 Jul 2015 12:07:13 +0200
Subject: Attach associated types information to instance header.

---
 haddock-api/src/Haddock/Backends/LaTeX.hs   | 2 +-
 haddock-api/src/Haddock/Convert.hs          | 3 +++
 haddock-api/src/Haddock/Interface/Rename.hs | 9 +++++----
 haddock-api/src/Haddock/Types.hs            | 1 +
 4 files changed, 10 insertions(+), 5 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 47087911..24779a94 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -562,7 +562,7 @@ ppInstDecl unicode instHead = keyword "instance" <+> ppInstHead unicode instHead
 
 ppInstHead :: Bool -> InstHead DocName -> LaTeX
 ppInstHead unicode (InstHead {..}) = case ihdInstType of
-    ClassInst ctx _ _ -> ppContextNoLocs ctx unicode <+> typ
+    ClassInst ctx _ _ _ -> ppContextNoLocs ctx unicode <+> typ
     TypeInst rhs -> keyword "type" <+> typ <+> tibody rhs
     DataInst _ -> error "data instances not supported by --latex yet"
   where
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 00a90e97..a2716d92 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -398,6 +398,9 @@ synifyInstHead (_, preds, cls, types) = InstHead
         { clsiCtx = map (unLoc . synifyType WithinType) preds
         , clsiTyVars = synifyTyVars $ classTyVars cls
         , clsiSigs = map synifyClsIdSig $ classMethods cls
+        , clsiAssocTys = do
+            (Right (FamDecl fam)) <- map (synifyTyCon Nothing) $ classATs cls
+            pure fam
         }
     }
   where
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 4e4d3ed9..82d14a2c 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -264,10 +264,11 @@ renameInstHead InstHead {..} = do
   kinds <- mapM renameType ihdKinds
   types <- mapM renameType ihdTypes
   itype <- case ihdInstType of
-    ClassInst ctx bndrs sigs -> ClassInst
-        <$> mapM renameType ctx
-        <*> renameLTyVarBndrs bndrs
-        <*> mapM renameSig sigs
+    ClassInst { .. } -> ClassInst
+        <$> mapM renameType clsiCtx
+        <*> renameLTyVarBndrs clsiTyVars
+        <*> mapM renameSig clsiSigs
+        <*> mapM renameFamilyDecl clsiAssocTys
     TypeInst  ts -> TypeInst  <$> traverse renameType ts
     DataInst  dd -> DataInst  <$> renameTyClD dd
   return InstHead
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index b4a41020..ac073036 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -328,6 +328,7 @@ data InstType name
       { clsiCtx :: [HsType name]
       , clsiTyVars :: LHsTyVarBndrs name
       , clsiSigs :: [Sig name]
+      , clsiAssocTys :: [FamilyDecl name]
       }
   | TypeInst  (Maybe (HsType name)) -- ^ Body (right-hand side)
   | DataInst (TyClDecl name)        -- ^ Data constructors
-- 
cgit v1.2.3


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

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

(limited to 'haddock-api/src')

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


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

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

(limited to 'haddock-api/src')

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


From de395700afa73065a2ec69ba5e3cc3ec1a474d11 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Wed, 29 Jul 2015 15:13:26 +0200
Subject: Introduce alternative type for family declarations.

---
 haddock-api/src/Haddock/Types.hs | 31 +++++++++++++++++++++++++++++++
 1 file changed, 31 insertions(+)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index ac073036..90672c9d 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -341,6 +341,37 @@ instance OutputableBndr a => Outputable (InstType a) where
   ppr (TypeInst  a) = text "TypeInst"  <+> ppr a
   ppr (DataInst  a) = text "DataInst"  <+> ppr a
 
+
+-- | Almost the same as 'FamilyDecl' except for type binders.
+--
+-- In order to perform type specialization for class instances, we need to
+-- substitute class variables to appropriate type. However, type variables in
+-- associated type are specified using 'LHsTyVarBndrs' instead of 'HsType'.
+-- This makes type substitution impossible and to overcome this issue,
+-- 'PseudoFamilyDecl' type is introduced.
+data PseudoFamilyDecl name = PseudoFamilyDecl
+    { pfdInfo :: FamilyInfo name
+    , pfdLName :: Located name
+    , pfdTyVars :: [LHsType name]
+    , pfdKindSig :: Maybe (LHsKind name)
+    }
+
+
+mkPseudoFamilyDecl :: FamilyDecl name -> PseudoFamilyDecl name
+mkPseudoFamilyDecl (FamilyDecl { .. }) = PseudoFamilyDecl
+    { pfdInfo = fdInfo
+    , pfdLName = fdLName
+    , pfdTyVars = [ L loc (mkType bndr) | L loc bndr <- hsq_tvs fdTyVars ]
+    , pfdKindSig = fdKindSig
+    }
+  where
+    mkType (KindedTyVar (L loc name) lkind) =
+        HsKindSig tvar lkind
+      where
+        tvar = L loc (HsTyVar name)
+    mkType (UserTyVar name) = HsTyVar name
+
+
 -- | An instance head that may have documentation and a source location.
 type DocInstance name = (InstHead name, Maybe (MDoc name), Located name)
 
-- 
cgit v1.2.3


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

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

(limited to 'haddock-api/src')

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


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

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

(limited to 'haddock-api/src')

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


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

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

(limited to 'haddock-api/src')

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


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

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

(limited to 'haddock-api/src')

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


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

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

(limited to 'haddock-api/src')

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


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

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

(limited to 'haddock-api/src')

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


From e3b0be8daf6f9fc8adad3d858f80187d3de74876 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Wed, 29 Jul 2015 19:45:15 +0200
Subject: Add some documentation for instance head specializer.

---
 haddock-api/src/Haddock/Interface/Specialize.hs | 2 ++
 1 file changed, 2 insertions(+)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index df7f63bc..59985de6 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -88,6 +88,8 @@ specializeSig bndrs typs (TypeSig lnames (L loc typ) prn) =
 specializeSig _ _ sig = sig
 
 
+-- | Make all details of instance head (signatures, associated types)
+-- specialized to that particular instance type.
 specializeInstHead :: (Eq name, Typeable name, DataId name, SetName name)
                    => InstHead name -> InstHead name
 specializeInstHead ihd@InstHead { ihdInstType = clsi@ClassInst { .. }, .. } =
-- 
cgit v1.2.3


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

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

(limited to 'haddock-api/src')

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


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

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

(limited to 'haddock-api/src')

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


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

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

(limited to 'haddock-api/src')

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


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

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

(limited to 'haddock-api/src')

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


From c537853ff7574a6bf3c3c94fa9db52aa23a5859f Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Mon, 3 Aug 2015 15:29:35 +0200
Subject: Fix issue with instance expander hijacking type hyperlink click.

---
 haddock-api/resources/html/Ocean.std-theme/ocean.css | 2 ++
 haddock-api/src/Haddock/Backends/Xhtml/Layout.hs     | 4 ++--
 2 files changed, 4 insertions(+), 2 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 428040bc..139335ac 100644
--- a/haddock-api/resources/html/Ocean.std-theme/ocean.css
+++ b/haddock-api/resources/html/Ocean.std-theme/ocean.css
@@ -159,6 +159,8 @@ p.caption.expander {
 .instance.collapser, .instance.expander {
   margin-left: 0px;
   background-position: left center;
+  min-width: 9px;
+  min-height: 9px;
 }
 
 
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
index 074b6801..d624a1d0 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
@@ -205,9 +205,9 @@ subInstHead :: String -- ^ Instance unique id (for anchor generation)
             -> Html -- ^ Header content (instance name and type)
             -> Html
 subInstHead iid hdr =
-    expander << hdr
+    expander noHtml <+> hdr
   where
-    expander = thediv ! collapseControl (instAnchorId iid) False "instance"
+    expander = thespan ! collapseControl (instAnchorId iid) False "instance"
 
 
 subInstDetails :: String -- ^ Instance unique id (for anchor generation)
-- 
cgit v1.2.3


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

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

(limited to 'haddock-api/src')

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


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

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

(limited to 'haddock-api/src')

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


From 809a24cc74b4ca23e69f2f4a857e31c5a440b436 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Wed, 5 Aug 2015 21:30:59 +0200
Subject: Add basic support for sugaring infix type operators.

---
 haddock-api/src/Haddock/Interface/Specialize.hs | 8 +++++++-
 1 file changed, 7 insertions(+), 1 deletion(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index 59985de6..ddae2b93 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -116,7 +116,7 @@ sugar =
     everywhere $ mkT step
   where
     step :: HsType name -> HsType name
-    step = sugarTuples . sugarLists
+    step = sugarOperators . sugarTuples . sugarLists
 
 
 sugarLists :: NamedThing name => HsType name -> HsType name
@@ -145,6 +145,12 @@ sugarTuples typ =
     aux _ _ = typ
 
 
+sugarOperators :: NamedThing name => HsType name -> HsType name
+sugarOperators (HsAppTy (L _ (HsAppTy (L loc (HsTyVar name)) la)) lb)
+    | isSymOcc $ getOccName name = mkHsOpTy la (L loc name) lb
+sugarOperators typ = typ
+
+
 -- | Compute arity of given tuple operator.
 --
 -- >>> parseTupleArity "(,,)"
-- 
cgit v1.2.3


From ac1894067ce7bc5c34f1cd4d70c9e7fbeb6ae6dc Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Thu, 6 Aug 2015 13:10:09 +0200
Subject: Add support for sugaring built-in function syntax.

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

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index ddae2b93..d6466570 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -147,7 +147,10 @@ sugarTuples typ =
 
 sugarOperators :: NamedThing name => HsType name -> HsType name
 sugarOperators (HsAppTy (L _ (HsAppTy (L loc (HsTyVar name)) la)) lb)
-    | isSymOcc $ getOccName name = mkHsOpTy la (L loc name) lb
+    | isSymOcc $ getOccName name' = mkHsOpTy la (L loc name) lb
+    | isBuiltInSyntax name' && getOccString name == "(->)" = HsFunTy la lb
+  where
+    name' = getName name
 sugarOperators typ = typ
 
 
-- 
cgit v1.2.3


From d4a48a121abb581611f4dd21a5c80d19cc5cf712 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Fri, 7 Aug 2015 16:11:30 +0200
Subject: Remove default methods from Hoogle class output.

---
 haddock-api/src/Haddock/Backends/Hoogle.hs | 6 +++++-
 1 file changed, 5 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 914e3466..f174ebcf 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -20,6 +20,8 @@ import InstEnv (ClsInst(..))
 import Haddock.GhcUtils
 import Haddock.Types hiding (Version)
 import Haddock.Utils hiding (out)
+
+import Bag
 import GHC
 import Outputable
 
@@ -154,9 +156,11 @@ ppSig dflags x  = ppSigWithDoc dflags x []
 
 -- note: does not yet output documentation for class methods
 ppClass :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String]
-ppClass dflags x subdocs = out dflags x{tcdSigs=[]} :
+ppClass dflags x subdocs = out dflags decl' :
             concatMap (flip (ppSigWithDoc dflags) subdocs . addContext . unL) (tcdSigs x)
     where
+        decl' = x { tcdSigs = [], tcdMeths = emptyBag }
+
         addContext (TypeSig name (L l sig) nwcs) = TypeSig name (L l $ f sig) nwcs
         addContext (MinimalSig src sig) = MinimalSig src sig
         addContext _ = error "expected TypeSig"
-- 
cgit v1.2.3


From 19205c89ea272faf3db38f9d3e219342db260efb Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Fri, 7 Aug 2015 17:06:58 +0200
Subject: Add fixity declarations in Hoogle backend output.

---
 haddock-api/src/Haddock/Backends/Hoogle.hs | 8 +++++++-
 1 file changed, 7 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 f174ebcf..04f266af 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -28,6 +28,7 @@ import Outputable
 import Data.Char
 import Data.List
 import Data.Maybe
+import qualified Data.Map as Map
 import Data.Version
 import System.FilePath
 import System.IO
@@ -57,7 +58,8 @@ ppModule dflags iface =
   "" : ppDocumentation dflags (ifaceDoc iface) ++
   ["module " ++ moduleString (ifaceMod iface)] ++
   concatMap (ppExport dflags) (ifaceExportItems iface) ++
-  concatMap (ppInstance dflags) (ifaceInstances iface)
+  concatMap (ppInstance dflags) (ifaceInstances iface) ++
+  concatMap (ppFixity dflags) (Map.toList $ ifaceFixMap iface)
 
 
 ---------------------------------------------------------------------
@@ -234,6 +236,10 @@ ppCtor dflags dat subdocs con
             ResTyGADT _ x -> x
 
 
+ppFixity :: DynFlags -> (Name, Fixity) -> [String]
+ppFixity dflags (name, fixity) = [out dflags (FixitySig [noLoc name] fixity)]
+
+
 ---------------------------------------------------------------------
 -- DOCUMENTATION
 
-- 
cgit v1.2.3


From d070abf3e2348d02f8698c653ca2247e913d222e Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Fri, 7 Aug 2015 18:29:55 +0200
Subject: Fix bug with incorrect fixities being generated in Hoogle backend.

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

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 04f266af..cd015c03 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -28,7 +28,6 @@ import Outputable
 import Data.Char
 import Data.List
 import Data.Maybe
-import qualified Data.Map as Map
 import Data.Version
 import System.FilePath
 import System.IO
@@ -58,8 +57,7 @@ ppModule dflags iface =
   "" : ppDocumentation dflags (ifaceDoc iface) ++
   ["module " ++ moduleString (ifaceMod iface)] ++
   concatMap (ppExport dflags) (ifaceExportItems iface) ++
-  concatMap (ppInstance dflags) (ifaceInstances iface) ++
-  concatMap (ppFixity dflags) (Map.toList $ ifaceFixMap iface)
+  concatMap (ppInstance dflags) (ifaceInstances iface)
 
 
 ---------------------------------------------------------------------
@@ -124,6 +122,7 @@ ppExport :: DynFlags -> ExportItem Name -> [String]
 ppExport dflags ExportDecl { expItemDecl    = L _ decl
                            , expItemMbDoc   = (dc, _)
                            , expItemSubDocs = subdocs
+                           , expItemFixities = fixities
                            } = ppDocumentation dflags dc ++ f decl
     where
         f (TyClD d@DataDecl{})  = ppData dflags d subdocs
@@ -131,8 +130,10 @@ ppExport dflags ExportDecl { expItemDecl    = L _ decl
         f (TyClD d@ClassDecl{}) = ppClass dflags d subdocs
         f (ForD (ForeignImport name typ _ _)) = ppSig dflags $ TypeSig [name] typ []
         f (ForD (ForeignExport name typ _ _)) = ppSig dflags $ TypeSig [name] typ []
-        f (SigD sig) = ppSig dflags sig
+        f (SigD sig) = ppSig dflags sig ++ ppFixities
         f _ = []
+
+        ppFixities = concatMap (ppFixity dflags) fixities
 ppExport _ _ = []
 
 ppSigWithDoc :: DynFlags -> Sig Name -> [(Name, DocForDecl Name)] -> [String]
-- 
cgit v1.2.3


From ff8464058e226f3f2cdf7df4b0f395ba826d5190 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Mon, 10 Aug 2015 14:05:23 +0200
Subject: Improve class type family declarations output in Hoogle backend.

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

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index cd015c03..0a174fd6 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -159,10 +159,17 @@ ppSig dflags x  = ppSigWithDoc dflags x []
 
 -- note: does not yet output documentation for class methods
 ppClass :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String]
-ppClass dflags x subdocs = out dflags decl' :
-            concatMap (flip (ppSigWithDoc dflags) subdocs . addContext . unL) (tcdSigs x)
+ppClass dflags decl subdocs = (out dflags decl' ++ " " ++ ppTyFams) : ppMethods
     where
-        decl' = x { tcdSigs = [], tcdMeths = emptyBag }
+        decl' = decl
+            { tcdSigs = [], tcdMeths = emptyBag
+            , tcdATs = [], tcdATDefs = []
+            }
+
+        ppMethods = concat . map (ppSig' . unLoc) $ tcdSigs decl
+        ppSig' = flip (ppSigWithDoc dflags) subdocs . addContext
+
+        ppTyFams = showSDocUnqual dflags . whereWrapper . map ppr $ tcdATs decl
 
         addContext (TypeSig name (L l sig) nwcs) = TypeSig name (L l $ f sig) nwcs
         addContext (MinimalSig src sig) = MinimalSig src sig
@@ -171,8 +178,8 @@ ppClass dflags x subdocs = out dflags decl' :
         f (HsForAllTy a b c con d) = HsForAllTy a b c (reL (context : unLoc con)) d
         f t = HsForAllTy Implicit Nothing emptyHsQTvs (reL [context]) (reL t)
 
-        context = nlHsTyConApp (tcdName x)
-            (map (reL . HsTyVar . hsTyVarName . unL) (hsQTvBndrs (tyClDeclTyVars x)))
+        context = nlHsTyConApp (tcdName decl)
+            (map (reL . HsTyVar . hsTyVarName . unL) (hsQTvBndrs (tyClDeclTyVars decl)))
 
 
 ppInstance :: DynFlags -> ClsInst -> [String]
@@ -369,3 +376,11 @@ escape = concatMap f
         f '>' = "&gt;"
         f '&' = "&amp;"
         f x = [x]
+
+
+semiSeparate :: [SDoc] -> SDoc
+semiSeparate = sep . punctuate semi
+
+
+whereWrapper :: [SDoc] -> SDoc
+whereWrapper xs = text "where" <+> braces (space <> semiSeparate xs <> space)
-- 
cgit v1.2.3


From fbfd09c8bf12b6991fb0aab24bf01e272f89a131 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Mon, 10 Aug 2015 14:38:43 +0200
Subject: Add missing default family equations in Hoogle output.

---
 haddock-api/src/Haddock/Backends/Hoogle.hs | 14 +++++++++++++-
 1 file changed, 13 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 0a174fd6..71e7cbc4 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -24,6 +24,7 @@ import Haddock.Utils hiding (out)
 import Bag
 import GHC
 import Outputable
+import NameSet
 
 import Data.Char
 import Data.List
@@ -169,7 +170,10 @@ ppClass dflags decl subdocs = (out dflags decl' ++ " " ++ ppTyFams) : ppMethods
         ppMethods = concat . map (ppSig' . unLoc) $ tcdSigs decl
         ppSig' = flip (ppSigWithDoc dflags) subdocs . addContext
 
-        ppTyFams = showSDocUnqual dflags . whereWrapper . map ppr $ tcdATs decl
+        ppTyFams = showSDocUnqual dflags . whereWrapper $ concat
+            [ map ppr (tcdATs decl)
+            , map (ppr . tyFamEqnToSyn . unLoc) (tcdATDefs decl)
+            ]
 
         addContext (TypeSig name (L l sig) nwcs) = TypeSig name (L l $ f sig) nwcs
         addContext (MinimalSig src sig) = MinimalSig src sig
@@ -181,6 +185,14 @@ ppClass dflags decl subdocs = (out dflags decl' ++ " " ++ ppTyFams) : ppMethods
         context = nlHsTyConApp (tcdName decl)
             (map (reL . HsTyVar . hsTyVarName . unL) (hsQTvBndrs (tyClDeclTyVars decl)))
 
+        tyFamEqnToSyn :: TyFamDefltEqn Name -> TyClDecl Name
+        tyFamEqnToSyn tfe = SynDecl
+            { tcdLName = tfe_tycon tfe
+            , tcdTyVars = tfe_pats tfe
+            , tcdRhs = tfe_rhs tfe
+            , tcdFVs = emptyNameSet
+            }
+
 
 ppInstance :: DynFlags -> ClsInst -> [String]
 ppInstance dflags x =
-- 
cgit v1.2.3


From 45d72d1d46dda593823bd6aedf860d18d60f3ab2 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Mon, 10 Aug 2015 16:04:08 +0200
Subject: Improve formatting of class details output in Hoogle backend.

---
 haddock-api/src/Haddock/Backends/Hoogle.hs | 15 +++++++++------
 1 file changed, 9 insertions(+), 6 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 71e7cbc4..f4f5be90 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -175,6 +175,12 @@ ppClass dflags decl subdocs = (out dflags decl' ++ " " ++ ppTyFams) : ppMethods
             , map (ppr . tyFamEqnToSyn . unLoc) (tcdATDefs decl)
             ]
 
+        whereWrapper elems = vcat'
+            [ text "where" <+> lbrace
+            , nest 4 . vcat . map (<> semi) $ elems
+            , rbrace
+            ]
+
         addContext (TypeSig name (L l sig) nwcs) = TypeSig name (L l $ f sig) nwcs
         addContext (MinimalSig src sig) = MinimalSig src sig
         addContext _ = error "expected TypeSig"
@@ -390,9 +396,6 @@ escape = concatMap f
         f x = [x]
 
 
-semiSeparate :: [SDoc] -> SDoc
-semiSeparate = sep . punctuate semi
-
-
-whereWrapper :: [SDoc] -> SDoc
-whereWrapper xs = text "where" <+> braces (space <> semiSeparate xs <> space)
+-- | Just like 'vcat' but uses '($+$)' instead of '($$)'.
+vcat' :: [SDoc] -> SDoc
+vcat' = foldr ($+$) empty
-- 
cgit v1.2.3


From ac10a4ccbe416e8612c6ca49b9f19c3a6f4cf25f Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Mon, 10 Aug 2015 16:14:18 +0200
Subject: Fix weird-looking Hoogle output for familyless classes.

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

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index f4f5be90..f6ad9808 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -160,7 +160,7 @@ ppSig dflags x  = ppSigWithDoc dflags x []
 
 -- note: does not yet output documentation for class methods
 ppClass :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String]
-ppClass dflags decl subdocs = (out dflags decl' ++ " " ++ ppTyFams) : ppMethods
+ppClass dflags decl subdocs = (out dflags decl' ++ ppTyFams) : ppMethods
     where
         decl' = decl
             { tcdSigs = [], tcdMeths = emptyBag
@@ -170,10 +170,12 @@ ppClass dflags decl subdocs = (out dflags decl' ++ " " ++ ppTyFams) : ppMethods
         ppMethods = concat . map (ppSig' . unLoc) $ tcdSigs decl
         ppSig' = flip (ppSigWithDoc dflags) subdocs . addContext
 
-        ppTyFams = showSDocUnqual dflags . whereWrapper $ concat
-            [ map ppr (tcdATs decl)
-            , map (ppr . tyFamEqnToSyn . unLoc) (tcdATDefs decl)
-            ]
+        ppTyFams
+            | null $ tcdATs decl = ""
+            | otherwise = (" " ++) . showSDocUnqual dflags . whereWrapper $ concat
+                [ map ppr (tcdATs decl)
+                , map (ppr . tyFamEqnToSyn . unLoc) (tcdATDefs decl)
+                ]
 
         whereWrapper elems = vcat'
             [ text "where" <+> lbrace
-- 
cgit v1.2.3


From 33e89b2b4719f0dd1cd416c7d20d610be504910c Mon Sep 17 00:00:00 2001
From: Herbert Valerio Riedel <hvr@gnu.org>
Date: Mon, 22 Dec 2014 17:51:52 +0100
Subject: Bump versions for ghc-7.11

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

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs
index d5762ce8..4f4218c9 100644
--- a/haddock-api/src/Haddock/InterfaceFile.hs
+++ b/haddock-api/src/Haddock/InterfaceFile.hs
@@ -78,7 +78,7 @@ binaryInterfaceMagic = 0xD0Cface
 -- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion]
 --
 binaryInterfaceVersion :: Word16
-#if (__GLASGOW_HASKELL__ >= 709) && (__GLASGOW_HASKELL__ < 711)
+#if (__GLASGOW_HASKELL__ >= 711) && (__GLASGOW_HASKELL__ < 713)
 binaryInterfaceVersion = 27
 
 binaryInterfaceVersionCompatibility :: [Word16]
diff --git a/haddock.cabal b/haddock.cabal
index 71b78347..6b5a8044 100644
--- a/haddock.cabal
+++ b/haddock.cabal
@@ -59,7 +59,7 @@ executable haddock
       array,
       xhtml >= 3000.2 && < 3000.3,
       Cabal >= 1.10,
-      ghc >= 7.9 && < 7.12,
+      ghc >= 7.11 && < 7.13,
       bytestring,
       transformers
 
-- 
cgit v1.2.3


From 7e49f55580ffb701944603983b41873649bb35f6 Mon Sep 17 00:00:00 2001
From: Simon Peyton Jones <simonpj@microsoft.com>
Date: Tue, 23 Dec 2014 15:22:56 +0000
Subject: Eliminate instanceHead' in favour of GHC's instanceSig

This is made possible by the elimination of "silent superclass
parameters" in GHC
---
 haddock-api/src/Haddock/Interface/AttachInstances.hs | 16 +---------------
 1 file changed, 1 insertion(+), 15 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 e2fd24ee..21569374 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -82,7 +82,7 @@ attachToExportItem expInfo iface ifaceMap instIfaceMap export =
                           , 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 = [ (instanceHead' i, getName i) | i <- cls_instances ]
+                          | let is = [ (instanceSig i, getName i) | i <- cls_instances ]
                           , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is
                           , not $ isInstanceHidden expInfo cls tys
                           ]
@@ -131,20 +131,6 @@ instLookup f name iface ifaceMap instIfaceMap =
       iface' <- Map.lookup (nameModule name) ifaceMaps
       Map.lookup name (f iface')
 
--- | Like GHC's 'instanceHead' but drops "silent" arguments.
-instanceHead' :: ClsInst -> ([TyVar], ThetaType, Class, [Type])
-instanceHead' ispec = (tvs, dropSilentArgs dfun theta, cls, tys)
-  where
-    dfun = is_dfun ispec
-    (tvs, cls, tys) = instanceHead ispec
-    (_, theta, _) = tcSplitSigmaTy (idType dfun)
-
--- | Drop "silent" arguments. See GHC Note [Silent superclass
--- arguments].
-dropSilentArgs :: DFunId -> ThetaType -> ThetaType
-dropSilentArgs dfun theta = drop (dfunNSilent dfun) theta
-
-
 -- | 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]))
-- 
cgit v1.2.3


From 85ea110309c23509817a26aad7dd6d072f9f732b Mon Sep 17 00:00:00 2001
From: Simon Peyton Jones <simonpj@microsoft.com>
Date: Tue, 6 Jan 2015 16:37:47 +0000
Subject: Remove redundant constraints from haddock, discovered by
 -fwarn-redundant-constraints

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

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs
index 1bb04ed3..afb5111e 100644
--- a/haddock-api/src/Haddock/Interface.hs
+++ b/haddock-api/src/Haddock/Interface.hs
@@ -239,6 +239,6 @@ buildHomeLinks ifaces = foldl upd Map.empty (reverse ifaces)
 --------------------------------------------------------------------------------
 
 
-withTempDir :: (ExceptionMonad m, MonadIO m) => FilePath -> m a -> m a
+withTempDir :: (ExceptionMonad m) => FilePath -> m a -> m a
 withTempDir dir = gbracket_ (liftIO $ createDirectory dir)
                             (liftIO $ removeDirectoryRecursive dir)
-- 
cgit v1.2.3


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

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

(limited to 'haddock-api/src')

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


From 20e56de6316d6e251975aa5a4ce39d48e5bf6798 Mon Sep 17 00:00:00 2001
From: Simon Peyton Jones <simonpj@microsoft.com>
Date: Fri, 1 May 2015 09:36:47 +0100
Subject: Track change in API of TyCon

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

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index c9664652..2bd111d6 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -339,8 +339,9 @@ synifyType :: SynifyTypeState -> Type -> LHsType Name
 synifyType _ (TyVarTy tv) = noLoc $ HsTyVar (getName tv)
 synifyType _ (TyConApp tc tys)
   -- Use non-prefix tuple syntax where possible, because it looks nicer.
-  | isTupleTyCon tc, tyConArity tc == length tys =
-     noLoc $ HsTupleTy (case tupleTyConSort tc of
+  | Just sort <- tyConTuple_maybe tc
+  , tyConArity tc == length tys
+  = noLoc $ HsTupleTy (case sort of
                           BoxedTuple      -> HsBoxedTuple
                           ConstraintTuple -> HsConstraintTuple
                           UnboxedTuple    -> HsUnboxedTuple)
-- 
cgit v1.2.3


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

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

(limited to 'haddock-api/src')

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


From 53ae59ff35fefacff28823f5b7c9e86535cbf024 Mon Sep 17 00:00:00 2001
From: Simon Peyton Jones <simonpj@microsoft.com>
Date: Wed, 13 May 2015 12:04:21 +0100
Subject: Track the new location of setRdrNameSpace

---
 haddock-api/src/Haddock/Interface/LexParseRn.hs | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs
index 14826eaa..0f6add36 100644
--- a/haddock-api/src/Haddock/Interface/LexParseRn.hs
+++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs
@@ -28,7 +28,8 @@ import Haddock.Interface.ParseModuleHeader
 import Haddock.Parser
 import Haddock.Types
 import Name
-import Outputable (showPpr)
+import RdrHsSyn   ( setRdrNameSpace )
+import Outputable ( showPpr )
 import RdrName
 import RnEnv (dataTcOccs)
 
-- 
cgit v1.2.3


From 75a23ec042888ba5387ad653b74fe170a6721784 Mon Sep 17 00:00:00 2001
From: Alan Zimmerman <alan.zimm@gmail.com>
Date: Mon, 25 May 2015 17:14:01 +0200
Subject: ApiAnnotations : strings in warnings do not return SourceText

The strings used in a WARNING pragma are captured via

strings :: { Located ([AddAnn],[Located FastString]) }
    : STRING { sL1 $1 ([],[L (gl $1) (getSTRING $1)]) }
..

The STRING token has a method getSTRINGs that returns the original
source text for a string.

A warning of the form

{-# WARNING Logic
          , mkSolver
          , mkSimpleSolver
          , mkSolverForLogic
          , solverSetParams
          , solverPush
          , solverPop
          , solverReset
          , solverGetNumScopes
          , solverAssertCnstr
          , solverAssertAndTrack
          , solverCheck
          , solverCheckAndGetModel
          , solverGetReasonUnknown
          "New Z3 API support is still incomplete and fragile: \
          \you may experience segmentation faults!"
  #-}

returns the concatenated warning string rather than the original source.
---
 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 0599151e..8b4605a7 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -164,7 +164,7 @@ mkAliasMap dflags mRenamedSource =
         return $
           (lookupModuleDyn dflags
              (fmap Module.fsToPackageKey $
-              ideclPkgQual impDecl)
+              fmap snd $ ideclPkgQual impDecl)
              (case ideclName impDecl of SrcLoc.L _ name -> name),
            alias))
         impDecls
@@ -200,8 +200,8 @@ moduleWarning dflags gre (WarnAll w) = Just $ parseWarning dflags gre w
 
 parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> Doc Name
 parseWarning dflags gre w = force $ case w of
-  DeprecatedTxt _ msg -> format "Deprecated: " (concatFS $ map unLoc msg)
-  WarningTxt    _ msg -> format "Warning: "    (concatFS $ map unLoc msg)
+  DeprecatedTxt _ msg -> format "Deprecated: " (concatFS $ map (snd . unLoc) msg)
+  WarningTxt    _ msg -> format "Warning: "    (concatFS $ map (snd . unLoc) msg)
   where
     format x xs = DocWarning . DocParagraph . DocAppend (DocString x)
                   . processDocString dflags gre $ HsDocString xs
-- 
cgit v1.2.3


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

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

Reviewers: simonpj, austin

Reviewed By: austin

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

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

(limited to 'haddock-api/src')

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


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

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

(limited to 'haddock-api/src')

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


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

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

(limited to 'haddock-api/src')

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


From 81653061d333a1e7d6024e132b1a72a947b9b0ab Mon Sep 17 00:00:00 2001
From: Alan Zimmerman <alan.zimm@gmail.com>
Date: Sun, 26 Jul 2015 22:19:40 +0200
Subject: Replace (SourceText,FastString) with WithSourceText data type

Phab:D907 introduced SourceText for a number of data types, by replacing
FastString with (SourceText,FastString). Since this has an Outputable
instance, no warnings are generated when ppr is called on it, but
unexpected output is generated. See Phab:D1096 for an example of this.

Replace the (SourceText,FastString) tuples with a new data type

data WithSourceText = WithSourceText SourceText FastString

Trac ticket: #10692
---
 haddock-api/src/Haddock/Interface/Create.hs | 7 ++++---
 1 file changed, 4 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 8b4605a7..d8f49edc 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -48,6 +48,7 @@ import Bag
 import RdrName
 import TcRnTypes
 import FastString (concatFS)
+import BasicTypes ( StringLiteral(..) )
 import qualified Outputable as O
 
 -- | Use a 'TypecheckedModule' to produce an 'Interface'.
@@ -164,7 +165,7 @@ mkAliasMap dflags mRenamedSource =
         return $
           (lookupModuleDyn dflags
              (fmap Module.fsToPackageKey $
-              fmap snd $ ideclPkgQual impDecl)
+              fmap sl_fs $ ideclPkgQual impDecl)
              (case ideclName impDecl of SrcLoc.L _ name -> name),
            alias))
         impDecls
@@ -200,8 +201,8 @@ moduleWarning dflags gre (WarnAll w) = Just $ parseWarning dflags gre w
 
 parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> Doc Name
 parseWarning dflags gre w = force $ case w of
-  DeprecatedTxt _ msg -> format "Deprecated: " (concatFS $ map (snd . unLoc) msg)
-  WarningTxt    _ msg -> format "Warning: "    (concatFS $ map (snd . unLoc) msg)
+  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
-- 
cgit v1.2.3


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

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

(limited to 'haddock-api/src')

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


From df0988170814b5e5e0e9015eb28c249b08a2d6de Mon Sep 17 00:00:00 2001
From: Eric Seidel <gridaphobe@gmail.com>
Date: Thu, 4 Jun 2015 20:29:56 -0700
Subject: account for changes to ipClass

---
 haddock-api/src/Haddock/Convert.hs | 5 ++---
 1 file changed, 2 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 7a8b1acb..24947876 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -29,14 +29,13 @@ import HsSyn
 import Kind ( splitKindFunTys, synTyConResKind, isKind )
 import Name
 import PatSyn
-import PrelNames (ipClassName)
 import SrcLoc ( Located, noLoc, unLoc, noSrcSpan )
 import TcType ( tcSplitSigmaTy )
 import TyCon
 import Type (isStrLitTy, mkFunTys)
 import TypeRep
 import TysPrim ( alphaTyVars )
-import TysWiredIn ( listTyConName, eqTyCon )
+import TysWiredIn ( listTyConName, eqTyCon, ipTyCon )
 import Unique ( getUnique )
 import Var
 
@@ -350,7 +349,7 @@ synifyType _ (TyConApp tc tys)
   | getName tc == listTyConName, [ty] <- tys =
      noLoc $ HsListTy (synifyType WithinType ty)
   -- ditto for implicit parameter tycons
-  | tyConName tc == ipClassName
+  | tc == ipTyCon
   , [name, ty] <- tys
   , Just x <- isStrLitTy name
   = noLoc $ HsIParamTy (HsIPName x) (synifyType WithinType ty)
-- 
cgit v1.2.3


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

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

(limited to 'haddock-api/src')

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


From 5aac8c97051760f4a13566c636a739f109acc4e1 Mon Sep 17 00:00:00 2001
From: Richard Eisenberg <eir@cis.upenn.edu>
Date: Mon, 21 Sep 2015 12:00:47 -0400
Subject: React to refactoring CoAxiom branch lists.

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

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index cf8b8243..b7aefd09 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -173,7 +173,7 @@ synifyTyCon coax tc
               ClosedSynFamilyTyCon mb -> case mb of
                   Just (CoAxiom { co_ax_branches = branches })
                           -> return $ ClosedTypeFamily $ Just $
-                               brListMap (noLoc . synifyAxBranch tc) branches
+                               map (noLoc . synifyAxBranch tc) (fromBranches branches)
                   Nothing -> return $ ClosedTypeFamily $ Just []
               BuiltInSynFamTyCon {}
                 -> return $ ClosedTypeFamily $ Just []
-- 
cgit v1.2.3


From 7a569775a5b10abed758b207e86c404034d543f4 Mon Sep 17 00:00:00 2001
From: "Edward Z. Yang" <ezyang@cs.stanford.edu>
Date: Sat, 25 Jul 2015 17:44:41 -0700
Subject: Track msHsFilePath change.

Signed-off-by: Edward Z. Yang <ezyang@cs.stanford.edu>
---
 haddock-api/src/Haddock/Interface/Create.hs | 4 +++-
 1 file changed, 3 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 d8f49edc..169dad7a 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -130,7 +130,9 @@ createInterface tm flags modMap instIfaceMap = do
 
   return $! Interface {
     ifaceMod             = mdl
-  , ifaceOrigFilename    = msHsFilePath ms
+  , ifaceOrigFilename    = case msHsFilePath ms of
+                            Just path -> path
+                            Nothing -> "(none)"
   , ifaceInfo            = info
   , ifaceDoc             = Documentation mbDoc modWarn
   , ifaceRnDoc           = Documentation Nothing Nothing
-- 
cgit v1.2.3


From cda84b49bfb0e17557eddd9178267d3ee0d9b343 Mon Sep 17 00:00:00 2001
From: Tamar Christina <tamar@zhox.com>
Date: Sat, 26 Sep 2015 16:23:00 +0200
Subject: Create Process: removed PhaseFailed

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

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 8f327b09..b87c4cf5 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -121,11 +121,8 @@ handleGhcExceptions =
   -- error messages propagated as exceptions
   handleGhcException $ \e -> do
     hFlush stdout
-    case e of
-      PhaseFailed _ code -> exitWith code
-      _ -> do
-        print (e :: GhcException)
-        exitFailure
+    print (e :: GhcException)
+    exitFailure
 
 
 -------------------------------------------------------------------------------
-- 
cgit v1.2.3


From 319acdd0c70d21c517aa09b3e35f87e9bc01ad8c Mon Sep 17 00:00:00 2001
From: "Edward Z. Yang" <ezyang@cs.stanford.edu>
Date: Sun, 11 Oct 2015 11:31:11 -0700
Subject: s/PackageKey/UnitId/g and s/packageKey/unitId/g

Signed-off-by: Edward Z. Yang <ezyang@cs.stanford.edu>
---
 haddock-api/src/Haddock.hs                       |  6 +++---
 haddock-api/src/Haddock/Backends/Xhtml.hs        |  2 +-
 haddock-api/src/Haddock/Backends/Xhtml/Layout.hs |  2 +-
 haddock-api/src/Haddock/Backends/Xhtml/Types.hs  |  2 +-
 haddock-api/src/Haddock/Interface/Create.hs      | 10 +++++-----
 haddock-api/src/Haddock/InterfaceFile.hs         | 13 ++++++++-----
 haddock-api/src/Haddock/ModuleTree.hs            |  6 +++---
 7 files changed, 22 insertions(+), 19 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index b87c4cf5..ef873500 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -255,8 +255,8 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do
     allVisibleIfaces = [ i | i <- allIfaces, OptHide `notElem` instOptions i ]
 
     pkgMod           = ifaceMod (head ifaces)
-    pkgKey           = modulePackageKey pkgMod
-    pkgStr           = Just (packageKeyString pkgKey)
+    pkgKey           = moduleUnitId pkgMod
+    pkgStr           = Just (unitIdString pkgKey)
     pkgNameVer       = modulePackageInfo dflags flags pkgMod
 
     (srcBase, srcModule, srcEntity, srcLEntity) = sourceUrls flags
@@ -353,7 +353,7 @@ modulePackageInfo dflags flags modu =
     cmdline <|> pkgDb
   where
     cmdline = (,) <$> optPackageName flags <*> optPackageVersion flags
-    pkgDb = (\pkg -> (packageName pkg, packageVersion pkg)) <$> lookupPackage dflags (modulePackageKey modu)
+    pkgDb = (\pkg -> (packageName pkg, packageVersion pkg)) <$> lookupPackage dflags (moduleUnitId modu)
 
 
 -------------------------------------------------------------------------------
diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index e5e4db3f..a1e4f94d 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -304,7 +304,7 @@ mkNode qual ss p (Node s leaf pkg srcPkg short ts) =
 
     htmlModule = thespan ! modAttrs << (cBtn +++
       if leaf
-        then ppModule (mkModule (stringToPackageKey (fromMaybe "" pkg))
+        then ppModule (mkModule (stringToUnitId (fromMaybe "" pkg))
                                        (mkModuleName mdl))
         else toHtml s
       )
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
index d624a1d0..d24ed9c4 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
@@ -271,7 +271,7 @@ links ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice (Documented n m
         -- TODO: do something about type instances. They will point to
         -- the module defining the type family, which is wrong.
         origMod = nameModule n
-        origPkg = modulePackageKey origMod
+        origPkg = moduleUnitId origMod
 
         fname = case loc of
           RealSrcSpan l -> unpackFS (srcSpanFile l)
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Types.hs b/haddock-api/src/Haddock/Backends/Xhtml/Types.hs
index 3d1db887..d1561791 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Types.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Types.hs
@@ -23,7 +23,7 @@ import GHC
 
 
 -- the base, module and entity URLs for the source code and wiki links.
-type SourceURLs = (Maybe FilePath, Maybe FilePath, Map PackageKey FilePath, Map PackageKey FilePath)
+type SourceURLs = (Maybe FilePath, Maybe FilePath, Map UnitId FilePath, Map UnitId FilePath)
 type WikiURLs = (Maybe FilePath, Maybe FilePath, Maybe FilePath)
 
 
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 169dad7a..b0a4d621 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -166,7 +166,7 @@ mkAliasMap dflags mRenamedSource =
         alias <- ideclAs impDecl
         return $
           (lookupModuleDyn dflags
-             (fmap Module.fsToPackageKey $
+             (fmap Module.fsToUnitId $
               fmap sl_fs $ ideclPkgQual impDecl)
              (case ideclName impDecl of SrcLoc.L _ name -> name),
            alias))
@@ -174,13 +174,13 @@ mkAliasMap dflags mRenamedSource =
 
 -- similar to GHC.lookupModule
 lookupModuleDyn ::
-  DynFlags -> Maybe PackageKey -> ModuleName -> Module
+  DynFlags -> Maybe UnitId -> ModuleName -> Module
 lookupModuleDyn _ (Just pkgId) mdlName =
   Module.mkModule pkgId mdlName
 lookupModuleDyn dflags Nothing mdlName =
   case Packages.lookupModuleInAllPackages dflags mdlName of
     (m,_):_ -> m
-    [] -> Module.mkModule Module.mainPackageKey mdlName
+    [] -> Module.mkModule Module.mainUnitId mdlName
 
 
 -------------------------------------------------------------------------------
@@ -704,8 +704,8 @@ moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfa
                     "documentation for exported module: " ++ pretty dflags expMod]
             return []
   where
-    m = mkModule packageKey expMod
-    packageKey = modulePackageKey thisMod
+    m = mkModule unitId expMod
+    unitId = moduleUnitId thisMod
 
 
 -- Note [1]:
diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs
index 4f4218c9..73185092 100644
--- a/haddock-api/src/Haddock/InterfaceFile.hs
+++ b/haddock-api/src/Haddock/InterfaceFile.hs
@@ -14,7 +14,7 @@
 -- Reading and writing the .haddock interface file
 -----------------------------------------------------------------------------
 module Haddock.InterfaceFile (
-  InterfaceFile(..), ifModule, ifPackageKey,
+  InterfaceFile(..), ifUnitId, ifModule,
   readInterfaceFile, nameCacheFromGhc, freshNameCache, NameCacheAccessor,
   writeInterfaceFile, binaryInterfaceVersion, binaryInterfaceVersionCompatibility
 ) where
@@ -57,8 +57,11 @@ ifModule if_ =
     [] -> error "empty InterfaceFile"
     iface:_ -> instMod iface
 
-ifPackageKey :: InterfaceFile -> PackageKey
-ifPackageKey = modulePackageKey . ifModule
+ifUnitId :: InterfaceFile -> UnitId
+ifUnitId if_ =
+  case ifInstalledIfaces if_ of
+    [] -> error "empty InterfaceFile"
+    iface:_ -> moduleUnitId $ instMod iface
 
 
 binaryInterfaceMagic :: Word32
@@ -312,7 +315,7 @@ getSymbolTable bh namecache = do
   return (namecache', arr)
 
 
-type OnDiskName = (PackageKey, ModuleName, OccName)
+type OnDiskName = (UnitId, ModuleName, OccName)
 
 
 fromOnDiskName
@@ -342,7 +345,7 @@ fromOnDiskName _ nc (pid, mod_name, occ) =
 serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO ()
 serialiseName bh name _ = do
   let modu = nameModule name
-  put_ bh (modulePackageKey modu, moduleName modu, nameOccName name)
+  put_ bh (moduleUnitId modu, moduleName modu, nameOccName name)
 
 
 -------------------------------------------------------------------------------
diff --git a/haddock-api/src/Haddock/ModuleTree.hs b/haddock-api/src/Haddock/ModuleTree.hs
index 2f731214..e6cf8201 100644
--- a/haddock-api/src/Haddock/ModuleTree.hs
+++ b/haddock-api/src/Haddock/ModuleTree.hs
@@ -15,7 +15,7 @@ module Haddock.ModuleTree ( ModuleTree(..), mkModuleTree ) where
 import Haddock.Types ( MDoc )
 
 import GHC           ( Name )
-import Module        ( Module, moduleNameString, moduleName, modulePackageKey, packageKeyString )
+import Module        ( Module, moduleNameString, moduleName, moduleUnitId, unitIdString )
 import DynFlags      ( DynFlags )
 import Packages      ( lookupPackage )
 import PackageConfig ( sourcePackageIdString )
@@ -28,10 +28,10 @@ mkModuleTree :: DynFlags -> Bool -> [(Module, Maybe (MDoc Name))] -> [ModuleTree
 mkModuleTree dflags showPkgs mods =
   foldr fn [] [ (splitModule mdl, modPkg mdl, modSrcPkg mdl, short) | (mdl, short) <- mods ]
   where
-    modPkg mod_ | showPkgs = Just (packageKeyString (modulePackageKey mod_))
+    modPkg mod_ | showPkgs = Just (unitIdString (moduleUnitId mod_))
                 | otherwise = Nothing
     modSrcPkg mod_ | showPkgs = fmap sourcePackageIdString
-                                     (lookupPackage dflags (modulePackageKey mod_))
+                                     (lookupPackage dflags (moduleUnitId mod_))
                    | otherwise = Nothing
     fn (mod_,pkg,srcPkg,short) = addToTrees mod_ pkg srcPkg short
 
-- 
cgit v1.2.3


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

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

(limited to 'haddock-api/src')

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


From 4e1eef5c7e79717af2c8d72234e4c82f8a11c443 Mon Sep 17 00:00:00 2001
From: Simon Peyton Jones <simonpj@microsoft.com>
Date: Mon, 26 Oct 2015 12:52:36 +0000
Subject: Track wip/spj-wildcard-refactor on main repo

---
 haddock-api/src/Haddock/Backends/Hoogle.hs  | 33 ++++++----------
 haddock-api/src/Haddock/Convert.hs          | 33 +++++++++-------
 haddock-api/src/Haddock/GhcUtils.hs         | 12 +++---
 haddock-api/src/Haddock/Interface/Rename.hs | 61 ++++++++++++++++++++---------
 haddock-api/src/Haddock/Utils.hs            |  2 +-
 5 files changed, 80 insertions(+), 61 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 42887834..afa694e3 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -68,7 +68,8 @@ dropHsDocTy :: HsType a -> HsType a
 dropHsDocTy = f
     where
         g (L src x) = L src (f x)
-        f (HsForAllTy a b c d e) = HsForAllTy a b c d (g e)
+        f (HsForAllTy a e) = HsForAllTy a (g e)
+        f (HsQualTy a e) = HsQualTy a (g e)
         f (HsBangTy a b) = HsBangTy a (g b)
         f (HsAppTy a b) = HsAppTy (g a) (g b)
         f (HsFunTy a b) = HsFunTy (g a) (g b)
@@ -85,14 +86,6 @@ outHsType :: OutputableBndr a => DynFlags -> HsType a -> String
 outHsType dflags = out dflags . dropHsDocTy
 
 
-makeExplicit :: HsType a -> HsType a
-makeExplicit (HsForAllTy _ a b c d) = HsForAllTy Explicit a b c d
-makeExplicit x = x
-
-makeExplicitL :: LHsType a -> LHsType a
-makeExplicitL (L src x) = L src (makeExplicit x)
-
-
 dropComment :: String -> String
 dropComment (' ':'-':'-':' ':_) = []
 dropComment (x:xs) = x : dropComment xs
@@ -129,8 +122,8 @@ ppExport dflags ExportDecl { expItemDecl    = L _ decl
         f (TyClD d@DataDecl{})  = ppData dflags d subdocs
         f (TyClD d@SynDecl{})   = ppSynonym dflags d
         f (TyClD d@ClassDecl{}) = ppClass dflags d subdocs
-        f (ForD (ForeignImport name typ _ _)) = ppSig dflags $ TypeSig [name] typ []
-        f (ForD (ForeignExport name typ _ _)) = ppSig dflags $ TypeSig [name] typ []
+        f (ForD (ForeignImport name typ _ _)) = ppSig dflags $ TypeSig [name] typ
+        f (ForD (ForeignExport name typ _ _)) = ppSig dflags $ TypeSig [name] typ
         f (SigD sig) = ppSig dflags sig ++ ppFixities
         f _ = []
 
@@ -138,7 +131,7 @@ ppExport dflags ExportDecl { expItemDecl    = L _ decl
 ppExport _ _ = []
 
 ppSigWithDoc :: DynFlags -> Sig Name -> [(Name, DocForDecl Name)] -> [String]
-ppSigWithDoc dflags (TypeSig names sig _) subdocs
+ppSigWithDoc dflags (TypeSig names sig) subdocs
     = concatMap mkDocSig names
     where
         mkDocSig n = concatMap (ppDocumentation dflags) (getDoc n)
@@ -148,10 +141,7 @@ ppSigWithDoc dflags (TypeSig names sig _) subdocs
         getDoc :: Located Name -> [Documentation Name]
         getDoc n = maybe [] (return . fst) (lookup (unL n) subdocs)
 
-        typ = case unL sig of
-                   HsForAllTy Explicit a b c d  -> HsForAllTy Implicit a b c d
-                   HsForAllTy Qualified a b c d -> HsForAllTy Implicit a b c d
-                   x -> x
+        typ = unL (hsSigType sig)
 ppSigWithDoc _ _ _ = []
 
 ppSig :: DynFlags -> Sig Name -> [String]
@@ -183,12 +173,13 @@ ppClass dflags decl subdocs = (out dflags decl' ++ ppTyFams) : ppMethods
             , rbrace
             ]
 
-        addContext (TypeSig name (L l sig) nwcs) = TypeSig name (L l $ f sig) nwcs
+        addContext (TypeSig name sig) = TypeSig name (mkHsSigType (f (hsSigType sig)))
         addContext (MinimalSig src sig) = MinimalSig src sig
         addContext _ = error "expected TypeSig"
 
-        f (HsForAllTy a b c con d) = HsForAllTy a b c (reL (context : unLoc con)) d
-        f t = HsForAllTy Implicit Nothing emptyHsQTvs (reL [context]) (reL t)
+        f (L _ (HsForAllTy a ty)) = reL (HsForallTy a (f ty))
+        f (L _ (HsQualTy cxt ty)) = HsQualTy (reL (context : unLoc cxt)) ty
+        f ty = HsQualTy (reL [context]) ty
 
         context = nlHsTyConApp (tcdName decl)
             (map (reL . HsTyVar . hsTyVarName . unL) (hsQTvBndrs (tyClDeclTyVars decl)))
@@ -249,10 +240,10 @@ ppCtor dflags dat subdocs con
                            [out dflags (map (selectorFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]]
                           | r <- map unLoc recs]
 
-        funs = foldr1 (\x y -> reL $ HsFunTy (makeExplicitL x) (makeExplicitL y))
+        funs = foldr1 (\x y -> reL $ HsFunTy x y)
         apps = foldl1 (\x y -> reL $ HsAppTy x y)
 
-        typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (makeExplicit $ unL $ funs flds)
+        typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds)
 
         -- We print the constructors as comma-separated list. See GHC
         -- docs for con_names on why it is a list to begin with.
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index f12556f8..bad99f24 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -97,7 +97,7 @@ tyThingToLHsDecl t = case t of
 
   -- a data-constructor alone just gets rendered as a function:
   AConLike (RealDataCon dc) -> allOK $ SigD (TypeSig [synifyName dc]
-    (synifyType ImplicitizeForAll (dataConUserType dc)) [])
+    (synifyType ImplicitizeForAll (dataConUserType dc)))
 
   AConLike (PatSynCon ps) ->
       let (univ_tvs, ex_tvs, req_theta, prov_theta, arg_tys, res_ty) = patSynSig ps
@@ -119,10 +119,9 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs })
         hs_rhs     = synifyType WithinType rhs
         (kvs, tvs) = partition isKindVar tkvs
     in TyFamEqn { tfe_tycon = name
-                , tfe_pats  = HsWB { hswb_cts = typats
-                                    , hswb_kvs = map tyVarName kvs
-                                    , hswb_tvs = map tyVarName tvs
-                                    , hswb_wcs = [] }
+                , tfe_pats  = HsIB { hsib_body = typats
+                                   , hsib_kvs = map tyVarName kvs
+                                   , hsib_tvs = map tyVarName tvs }
                 , tfe_rhs   = hs_rhs }
 
 synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl Name)
@@ -311,8 +310,14 @@ synifyDataCon use_gadt_syntax dc =
               else ResTyH98
  -- finally we get synifyDataCon's result!
  in hs_arg_tys >>=
-      \hat -> return . noLoc $ ConDecl [name] Implicit -- we don't know nor care
-                qvars ctx hat hs_res_ty Nothing
+      \hat -> return $ noLoc $
+              ConDecl { con_names = [name]
+                      , con_explicit = False    -- we don't know nor care
+                      , con_qvars = qvars
+                      , con_cxt   = ctx
+                      , con_details =  hat
+                      , con_res = hs_res_ty
+                      , con_doc =  Nothing }
                 -- we don't want any "deprecated GADT syntax" warnings!
                 False
 
@@ -328,7 +333,7 @@ synifyCtx :: [PredType] -> LHsContext Name
 synifyCtx = noLoc . map (synifyType WithinType)
 
 
-synifyTyVars :: [TyVar] -> LHsTyVarBndrs Name
+synifyTyVars :: [TyVar] -> LHsQTyVars Name
 synifyTyVars ktvs = HsQTvs { hsq_kvs = map tyVarName kvs
                            , hsq_tvs = map synifyTyVar tvs }
   where
@@ -394,15 +399,13 @@ synifyType _ (FunTy t1 t2) = let
   in noLoc $ HsFunTy s1 s2
 synifyType s forallty@(ForAllTy _tv _ty) =
   let (tvs, ctx, tau) = tcSplitSigmaTy forallty
-      sTvs = synifyTyVars tvs
-      sCtx = synifyCtx ctx
-      sTau = synifyType WithinType tau
-      mkHsForAllTy forallPlicitness =
-        noLoc $ HsForAllTy forallPlicitness Nothing sTvs sCtx sTau
+      sPhi = HsQualTy { hst_ctxt = noLoc (synifyCtx ctx)
+                      , hst_body = noLoc (synify WithinType tau) }
   in case s of
     DeleteTopLevelQuantification -> synifyType ImplicitizeForAll tau
-    WithinType -> mkHsForAllTy Explicit
-    ImplicitizeForAll -> mkHsForAllTy Implicit
+    WithinType        -> noLoc $ HsForAllTy { hst_bndrs = synifyTyVars tvs
+                                            , hst_body  = noLoc sPhi }
+    ImplicitizeForAll -> noLoc sPhi
 
 synifyType _ (LitTy t) = noLoc $ HsTyLit $ synifyTyLit t
 
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 0581ceb8..e2aa8f06 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -68,7 +68,7 @@ getMainDeclBinder _ = []
 -- to correlate InstDecls with their Instance/CoAxiom Names, via the
 -- instanceMap.
 getInstLoc :: InstDecl name -> SrcSpan
-getInstLoc (ClsInstD (ClsInstDecl { cid_poly_ty = L l _ })) = l
+getInstLoc (ClsInstD (ClsInstDecl { cid_poly_ty = ty })) = getLoc (hsSigType ty)
 getInstLoc (DataFamInstD (DataFamInstDecl { dfid_tycon = L l _ })) = l
 getInstLoc (TyFamInstD (TyFamInstDecl
   -- Since CoAxioms' Names refer to the whole line for type family instances
@@ -91,10 +91,10 @@ filterSigNames p (FixSig (FixitySig ns ty)) =
     []       -> Nothing
     filtered -> Just (FixSig (FixitySig filtered ty))
 filterSigNames _ orig@(MinimalSig _ _)      = Just orig
-filterSigNames p (TypeSig ns ty nwcs) =
+filterSigNames p (TypeSig ns ty) =
   case filter (p . unLoc) ns of
     []       -> Nothing
-    filtered -> Just (TypeSig filtered ty nwcs)
+    filtered -> Just (TypeSig filtered ty)
 filterSigNames _ _                           = Nothing
 
 ifTrueJust :: Bool -> name -> Maybe name
@@ -105,8 +105,8 @@ sigName :: LSig name -> [name]
 sigName (L _ sig) = sigNameNoLoc sig
 
 sigNameNoLoc :: Sig name -> [name]
-sigNameNoLoc (TypeSig   ns _ _)        = map unLoc ns
-sigNameNoLoc (PatSynSig n _ _ _ _)     = [unLoc n]
+sigNameNoLoc (TypeSig   ns _)          = map unLoc ns
+sigNameNoLoc (PatSynSig n _)           = [unLoc n]
 sigNameNoLoc (SpecSig   n _ _)         = [unLoc n]
 sigNameNoLoc (InlineSig n _)           = [unLoc n]
 sigNameNoLoc (FixSig (FixitySig ns _)) = map unLoc ns
@@ -198,7 +198,7 @@ instance Parent (TyClDecl Name) where
                               $ (dd_cons . tcdDataDefn) $ d
     | isClassDecl d =
         map (unL . fdLName . unL) (tcdATs d) ++
-        [ unL n | L _ (TypeSig ns _ _) <- tcdSigs d, n <- ns ]
+        [ unL n | L _ (TypeSig ns _) <- tcdSigs d, n <- ns ]
     | otherwise = []
 
 
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 1671a38d..61eb6cde 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -170,6 +170,12 @@ renameFnArgsDoc = mapM renameDoc
 renameLType :: LHsType Name -> RnM (LHsType DocName)
 renameLType = mapM renameType
 
+renameLSigType :: LHsWcSigType Name -> RnM (LHsType DocName)
+renameLSigType = renameWc renameLType
+
+renameLWcSigType :: LHsWcSigType Name -> RnM (LHsType DocName)
+renameLWcSigType = renameImplicit renameLSigType
+
 renameLKind :: LHsKind Name -> RnM (LHsKind DocName)
 renameLKind = renameLType
 
@@ -198,11 +204,15 @@ renameMaybeInjectivityAnn = traverse renameInjectivityAnn
 
 renameType :: HsType Name -> RnM (HsType DocName)
 renameType t = case t of
-  HsForAllTy expl extra tyvars lcontext ltype -> do
+  HsForAllTy { hst_bndrs = tyvars, hst_body = ltype } -> do
     tyvars'   <- renameLTyVarBndrs tyvars
+    ltype'    <- renameLType ltype
+    return (HsForAllTy { hst_bndrs = tyvars', hst_body = ltype' })
+
+  HsQualTy { hst_cttx = lcontext , hst_body = ltype } -> do
     lcontext' <- renameLContext lcontext
     ltype'    <- renameLType ltype
-    return (HsForAllTy expl extra tyvars' lcontext' ltype')
+    return (HsQualTy { hst_ctxt = lcontext', hst_body = ltype' })
 
   HsTyVar n -> return . HsTyVar =<< rename n
   HsBangTy b ltype -> return . HsBangTy b =<< renameLType ltype
@@ -252,7 +262,7 @@ renameType t = case t of
   HsSpliceTy _ _          -> error "renameType: HsSpliceTy"
   HsWildCardTy a          -> HsWildCardTy <$> renameWildCardInfo a
 
-renameLTyVarBndrs :: LHsTyVarBndrs Name -> RnM (LHsTyVarBndrs DocName)
+renameLTyVarBndrs :: LHsQTyVars Name -> RnM (LHsQTyVars DocName)
 renameLTyVarBndrs (HsQTvs { hsq_kvs = _, hsq_tvs = tvs })
   = do { tvs' <- mapM renameLTyVarBndr tvs
        ; return (HsQTvs { hsq_kvs = error "haddock:renameLTyVarBndrs", hsq_tvs = tvs' }) }
@@ -441,16 +451,16 @@ renameLFieldOcc (L l (FieldOcc lbl sel)) = do
 
 renameSig :: Sig Name -> RnM (Sig DocName)
 renameSig sig = case sig of
-  TypeSig lnames ltype _ -> do
+  TypeSig lnames ltype -> do
     lnames' <- mapM renameL lnames
-    ltype' <- renameLType ltype
-    return (TypeSig lnames' ltype' PlaceHolder)
+    ltype' <- renameLWcSigType ltype
+    return (TypeSig lnames' ltype')
   PatSynSig lname (flag, qtvs) lreq lprov lty -> do
     lname' <- renameL lname
     qtvs' <- renameLTyVarBndrs qtvs
     lreq' <- renameLContext lreq
     lprov' <- renameLContext lprov
-    lty' <- renameLType lty
+    lty' <- renameLSigType lty
     return $ PatSynSig lname' (flag, qtvs') lreq' lprov' lty'
   FixSig (FixitySig lnames fixity) -> do
     lnames' <- mapM renameL lnames
@@ -463,11 +473,11 @@ renameSig sig = case sig of
 renameForD :: ForeignDecl Name -> RnM (ForeignDecl DocName)
 renameForD (ForeignImport lname ltype co x) = do
   lname' <- renameL lname
-  ltype' <- renameLType ltype
+  ltype' <- renameLSigType ltype
   return (ForeignImport lname' ltype' co x)
 renameForD (ForeignExport lname ltype co x) = do
   lname' <- renameL lname
-  ltype' <- renameLType ltype
+  ltype' <- renameLSigType ltype
   return (ForeignExport lname' ltype' co x)
 
 
@@ -502,33 +512,48 @@ renameTyFamInstD (TyFamInstDecl { tfid_eqn = eqn })
                                , tfid_fvs = placeHolderNames }) }
 
 renameLTyFamInstEqn :: LTyFamInstEqn Name -> RnM (LTyFamInstEqn DocName)
-renameLTyFamInstEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = pats_w_bndrs, tfe_rhs = rhs }))
+renameLTyFamInstEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_rhs = rhs }))
   = do { tc' <- renameL tc
-       ; pats' <- mapM renameLType (hswb_cts pats_w_bndrs)
+       ; pats' <- renameImplicit (mapM renameLType) pats
        ; rhs' <- renameLType rhs
        ; return (L loc (TyFamEqn { tfe_tycon = tc'
-                                 , tfe_pats = HsWB pats' PlaceHolder PlaceHolder PlaceHolder
+                                 , tfe_pats = pats'
                                  , tfe_rhs = rhs' })) }
 
 renameLTyFamDefltEqn :: LTyFamDefltEqn Name -> RnM (LTyFamDefltEqn DocName)
 renameLTyFamDefltEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = tvs, tfe_rhs = rhs }))
-  = do { tc' <- renameL tc
-       ; tvs'  <- renameLTyVarBndrs tvs
+  = do { tc'  <- renameL tc
+       ; tvs' <- renameLTyVarBndrs tvs
        ; rhs' <- renameLType rhs
        ; return (L loc (TyFamEqn { tfe_tycon = tc'
                                  , tfe_pats = tvs'
                                  , tfe_rhs = rhs' })) }
 
 renameDataFamInstD :: DataFamInstDecl Name -> RnM (DataFamInstDecl DocName)
-renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats_w_bndrs, dfid_defn = defn })
+renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats, dfid_defn = defn })
   = do { tc' <- renameL tc
-       ; pats' <- mapM renameLType (hswb_cts pats_w_bndrs)
+       ; pats' <- renameImplicit (mapM renameLType) pats
        ; defn' <- renameDataDefn defn
        ; return (DataFamInstDecl { dfid_tycon = tc'
-                                 , dfid_pats
-                                       = HsWB pats' PlaceHolder PlaceHolder PlaceHolder
+                                 , dfid_pats = pats'
                                  , dfid_defn = defn', dfid_fvs = placeHolderNames }) }
 
+renameImplicit :: (in_thing -> RnM out_thing)
+               -> HsImplicitBndrs Name in_thing
+               -> RnM (HsImplicitBndrs DocName out_thing)
+renameImplicit rn_thing (HsIB { hsib_body = thing })
+  = do { thing' <- rn_thing thing
+       ; return (HsIB { hsib_body = thing'
+                      , hsib_kvs = PlaceHolder, hsib_tvs = PlaceHolder })
+
+renameWc :: (in_thing -> RnM out_thing)
+               -> HsWildcardBndrs Name in_thing
+               -> RnM (HsWildcardBndrs DocName out_thing)
+renameWc rn_thing (HsWC { hswc_body = thing })
+  = do { thing' <- rn_thing thing
+       ; return (HsWC { hswc_body = thing'
+                      , hswc_wcs = PlaceHolder, hswc_ctx = Nothing })
+
 renameExportItem :: ExportItem Name -> RnM (ExportItem DocName)
 renameExportItem item = case item of
   ExportModule mdl -> return (ExportModule mdl)
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index c2e1b09a..3964c86a 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -177,7 +177,7 @@ restrictDecls names = mapMaybe (filterLSigNames (`elem` names))
 restrictATs :: [Name] -> [LFamilyDecl Name] -> [LFamilyDecl Name]
 restrictATs names ats = [ at | at <- ats , unL (fdLName (unL at)) `elem` names ]
 
-emptyHsQTvs :: LHsTyVarBndrs Name
+emptyHsQTvs :: LHsQTyVars Name
 -- This function is here, rather than in HsTypes, because it *renamed*, but
 -- does not necessarily have all the rigt kind variables.  It is used
 -- in Haddock just for printing, so it doesn't matter
-- 
cgit v1.2.3


From 5628084e7a9d7bf8ec083cd93321eaa6ac686b4a Mon Sep 17 00:00:00 2001
From: Simon Peyton Jones <simonpj@microsoft.com>
Date: Tue, 27 Oct 2015 17:34:18 +0000
Subject: Follow changes to HsTYpe

Not yet complete (but on a wip/ branch)
---
 haddock-api/src/Haddock/Backends/Hoogle.hs  | 35 ++++++++------------
 haddock-api/src/Haddock/Convert.hs          | 46 ++++++++++++++------------
 haddock-api/src/Haddock/Interface/Create.hs | 48 ++++++++-------------------
 haddock-api/src/Haddock/Interface/Rename.hs | 51 ++++++++++++++---------------
 haddock-api/src/Haddock/Utils.hs            | 29 ++++++++++++++++
 5 files changed, 105 insertions(+), 104 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index afa694e3..1d85b474 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -122,8 +122,8 @@ ppExport dflags ExportDecl { expItemDecl    = L _ decl
         f (TyClD d@DataDecl{})  = ppData dflags d subdocs
         f (TyClD d@SynDecl{})   = ppSynonym dflags d
         f (TyClD d@ClassDecl{}) = ppClass dflags d subdocs
-        f (ForD (ForeignImport name typ _ _)) = ppSig dflags $ TypeSig [name] typ
-        f (ForD (ForeignExport name typ _ _)) = ppSig dflags $ TypeSig [name] typ
+        f (ForD (ForeignImport name typ _ _)) = pp_sig dflags [name] (hsSigType typ)
+        f (ForD (ForeignExport name typ _ _)) = pp_sig dflags [name] (hsSigType typ)
         f (SigD sig) = ppSig dflags sig ++ ppFixities
         f _ = []
 
@@ -135,31 +135,33 @@ ppSigWithDoc dflags (TypeSig names sig) subdocs
     = concatMap mkDocSig names
     where
         mkDocSig n = concatMap (ppDocumentation dflags) (getDoc n)
-                     ++ [mkSig n]
-        mkSig n = operator (out dflags n) ++ " :: " ++ outHsType dflags typ
+                     ++ [pp_sig dflags names (hsSigWcType sig)]
 
         getDoc :: Located Name -> [Documentation Name]
         getDoc n = maybe [] (return . fst) (lookup (unL n) subdocs)
 
-        typ = unL (hsSigType sig)
+        typ = unL (hsSigWcType sig)
 ppSigWithDoc _ _ _ = []
 
 ppSig :: DynFlags -> Sig Name -> [String]
 ppSig dflags x  = ppSigWithDoc dflags x []
 
+pp_sig :: DynFlags -> [Located Name] -> LHsType Name -> String
+pp_sig dflags names (L _ typ)  =
+    operator prettyNames ++ " :: " ++ outHsType dflags typ
+    where
+      prettyNames = intercalate ", " $ map (out dflags) names
 
 -- note: does not yet output documentation for class methods
 ppClass :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String]
-ppClass dflags decl subdocs = (out dflags decl' ++ ppTyFams) : ppMethods
+ppClass dflags decl subdocs = (out dflags decl{tcdSigs=[]} ++ ppTyFams) :  ppMethods
     where
-        decl' = decl
-            { tcdSigs = [], tcdMeths = emptyBag
-            , tcdATs = [], tcdATDefs = []
-            }
 
-        ppMethods = concat . map (ppSig' . unLoc) $ tcdSigs decl
+        ppMethods = concat . map (ppSig' . unL . add_ctxt) $ tcdSigs decl
         ppSig' = flip (ppSigWithDoc dflags) subdocs . addContext
 
+        add_ctxt = addClassContext (tcdName x) (tyClDeclTyVars x)
+
         ppTyFams
             | null $ tcdATs decl = ""
             | otherwise = (" " ++) . showSDocUnqual dflags . whereWrapper $ concat
@@ -173,17 +175,6 @@ ppClass dflags decl subdocs = (out dflags decl' ++ ppTyFams) : ppMethods
             , rbrace
             ]
 
-        addContext (TypeSig name sig) = TypeSig name (mkHsSigType (f (hsSigType sig)))
-        addContext (MinimalSig src sig) = MinimalSig src sig
-        addContext _ = error "expected TypeSig"
-
-        f (L _ (HsForAllTy a ty)) = reL (HsForallTy a (f ty))
-        f (L _ (HsQualTy cxt ty)) = HsQualTy (reL (context : unLoc cxt)) ty
-        f ty = HsQualTy (reL [context]) ty
-
-        context = nlHsTyConApp (tcdName decl)
-            (map (reL . HsTyVar . hsTyVarName . unL) (hsQTvBndrs (tyClDeclTyVars decl)))
-
         tyFamEqnToSyn :: TyFamDefltEqn Name -> TyClDecl Name
         tyFamEqnToSyn tfe = SynDecl
             { tcdLName = tfe_tycon tfe
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index bad99f24..7f807569 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -97,17 +97,10 @@ tyThingToLHsDecl t = case t of
 
   -- a data-constructor alone just gets rendered as a function:
   AConLike (RealDataCon dc) -> allOK $ SigD (TypeSig [synifyName dc]
-    (synifyType ImplicitizeForAll (dataConUserType dc)))
+    (synifySigWcType ImplicitizeForAll (dataConUserType dc)))
 
   AConLike (PatSynCon ps) ->
-      let (univ_tvs, ex_tvs, req_theta, prov_theta, arg_tys, res_ty) = patSynSig ps
-          qtvs = univ_tvs ++ ex_tvs
-          ty = mkFunTys arg_tys res_ty
-      in allOK . SigD $ PatSynSig (synifyName ps)
-                          (Implicit, synifyTyVars qtvs)
-                          (synifyCtx req_theta)
-                          (synifyCtx prov_theta)
-                          (synifyType WithinType ty)
+     allOK . SigD $ PatSynSig (synifyName ps) (synifySigType WithinType (patSynType ps))
   where
     withErrs e x = return (e, x)
     allOK x = return (mempty, x)
@@ -317,16 +310,16 @@ synifyDataCon use_gadt_syntax dc =
                       , con_cxt   = ctx
                       , con_details =  hat
                       , con_res = hs_res_ty
-                      , con_doc =  Nothing }
+                      , con_doc =  Nothing
                 -- we don't want any "deprecated GADT syntax" warnings!
-                False
+                      , con_old_rec = False }
 
 synifyName :: NamedThing n => n -> Located Name
 synifyName = noLoc . getName
 
 
 synifyIdSig :: SynifyTypeState -> Id -> Sig Name
-synifyIdSig s i = TypeSig [synifyName i] (synifyType s (varType i)) []
+synifyIdSig s i = TypeSig [synifyName i] (synifySigWcType s (varType i))
 
 
 synifyCtx :: [PredType] -> LHsContext Name
@@ -338,12 +331,14 @@ synifyTyVars ktvs = HsQTvs { hsq_kvs = map tyVarName kvs
                            , hsq_tvs = map synifyTyVar tvs }
   where
     (kvs, tvs) = partition isKindVar ktvs
-    synifyTyVar tv
-      | isLiftedTypeKind kind = noLoc (UserTyVar name)
-      | otherwise             = noLoc (KindedTyVar (noLoc name) (synifyKindSig kind))
-      where
-        kind = tyVarKind tv
-        name = getName tv
+
+synifyTyVar :: TyVar -> LHsTyVarBndr Name
+synifyTyVar tv
+  | isLiftedTypeKind kind = noLoc (UserTyVar name)
+  | otherwise             = noLoc (KindedTyVar (noLoc name) (synifyKindSig kind))
+  where
+    kind = tyVarKind tv
+    name = getName tv
 
 --states of what to do with foralls:
 data SynifyTypeState
@@ -361,6 +356,15 @@ data SynifyTypeState
   --   the defining class gets to quantify all its functions for free!
 
 
+synifySigType :: SynifyTypeState -> Type -> LHsSigType Name
+-- The empty binders is a bit suspicious;
+-- what if the type has free variables?
+synifySigType s ty = mkEmptyImplicitBndrs (synifyType s ty)
+
+synifySigWcType :: SynifyTypeState -> Type -> LHsSigWcType Name
+-- Ditto (see synifySigType)
+synifySigWcType s ty = mkEmptyImplicitBndrs (mkEmptyWildCardBndrs (synifyType s ty))
+
 synifyType :: SynifyTypeState -> Type -> LHsType Name
 synifyType _ (TyVarTy tv) = noLoc $ HsTyVar (getName tv)
 synifyType _ (TyConApp tc tys)
@@ -399,11 +403,11 @@ synifyType _ (FunTy t1 t2) = let
   in noLoc $ HsFunTy s1 s2
 synifyType s forallty@(ForAllTy _tv _ty) =
   let (tvs, ctx, tau) = tcSplitSigmaTy forallty
-      sPhi = HsQualTy { hst_ctxt = noLoc (synifyCtx ctx)
-                      , hst_body = noLoc (synify WithinType tau) }
+      sPhi = HsQualTy { hst_ctxt = synifyCtx ctx
+                      , hst_body = synifyType WithinType tau }
   in case s of
     DeleteTopLevelQuantification -> synifyType ImplicitizeForAll tau
-    WithinType        -> noLoc $ HsForAllTy { hst_bndrs = synifyTyVars tvs
+    WithinType        -> noLoc $ HsForAllTy { hst_bndrs = map synifyTyVar tvs
                                             , hst_body  = noLoc sPhi }
     ImplicitizeForAll -> noLoc sPhi
 
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 7a5eb8d7..11906efa 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -353,15 +353,14 @@ typeDocs :: HsDecl Name -> Map Int HsDocString
 typeDocs d =
   let docs = go 0 in
   case d of
-    SigD (TypeSig _ ty _) -> docs (unLoc ty)
-    SigD (PatSynSig _ _ req prov ty) ->
-        let allTys = ty : concat [ unLoc req, unLoc prov ]
-        in F.foldMap (docs . unLoc) allTys
-    ForD (ForeignImport _ ty _ _) -> docs (unLoc ty)
+    SigD (TypeSig _ ty)   -> docs (unLoc (hsSigWcType ty))
+    SigD (PatSynSig _ ty) -> docs (unLoc (hsSigType ty))
+    ForD (ForeignImport _ ty _ _)   -> docs (unLoc (hsSigType ty))
     TyClD (SynDecl { tcdRhs = ty }) -> docs (unLoc ty)
     _ -> M.empty
   where
-    go n (HsForAllTy _ _ _ _ ty) = go n (unLoc ty)
+    go n (HsForAllTy { hst_body = ty }) = go n (unLoc ty)
+    go n (HsQualTy   { hst_body = ty }) = go n (unLoc ty)
     go n (HsFunTy (L _ (HsDocTy _ (L _ x))) (L _ ty)) = M.insert n x $ go (n+1) ty
     go n (HsFunTy _ ty) = go (n+1) (unLoc ty)
     go n (HsDocTy _ (L _ doc)) = M.singleton n doc
@@ -740,8 +739,8 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap
     expandSig = foldr f []
       where
         f :: LHsDecl name -> [LHsDecl name] -> [LHsDecl name]
-        f (L l (SigD (TypeSig    names t nwcs)))     xs = foldr (\n acc -> L l (SigD (TypeSig    [n] t nwcs))     : acc) xs names
-        f (L l (SigD (GenericSig names t)))          xs = foldr (\n acc -> L l (SigD (GenericSig [n] t))          : acc) xs names
+        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
 
     mkExportItem :: LHsDecl Name -> ErrMsgGhc (Maybe (ExportItem Name))
@@ -785,17 +784,17 @@ extractDecl name mdl decl
     case unLoc decl of
       TyClD d@ClassDecl {} ->
         let matches = [ sig | sig <- tcdSigs d, name `elem` sigName sig,
-                        isVanillaLSig sig ] -- TODO: document fixity
+                        isTypeLSig sig ] -- TODO: document fixity
         in case matches of
-          [s0] -> let (n, tyvar_names) = (tcdName d, getTyVars d)
-                      L pos sig = extractClassDecl n tyvar_names s0
+          [s0] -> let (n, tyvar_names) = (tcdName d, tyClDeclTyVars d)
+                      L pos sig = addClassContext n tyvar_names s0
                   in L pos (SigD sig)
           _ -> error "internal: extractDecl (ClassDecl)"
       TyClD d@DataDecl {} ->
-        let (n, tyvar_names) = (tcdName d, map toTypeNoLoc $ getTyVars d)
-        in SigD <$> extractRecSel name mdl n tyvar_names (dd_cons (tcdDataDefn d))
+        let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars d))
+        in SigD <$> extractRecSel name mdl n tyvar_tys (dd_cons (tcdDataDefn d))
       InstD (DataFamInstD DataFamInstDecl { dfid_tycon = L _ n
-                                          , dfid_pats = HsWB { hswb_cts = tys }
+                                          , dfid_pats = HsIB { hsib_body = tys }
                                           , dfid_defn = defn }) ->
         SigD <$> extractRecSel name mdl n tys (dd_cons defn)
       InstD (ClsInstD ClsInstDecl { cid_datafam_insts = insts }) ->
@@ -809,24 +808,6 @@ extractDecl name mdl decl
           [d0] -> extractDecl name mdl (noLoc . InstD $ DataFamInstD d0)
           _ -> error "internal: extractDecl (ClsInstD)"
       _ -> error "internal: extractDecl"
-  where
-    getTyVars = hsLTyVarLocNames . tyClDeclTyVars
-
-
-toTypeNoLoc :: Located Name -> LHsType Name
-toTypeNoLoc = noLoc . HsTyVar . unLoc
-
-
-extractClassDecl :: Name -> [Located Name] -> LSig Name -> LSig Name
-extractClassDecl c tvs0 (L pos (TypeSig lname ltype _)) = case ltype of
-  L _ (HsForAllTy expl _ tvs (L _ preds) ty) ->
-    L pos (TypeSig lname (noLoc (HsForAllTy expl Nothing tvs (lctxt preds) ty)) [])
-  _ -> L pos (TypeSig lname (noLoc (HsForAllTy Implicit Nothing emptyHsQTvs (lctxt []) ltype)) [])
-  where
-    lctxt = noLoc . ctxt
-    ctxt preds = nlHsTyConApp c (map toTypeNoLoc tvs0) : preds
-extractClassDecl _ _ _ = error "extractClassDecl: unexpected decl"
-
 
 extractRecSel :: Name -> Module -> Name -> [LHsType Name] -> [LConDecl Name]
               -> LSig Name
@@ -835,7 +816,7 @@ extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found"
 extractRecSel nm mdl t tvs (L _ con : rest) =
   case con_details con of
     RecCon (L _ fields) | ((l,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields ->
-      L l (TypeSig [noLoc nm] (noLoc (HsFunTy data_ty (getBangType ty))) [])
+      L l (TypeSig [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy data_ty (getBangType ty)))))
     _ -> extractRecSel nm mdl t tvs rest
  where
   matching_fields :: [LConDeclField Name] -> [(SrcSpan, LConDeclField Name)]
@@ -845,7 +826,6 @@ extractRecSel nm mdl t tvs (L _ con : rest) =
     | ResTyGADT _ ty <- con_res con = ty
     | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) tvs
 
-
 -- | Keep export items with docs.
 pruneExportItems :: [ExportItem Name] -> [ExportItem Name]
 pruneExportItems = filter hasDoc
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 61eb6cde..3a170f4a 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -170,11 +170,11 @@ renameFnArgsDoc = mapM renameDoc
 renameLType :: LHsType Name -> RnM (LHsType DocName)
 renameLType = mapM renameType
 
-renameLSigType :: LHsWcSigType Name -> RnM (LHsType DocName)
-renameLSigType = renameWc renameLType
+renameLSigType :: LHsSigType Name -> RnM (LHsSigType DocName)
+renameLSigType = renameImplicit renameLType
 
-renameLWcSigType :: LHsWcSigType Name -> RnM (LHsType DocName)
-renameLWcSigType = renameImplicit renameLSigType
+renameLSigWcType :: LHsSigWcType Name -> RnM (LHsSigWcType DocName)
+renameLSigWcType = renameImplicit (renameWc renameLType)
 
 renameLKind :: LHsKind Name -> RnM (LHsKind DocName)
 renameLKind = renameLType
@@ -205,11 +205,11 @@ renameMaybeInjectivityAnn = traverse renameInjectivityAnn
 renameType :: HsType Name -> RnM (HsType DocName)
 renameType t = case t of
   HsForAllTy { hst_bndrs = tyvars, hst_body = ltype } -> do
-    tyvars'   <- renameLTyVarBndrs tyvars
+    tyvars'   <- mapM renameLTyVarBndr tyvars
     ltype'    <- renameLType ltype
     return (HsForAllTy { hst_bndrs = tyvars', hst_body = ltype' })
 
-  HsQualTy { hst_cttx = lcontext , hst_body = ltype } -> do
+  HsQualTy { hst_ctxt = lcontext , hst_body = ltype } -> do
     lcontext' <- renameLContext lcontext
     ltype'    <- renameLType ltype
     return (HsQualTy { hst_ctxt = lcontext', hst_body = ltype' })
@@ -262,10 +262,10 @@ renameType t = case t of
   HsSpliceTy _ _          -> error "renameType: HsSpliceTy"
   HsWildCardTy a          -> HsWildCardTy <$> renameWildCardInfo a
 
-renameLTyVarBndrs :: LHsQTyVars Name -> RnM (LHsQTyVars DocName)
-renameLTyVarBndrs (HsQTvs { hsq_kvs = _, hsq_tvs = tvs })
+renameLHsQTyVars :: LHsQTyVars Name -> RnM (LHsQTyVars DocName)
+renameLHsQTyVars (HsQTvs { hsq_kvs = _, hsq_tvs = tvs })
   = do { tvs' <- mapM renameLTyVarBndr tvs
-       ; return (HsQTvs { hsq_kvs = error "haddock:renameLTyVarBndrs", hsq_tvs = tvs' }) }
+       ; return (HsQTvs { hsq_kvs = error "haddock:renameLHsQTyVars", hsq_tvs = tvs' }) }
                 -- This is rather bogus, but I'm not sure what else to do
 
 renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName)
@@ -338,13 +338,13 @@ renameTyClD d = case d of
 
   SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdRhs = rhs, tcdFVs = _fvs } -> do
     lname'    <- renameL lname
-    tyvars'   <- renameLTyVarBndrs tyvars
+    tyvars'   <- renameLHsQTyVars tyvars
     rhs'     <- renameLType rhs
     return (SynDecl { tcdLName = lname', tcdTyVars = tyvars', tcdRhs = rhs', tcdFVs = placeHolderNames })
 
   DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdDataDefn = defn, tcdFVs = _fvs } -> do
     lname'    <- renameL lname
-    tyvars'   <- renameLTyVarBndrs tyvars
+    tyvars'   <- renameLHsQTyVars tyvars
     defn'     <- renameDataDefn defn
     return (DataDecl { tcdLName = lname', tcdTyVars = tyvars', tcdDataDefn = defn', tcdFVs = placeHolderNames })
 
@@ -352,7 +352,7 @@ renameTyClD d = case d of
             , tcdFDs = lfundeps, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs } -> do
     lcontext' <- renameLContext lcontext
     lname'    <- renameL lname
-    ltyvars'  <- renameLTyVarBndrs ltyvars
+    ltyvars'  <- renameLHsQTyVars ltyvars
     lfundeps' <- mapM renameLFunDep lfundeps
     lsigs'    <- mapM renameLSig lsigs
     ats'      <- mapM (renameLThing renameFamilyDecl) ats
@@ -376,7 +376,7 @@ renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname
                              , fdInjectivityAnn = injectivity }) = do
     info'        <- renameFamilyInfo info
     lname'       <- renameL lname
-    ltyvars'     <- renameLTyVarBndrs ltyvars
+    ltyvars'     <- renameLHsQTyVars ltyvars
     result'      <- renameFamilyResultSig result
     injectivity' <- renameMaybeInjectivityAnn injectivity
     return (FamilyDecl { fdInfo = info', fdLName = lname'
@@ -415,7 +415,7 @@ renameCon decl@(ConDecl { con_names = lnames, con_qvars = ltyvars
                         , con_cxt = lcontext, con_details = details
                         , con_res = restype, con_doc = mbldoc }) = do
       lnames'   <- mapM renameL lnames
-      ltyvars'  <- renameLTyVarBndrs ltyvars
+      ltyvars'  <- renameLHsQTyVars ltyvars
       lcontext' <- renameLContext lcontext
       details'  <- renameDetails details
       restype'  <- renameResType restype
@@ -453,15 +453,12 @@ renameSig :: Sig Name -> RnM (Sig DocName)
 renameSig sig = case sig of
   TypeSig lnames ltype -> do
     lnames' <- mapM renameL lnames
-    ltype' <- renameLWcSigType ltype
+    ltype' <- renameLSigWcType ltype
     return (TypeSig lnames' ltype')
-  PatSynSig lname (flag, qtvs) lreq lprov lty -> do
+  PatSynSig lname sig_ty -> do
     lname' <- renameL lname
-    qtvs' <- renameLTyVarBndrs qtvs
-    lreq' <- renameLContext lreq
-    lprov' <- renameLContext lprov
-    lty' <- renameLSigType lty
-    return $ PatSynSig lname' (flag, qtvs') lreq' lprov' lty'
+    sig_ty' <- renameLSigType sig_ty
+    return $ PatSynSig lname' sig_ty'
   FixSig (FixitySig lnames fixity) -> do
     lnames' <- mapM renameL lnames
     return $ FixSig (FixitySig lnames' fixity)
@@ -496,7 +493,7 @@ renameClsInstD :: ClsInstDecl Name -> RnM (ClsInstDecl DocName)
 renameClsInstD (ClsInstDecl { cid_overlap_mode = omode
                             , cid_poly_ty =ltype, cid_tyfam_insts = lATs
                             , cid_datafam_insts = lADTs }) = do
-  ltype' <- renameLType ltype
+  ltype' <- renameLSigType ltype
   lATs'  <- mapM (mapM renameTyFamInstD) lATs
   lADTs' <- mapM (mapM renameDataFamInstD) lADTs
   return (ClsInstDecl { cid_overlap_mode = omode
@@ -523,7 +520,7 @@ renameLTyFamInstEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_rhs
 renameLTyFamDefltEqn :: LTyFamDefltEqn Name -> RnM (LTyFamDefltEqn DocName)
 renameLTyFamDefltEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = tvs, tfe_rhs = rhs }))
   = do { tc'  <- renameL tc
-       ; tvs' <- renameLTyVarBndrs tvs
+       ; tvs' <- renameLHsQTyVars tvs
        ; rhs' <- renameLType rhs
        ; return (L loc (TyFamEqn { tfe_tycon = tc'
                                  , tfe_pats = tvs'
@@ -544,15 +541,15 @@ renameImplicit :: (in_thing -> RnM out_thing)
 renameImplicit rn_thing (HsIB { hsib_body = thing })
   = do { thing' <- rn_thing thing
        ; return (HsIB { hsib_body = thing'
-                      , hsib_kvs = PlaceHolder, hsib_tvs = PlaceHolder })
+                      , hsib_kvs = PlaceHolder, hsib_tvs = PlaceHolder }) }
 
 renameWc :: (in_thing -> RnM out_thing)
-               -> HsWildcardBndrs Name in_thing
-               -> RnM (HsWildcardBndrs DocName out_thing)
+         -> HsWildCardBndrs Name in_thing
+         -> RnM (HsWildCardBndrs DocName out_thing)
 renameWc rn_thing (HsWC { hswc_body = thing })
   = do { thing' <- rn_thing thing
        ; return (HsWC { hswc_body = thing'
-                      , hswc_wcs = PlaceHolder, hswc_ctx = Nothing })
+                      , hswc_wcs = PlaceHolder, hswc_ctx = Nothing }) }
 
 renameExportItem :: ExportItem Name -> RnM (ExportItem DocName)
 renameExportItem item = case item of
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index 3964c86a..6a499f64 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -16,6 +16,7 @@ module Haddock.Utils (
   -- * Misc utilities
   restrictTo, emptyHsQTvs,
   toDescription, toInstalledDescription,
+  mkEmptySigWcType, addClassContext, lHsQTyVarsToTypes,
 
   -- * Filename utilities
   moduleHtmlFile, moduleHtmlFile',
@@ -124,6 +125,34 @@ toInstalledDescription = fmap mkMeta . hmi_description . instInfo
 mkMeta :: Doc a -> MDoc a
 mkMeta x = emptyMetaDoc { _doc = x }
 
+mkEmptySigWcType :: LHsType Name -> LHsSigWcType Name
+-- Dubious, because the implicit binders are empty even
+-- though the type might have free varaiables
+mkEmptySigWcType ty = mkEmptyImplicitBndrs (mkEmptyWildCardBndrs ty)
+
+addClassContext :: Name -> LHsQTyVars Name -> LSig Name -> LSig Name
+-- Add the class context to a class-op signature
+addClassContxt cls tvs0 (L pos (ClassOpSig _ lname ltype))
+  = L pos (TypeSig lname (mkEmptySigWcType (go (hsSigType ltype))))
+          -- The mkEmptySigWcType is suspicious
+  where
+    go (L loc (HsForAllTy { hst_bndrs = tvs, hst_body = ty }))
+       = L loc (HsForAllTy { hst_bndrs = tvs, hst_body = go ty })
+    go (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty }))
+       = L loc (HsQualTy { hst_ctxt = add_ctxt ctxt, hst_body = ty })
+    go (L loc ty)
+       = L loc (HsQualTy { hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty })
+
+    extra_pred = nlHsTyConApp cls (lHsQTyVarsToTypes tvs0)
+    add_ctxt (L loc preds) = L loc (extra_pred : preds)
+
+addClassContext _ _ sig = sig   -- E.g. a MinimalSig is fine
+
+lHsQTyVarsToTypes :: LHsQTyVars Name -> [LHsType Name]
+lHsQTyVarsToTypes tvs
+  = [ noLoc (HsTyVar (hsLTyVarName tv))
+    | tv <- hsQTvBndrs tvs ]
+
 --------------------------------------------------------------------------------
 -- * Making abstract declarations
 --------------------------------------------------------------------------------
-- 
cgit v1.2.3


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

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

(limited to 'haddock-api/src')

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


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

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

(limited to 'haddock-api/src')

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


From 617392c5df94fae16261e1d298ce5c87575233c8 Mon Sep 17 00:00:00 2001
From: Simon Peyton Jones <simonpj@microsoft.com>
Date: Tue, 27 Oct 2015 14:24:56 +0000
Subject: Track change to PatSyn.patSynSig

---
 haddock-api/src/Haddock/Convert.hs | 9 ++++++++-
 1 file changed, 8 insertions(+), 1 deletion(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 7f807569..2458f027 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -100,7 +100,14 @@ tyThingToLHsDecl t = case t of
     (synifySigWcType ImplicitizeForAll (dataConUserType dc)))
 
   AConLike (PatSynCon ps) ->
-     allOK . SigD $ PatSynSig (synifyName ps) (synifySigType WithinType (patSynType ps))
+      let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, res_ty) = patSynSig ps
+          qtvs = univ_tvs ++ ex_tvs
+          ty = mkFunTys arg_tys res_ty
+      in allOK . SigD $ PatSynSig (synifyName ps)
+                          (Implicit, synifyTyVars qtvs)
+                          (synifyCtx req_theta)
+                          (synifyCtx prov_theta)
+                          (synifyType WithinType ty)
   where
     withErrs e x = return (e, x)
     allOK x = return (mempty, x)
-- 
cgit v1.2.3


From 3e6b341a7bc2331a1646760f20f2451932d725d6 Mon Sep 17 00:00:00 2001
From: Ben Gamari <ben@smart-cactus.org>
Date: Wed, 23 Sep 2015 18:43:18 +0200
Subject: Account for Typeable changes

The treatment of type families changed.
---
 haddock-api/src/Haddock/Convert.hs | 69 ++++++++++++++++++--------------------
 1 file changed, 32 insertions(+), 37 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 2458f027..e563ac08 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -141,7 +141,7 @@ synifyAxiom ax@(CoAxiom { co_ax_tc = tc })
 
 -- | Turn type constructors into type class declarations
 synifyTyCon :: Maybe (CoAxiom br) -> TyCon -> Either ErrMsg (TyClDecl Name)
-synifyTyCon coax tc
+synifyTyCon _coax tc
   | isFunTyCon tc || isPrimTyCon tc
   = return $
     DataDecl { tcdLName = synifyName tc
@@ -164,42 +164,37 @@ synifyTyCon coax tc
                                       , dd_derivs = Nothing }
            , tcdFVs = placeHolderNamesTc }
 
-  | isTypeFamilyTyCon tc
-  = case famTyConFlav_maybe tc of
-      Just rhs ->
-        let resultVar = famTcResVar tc
-            info = case rhs of
-              OpenSynFamilyTyCon -> return OpenTypeFamily
-              ClosedSynFamilyTyCon mb -> case mb of
-                  Just (CoAxiom { co_ax_branches = branches })
-                          -> return $ ClosedTypeFamily $ Just $
-                               map (noLoc . synifyAxBranch tc) (fromBranches branches)
-                  Nothing -> return $ ClosedTypeFamily $ Just []
-              BuiltInSynFamTyCon {}
-                -> return $ ClosedTypeFamily $ Just []
-              AbstractClosedSynFamilyTyCon {}
-                -> return $ ClosedTypeFamily Nothing
-        in info >>= \i ->
-           return (FamDecl (FamilyDecl { fdInfo = i
-                          , fdLName = synifyName tc
-                          , fdTyVars = synifyTyVars (tyConTyVars tc)
-                          , fdResultSig =
-                              synifyFamilyResultSig resultVar (tyConResKind tc)
-                          , fdInjectivityAnn =
-                              synifyInjectivityAnn  resultVar (tyConTyVars tc)
-                                               (familyTyConInjectivityInfo tc)
-                          }))
-      Nothing -> Left "synifyTyCon: impossible open type synonym?"
-
-  | isDataFamilyTyCon tc
-  = --(why no "isOpenAlgTyCon"?)
-    case algTyConRhs tc of
-        DataFamilyTyCon -> return $
-          FamDecl (FamilyDecl DataFamily (synifyName tc)
-                              (synifyTyVars (tyConTyVars tc))
-                              (noLoc NoSig) -- always kind '*'
-                              Nothing)      -- no injectivity
-        _ -> Left "synifyTyCon: impossible open data type?"
+synifyTyCon _coax tc
+  | Just flav <- famTyConFlav_maybe tc
+  = case flav of
+      -- Type families
+      OpenSynFamilyTyCon -> mkFamDecl OpenTypeFamily
+      ClosedSynFamilyTyCon mb
+        | Just (CoAxiom { co_ax_branches = branches }) <- mb
+          -> mkFamDecl $ ClosedTypeFamily $ Just
+            $ map (noLoc . synifyAxBranch tc) (fromBranches branches)
+        | otherwise
+          -> mkFamDecl $ ClosedTypeFamily $ Just []
+      BuiltInSynFamTyCon {}
+        -> mkFamDecl $ ClosedTypeFamily $ Just []
+      AbstractClosedSynFamilyTyCon {}
+        -> mkFamDecl $ ClosedTypeFamily Nothing
+      DataFamilyTyCon {}
+        -> mkFamDecl DataFamily
+  where
+    resultVar = famTcResVar tc
+    mkFamDecl i = return $ FamDecl $
+      FamilyDecl { fdInfo = i
+                 , fdLName = synifyName tc
+                 , fdTyVars = synifyTyVars (tyConTyVars tc)
+                 , fdResultSig =
+                       synifyFamilyResultSig resultVar (tyConResKind tc)
+                 , fdInjectivityAnn =
+                       synifyInjectivityAnn  resultVar (tyConTyVars tc)
+                                       (familyTyConInjectivityInfo tc)
+                 }
+
+synifyTyCon coax tc
   | Just ty <- synTyConRhs_maybe tc
   = return $ SynDecl { tcdLName = synifyName tc
                      , tcdTyVars = synifyTyVars (tyConTyVars tc)
-- 
cgit v1.2.3


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

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

(limited to 'haddock-api/src')

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


From e02a744ba29b7b8c904563c42b59e781f586491b Mon Sep 17 00:00:00 2001
From: Matthew Pickering <matthewtpickering@gmail.com>
Date: Sun, 1 Nov 2015 12:08:58 +0000
Subject: Change for IEThingWith

---
 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 6f0254c5..ba3cee25 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -507,7 +507,7 @@ mkExportItems
     lookupExport (IEVar (L _ x))         = declWith x
     lookupExport (IEThingAbs (L _ t))    = declWith t
     lookupExport (IEThingAll (L _ t))    = declWith t
-    lookupExport (IEThingWith (L _ t) _ _) = declWith t
+    lookupExport (IEThingWith (L _ t) _ _ _) = declWith t
     lookupExport (IEModuleContents (L _ m)) =
       moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps fixMap splices
     lookupExport (IEGroup lev docStr)  = return $
-- 
cgit v1.2.3


From 064a7dfb98c197cd04f596aa7593b56cc93b63b6 Mon Sep 17 00:00:00 2001
From: Ben Gamari <ben@smart-cactus.org>
Date: Wed, 11 Nov 2015 11:35:51 +0100
Subject: Eliminate support for deprecated GADT syntax

Follows from GHC D1460.
---
 haddock-api/src/Haddock/Convert.hs | 6 ++----
 1 file changed, 2 insertions(+), 4 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index b829a5fd..ddf8f6b3 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -307,14 +307,12 @@ synifyDataCon use_gadt_syntax dc =
  in hs_arg_tys >>=
       \hat -> return $ noLoc $
               ConDecl { con_names = [name]
-                      , con_explicit = False    -- we don't know nor care
+                      , con_explicit = Implicit   -- we don't know nor care
                       , con_qvars = qvars
                       , con_cxt   = ctx
                       , con_details =  hat
                       , con_res = hs_res_ty
-                      , con_doc =  Nothing
-                -- we don't want any "deprecated GADT syntax" warnings!
-                      , con_old_rec = False }
+                      , con_doc =  Nothing }
 
 synifyName :: NamedThing n => n -> Located Name
 synifyName = noLoc . getName
-- 
cgit v1.2.3


From 22aef2dd92e488af31556b8b4c1e034d6eb25de9 Mon Sep 17 00:00:00 2001
From: "Edward Z. Yang" <ezyang@cs.stanford.edu>
Date: Fri, 13 Nov 2015 21:56:18 -0800
Subject: Undo msHsFilePath change.

Signed-off-by: Edward Z. Yang <ezyang@cs.stanford.edu>
---
 haddock-api/src/Haddock/Interface/Create.hs | 4 +---
 1 file changed, 1 insertion(+), 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 ba3cee25..1c2cf5c9 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -130,9 +130,7 @@ createInterface tm flags modMap instIfaceMap = do
 
   return $! Interface {
     ifaceMod             = mdl
-  , ifaceOrigFilename    = case msHsFilePath ms of
-                            Just path -> path
-                            Nothing -> "(none)"
+  , ifaceOrigFilename    = msHsFilePath ms
   , ifaceInfo            = info
   , ifaceDoc             = Documentation mbDoc modWarn
   , ifaceRnDoc           = Documentation Nothing Nothing
-- 
cgit v1.2.3


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

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

(limited to 'haddock-api/src')

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


From f310809a04592f8841583a2e146021d68f9a8432 Mon Sep 17 00:00:00 2001
From: Simon Peyton Jones <simonpj@microsoft.com>
Date: Mon, 23 Nov 2015 17:17:18 +0000
Subject: Wibble

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

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index f7a32dd3..658007ba 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -150,7 +150,7 @@ addClassContext _ _ sig = sig   -- E.g. a MinimalSig is fine
 
 lHsQTyVarsToTypes :: LHsQTyVars Name -> [LHsType Name]
 lHsQTyVarsToTypes tvs
-  = [ noLoc (HsTyVar (hsLTyVarName tv))
+  = [ noLoc (HsTyVar (noLoc (hsLTyVarName tv)))
     | tv <- hsQTvBndrs tvs ]
 
 --------------------------------------------------------------------------------
-- 
cgit v1.2.3


From 3f503bd54678ec9ea611ba81360b573eb745e7b0 Mon Sep 17 00:00:00 2001
From: Herbert Valerio Riedel <hvr@gnu.org>
Date: Sat, 5 Dec 2015 00:29:55 +0100
Subject: Canonicalise Monad instances

---
 haddock-api/src/Haddock/Interface/Rename.hs                    |  4 ++--
 haddock-api/src/Haddock/Types.hs                               | 10 +++++-----
 .../attoparsec-0.12.1.1/Data/Attoparsec/Internal/Types.hs      |  6 +++---
 3 files changed, 10 insertions(+), 10 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 4804faff..2183d8f2 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -91,13 +91,13 @@ newtype RnM a =
 
 instance Monad RnM where
   (>>=) = thenRn
-  return = returnRn
+  return = pure
 
 instance Functor RnM where
   fmap f x = do a <- x; return (f a)
 
 instance Applicative RnM where
-  pure = return
+  pure = returnRn
   (<*>) = ap
 
 returnRn :: a -> RnM a
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 9db11be6..e07f55f1 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -586,11 +586,11 @@ instance Functor ErrMsgM where
         fmap f (Writer (a, msgs)) = Writer (f a, msgs)
 
 instance Applicative ErrMsgM where
-    pure = return
-    (<*>) = ap
+    pure a = Writer (a, [])
+    (<*>)  = ap
 
 instance Monad ErrMsgM where
-        return a = Writer (a, [])
+        return   = pure
         m >>= k  = Writer $ let
                 (a, w)  = runWriter m
                 (b, w') = runWriter (k a)
@@ -639,11 +639,11 @@ instance Functor ErrMsgGhc where
   fmap f (WriterGhc x) = WriterGhc (fmap (first f) x)
 
 instance Applicative ErrMsgGhc where
-    pure = return
+    pure a = WriterGhc (return (a, []))
     (<*>) = ap
 
 instance Monad ErrMsgGhc where
-  return a = WriterGhc (return (a, []))
+  return = pure
   m >>= k = WriterGhc $ runWriterGhc m >>= \ (a, msgs1) ->
                fmap (second (msgs1 ++)) (runWriterGhc (k a))
 
diff --git a/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/Internal/Types.hs b/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/Internal/Types.hs
index 6719e09a..9c7994e9 100644
--- a/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/Internal/Types.hs
+++ b/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/Internal/Types.hs
@@ -126,7 +126,7 @@ instance Monad (Parser i) where
       where msg = "Failed reading: " ++ err
     {-# INLINE fail #-}
 
-    return v = Parser $ \t pos more _lose succ -> succ t pos more v
+    return = pure
     {-# INLINE return #-}
 
     m >>= k = Parser $ \t !pos more lose succ ->
@@ -158,7 +158,7 @@ apP d e = do
 {-# INLINE apP #-}
 
 instance Applicative (Parser i) where
-    pure   = return
+    pure v = Parser $ \t pos more _lose succ -> succ t pos more v
     {-# INLINE pure #-}
     (<*>)  = apP
     {-# INLINE (<*>) #-}
@@ -166,7 +166,7 @@ instance Applicative (Parser i) where
     -- These definitions are equal to the defaults, but this
     -- way the optimizer doesn't have to work so hard to figure
     -- that out.
-    (*>)   = (>>)
+    m *> k = m >>= \_ -> k
     {-# INLINE (*>) #-}
     x <* y = x >>= \a -> y >> return a
     {-# INLINE (<*) #-}
-- 
cgit v1.2.3


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

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

(limited to 'haddock-api/src')

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


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

A GADT Declaration is now presented as

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

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

(limited to 'haddock-api/src')

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


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

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

(limited to 'haddock-api/src')

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


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

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

(limited to 'haddock-api/src')

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


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

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

(limited to 'haddock-api/src')

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


From 85be6fdc7832eae3afd141229c8ac3475da8f542 Mon Sep 17 00:00:00 2001
From: Ben Gamari <ben@smart-cactus.org>
Date: Sat, 12 Dec 2015 17:20:15 +0100
Subject: Update for D1200

---
 haddock-api/haddock-api.cabal                   | 1 +
 haddock-api/src/Haddock/Interface/LexParseRn.hs | 5 +++--
 haddock-api/src/Haddock/Types.hs                | 5 +++--
 haddock.cabal                                   | 1 +
 4 files changed, 8 insertions(+), 4 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal
index 26bb1d94..7835ea50 100644
--- a/haddock-api/haddock-api.cabal
+++ b/haddock-api/haddock-api.cabal
@@ -48,6 +48,7 @@ library
     , array
     , xhtml >= 3000.2 && < 3000.3
     , Cabal >= 1.10
+    , ghc-boot
     , ghc >= 7.10 && < 7.12
 
     , ghc-paths
diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs
index 661bd6be..3c14498c 100644
--- a/haddock-api/src/Haddock/Interface/LexParseRn.hs
+++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs
@@ -21,7 +21,8 @@ module Haddock.Interface.LexParseRn
 import Data.IntSet (toList)
 import Data.List
 import Documentation.Haddock.Doc (metaDocConcat)
-import DynFlags (ExtensionFlag(..), languageExtensions)
+import DynFlags (languageExtensions)
+import qualified GHC.LanguageExtensions as LangExt
 import FastString
 import GHC
 import Haddock.Interface.ParseModuleHeader
@@ -64,7 +65,7 @@ processModuleHeader dflags gre safety mayStr = do
             doc' = overDoc (rename dflags gre) doc
         return (hmi', Just doc')
 
-  let flags :: [ExtensionFlag]
+  let flags :: [LangExt.Extension]
       -- We remove the flags implied by the language setting and we display the language instead
       flags = map toEnum (toList $ extensionFlags dflags) \\ languageExtensions (language dflags)
   return (hmi { hmi_safety = Just $ showPpr dflags safety
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 6bc00f63..914f00f2 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -33,7 +33,8 @@ import Documentation.Haddock.Types
 import BasicTypes (Fixity(..))
 
 import GHC hiding (NoLink)
-import DynFlags (ExtensionFlag, Language)
+import DynFlags (Language)
+import qualified GHC.LanguageExtensions as LangExt
 import Coercion
 import NameSet
 import OccName
@@ -494,7 +495,7 @@ data HaddockModInfo name = HaddockModInfo
   , hmi_portability :: Maybe String
   , hmi_safety      :: Maybe String
   , hmi_language    :: Maybe Language
-  , hmi_extensions  :: [ExtensionFlag]
+  , hmi_extensions  :: [LangExt.Extension]
   }
 
 
diff --git a/haddock.cabal b/haddock.cabal
index 55af3c05..ec2a43bc 100644
--- a/haddock.cabal
+++ b/haddock.cabal
@@ -59,6 +59,7 @@ executable haddock
       array,
       xhtml >= 3000.2 && < 3000.3,
       Cabal >= 1.10,
+      ghc-boot,
       ghc >= 7.11 && < 7.13,
       bytestring,
       transformers
-- 
cgit v1.2.3


From a45a133af1f25ce60a8d1b0750c8f3ce452129d6 Mon Sep 17 00:00:00 2001
From: Ben Gamari <ben@smart-cactus.org>
Date: Wed, 16 Dec 2015 05:40:17 -0500
Subject: Types: Add Outputable[Bndr] DocName instances

---
 haddock-api/src/Haddock/Types.hs | 8 ++++++++
 1 file changed, 8 insertions(+)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 914f00f2..b837970b 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -301,6 +301,14 @@ instance NamedThing DocName where
   getName (Documented name _) = name
   getName (Undocumented name) = name
 
+-- | Useful for debugging
+instance Outputable DocName where
+  ppr = ppr . getName
+
+instance OutputableBndr DocName where
+  pprBndr _ = ppr . getName
+  pprPrefixOcc = pprPrefixOcc . getName
+  pprInfixOcc = pprInfixOcc . getName
 
 class NamedThing name => SetName name where
 
-- 
cgit v1.2.3


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

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

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

(limited to 'haddock-api/src')

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


From fa03f80d76f1511a811a0209ea7a6a8b6c58704f Mon Sep 17 00:00:00 2001
From: Ben Gamari <ben@smart-cactus.org>
Date: Wed, 16 Dec 2015 23:32:38 +0100
Subject: Fix Hyperlinker

GHC.con_names is now GHC.getConNames
---
 haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(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 1f396df5..e8baae88 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -127,7 +127,7 @@ decls (group, _, _, _) = concatMap ($ group)
         _ -> empty
     con term = case cast term of
         (Just cdcl) ->
-            map decl (GHC.con_names cdcl) ++ everything (<|>) fld cdcl
+            map decl (GHC.getConNames cdcl) ++ everything (<|>) fld cdcl
         Nothing -> empty
     ins term = case cast term of
         (Just (GHC.DataFamInstD inst)) -> pure . tyref $ GHC.dfid_tycon inst
-- 
cgit v1.2.3