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/Rename.hs | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

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

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/Rename.hs')

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/Rename.hs')

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


From 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/Rename.hs')

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


From 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/Rename.hs')

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


From 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/Rename.hs')

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/Rename.hs')

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


From 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/Rename.hs')

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/Rename.hs')

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


From 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/Rename.hs')

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


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

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

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

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


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

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

Reviewers: simonpj, austin

Reviewed By: austin

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

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

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

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


From 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/Rename.hs')

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


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

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

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

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


From 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/Rename.hs')

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/Rename.hs')

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/Rename.hs')

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


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

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

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

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


From 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/Rename.hs')

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/Rename.hs')

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


From 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/Rename.hs')

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


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

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

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

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


From 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/Rename.hs')

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