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/Interface/AttachInstances.hs | 11 ++++++-----
 haddock-api/src/Haddock/Interface/Rename.hs          |  4 ++--
 2 files changed, 8 insertions(+), 7 deletions(-)

(limited to 'haddock-api/src/Haddock/Interface')

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)
-- 
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/Haddock/Interface')

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

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

(limited to 'haddock-api/src/Haddock/Interface')

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


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

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

(limited to 'haddock-api/src/Haddock/Interface')

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/Haddock/Interface')

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 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/Haddock/Interface')

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/Haddock/Interface')

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 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/Haddock/Interface')

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/Haddock/Interface')

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 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/Haddock/Interface')

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

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

(limited to 'haddock-api/src/Haddock/Interface')

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 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/Haddock/Interface')

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

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

(limited to 'haddock-api/src/Haddock/Interface')

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 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/Haddock/Interface')

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

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

(limited to 'haddock-api/src/Haddock/Interface')

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

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

(limited to 'haddock-api/src/Haddock/Interface')

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/Haddock/Interface')

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 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/Haddock/Interface')

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/Haddock/Interface')

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 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/Haddock/Interface')

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

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

(limited to 'haddock-api/src/Haddock/Interface')

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


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

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

(limited to 'haddock-api/src/Haddock/Interface')

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/Haddock/Interface')

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/Haddock/Interface')

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/Haddock/Interface')

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 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/Haddock/Interface')

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

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

(limited to 'haddock-api/src/Haddock/Interface')

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 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/Haddock/Interface')

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 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/Haddock/Interface')

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/Haddock/Interface')

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/Haddock/Interface')

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/Haddock/Interface')

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

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

(limited to 'haddock-api/src/Haddock/Interface')

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/Haddock/Interface')

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 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/Haddock/Interface')

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/Haddock/Interface')

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 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/Haddock/Interface')

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/Haddock/Interface')

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

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

(limited to 'haddock-api/src/Haddock/Interface')

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


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

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

(limited to 'haddock-api/src/Haddock/Interface')

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


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

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

(limited to 'haddock-api/src/Haddock/Interface')

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/Haddock/Interface')

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

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

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

(limited to 'haddock-api/src/Haddock/Interface')

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