aboutsummaryrefslogtreecommitdiff
path: root/haddock-api
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api')
-rw-r--r--haddock-api/haddock-api.cabal4
-rw-r--r--haddock-api/src/Haddock/Backends/Hoogle.hs67
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs54
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs602
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml.hs2
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs528
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Utils.hs4
-rw-r--r--haddock-api/src/Haddock/Convert.hs155
-rw-r--r--haddock-api/src/Haddock/GhcUtils.hs155
-rw-r--r--haddock-api/src/Haddock/Interface/AttachInstances.hs2
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs213
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs253
-rw-r--r--haddock-api/src/Haddock/Interface/Specialize.hs168
-rw-r--r--haddock-api/src/Haddock/InterfaceFile.hs2
-rw-r--r--haddock-api/src/Haddock/Types.hs99
-rw-r--r--haddock-api/src/Haddock/Utils.hs63
16 files changed, 1359 insertions, 1012 deletions
diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal
index acb4d9e4..6a7fe0cb 100644
--- a/haddock-api/haddock-api.cabal
+++ b/haddock-api/haddock-api.cabal
@@ -40,9 +40,9 @@ library
default-language: Haskell2010
-- this package typically supports only single major versions
- build-depends: base ^>= 4.11.0
+ build-depends: base ^>= 4.12.0
, Cabal ^>= 2.2.0
- , ghc ^>= 8.4
+ , ghc ^>= 8.5
, ghc-paths ^>= 0.1.0.9
, haddock-library ^>= 1.6.0
, xhtml ^>= 3000.2.2
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index e7ce9d30..9a31428f 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Backends.Hoogle
@@ -73,21 +74,21 @@ dropHsDocTy :: HsType a -> HsType a
dropHsDocTy = f
where
g (L src x) = L src (f x)
- 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)
- f (HsListTy a) = HsListTy (g a)
- f (HsPArrTy a) = HsPArrTy (g a)
- f (HsTupleTy a b) = HsTupleTy a (map g b)
- f (HsOpTy a b c) = HsOpTy (g a) b (g c)
- f (HsParTy a) = HsParTy (g a)
- f (HsKindSig a b) = HsKindSig (g a) b
- f (HsDocTy a _) = f $ unL a
+ f (HsForAllTy x a e) = HsForAllTy x a (g e)
+ f (HsQualTy x a e) = HsQualTy x a (g e)
+ f (HsBangTy x a b) = HsBangTy x a (g b)
+ f (HsAppTy x a b) = HsAppTy x (g a) (g b)
+ f (HsFunTy x a b) = HsFunTy x (g a) (g b)
+ f (HsListTy x a) = HsListTy x (g a)
+ f (HsPArrTy x a) = HsPArrTy x (g a)
+ f (HsTupleTy x a b) = HsTupleTy x a (map g b)
+ f (HsOpTy x a b c) = HsOpTy x (g a) b (g c)
+ f (HsParTy x a) = HsParTy x (g a)
+ f (HsKindSig x a b) = HsKindSig x (g a) b
+ f (HsDocTy _ a _) = f $ unL a
f x = x
-outHsType :: (SourceTextX a, OutputableBndrId a)
+outHsType :: (a ~ GhcPass p, OutputableBndrId a)
=> DynFlags -> HsType a -> String
outHsType dflags = out dflags . dropHsDocTy
@@ -125,20 +126,20 @@ ppExport dflags ExportDecl { expItemDecl = L _ decl
, expItemFixities = fixities
} = ppDocumentation dflags dc ++ f decl
where
- f (TyClD d@DataDecl{}) = ppData dflags d subdocs
- f (TyClD d@SynDecl{}) = ppSynonym dflags d
- f (TyClD d@ClassDecl{}) = ppClass dflags d subdocs
- f (TyClD (FamDecl d)) = ppFam dflags d
- 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 (TyClD _ d@DataDecl{}) = ppData dflags d subdocs
+ f (TyClD _ d@SynDecl{}) = ppSynonym dflags d
+ f (TyClD _ d@ClassDecl{}) = ppClass dflags d subdocs
+ f (TyClD _ (FamDecl _ d)) = ppFam dflags d
+ 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 _ = []
ppFixities = concatMap (ppFixity dflags) fixities
ppExport _ _ = []
ppSigWithDoc :: DynFlags -> Sig GhcRn -> [(Name, DocForDecl Name)] -> [String]
-ppSigWithDoc dflags (TypeSig names sig) subdocs
+ppSigWithDoc dflags (TypeSig _ names sig) subdocs
= concatMap mkDocSig names
where
mkDocSig n = mkSubdoc dflags n subdocs [pp_sig dflags [n] (hsSigWcType sig)]
@@ -189,7 +190,7 @@ ppClass dflags decl subdocs =
, tcdTyVars = feqn_pats tfe
, tcdFixity = feqn_fixity tfe
, tcdRhs = feqn_rhs tfe
- , tcdFVs = emptyNameSet
+ , tcdSExt = emptyNameSet
}
ppFam :: DynFlags -> FamilyDecl GhcRn -> [String]
@@ -241,17 +242,17 @@ lookupCon dflags subdocs (L _ name) = case lookup name subdocs of
ppCtor :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> ConDecl GhcRn -> [String]
ppCtor dflags dat subdocs con@ConDeclH98 {}
-- AZ:TODO get rid of the concatMap
- = concatMap (lookupCon dflags subdocs) [con_name con] ++ f (getConDetails con)
+ = concatMap (lookupCon dflags subdocs) [con_name con] ++ f (getConArgs con)
where
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 . noLoc . selectorFieldOcc . unLoc) (cd_fld_names r)) ++
- [out dflags (map (selectorFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]]
+ [(concatMap (lookupCon dflags subdocs . noLoc . extFieldOcc . unLoc) (cd_fld_names r)) ++
+ [out dflags (map (extFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]]
| r <- map unLoc recs]
- funs = foldr1 (\x y -> reL $ HsFunTy x y)
- apps = foldl1 (\x y -> reL $ HsAppTy x y)
+ funs = foldr1 (\x y -> reL $ HsFunTy NoExt x y)
+ apps = foldl1 (\x y -> reL $ HsAppTy NoExt x y)
typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds)
@@ -259,20 +260,20 @@ ppCtor dflags dat subdocs con@ConDeclH98 {}
-- docs for con_names on why it is a list to begin with.
name = commaSeparate dflags . map unL $ getConNames con
- resType = apps $ map (reL . HsTyVar NotPromoted . reL) $
- (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvExplicit $ tyClDeclTyVars dat]
+ resType = apps $ map (reL . HsTyVar NoExt NotPromoted . reL) $
+ (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _ _) <- hsQTvExplicit $ tyClDeclTyVars dat]
-ppCtor dflags _dat subdocs con@ConDeclGADT {}
+ppCtor dflags _dat subdocs con@(ConDeclGADT { })
= concatMap (lookupCon dflags subdocs) (getConNames con) ++ f
where
- f = [typeSig name (hsib_body $ con_type con)]
+ f = [typeSig name (getGADTConTypeG con)]
typeSig nm ty = operator nm ++ " :: " ++ outHsType dflags (unL ty)
name = out dflags $ map unL $ getConNames con
-
+ppCtor _ _ _ XConDecl {} = panic "haddock:ppCtor"
ppFixity :: DynFlags -> (Name, Fixity) -> [String]
-ppFixity dflags (name, fixity) = [out dflags ((FixitySig [noLoc name] fixity) :: FixitySig GhcRn)]
+ppFixity dflags (name, fixity) = [out dflags ((FixitySig noExt [noLoc name] fixity) :: FixitySig GhcRn)]
---------------------------------------------------------------------
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index c4a9091f..220a59fe 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -13,6 +13,7 @@ import Haddock.Backends.Hyperlinker.Types
import qualified GHC
import qualified SrcLoc
+import qualified Outputable as GHC
import Control.Applicative
import Control.Monad (guard)
@@ -79,9 +80,9 @@ variables =
everythingInRenamedSource (var `Syb.combine` rec)
where
var term = case cast term of
- (Just ((GHC.L sspan (GHC.HsVar name)) :: GHC.LHsExpr GHC.GhcRn)) ->
+ (Just ((GHC.L sspan (GHC.HsVar _ name)) :: GHC.LHsExpr GHC.GhcRn)) ->
pure (sspan, RtkVar (GHC.unLoc name))
- (Just (GHC.L _ (GHC.RecordCon (GHC.L sspan name) _ _ _))) ->
+ (Just (GHC.L _ (GHC.RecordCon _ (GHC.L sspan name) _))) ->
pure (sspan, RtkVar name)
_ -> empty
rec term = case cast term of
@@ -95,9 +96,9 @@ types = everythingInRenamedSource ty
where
ty :: forall a. Data a => a -> [(GHC.SrcSpan, TokenDetails)]
ty term = case cast term of
- (Just ((GHC.L sspan (GHC.HsTyVar _ name)) :: GHC.LHsType GHC.GhcRn)) ->
+ (Just ((GHC.L sspan (GHC.HsTyVar _ _ name)) :: GHC.LHsType GHC.GhcRn)) ->
pure (sspan, RtkType (GHC.unLoc name))
- (Just ((GHC.L sspan (GHC.HsOpTy l name r)) :: GHC.LHsType GHC.GhcRn)) ->
+ (Just ((GHC.L sspan (GHC.HsOpTy _ l name r)) :: GHC.LHsType GHC.GhcRn)) ->
(sspan, RtkType (GHC.unLoc name)):(ty l ++ ty r)
_ -> empty
@@ -112,20 +113,20 @@ binds = everythingInRenamedSource
(fun `Syb.combine` pat `Syb.combine` tvar)
where
fun term = case cast term of
- (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.GhcRn)) ->
+ (Just (GHC.FunBind _ (GHC.L sspan name) _ _ _ :: GHC.HsBind GHC.GhcRn)) ->
pure (sspan, RtkBind name)
- (Just (GHC.PatSynBind (GHC.PSB (GHC.L sspan name) _ args _ _))) ->
+ (Just (GHC.PatSynBind _ (GHC.PSB _ (GHC.L sspan name) args _ _))) ->
pure (sspan, RtkBind name) ++ everythingInRenamedSource patsyn_binds args
_ -> empty
patsyn_binds term = case cast term of
(Just (GHC.L sspan (name :: GHC.Name))) -> pure (sspan, RtkVar name)
_ -> empty
pat term = case cast term of
- (Just ((GHC.L sspan (GHC.VarPat name)) :: GHC.LPat GHC.GhcRn)) ->
+ (Just ((GHC.L sspan (GHC.VarPat _ name)) :: GHC.LPat GHC.GhcRn)) ->
pure (sspan, RtkBind (GHC.unLoc name))
(Just (GHC.L _ (GHC.ConPatIn (GHC.L sspan name) recs))) ->
[(sspan, RtkVar name)] ++ everythingInRenamedSource rec recs
- (Just (GHC.L _ (GHC.AsPat (GHC.L sspan name) _))) ->
+ (Just (GHC.L _ (GHC.AsPat _ (GHC.L sspan name) _))) ->
pure (sspan, RtkBind name)
_ -> empty
rec term = case cast term of
@@ -133,9 +134,9 @@ binds = everythingInRenamedSource
pure (sspan, RtkVar name)
_ -> empty
tvar term = case cast term of
- (Just ((GHC.L sspan (GHC.UserTyVar name)) :: GHC.LHsTyVarBndr GHC.GhcRn)) ->
+ (Just ((GHC.L sspan (GHC.UserTyVar _ name)) :: GHC.LHsTyVarBndr GHC.GhcRn)) ->
pure (sspan, RtkBind (GHC.unLoc name))
- (Just (GHC.L _ (GHC.KindedTyVar (GHC.L sspan name) _))) ->
+ (Just (GHC.L _ (GHC.KindedTyVar _ (GHC.L sspan name) _))) ->
pure (sspan, RtkBind name)
_ -> empty
@@ -150,16 +151,17 @@ decls (group, _, _, _) = concatMap ($ group)
where
typ (GHC.L _ t) = case t of
GHC.DataDecl { tcdLName = name } -> pure . decl $ name
- GHC.SynDecl name _ _ _ _ -> pure . decl $ name
- GHC.FamDecl fam -> pure . decl $ GHC.fdLName fam
+ GHC.SynDecl _ name _ _ _ -> pure . decl $ name
+ GHC.FamDecl _ fam -> pure . decl $ GHC.fdLName fam
GHC.ClassDecl{..} ->
[decl tcdLName]
++ concatMap sig tcdSigs
++ concatMap tyfam tcdATs
+ GHC.XTyClDecl {} -> GHC.panic "haddock:decls"
fun term = case cast term of
- (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.GhcRn))
+ (Just (GHC.FunBind _ (GHC.L sspan name) _ _ _ :: GHC.HsBind GHC.GhcRn))
| GHC.isExternalName name -> pure (sspan, RtkDecl name)
- (Just (GHC.PatSynBind (GHC.PSB (GHC.L sspan name) _ _ _ _)))
+ (Just (GHC.PatSynBind _ (GHC.PSB _ (GHC.L sspan name) _ _ _)))
| GHC.isExternalName name -> pure (sspan, RtkDecl name)
_ -> empty
con term = case cast term of
@@ -168,24 +170,24 @@ decls (group, _, _, _) = concatMap ($ group)
++ everythingInRenamedSource fld cdcl
Nothing -> empty
ins term = case cast term of
- (Just ((GHC.DataFamInstD (GHC.DataFamInstDecl eqn))
+ (Just ((GHC.DataFamInstD _ (GHC.DataFamInstDecl eqn))
:: GHC.InstDecl GHC.GhcRn))
-> pure . tyref $ GHC.feqn_tycon $ GHC.hsib_body eqn
- (Just (GHC.TyFamInstD (GHC.TyFamInstDecl eqn))) ->
+ (Just (GHC.TyFamInstD _ (GHC.TyFamInstDecl eqn))) ->
pure . tyref $ GHC.feqn_tycon $ GHC.hsib_body eqn
_ -> empty
fld term = case cast term of
Just (field :: GHC.ConDeclField GHC.GhcRn)
- -> map (decl . fmap GHC.selectorFieldOcc) $ GHC.cd_fld_names field
+ -> map (decl . fmap GHC.extFieldOcc) $ GHC.cd_fld_names field
Nothing -> empty
fix term = case cast term of
- Just ((GHC.FixitySig names _) :: GHC.FixitySig GHC.GhcRn)
+ Just ((GHC.FixitySig _ names _) :: GHC.FixitySig GHC.GhcRn)
-> map (\(GHC.L sspan x) -> (sspan, RtkVar x)) names
Nothing -> empty
tyfam (GHC.L _ (GHC.FamilyDecl{..})) = [decl fdLName]
- sig (GHC.L _ (GHC.TypeSig names _)) = map decl names
- sig (GHC.L _ (GHC.PatSynSig names _)) = map decl names
- sig (GHC.L _ (GHC.ClassOpSig _ names _)) = map decl names
+ sig (GHC.L _ (GHC.TypeSig _ names _)) = map decl names
+ sig (GHC.L _ (GHC.PatSynSig _ names _)) = map decl names
+ sig (GHC.L _ (GHC.ClassOpSig _ _ names _)) = map decl names
sig _ = []
decl (GHC.L sspan name) = (sspan, RtkDecl name)
tyref (GHC.L sspan name) = (sspan, RtkType name)
@@ -199,12 +201,12 @@ imports src@(_, imps, _, _) =
everythingInRenamedSource ie src ++ mapMaybe (imp . GHC.unLoc) imps
where
ie term = case cast term of
- (Just ((GHC.IEVar v) :: GHC.IE GHC.GhcRn)) -> pure $ var $ GHC.ieLWrappedName v
- (Just (GHC.IEThingAbs t)) -> pure $ typ $ GHC.ieLWrappedName t
- (Just (GHC.IEThingAll t)) -> pure $ typ $ GHC.ieLWrappedName t
- (Just (GHC.IEThingWith t _ vs _fls)) ->
+ (Just ((GHC.IEVar _ v) :: GHC.IE GHC.GhcRn)) -> pure $ var $ GHC.ieLWrappedName v
+ (Just (GHC.IEThingAbs _ t)) -> pure $ typ $ GHC.ieLWrappedName t
+ (Just (GHC.IEThingAll _ t)) -> pure $ typ $ GHC.ieLWrappedName t
+ (Just (GHC.IEThingWith _ t _ vs _fls)) ->
[typ $ GHC.ieLWrappedName t] ++ map (var . GHC.ieLWrappedName) vs
- (Just (GHC.IEModuleContents m)) -> pure $ modu m
+ (Just (GHC.IEModuleContents _ m)) -> pure $ modu m
_ -> 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/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 38fccf0c..d06e85d1 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -179,13 +179,14 @@ string_txt (PStr s1) s2 = unpackFS s1 ++ s2
string_txt (ZStr s1) s2 = zString s1 ++ s2
string_txt (LStr s1 _) s2 = unpackLitString s1 ++ s2
-
+-- | Prints out an entry in a module export list.
exportListItem :: ExportItem DocNameI -> LaTeX
exportListItem ExportDecl { expItemDecl = decl, expItemSubDocs = subdocs }
- = sep (punctuate comma . map ppDocBinder $ declNames decl) <>
- case subdocs of
- [] -> empty
- _ -> parens (sep (punctuate comma (map (ppDocBinder . fst) subdocs)))
+ = let (leader, names) = declNames decl
+ in sep (punctuate comma [ leader <+> ppDocBinder name | name <- names ]) <>
+ case subdocs of
+ [] -> empty
+ _ -> parens (sep (punctuate comma (map (ppDocBinder . fst) subdocs)))
exportListItem (ExportNoDecl y [])
= ppDocBinder y
exportListItem (ExportNoDecl y subs)
@@ -215,7 +216,7 @@ processExports (e : es) =
isSimpleSig :: ExportItem DocNameI -> Maybe ([DocName], HsType DocNameI)
-isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig lnames t))
+isSimpleSig ExportDecl { expItemDecl = L _ (SigD _ (TypeSig _ lnames t))
, expItemMbDoc = (Documentation Nothing Nothing, argDocs) }
| Map.null argDocs = Just (map unLoc lnames, unLoc (hsSigWcType t))
isSimpleSig _ = Nothing
@@ -249,13 +250,17 @@ ppDocGroup lev doc = sec lev <> braces doc
sec _ = text "\\paragraph"
-declNames :: LHsDecl DocNameI -> [DocName]
+-- | Given a declaration, extract out the names being declared
+declNames :: LHsDecl DocNameI
+ -> ( LaTeX -- ^ to print before each name in an export list
+ , [DocName] -- ^ names being declared
+ )
declNames (L _ decl) = case decl of
- TyClD d -> [tcdName d]
- SigD (TypeSig lnames _ ) -> map unLoc lnames
- SigD (PatSynSig lnames _) -> map unLoc lnames
- ForD (ForeignImport (L _ n) _ _ _) -> [n]
- ForD (ForeignExport (L _ n) _ _ _) -> [n]
+ TyClD _ d -> (empty, [tcdName d])
+ SigD _ (TypeSig _ lnames _ ) -> (empty, map unLoc lnames)
+ SigD _ (PatSynSig _ lnames _) -> (text "pattern", map unLoc lnames)
+ ForD _ (ForeignImport _ (L _ n) _ _) -> (empty, [n])
+ ForD _ (ForeignExport _ (L _ n) _ _) -> (empty, [n])
_ -> error "declaration not supported by declNames"
@@ -278,47 +283,44 @@ moduleBasename mdl = map (\c -> if c == '.' then '-' else c)
-- * Decls
-------------------------------------------------------------------------------
-
-ppDecl :: LHsDecl DocNameI
- -> [(HsDecl DocNameI, DocForDecl DocName)]
- -> DocForDecl DocName
- -> [DocInstance DocNameI]
- -> [(DocName, DocForDecl DocName)]
- -> [(DocName, Fixity)]
+-- | Pretty print a declaration
+ppDecl :: LHsDecl DocNameI -- ^ decl to print
+ -> [(HsDecl DocNameI, DocForDecl DocName)] -- ^ all pattern decls
+ -> DocForDecl DocName -- ^ documentation for decl
+ -> [DocInstance DocNameI] -- ^ all instances
+ -> [(DocName, DocForDecl DocName)] -- ^ all subdocs
+ -> [(DocName, Fixity)] -- ^ all fixities
-> LaTeX
-ppDecl (L loc decl) pats (doc, fnArgsDoc) instances subdocs _fixities = case decl of
- TyClD d@(FamDecl {}) -> ppTyFam False loc doc d unicode
- TyClD d@(DataDecl {})
- -> ppDataDecl pats instances subdocs loc (Just doc) d unicode
- TyClD d@(SynDecl {}) -> ppTySyn loc (doc, fnArgsDoc) d unicode
+ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of
+ TyClD _ d@FamDecl {} -> ppTyFam False doc d unicode
+ TyClD _ d@DataDecl {} -> ppDataDecl pats instances subdocs (Just doc) d unicode
+ TyClD _ d@SynDecl {} -> ppTySyn (doc, fnArgsDoc) d unicode
-- Family instances happen via FamInst now
--- TyClD d@(TySynonym {})
+-- TyClD _ d@TySynonym{}
-- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode
-- Family instances happen via FamInst now
- TyClD d@(ClassDecl {}) -> ppClassDecl instances loc doc subdocs d unicode
- SigD (TypeSig lnames t) -> ppFunSig loc (doc, fnArgsDoc) (map unLoc lnames)
- (hsSigWcType t) unicode
- SigD (PatSynSig lnames ty) ->
- ppLPatSig loc (doc, fnArgsDoc) (map unLoc lnames) ty unicode
- ForD d -> ppFor loc (doc, fnArgsDoc) d unicode
- InstD _ -> empty
- DerivD _ -> empty
+ TyClD _ d@ClassDecl{} -> ppClassDecl instances doc subdocs d unicode
+ SigD _ (TypeSig _ lnames ty) -> ppFunSig (doc, fnArgsDoc) (map unLoc lnames) (hsSigWcType ty) unicode
+ SigD _ (PatSynSig _ lnames ty) -> ppLPatSig (doc, fnArgsDoc) (map unLoc lnames) ty unicode
+ ForD _ d -> ppFor (doc, fnArgsDoc) d unicode
+ InstD _ _ -> empty
+ DerivD _ _ -> empty
_ -> error "declaration not supported by ppDecl"
where
unicode = False
-ppTyFam :: Bool -> SrcSpan -> Documentation DocName ->
+ppTyFam :: Bool -> Documentation DocName ->
TyClDecl DocNameI -> Bool -> LaTeX
-ppTyFam _ _ _ _ _ =
+ppTyFam _ _ _ _ =
error "type family declarations are currently not supported by --latex"
-ppFor :: SrcSpan -> DocForDecl DocName -> ForeignDecl DocNameI -> Bool -> LaTeX
-ppFor loc doc (ForeignImport (L _ name) typ _ _) unicode =
- ppFunSig loc doc [name] (hsSigType typ) unicode
-ppFor _ _ _ _ = error "ppFor error in Haddock.Backends.LaTeX"
+ppFor :: DocForDecl DocName -> ForeignDecl DocNameI -> Bool -> LaTeX
+ppFor doc (ForeignImport _ (L _ name) typ _) unicode =
+ ppFunSig doc [name] (hsSigType typ) unicode
+ppFor _ _ _ = error "ppFor error in Haddock.Backends.LaTeX"
-- error "foreign declarations are currently not supported by --latex"
@@ -328,18 +330,18 @@ ppFor _ _ _ _ = error "ppFor error in Haddock.Backends.LaTeX"
-- we skip type patterns for now
-ppTySyn :: SrcSpan -> DocForDecl DocName -> TyClDecl DocNameI -> Bool -> LaTeX
+ppTySyn :: DocForDecl DocName -> TyClDecl DocNameI -> Bool -> LaTeX
-ppTySyn loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars
+ppTySyn doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars
, tcdRhs = ltype }) unicode
- = ppTypeOrFunSig loc [name] (unLoc ltype) doc (full, hdr, char '=') unicode
+ = ppTypeOrFunSig (unLoc ltype) doc (full, hdr, char '=') unicode
where
hdr = hsep (keyword "type"
: ppDocBinder name
: map ppSymName (tyvarNames ltyvars))
full = hdr <+> char '=' <+> ppLType unicode ltype
-ppTySyn _ _ _ _ = error "declaration not supported by ppTySyn"
+ppTySyn _ _ _ = error "declaration not supported by ppTySyn"
-------------------------------------------------------------------------------
@@ -347,61 +349,98 @@ ppTySyn _ _ _ _ = error "declaration not supported by ppTySyn"
-------------------------------------------------------------------------------
-ppFunSig :: SrcSpan -> DocForDecl DocName -> [DocName] -> LHsType DocNameI
+ppFunSig :: DocForDecl DocName -> [DocName] -> LHsType DocNameI
-> Bool -> LaTeX
-ppFunSig loc doc docnames (L _ typ) unicode =
- ppTypeOrFunSig loc docnames typ doc
+ppFunSig doc docnames (L _ typ) unicode =
+ ppTypeOrFunSig typ doc
( ppTypeSig names typ False
, hsep . punctuate comma $ map ppSymName names
- , dcolon unicode)
+ , dcolon unicode
+ )
unicode
where
names = map getName docnames
-ppLPatSig :: SrcSpan -> DocForDecl DocName -> [DocName]
- -> LHsSigType DocNameI
- -> Bool -> LaTeX
-ppLPatSig _loc (doc, _argDocs) docnames ty unicode
- = declWithDoc pref1 (documentationToLaTeX doc)
+-- | Pretty-print a pattern synonym
+ppLPatSig :: DocForDecl DocName -- ^ documentation
+ -> [DocName] -- ^ pattern names in the pattern signature
+ -> LHsSigType DocNameI -- ^ type of the pattern synonym
+ -> Bool -- ^ unicode
+ -> LaTeX
+ppLPatSig doc docnames ty unicode
+ = ppTypeOrFunSig typ doc
+ ( keyword "pattern" <+> ppTypeSig names typ False
+ , keyword "pattern" <+> (hsep . punctuate comma $ map ppSymName names)
+ , dcolon unicode
+ )
+ unicode
where
- pref1 = hsep [ keyword "pattern"
- , hsep $ punctuate comma $ map ppDocBinder docnames
- , dcolon unicode
- , ppLType unicode (hsSigType ty)
- ]
-
-ppTypeOrFunSig :: SrcSpan -> [DocName] -> HsType DocNameI
- -> DocForDecl DocName -> (LaTeX, LaTeX, LaTeX)
- -> Bool -> LaTeX
-ppTypeOrFunSig _ _ typ (doc, argDocs) (pref1, pref2, sep0)
- unicode
- | Map.null argDocs =
- declWithDoc pref1 (documentationToLaTeX doc)
- | otherwise =
- declWithDoc pref2 $ Just $
+ typ = unLoc (hsSigType ty)
+ names = map getName docnames
+
+-- | Pretty-print a type, adding documentation to the whole type and its
+-- arguments as needed.
+ppTypeOrFunSig :: HsType DocNameI
+ -> DocForDecl DocName -- ^ documentation
+ -> ( LaTeX -- ^ first-line (no-argument docs only)
+ , LaTeX -- ^ first-line (argument docs only)
+ , LaTeX -- ^ type prefix (argument docs only)
+ )
+ -> Bool -- ^ unicode
+ -> LaTeX
+ppTypeOrFunSig typ (doc, argDocs) (pref1, pref2, sep0) unicode
+ | Map.null argDocs = declWithDoc pref1 (documentationToLaTeX doc)
+ | otherwise = declWithDoc pref2 $ Just $
text "\\haddockbeginargs" $$
- do_args 0 sep0 typ $$
+ vcat (map (uncurry (<->)) (ppSubSigLike unicode typ argDocs [] sep0)) $$
text "\\end{tabulary}\\par" $$
fromMaybe empty (documentationToLaTeX doc)
+
+-- This splits up a type signature along `->` and adds docs (when they exist)
+-- to the arguments. The output is a list of (leader/seperator, argument and
+-- its doc)
+ppSubSigLike :: Bool -- ^ unicode
+ -> HsType DocNameI -- ^ type signature
+ -> FnArgsDoc DocName -- ^ docs to add
+ -> [(DocName, DocForDecl DocName)] -- ^ all subdocs (useful when we have `HsRecTy`)
+ -> LaTeX -- ^ seperator (beginning of first line)
+ -> [(LaTeX, LaTeX)] -- ^ arguments (leader/sep, type)
+ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ
where
- do_largs n leader (L _ t) = do_args n leader t
-
- arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs
-
- do_args :: Int -> LaTeX -> HsType DocNameI -> LaTeX
- do_args _n leader (HsForAllTy tvs ltype)
- = decltt leader
- <-> decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]))
- <+> ppLType unicode ltype
- do_args n leader (HsQualTy lctxt ltype)
- = decltt leader
- <-> ppLContextNoArrow lctxt unicode <+> nl $$
- do_largs n (darrow unicode) ltype
- do_args n leader (HsFunTy lt r)
- = decltt leader <-> decltt (ppLFunLhType unicode lt) <-> arg_doc n <+> nl $$
- do_largs (n+1) (arrow unicode) r
- do_args n leader t
- = decltt leader <-> decltt (ppType unicode t) <-> arg_doc n <+> nl
+ do_largs n leader (L _ t) = do_args n leader t
+
+ arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs
+
+ do_args :: Int -> LaTeX -> HsType DocNameI -> [(LaTeX, LaTeX)]
+ do_args _n leader (HsForAllTy _ tvs ltype)
+ = [ ( decltt leader
+ , decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]))
+ <+> ppLType unicode ltype
+ ) ]
+ do_args n leader (HsQualTy _ lctxt ltype)
+ = (decltt leader, ppLContextNoArrow lctxt unicode <+> nl)
+ : do_largs n (darrow unicode) ltype
+
+ do_args n leader (HsFunTy _ (L _ (HsRecTy _ fields)) r)
+ = [ (decltt ldr, latex <+> nl)
+ | (L _ field, ldr) <- zip fields (leader <+> gadtOpen : repeat gadtComma)
+ , let latex = ppSideBySideField subdocs unicode field
+ ]
+ ++ do_largs (n+1) (gadtEnd <+> arrow unicode) r
+ do_args n leader (HsFunTy _ lt r)
+ = (decltt leader, decltt (ppLFunLhType unicode lt) <-> arg_doc n <+> nl)
+ : do_largs (n+1) (arrow unicode) r
+ do_args n leader t
+ = [ (decltt leader, decltt (ppType unicode t) <-> arg_doc n <+> nl) ]
+
+ -- FIXME: this should be done more elegantly
+ --
+ -- We need 'gadtComma' and 'gadtEnd' to line up with the `{` from
+ -- 'gadtOpen', so we add 3 spaces to cover for `-> `/`:: ` (3 in unicode
+ -- mode since `->` and `::` are rendered as single characters.
+ gadtComma = hcat (replicate (if unicode then 3 else 4) (text "\\ ")) <> text ","
+ gadtEnd = hcat (replicate (if unicode then 3 else 4) (text "\\ ")) <> text "\\}"
+ gadtOpen = text "\\{"
ppTypeSig :: [Name] -> HsType DocNameI -> Bool -> LaTeX
@@ -483,10 +522,10 @@ ppFds fds unicode =
hsep (map (ppDocName . unLoc) vars2)
-ppClassDecl :: [DocInstance DocNameI] -> SrcSpan
+ppClassDecl :: [DocInstance DocNameI]
-> Documentation DocName -> [(DocName, DocForDecl DocName)]
-> TyClDecl DocNameI -> Bool -> LaTeX
-ppClassDecl instances loc doc subdocs
+ppClassDecl instances doc subdocs
(ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars, tcdFDs = lfds
, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs }) unicode
= declWithDoc classheader (if null body then Nothing else Just (vcat body)) $$
@@ -508,15 +547,15 @@ ppClassDecl instances loc doc subdocs
methodTable =
text "\\haddockpremethods{}\\textbf{Methods}" $$
- vcat [ ppFunSig loc doc [name] (hsSigWcType typ) unicode
- | L _ (TypeSig lnames typ) <- lsigs
+ vcat [ ppFunSig doc [name] (hsSigWcType typ) unicode
+ | L _ (TypeSig _ lnames typ) <- lsigs
, name <- map unLoc lnames
, let doc = lookupAnySubdoc name subdocs
]
instancesBit = ppDocInstances unicode instances
-ppClassDecl _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
+ppClassDecl _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
ppDocInstances :: Bool -> [DocInstance DocNameI] -> LaTeX
ppDocInstances _unicode [] = empty
@@ -565,15 +604,17 @@ lookupAnySubdoc n subdocs = case lookup n subdocs of
-- * Data & newtype declarations
-------------------------------------------------------------------------------
-
-ppDataDecl :: [(HsDecl DocNameI, DocForDecl DocName)] -> [DocInstance DocNameI] ->
- [(DocName, DocForDecl DocName)] -> SrcSpan ->
- Maybe (Documentation DocName) -> TyClDecl DocNameI -> Bool ->
- LaTeX
-ppDataDecl pats instances subdocs _loc doc dataDecl unicode
-
- = declWithDoc (ppDataHeader dataDecl unicode <+> whereBit)
- (if null body then Nothing else Just (vcat body))
+-- | Pretty-print a data declaration
+ppDataDecl :: [(HsDecl DocNameI, DocForDecl DocName)] -- ^ relevant patterns
+ -> [DocInstance DocNameI] -- ^ relevant instances
+ -> [(DocName, DocForDecl DocName)] -- ^ relevant decl docs
+ -> Maybe (Documentation DocName) -- ^ this decl's docs
+ -> TyClDecl DocNameI -- ^ data decl to print
+ -> Bool -- ^ unicode
+ -> LaTeX
+ppDataDecl pats instances subdocs doc dataDecl unicode =
+ declWithDoc (ppDataHeader dataDecl unicode <+> whereBit)
+ (if null body then Nothing else Just (vcat body))
$$ instancesBit
where
@@ -585,28 +626,26 @@ ppDataDecl pats instances subdocs _loc doc dataDecl unicode
(whereBit, leaders)
| null cons
, null pats = (empty,[])
- | null cons = (decltt (keyword "where"), repeat empty)
+ | null cons = (text "where", repeat empty)
| otherwise = case resTy of
- ConDeclGADT{} -> (decltt (keyword "where"), repeat empty)
+ ConDeclGADT{} -> (text "where", repeat empty)
_ -> (empty, (decltt (text "=") : repeat (decltt (text "|"))))
constrBit
| null cons = Nothing
| otherwise = Just $
+ text "\\enspace" <+> emph (text "Constructors") <> text "\\par" $$
text "\\haddockbeginconstrs" $$
vcat (zipWith (ppSideBySideConstr subdocs unicode) leaders cons) $$
text "\\end{tabulary}\\par"
patternBit
- | null cons = Nothing
- | otherwise = Just $
+ | null pats = Nothing
+ | otherwise = Just $
+ text "\\enspace" <+> emph (text "Bundled Patterns") <> text "\\par" $$
text "\\haddockbeginconstrs" $$
- vcat [ hsep [ keyword "pattern"
- , hsep $ punctuate comma $ map (ppDocBinder . unLoc) lnames
- , dcolon unicode
- , ppLType unicode (hsSigType ty)
- ] <-> rDoc (fmap _doc . combineDocumentation . fst $ d)
- | (SigD (PatSynSig lnames ty),d) <- pats
+ vcat [ empty <-> ppSideBySidePat lnames typ d unicode
+ | (SigD _ (PatSynSig _ lnames typ), d) <- pats
] $$
text "\\end{tabulary}\\par"
@@ -625,41 +664,102 @@ ppConstrHdr forall tvs ctxt unicode
False -> empty
-ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LaTeX
- -> LConDecl DocNameI -> 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
+-- | Pretty-print a constructor
+ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -- ^ all decl docs
+ -> Bool -- ^ unicode
+ -> LaTeX -- ^ prefix to decl
+ -> LConDecl DocNameI -- ^ constructor decl
+ -> LaTeX
+ppSideBySideConstr subdocs unicode leader (L _ con) =
+ leader <-> decltt decl <-> rDoc mbDoc <+> nl
+ $$ fieldPart
+ where
+ -- Find the name of a constructors in the decl (`getConName` always returns
+ -- a non-empty list)
+ aConName = unLoc (head (getConNames con))
+
+ occ = map (nameOccName . getName . unLoc) $ getConNames con
+
+ ppOcc = cat (punctuate comma (map ppBinder occ))
+ ppOccInfix = cat (punctuate comma (map ppBinderInfix occ))
+
+ -- Extract out the map of of docs corresponding to the constructors arguments
+ argDocs = maybe Map.empty snd (lookup aConName subdocs)
+ hasArgDocs = not $ Map.null argDocs
+
+ -- First line of the constructor (no doc, no fields, single-line)
+ decl = case con of
+ ConDeclH98{ con_args = det
+ , con_ex_tvs = vars
+ , con_mb_cxt = cxt
+ } -> let tyVars = map (getName . hsLTyVarName) vars
+ context = unLoc (fromMaybe (noLoc []) cxt)
+ forall_ = False
+ header_ = ppConstrHdr forall_ tyVars context unicode
+ in case det of
+ -- Prefix constructor, e.g. 'Just a'
+ PrefixCon args
+ | hasArgDocs -> header_ <+> ppOcc
+ | otherwise -> hsep [ header_
+ , ppOcc
+ , hsep (map (ppLParendType unicode) args)
+ ]
+
+ -- Record constructor, e.g. 'Identity { runIdentity :: a }'
+ RecCon _ -> header_ <+> ppOcc
+
+ -- Infix constructor, e.g. 'a :| [a]'
+ InfixCon arg1 arg2
+ | hasArgDocs -> header_ <+> ppOcc
+ | otherwise -> hsep [ header_
+ , ppLParendType unicode arg1
+ , ppOccInfix
+ , ppLParendType unicode arg2
+ ]
+
+ ConDeclGADT{}
+ | hasArgDocs || not (isEmpty fieldPart) -> ppOcc
+ | otherwise -> hsep [ ppOcc
+ , dcolon unicode
+ -- ++AZ++ make this prepend "{..}" when it is a record style GADT
+ , ppLType unicode (getGADTConType con)
+ ]
+ XConDecl{} -> panic "haddock:ppSideBySideConstr"
+
+ fieldPart = case (con, getConArgs con) of
+ -- Record style GADTs
+ (ConDeclGADT{}, RecCon _) -> doConstrArgsWithDocs []
+
+ -- Regular record declarations
+ (_, RecCon (L _ fields)) -> doRecordFields fields
+
+ -- Any GADT or a regular H98 prefix data constructor
+ (_, PrefixCon args) | hasArgDocs -> doConstrArgsWithDocs args
+
+ -- An infix H98 data constructor
+ (_, InfixCon arg1 arg2) | hasArgDocs -> doConstrArgsWithDocs [arg1,arg2]
+
+ _ -> empty
- where
doRecordFields fields =
- vcat (map (ppSideBySideField subdocs unicode) (map unLoc fields))
+ vcat [ empty <-> tt (text begin) <+> ppSideBySideField subdocs unicode field <+> nl
+ | (begin, L _ field) <- zip ("\\qquad \\{" : repeat "\\qquad ,") fields
+ ]
+ $$
+ empty <-> tt (text "\\qquad \\}") <+> nl
+ doConstrArgsWithDocs args = vcat $ map (\l -> empty <-> text "\\qquad" <+> l) $ case con of
+ ConDeclH98{} ->
+ [ decltt (ppLParendType unicode arg) <-> rDoc (fmap _doc mdoc) <+> nl
+ | (i, arg) <- zip [0..] args
+ , let mdoc = Map.lookup i argDocs
+ ]
+ ConDeclGADT{} ->
+ [ l <+> text "\\enspace" <+> r
+ | (l,r) <- ppSubSigLike unicode (unLoc (getGADTConType con)) argDocs subdocs (dcolon unicode)
+ ]
+ XConDecl{} -> panic "haddock:doConstrArgsWithDocs"
- 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 [] 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.
@@ -668,147 +768,49 @@ ppSideBySideConstr subdocs unicode leader (L _ con@(ConDeclH98 {})) =
(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) =
- leader <->
- case con_res con of
- ResTyH98 -> 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
-
- 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 (L _ fields)) -> doGADTCon (hsConDeclArgTys cd) resTy <+> nl $$
- doRecordFields fields
- InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy
-
- where
- doRecordFields fields =
- vcat (map (ppSideBySideField subdocs unicode) (map unLoc fields))
-
- doGADTCon args resTy = decltt (ppOcc <+> dcolon unicode <+>
- ppLType unicode (mk_forall $ mk_phi $
- foldr mkFunTy resTy args)
- ) <-> rDoc mbDoc
-
-
- header_ = ppConstrHdr (con_explicit con) tyVars context
- occ = map (nameOccName . getName . unLoc) $ con_names con
- ppOcc = case occ of
- [one] -> ppBinder one
- _ -> cat (punctuate comma (map ppBinder occ))
- ltvs = con_qvars con
- tyVars = tyvarNames (con_qvars con)
- context = unLoc (con_cxt con)
-
- 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)
-
- -- don't use "con_doc con", in case it's reconstructed from a .hi file,
- -- or also because we want Haddock to do the doc-parsing, not GHC.
- mbDoc = case con_names con of
- [] -> panic "empty con_names"
- (cn:_) -> lookup (unLoc cn) subdocs >>=
- fmap _doc . combineDocumentation . fst
- mkFunTy a b = noLoc (HsFunTy a b)
--}
+-- | Pretty-print a record field
ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocNameI -> LaTeX
-ppSideBySideField subdocs unicode (ConDeclField names ltype _) =
+ppSideBySideField subdocs unicode (ConDeclField _ names ltype _) =
decltt (cat (punctuate comma (map (ppBinder . rdrNameOcc . unLoc . 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 (selectorFieldOcc $ unLoc $ head names) subdocs >>= fmap _doc . combineDocumentation . fst
-
--- {-
--- ppHsFullConstr :: HsConDecl -> LaTeX
--- ppHsFullConstr (HsConDecl _ nm tvs ctxt typeList doc) =
--- declWithDoc False doc (
--- hsep ((ppHsConstrHdr tvs ctxt +++
--- ppHsBinder False nm) : map ppHsBangType typeList)
--- )
--- ppHsFullConstr (HsRecDecl _ nm tvs ctxt fields doc) =
--- td << vanillaTable << (
--- case doc of
--- Nothing -> aboves [hdr, fields_html]
--- Just _ -> aboves [hdr, constr_doc, fields_html]
--- )
---
--- where hdr = declBox (ppHsConstrHdr tvs ctxt +++ ppHsBinder False nm)
---
--- constr_doc
--- | isJust doc = docBox (docToLaTeX (fromJust doc))
--- | otherwise = LaTeX.emptyTable
---
--- fields_html =
--- td <<
--- table ! [width "100%", cellpadding 0, cellspacing 8] << (
--- aboves (map ppFullField (concat (map expandField fields)))
--- )
--- -}
---
--- ppShortField :: Bool -> Bool -> ConDeclField DocName -> LaTeX
--- ppShortField summary unicode (ConDeclField (L _ name) ltype _)
--- = tda [theclass "recfield"] << (
--- ppBinder summary (docNameOcc name)
--- <+> dcolon unicode <+> ppLType unicode ltype
--- )
---
--- {-
--- ppFullField :: HsFieldDecl -> LaTeX
--- ppFullField (HsFieldDecl [n] ty doc)
--- = declWithDoc False doc (
--- ppHsBinder False n <+> dcolon <+> ppHsBangType ty
--- )
--- ppFullField _ = error "ppFullField"
---
--- expandField :: HsFieldDecl -> [HsFieldDecl]
--- expandField (HsFieldDecl ns ty doc) = [ HsFieldDecl [n] ty doc | n <- ns ]
--- -}
+ mbDoc = lookup (extFieldOcc $ unLoc $ head names) subdocs >>= fmap _doc . combineDocumentation . fst
+ppSideBySideField _ _ (XConDeclField _) = panic "haddock:ppSideBySideField"
+
+
+-- | Pretty-print a bundled pattern synonym
+ppSideBySidePat :: [Located DocName] -- ^ pattern name(s)
+ -> LHsSigType DocNameI -- ^ type of pattern(s)
+ -> DocForDecl DocName -- ^ doc map
+ -> Bool -- ^ unicode
+ -> LaTeX
+ppSideBySidePat lnames typ (doc, argDocs) unicode =
+ decltt decl <-> rDoc mDoc <+> nl
+ $$ fieldPart
+ where
+ hasArgDocs = not $ Map.null argDocs
+ ppOcc = hsep (punctuate comma (map (ppDocBinder . unLoc) lnames))
+
+ decl | hasArgDocs = keyword "pattern" <+> ppOcc
+ | otherwise = hsep [ keyword "pattern"
+ , ppOcc
+ , dcolon unicode
+ , ppLType unicode (hsSigType typ)
+ ]
+
+ fieldPart
+ | not hasArgDocs = empty
+ | otherwise = vcat
+ [ empty <-> text "\\qquad" <+> l <+> text "\\enspace" <+> r
+ | (l,r) <- ppSubSigLike unicode (unLoc patTy) argDocs [] (dcolon unicode)
+ ]
+
+ patTy = hsSigType typ
+
+ mDoc = fmap _doc $ combineDocumentation doc
-- | Print the LHS of a data\/newtype declaration.
@@ -824,6 +826,7 @@ ppDataHeader (DataDecl { tcdLName = L _ name, tcdTyVars = tyvars
ppAppDocNameNames False name (tyvarNames tyvars)
ppDataHeader _ _ = error "ppDataHeader: illegal argument"
+
--------------------------------------------------------------------------------
-- * Type applications
--------------------------------------------------------------------------------
@@ -955,57 +958,57 @@ ppr_mono_lty ctxt_prec ty unicode = ppr_mono_ty ctxt_prec (unLoc ty) unicode
ppr_mono_ty :: Int -> HsType DocNameI -> Bool -> LaTeX
-ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode
+ppr_mono_ty ctxt_prec (HsForAllTy _ tvs ty) unicode
= maybeParen ctxt_prec pREC_FUN $
sep [ hsep (forallSymbol unicode : ppTyVars tvs) <> dot
, ppr_mono_lty pREC_TOP ty unicode ]
-ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode
+ppr_mono_ty ctxt_prec (HsQualTy _ ctxt ty) unicode
= maybeParen ctxt_prec pREC_FUN $
sep [ ppLContext ctxt unicode
, ppr_mono_lty pREC_TOP ty unicode ]
-ppr_mono_ty _ (HsBangTy b ty) u = ppBang b <> ppLParendType u ty
-ppr_mono_ty _ (HsTyVar NotPromoted (L _ name)) _ = ppDocName name
-ppr_mono_ty _ (HsTyVar Promoted (L _ name)) _ = char '\'' <> 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 _ (HsSumTy tys) u = sumParens (map (ppLType u) tys)
-ppr_mono_ty _ (HsKindSig ty kind) u = parens (ppr_mono_lty pREC_TOP ty u <+> dcolon u <+> ppLKind u kind)
-ppr_mono_ty _ (HsListTy ty) u = brackets (ppr_mono_lty pREC_TOP ty u)
-ppr_mono_ty _ (HsPArrTy ty) u = pabrackets (ppr_mono_lty pREC_TOP ty u)
-ppr_mono_ty _ (HsIParamTy (L _ n) ty) u = brackets (ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u)
+ppr_mono_ty _ (HsBangTy _ b ty) u = ppBang b <> ppLParendType u ty
+ppr_mono_ty _ (HsTyVar _ NotPromoted (L _ name)) _ = ppDocName name
+ppr_mono_ty _ (HsTyVar _ Promoted (L _ name)) _ = char '\'' <> 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 _ (HsSumTy _ tys) u = sumParens (map (ppLType u) tys)
+ppr_mono_ty _ (HsKindSig _ ty kind) u = parens (ppr_mono_lty pREC_TOP ty u <+> dcolon u <+> ppLKind u kind)
+ppr_mono_ty _ (HsListTy _ ty) u = brackets (ppr_mono_lty pREC_TOP ty u)
+ppr_mono_ty _ (HsPArrTy _ ty) u = pabrackets (ppr_mono_lty pREC_TOP ty u)
+ppr_mono_ty _ (HsIParamTy _ (L _ 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 _ (HsRecTy {}) _ = error "ppr_mono_ty HsRecTy"
-ppr_mono_ty _ (HsCoreTy {}) _ = error "ppr_mono_ty HsCoreTy"
-ppr_mono_ty _ (HsExplicitListTy Promoted _ tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys
-ppr_mono_ty _ (HsExplicitListTy NotPromoted _ tys) u = brackets $ hsep $ punctuate comma $ map (ppLType u) tys
+ppr_mono_ty _ (HsRecTy {}) _ = text "{..}"
+ppr_mono_ty _ (XHsType (NHsCoreTy {})) _ = error "ppr_mono_ty HsCoreTy"
+ppr_mono_ty _ (HsExplicitListTy _ Promoted tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys
+ppr_mono_ty _ (HsExplicitListTy _ NotPromoted tys) u = brackets $ hsep $ punctuate comma $ map (ppLType u) tys
ppr_mono_ty _ (HsExplicitTupleTy _ tys) u = Pretty.quote $ parenList $ map (ppLType u) tys
-ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode
+ppr_mono_ty ctxt_prec (HsEqTy _ ty1 ty2) unicode
= maybeParen ctxt_prec pREC_OP $
ppr_mono_lty pREC_OP ty1 unicode <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode
-ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode
+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
ppr_op = if not (isSymOcc occName) then char '`' <> ppLDocName op <> char '`' else ppLDocName op
occName = nameOccName . getName . unLoc $ op
-ppr_mono_ty ctxt_prec (HsParTy ty) unicode
+ppr_mono_ty ctxt_prec (HsParTy _ ty) unicode
-- = parens (ppr_mono_lty pREC_TOP ty)
= ppr_mono_lty ctxt_prec ty unicode
-ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode
+ppr_mono_ty ctxt_prec (HsDocTy _ ty _) unicode
= ppr_mono_lty ctxt_prec ty unicode
ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ = char '_'
-ppr_mono_ty _ (HsTyLit t) u = ppr_tylit t u
+ppr_mono_ty _ (HsTyLit _ t) u = ppr_tylit t u
ppr_mono_ty _ (HsAppsTy {}) _ = panic "ppr_mono_ty:HsAppsTy"
@@ -1036,6 +1039,11 @@ ppBinder n
| isInfixName n = parens $ ppOccName n
| otherwise = ppOccName n
+ppBinderInfix :: OccName -> LaTeX
+ppBinderInfix n
+ | isInfixName n = ppOccName n
+ | otherwise = cat [ char '`', ppOccName n, char '`' ]
+
isInfixName :: OccName -> Bool
isInfixName n = isVarSym n || isConSym n
diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index c9a262a4..6da6a2e8 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -667,7 +667,7 @@ numberSectionHeadings = go 1
processExport :: Bool -> LinksInfo -> Bool -> Maybe Package -> Qualification
-> ExportItem DocNameI -> Maybe Html
-processExport _ _ _ _ _ ExportDecl { expItemDecl = L _ (InstD _) } = Nothing -- Hide empty instances
+processExport _ _ _ _ _ ExportDecl { expItemDecl = L _ (InstD {}) } = Nothing -- Hide empty instances
processExport summary _ _ pkg qual (ExportGroup lev id0 doc)
= nothingIf summary $ groupHeading lev id0 << docToHtml (Just id0) pkg qual (mkMeta doc)
processExport summary links unicode pkg qual (ExportDecl decl pats doc subdocs insts fixities splice)
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 815ecee9..3fbe6eaf 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -39,24 +39,34 @@ import GHC.Exts
import Name
import BooleanFormula
import RdrName ( rdrNameOcc )
-
-ppDecl :: Bool -> LinksInfo -> LHsDecl DocNameI
- -> [(HsDecl DocNameI, DocForDecl DocName)]
- -> DocForDecl DocName -> [DocInstance DocNameI] -> [(DocName, Fixity)]
- -> [(DocName, DocForDecl DocName)] -> Splice -> Unicode
- -> Maybe Package -> Qualification -> Html
+import Outputable ( panic )
+
+-- | Pretty print a declaration
+ppDecl :: Bool -- ^ print summary info only
+ -> LinksInfo -- ^ link information
+ -> LHsDecl DocNameI -- ^ declaration to print
+ -> [(HsDecl DocNameI, DocForDecl DocName)] -- ^ relevant pattern synonyms
+ -> DocForDecl DocName -- ^ documentation for this decl
+ -> [DocInstance DocNameI] -- ^ relevant instances
+ -> [(DocName, Fixity)] -- ^ relevant fixities
+ -> [(DocName, DocForDecl DocName)] -- ^ documentation for all decls
+ -> Splice
+ -> Unicode -- ^ unicode output
+ -> Maybe Package
+ -> Qualification
+ -> Html
ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode pkg qual = case decl of
- TyClD (FamDecl d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode pkg qual
- TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d pats splice unicode pkg qual
- TyClD d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode pkg qual
- TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode pkg qual
- SigD (TypeSig lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames
+ TyClD _ (FamDecl _ d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode pkg qual
+ TyClD _ d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d pats splice unicode pkg qual
+ TyClD _ d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode pkg qual
+ TyClD _ d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode pkg qual
+ SigD _ (TypeSig _ lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames
(hsSigWcType lty) fixities splice unicode pkg qual
- SigD (PatSynSig lnames ty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames
- ty fixities splice unicode pkg qual
- ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode pkg qual
- InstD _ -> noHtml
- DerivD _ -> noHtml
+ SigD _ (PatSynSig _ lnames lty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames
+ (hsSigType lty) fixities splice unicode pkg qual
+ ForD _ d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode pkg qual
+ InstD _ _ -> noHtml
+ DerivD _ _ -> noHtml
_ -> error "declaration not supported by ppDecl"
@@ -76,21 +86,18 @@ ppFunSig summary links loc doc docnames typ fixities splice unicode pkg qual =
where
pp_typ = ppLType unicode qual HideEmptyContexts typ
-ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
- [Located DocName] -> LHsSigType DocNameI ->
- [(DocName, Fixity)] ->
- Splice -> Unicode -> Maybe Package -> Qualification -> Html
-ppLPatSig summary links loc (doc, _argDocs) docnames typ fixities splice
- unicode pkg qual
- | summary = pref1
- | otherwise = topDeclElem links loc splice (map unLoc docnames) (pref1 <+> ppFixities fixities qual)
- +++ docSection Nothing pkg qual doc
+-- | Pretty print a pattern synonym
+ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName
+ -> [Located DocName] -- ^ names of patterns in declaration
+ -> LHsType DocNameI -- ^ type of patterns in declaration
+ -> [(DocName, Fixity)]
+ -> Splice -> Unicode -> Maybe Package -> Qualification -> Html
+ppLPatSig summary links loc doc lnames typ fixities splice unicode pkg qual =
+ ppSigLike summary links loc (keyword "pattern") doc (map unLoc lnames) fixities
+ (unLoc typ, pp_typ) splice unicode pkg qual (patSigContext typ)
where
- pref1 = hsep [ keyword "pattern"
- , hsep $ punctuate comma $ map (ppBinder summary . getOccName) docnames
- , dcolon unicode
- , ppPatSigType unicode qual (hsSigType typ)
- ]
+ pp_typ = ppPatSigType unicode qual typ
+
ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName ->
[DocName] -> [(DocName, Fixity)] -> (HsType DocNameI, Html) ->
@@ -99,7 +106,7 @@ ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ)
splice unicode pkg qual emptyCtxts =
ppTypeOrFunSig summary links loc docnames typ doc
( addFixities $ leader <+> ppTypeSig summary occnames pp_typ unicode
- , addFixities . concatHtml . punctuate comma $ map (ppBinder False) occnames
+ , (leader <+>) . addFixities . concatHtml . punctuate comma $ map (ppBinder False) occnames
, dcolon unicode
)
splice unicode pkg qual emptyCtxts
@@ -118,36 +125,72 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep)
splice unicode pkg qual emptyCtxts
| summary = pref1
| Map.null argDocs = topDeclElem links loc splice docnames pref1 +++ docSection curName pkg qual doc
- | otherwise = topDeclElem links loc splice docnames pref2 +++
- subArguments pkg qual (do_args 0 sep typ) +++ docSection curName pkg qual doc
+ | otherwise = topDeclElem links loc splice docnames pref2
+ +++ subArguments pkg qual (ppSubSigLike unicode qual typ argDocs [] sep emptyCtxts)
+ +++ docSection curName pkg qual doc
where
curName = getName <$> listToMaybe docnames
+
+
+-- This splits up a type signature along `->` and adds docs (when they exist) to
+-- the arguments.
+--
+-- If one passes in a list of the available subdocs, any top-level `HsRecTy`
+-- found will be expanded out into their fields.
+ppSubSigLike :: Unicode -> Qualification
+ -> HsType DocNameI -- ^ type signature
+ -> FnArgsDoc DocName -- ^ docs to add
+ -> [(DocName, DocForDecl DocName)] -- ^ all subdocs (useful when
+ -- we expand an `HsRecTy`)
+ -> Html -> HideEmptyContexts -> [SubDecl]
+ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_args 0 sep typ
+ where
argDoc n = Map.lookup n argDocs
do_largs n leader (L _ t) = do_args n leader t
do_args :: Int -> Html -> HsType DocNameI -> [SubDecl]
- do_args n leader (HsForAllTy tvs ltype)
+ do_args n leader (HsForAllTy _ tvs ltype)
= do_largs n leader' ltype
where
leader' = leader <+> ppForAll tvs unicode qual
- do_args n leader (HsQualTy lctxt ltype)
+ do_args n leader (HsQualTy _ lctxt ltype)
| null (unLoc lctxt)
= do_largs n leader ltype
| otherwise
= (leader <+> ppLContextNoArrow lctxt unicode qual emptyCtxts, Nothing, [])
: do_largs n (darrow unicode) ltype
- do_args n leader (HsFunTy lt r)
+ do_args n leader (HsFunTy _ (L _ (HsRecTy _ fields)) r)
+ = [ (ldr <+> html, mdoc, subs)
+ | (L _ field, ldr) <- zip fields (leader <+> gadtOpen : repeat gadtComma)
+ , let (html, mdoc, subs) = ppSideBySideField subdocs unicode qual field
+ ]
+ ++ do_largs (n+1) (gadtEnd <+> arrow unicode) r
+
+ do_args n leader (HsFunTy _ lt r)
= (leader <+> ppLFunLhType unicode qual emptyCtxts lt, argDoc n, [])
: do_largs (n+1) (arrow unicode) r
+
do_args n leader t
= [(leader <+> ppType unicode qual emptyCtxts t, argDoc n, [])]
+
+ -- FIXME: this should be done more elegantly
+ --
+ -- We need 'gadtComma' and 'gadtEnd' to line up with the `{` from
+ -- 'gadtOpen', so we add 3 spaces to cover for `-> `/`:: ` (3 in unicode
+ -- mode since `->` and `::` are rendered as single characters.
+ gadtComma = concatHtml (replicate (if unicode then 2 else 3) spaceHtml) <> toHtml ","
+ gadtEnd = concatHtml (replicate (if unicode then 2 else 3) spaceHtml) <> toHtml "}"
+ gadtOpen = toHtml "{"
+
+
+
ppForAll :: [LHsTyVarBndr DocNameI] -> Unicode -> Qualification -> Html
ppForAll tvs unicode qual =
- case [ppKTv n k | L _ (KindedTyVar (L _ n) k) <- tvs] of
+ case [ppKTv n k | L _ (KindedTyVar _ (L _ n) k) <- tvs] of
[] -> noHtml
ts -> forallSymbol unicode <+> hsep ts +++ dot
where ppKTv n k = parens $
@@ -186,7 +229,7 @@ tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit
ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName
-> ForeignDecl DocNameI -> [(DocName, Fixity)]
-> Splice -> Unicode -> Maybe Package -> Qualification -> Html
-ppFor summary links loc doc (ForeignImport (L _ name) typ _ _) fixities
+ppFor summary links loc doc (ForeignImport _ (L _ name) typ _) fixities
splice unicode pkg qual
= ppFunSig summary links loc doc [name] (hsSigType typ) fixities splice unicode pkg qual
ppFor _ _ _ _ _ _ _ _ _ _ = error "ppFor"
@@ -279,12 +322,14 @@ ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info
ClosedTypeFamily _ -> keyword "where ..."
_ -> mempty
)
+ppTyFamHeader _ _ (XFamilyDecl _) _ _ = panic "haddock;ppTyFamHeader"
ppResultSig :: FamilyResultSig DocNameI -> 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
+ NoSig _ -> noHtml
+ KindSig _ kind -> dcolon unicode <+> ppLKind unicode qual kind
+ TyVarSig _ (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr
+ XFamilyResultSig _ -> panic "haddock:ppResultSig"
ppPseudoFamilyHeader :: Unicode -> Qualification -> PseudoFamilyDecl DocNameI
-> Html
@@ -330,6 +375,8 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode
= ( ppAppNameTypes (unLoc n) (map unLoc ts) unicode qual
<+> equals <+> ppType unicode qual HideEmptyContexts (unLoc rhs)
, Nothing, [] )
+ ppTyFamEqn (XHsImplicitBndrs _) = panic "haddock:ppTyFam"
+ ppTyFamEqn (HsIB { hsib_body = XFamEqn _}) = panic "haddock:ppTyFam"
@@ -363,6 +410,7 @@ ppAssocType summ links doc (L loc decl) fixities splice unicode pkg qual =
ppFamDeclBinderWithVars :: Bool -> Unicode -> Qualification -> FamilyDecl DocNameI -> Html
ppFamDeclBinderWithVars summ unicode qual (FamilyDecl { fdLName = lname, fdTyVars = tvs }) =
ppAppDocNameTyVarBndrs summ unicode qual (unLoc lname) (hsq_explicit tvs)
+ppFamDeclBinderWithVars _ _ _ (XFamilyDecl _) = panic "haddock:ppFamDeclBinderWithVars"
-- | Print a newtype / data binder and its variables
ppDataBinderWithVars :: Bool -> Unicode -> Qualification -> TyClDecl DocNameI -> Html
@@ -477,7 +525,7 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, t
[ ppFunSig summary links loc doc names (hsSigWcType typ)
[] splice unicode pkg qual
- | L _ (TypeSig lnames typ) <- sigs
+ | L _ (TypeSig _ lnames typ) <- sigs
, let doc = lookupAnySubdoc (head names) subdocs
names = map unLoc lnames ]
-- FIXME: is taking just the first name ok? Is it possible that
@@ -525,7 +573,7 @@ ppClassDecl summary links instances fixities loc d subdocs
methodBit = subMethods [ ppFunSig summary links loc doc [name] (hsSigType typ)
subfixs splice unicode pkg qual
- | L _ (ClassOpSig _ lnames typ) <- lsigs
+ | L _ (ClassOpSig _ _ lnames typ) <- lsigs
, name <- map unLoc lnames
, let doc = lookupAnySubdoc name subdocs
subfixs = [ f | f@(n',_) <- fixities
@@ -534,15 +582,15 @@ ppClassDecl summary links instances fixities loc d subdocs
-- N.B. taking just the first name is ok. Signatures with multiple names
-- are expanded so that each name gets its own signature.
- minimalBit = case [ s | MinimalSig _ (L _ s) <- sigs ] of
+ 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
Var (L _ n) : _ | [getName n] ==
- [getName n' | L _ (TypeSig ns _) <- lsigs, L _ n' <- ns]
+ [getName n' | L _ (TypeSig _ ns _) <- lsigs, L _ n' <- ns]
-> noHtml
-- Minimal complete definition = nothing
@@ -645,7 +693,7 @@ ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification
-> [Sig DocNameI]
-> [Html]
ppInstanceSigs links splice unicode qual sigs = do
- TypeSig lnames typ <- sigs
+ TypeSig _ lnames typ <- sigs
let names = map unLoc lnames
L _ rtyp = hsSigWcType typ
-- Instance methods signatures are synified and thus don't have a useful
@@ -706,21 +754,27 @@ ppShortDataDecl summary dataInst dataDecl pats unicode qual
isH98 = case unLoc (head cons) of
ConDeclH98 {} -> True
ConDeclGADT{} -> False
+ XConDecl{} -> False
pats1 = [ hsep [ keyword "pattern"
, hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames
, dcolon unicode
, ppPatSigType unicode qual (hsSigType typ)
]
- | (SigD (PatSynSig lnames typ),_) <- pats
+ | (SigD _ (PatSynSig _ lnames typ),_) <- pats
]
-ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocNameI] -> [(DocName, Fixity)] ->
- [(DocName, DocForDecl DocName)] ->
- SrcSpan -> Documentation DocName -> TyClDecl DocNameI ->
- [(HsDecl DocNameI, DocForDecl DocName)] ->
- Splice -> Unicode -> Maybe Package -> Qualification -> Html
+-- | Pretty-print a data declaration
+ppDataDecl :: Bool -> LinksInfo
+ -> [DocInstance DocNameI] -- ^ relevant instances
+ -> [(DocName, Fixity)] -- ^ relevant fixities
+ -> [(DocName, DocForDecl DocName)] -- ^ all decl documentation
+ -> SrcSpan
+ -> Documentation DocName -- ^ this decl's documentation
+ -> TyClDecl DocNameI -- ^ this decl
+ -> [(HsDecl DocNameI, DocForDecl DocName)] -- ^ relevant patterns
+ -> Splice -> Unicode -> Maybe Package -> Qualification -> Html
ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats
splice unicode pkg qual
@@ -733,6 +787,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats
isH98 = case unLoc (head cons) of
ConDeclH98 {} -> True
ConDeclGADT{} -> False
+ XConDecl{} -> False
header_ = topDeclElem links loc splice [docname] $
ppDataHeader summary dataDecl unicode qual <+> whereBit <+> fix
@@ -749,25 +804,20 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats
[ ppSideBySideConstr subdocs subfixs unicode pkg qual c
| c <- cons
, let subfixs = filter (\(n,_) -> any (\cn -> cn == n)
- (map unLoc (getConNames (unLoc c)))) fixities
+ (map unLoc (getConNames (unLoc c)))) fixities
]
patternBit = subPatterns pkg qual
- [ (hsep [ keyword "pattern"
- , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames
- , dcolon unicode
- , ppPatSigType unicode qual (hsSigType typ)
- ] <+> ppFixities subfixs qual
- ,combineDocumentation (fst d), [])
- | (SigD (PatSynSig lnames typ),d) <- pats
- , let subfixs = filter (\(n,_) -> any (\cn -> cn == n) (map unLoc lnames)) fixities
+ [ ppSideBySidePat subfixs unicode qual lnames typ d
+ | (SigD _ (PatSynSig _ lnames typ), d) <- pats
+ , let subfixs = filter (\(n,_) -> any (\cn -> cn == n)
+ (map unLoc lnames)) fixities
]
instancesBit = ppInstances links (OriginData docname) instances
splice unicode pkg qual
-
ppShortConstr :: Bool -> ConDecl DocNameI -> Unicode -> Qualification -> Html
ppShortConstr summary con unicode qual = cHead <+> cBody <+> cFoot
where
@@ -777,121 +827,183 @@ 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 DocNameI -> Unicode -> Qualification -> (Html, Html, Html)
-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 HideEmptyContexts) args), noHtml, noHtml)
- RecCon (L _ fields) ->
- (header_ unicode qual +++ ppOcc <+> char '{',
- doRecordFields fields,
- char '}')
- InfixCon arg1 arg2 ->
- (header_ unicode qual +++ hsep [ppLParendType unicode qual HideEmptyContexts arg1,
- ppOccInfix, ppLParendType unicode qual HideEmptyContexts arg2],
- noHtml, noHtml)
-
- ConDeclGADT {} -> (ppOcc <+> dcolon unicode <+> ppLType unicode qual HideEmptyContexts resTy,noHtml,noHtml)
-
- where
- resTy = hsib_body (con_type con)
-
- doRecordFields fields = shortSubDecls dataInst (map (ppShortField summary unicode qual) (map unLoc fields))
-
- header_ = ppConstrHdr forall_ tyVars context
- occ = map (nameOccName . getName . unLoc) $ getConNames con
-
- ppOcc = case occ of
- [one] -> ppBinder summary one
- _ -> hsep (punctuate comma (map (ppBinder summary) occ))
+ppShortConstrParts summary dataInst con unicode qual
+ = case con of
+ ConDeclH98{ con_args = det
+ , con_ex_tvs = vars
+ , con_mb_cxt = cxt
+ } -> let tyVars = map (getName . hsLTyVarName) vars
+ context = unLoc (fromMaybe (noLoc []) cxt)
+ forall_ = False
+ header_ = ppConstrHdr forall_ tyVars context unicode qual
+ in case det of
+
+ -- Prefix constructor, e.g. 'Just a'
+ PrefixCon args ->
+ ( header_ +++ hsep (ppOcc : map (ppLParendType unicode qual HideEmptyContexts) args)
+ , noHtml
+ , noHtml
+ )
- ppOccInfix = case occ of
- [one] -> ppBinderInfix summary one
- _ -> hsep (punctuate comma (map (ppBinderInfix summary) occ))
+ -- Record constructor, e.g. 'Identity { runIdentity :: a }'
+ RecCon (L _ fields) ->
+ ( header_ +++ ppOcc <+> char '{'
+ , shortSubDecls dataInst [ ppShortField summary unicode qual field
+ | L _ field <- fields
+ ]
+ , char '}'
+ )
- ltvs = fromMaybe (HsQTvs PlaceHolder [] PlaceHolder) (con_qvars con)
- tyVars = tyvarNames ltvs
- lcontext = fromMaybe (noLoc []) (con_cxt con)
- context = unLoc lcontext
- forall_ = False
+ -- Infix constructor, e.g. 'a :| [a]'
+ InfixCon arg1 arg2 ->
+ ( header_ +++ hsep [ ppLParendType unicode qual HideEmptyContexts arg1
+ , ppOccInfix
+ , ppLParendType unicode qual HideEmptyContexts arg2
+ ]
+ , noHtml
+ , noHtml
+ )
+ -- GADT constructor, e.g. 'Foo :: Int -> Foo'
+ ConDeclGADT {} ->
+ ( hsep [ ppOcc, dcolon unicode, ppLType unicode qual HideEmptyContexts (getGADTConType con) ]
+ , noHtml
+ , noHtml
+ )
+ XConDecl {} -> panic "haddock:ppShortConstrParts"
--- ppConstrHdr is for (non-GADT) existentials constructors' syntax
-ppConstrHdr :: Bool -> [Name] -> HsContext DocNameI -> Unicode
- -> Qualification -> Html
-ppConstrHdr forall_ tvs ctxt unicode qual
- = (if null tvs then noHtml else ppForall)
- +++
- (if null ctxt then noHtml
- else ppContextNoArrow ctxt unicode qual HideEmptyContexts
- <+> darrow unicode +++ toHtml " ")
where
- ppForall | forall_ = forallSymbol unicode <+> hsep (map (ppName Prefix) tvs)
- <+> toHtml ". "
- | otherwise = noHtml
+ occ = map (nameOccName . getName . unLoc) $ getConNames con
+ ppOcc = hsep (punctuate comma (map (ppBinder summary) occ))
+ ppOccInfix = hsep (punctuate comma (map (ppBinderInfix summary) occ))
+
+-- | Pretty print an expanded constructor
ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> [(DocName, Fixity)]
- -> Unicode -> Maybe Package -> Qualification -> LConDecl DocNameI -> SubDecl
+ -> Unicode -> Maybe Package -> Qualification
+ -> LConDecl DocNameI -- ^ constructor declaration to print
+ -> SubDecl
ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con)
- = (decl, mbDoc, fieldPart)
+ = ( decl -- Constructor header (name, fixity)
+ , mbDoc -- Docs on the whole constructor
+ , fieldPart -- Information on the fields (or arguments, if they have docs)
+ )
where
- decl = case con of
- ConDeclH98{} -> case con_details con of
- PrefixCon args ->
- hsep ((header_ +++ ppOcc)
- : map (ppLParendType unicode qual HideEmptyContexts) args)
- <+> fixity
+ -- Find the name of a constructors in the decl (`getConName` always returns a non-empty list)
+ aConName = unLoc (head (getConNames con))
- RecCon _ -> header_ +++ ppOcc <+> fixity
+ fixity = ppFixities fixities qual
+ occ = map (nameOccName . getName . unLoc) $ getConNames con
- InfixCon arg1 arg2 ->
- hsep [header_ +++ ppLParendType unicode qual HideEmptyContexts arg1,
- ppOccInfix,
- ppLParendType unicode qual HideEmptyContexts arg2]
- <+> fixity
+ ppOcc = hsep (punctuate comma (map (ppBinder False) occ))
+ ppOccInfix = hsep (punctuate comma (map (ppBinderInfix False) occ))
- ConDeclGADT{} -> doGADTCon resTy
+ -- Extract out the map of of docs corresponding to the constructors arguments
+ argDocs = maybe Map.empty snd (lookup aConName subdocs)
+ hasArgDocs = not $ Map.null argDocs
- resTy = hsib_body (con_type con)
+ decl = case con of
+ ConDeclH98{ con_args = det
+ , con_ex_tvs = vars
+ , con_mb_cxt = cxt
+ } -> let tyVars = map (getName . hsLTyVarName) vars
+ context = unLoc (fromMaybe (noLoc []) cxt)
+ forall_ = False
+ header_ = ppConstrHdr forall_ tyVars context unicode qual
+ in case det of
+ -- Prefix constructor, e.g. 'Just a'
+ PrefixCon args
+ | hasArgDocs -> header_ +++ ppOcc <+> fixity
+ | otherwise -> hsep [ header_ +++ ppOcc
+ , hsep (map (ppLParendType unicode qual HideEmptyContexts) args)
+ , fixity
+ ]
+
+ -- Record constructor, e.g. 'Identity { runIdentity :: a }'
+ RecCon _ -> header_ +++ ppOcc <+> fixity
+
+ -- Infix constructor, e.g. 'a :| [a]'
+ InfixCon arg1 arg2
+ | hasArgDocs -> header_ +++ ppOcc <+> fixity
+ | otherwise -> hsep [ header_ +++ ppLParendType unicode qual HideEmptyContexts arg1
+ , ppOccInfix
+ , ppLParendType unicode qual HideEmptyContexts arg2
+ , fixity
+ ]
+
+ -- GADT constructor, e.g. 'Foo :: Int -> Foo'
+ ConDeclGADT{}
+ | hasArgDocs || not (null fieldPart) -> ppOcc <+> fixity
+ | otherwise -> hsep [ ppOcc
+ , dcolon unicode
+ -- ++AZ++ make this prepend "{..}" when it is a record style GADT
+ , ppLType unicode qual HideEmptyContexts (getGADTConType con)
+ , fixity
+ ]
+ XConDecl{} -> panic "haddock:ppSideBySideConstr"
+
+ fieldPart = case (con, getConArgs con) of
+ -- Record style GADTs
+ (ConDeclGADT{}, RecCon _) -> [ doConstrArgsWithDocs [] ]
+
+ -- Regular record declarations
+ (_, RecCon (L _ fields)) -> [ doRecordFields fields ]
+
+ -- Any GADT or a regular H98 prefix data constructor
+ (_, PrefixCon args) | hasArgDocs -> [ doConstrArgsWithDocs args ]
+
+ -- An infix H98 data constructor
+ (_, InfixCon arg1 arg2) | hasArgDocs -> [ doConstrArgsWithDocs [arg1,arg2] ]
- fieldPart = case getConDetails con of
- RecCon (L _ fields) -> [doRecordFields fields]
_ -> []
doRecordFields fields = subFields pkg qual
(map (ppSideBySideField subdocs unicode qual) (map unLoc fields))
- doGADTCon :: Located (HsType DocNameI) -> Html
- doGADTCon ty = ppOcc <+> dcolon unicode
- -- ++AZ++ make this prepend "{..}" when it is a record style GADT
- <+> ppLType unicode qual HideEmptyContexts ty
- <+> fixity
-
- fixity = ppFixities fixities qual
- header_ = ppConstrHdr forall_ tyVars context unicode qual
- occ = map (nameOccName . getName . unLoc) $ getConNames con
-
- ppOcc = case occ of
- [one] -> ppBinder False one
- _ -> hsep (punctuate comma (map (ppBinder False) occ))
+ doConstrArgsWithDocs args = subFields pkg qual $ case con of
+ ConDeclH98{} ->
+ [ (ppLParendType unicode qual HideEmptyContexts arg, mdoc, [])
+ | (i, arg) <- zip [0..] args
+ , let mdoc = Map.lookup i argDocs
+ ]
+ ConDeclGADT{} ->
+ ppSubSigLike unicode qual (unLoc (getGADTConType con))
+ argDocs subdocs (dcolon unicode) HideEmptyContexts
+ XConDecl{} -> panic "haddock:doConstrArgsWithDocs"
- ppOccInfix = case occ of
- [one] -> ppBinderInfix False one
- _ -> hsep (punctuate comma (map (ppBinderInfix False) occ))
-
- tyVars = tyvarNames (fromMaybe (HsQTvs PlaceHolder [] 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 $ getConNames con) subdocs >>=
combineDocumentation . fst
+-- ppConstrHdr is for (non-GADT) existentials constructors' syntax
+ppConstrHdr :: Bool -- ^ print explicit foralls
+ -> [Name] -- ^ type variables
+ -> HsContext DocNameI -- ^ context
+ -> Unicode -> Qualification -> Html
+ppConstrHdr forall_ tvs ctxt unicode qual = ppForall +++ ppCtxt
+ where
+ ppForall
+ | null tvs || not forall_ = noHtml
+ | otherwise = forallSymbol unicode
+ <+> hsep (map (ppName Prefix) tvs)
+ <+> toHtml ". "
+
+ ppCtxt
+ | null ctxt = noHtml
+ | otherwise = ppContextNoArrow ctxt unicode qual HideEmptyContexts
+ <+> darrow unicode +++ toHtml " "
+
+
+-- | Pretty-print a record field
ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification
-> ConDeclField DocNameI -> SubDecl
-ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) =
- ( hsep (punctuate comma (map ((ppBinder False) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names))
+ppSideBySideField subdocs unicode qual (ConDeclField _ names ltype _) =
+ ( hsep (punctuate comma [ ppBinder False (rdrNameOcc field)
+ | L _ name <- names
+ , let field = (unLoc . rdrNameFieldOcc) name
+ ])
<+> dcolon unicode
<+> ppLType unicode qual HideEmptyContexts ltype
, mbDoc
@@ -900,13 +1012,49 @@ ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) =
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 (selectorFieldOcc $ unLoc $ head names) subdocs >>= combineDocumentation . fst
+ mbDoc = lookup (extFieldOcc $ unLoc $ head names) subdocs >>= combineDocumentation . fst
+ppSideBySideField _ _ _ (XConDeclField _) = panic "haddock:ppSideBySideField"
ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocNameI -> Html
-ppShortField summary unicode qual (ConDeclField names ltype _)
+ppShortField summary unicode qual (ConDeclField _ names ltype _)
= hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names))
<+> dcolon unicode <+> ppLType unicode qual HideEmptyContexts ltype
+ppShortField _ _ _ (XConDeclField _) = panic "haddock:ppShortField"
+
+
+-- | Pretty print an expanded pattern (for bundled patterns)
+ppSideBySidePat :: [(DocName, Fixity)] -> Unicode -> Qualification
+ -> [Located DocName] -- ^ pattern name(s)
+ -> LHsSigType DocNameI -- ^ type of pattern(s)
+ -> DocForDecl DocName -- ^ doc map
+ -> SubDecl
+ppSideBySidePat fixities unicode qual lnames typ (doc, argDocs) =
+ ( decl
+ , combineDocumentation doc
+ , fieldPart
+ )
+ where
+ hasArgDocs = not $ Map.null argDocs
+ fixity = ppFixities fixities qual
+ ppOcc = hsep (punctuate comma (map (ppBinder False . getOccName) lnames))
+
+ decl | hasArgDocs = keyword "pattern" <+> ppOcc <+> fixity
+ | otherwise = hsep [ keyword "pattern"
+ , ppOcc
+ , dcolon unicode
+ , ppPatSigType unicode qual (hsSigType typ)
+ , fixity
+ ]
+
+ fieldPart
+ | not hasArgDocs = []
+ | otherwise = [ subFields Nothing qual (ppSubSigLike unicode qual (unLoc patTy)
+ argDocs [] (dcolon unicode)
+ emptyCtxt) ]
+
+ patTy = hsSigType typ
+ emptyCtxt = patSigContext patTy
-- | Print the LHS of a data\/newtype declaration.
@@ -987,11 +1135,12 @@ ppParendType unicode qual emptyCtxts ty = ppr_mono_ty pREC_CON ty unicode qual e
ppFunLhType unicode qual emptyCtxts ty = ppr_mono_ty pREC_FUN ty unicode qual emptyCtxts
ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr DocNameI -> Html
-ppHsTyVarBndr _ qual (UserTyVar (L _ name)) =
+ppHsTyVarBndr _ qual (UserTyVar _ (L _ name)) =
ppDocName qual Raw False name
-ppHsTyVarBndr unicode qual (KindedTyVar name kind) =
+ppHsTyVarBndr unicode qual (KindedTyVar _ name kind) =
parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+>
ppLKind unicode qual kind)
+ppHsTyVarBndr _ _ (XTyVarBndr _) = error "haddock:ppHsTyVarBndr"
ppLKind :: Unicode -> Qualification -> LHsKind DocNameI -> Html
ppLKind unicode qual y = ppKind unicode qual (unLoc y)
@@ -999,29 +1148,32 @@ ppLKind unicode qual y = ppKind unicode qual (unLoc y)
ppKind :: Unicode -> Qualification -> HsKind DocNameI -> Html
ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual HideEmptyContexts
-ppPatSigType :: Unicode -> Qualification -> LHsType DocNameI -> Html
-ppPatSigType unicode qual typ =
- let emptyCtxts =
- if hasNonEmptyContext typ && isFirstContextEmpty typ
- then ShowEmptyToplevelContexts
- else HideEmptyContexts
- in ppLType unicode qual emptyCtxts typ
+patSigContext :: LHsType name -> HideEmptyContexts
+patSigContext typ | hasNonEmptyContext typ && isFirstContextEmpty typ = ShowEmptyToplevelContexts
+ | otherwise = HideEmptyContexts
where
hasNonEmptyContext :: LHsType name -> Bool
hasNonEmptyContext t =
case unLoc t of
- HsForAllTy _ s -> hasNonEmptyContext s
- HsQualTy cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True
- HsFunTy _ s -> hasNonEmptyContext s
+ HsForAllTy _ _ s -> hasNonEmptyContext s
+ HsQualTy _ cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True
+ HsFunTy _ _ s -> hasNonEmptyContext s
_ -> False
isFirstContextEmpty :: LHsType name -> Bool
isFirstContextEmpty t =
case unLoc t of
- HsForAllTy _ s -> isFirstContextEmpty s
- HsQualTy cxt _ -> null (unLoc cxt)
- HsFunTy _ s -> isFirstContextEmpty s
+ HsForAllTy _ _ s -> isFirstContextEmpty s
+ HsQualTy _ cxt _ -> null (unLoc cxt)
+ HsFunTy _ _ s -> isFirstContextEmpty s
_ -> False
+
+-- | Pretty-print a pattern signature (all this does over 'ppLType' is slot in
+-- the right 'HideEmptyContext' value)
+ppPatSigType :: Unicode -> Qualification -> LHsType DocNameI -> Html
+ppPatSigType unicode qual typ =
+ let emptyCtxts = patSigContext typ in ppLType unicode qual emptyCtxts typ
+
ppForAllPart :: Unicode -> Qualification -> [LHsTyVarBndr DocNameI] -> Html
ppForAllPart unicode qual tvs = hsep (forallSymbol unicode : ppTyVars unicode qual tvs) +++ dot
@@ -1030,50 +1182,50 @@ ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty)
ppr_mono_ty :: Int -> HsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html
-ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode qual emptyCtxts
+ppr_mono_ty ctxt_prec (HsForAllTy _ tvs ty) unicode qual emptyCtxts
= maybeParen ctxt_prec pREC_FUN $
ppForAllPart unicode qual tvs <+> ppr_mono_lty pREC_TOP ty unicode qual emptyCtxts
-ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode qual emptyCtxts
+ppr_mono_ty ctxt_prec (HsQualTy _ ctxt ty) unicode qual emptyCtxts
= maybeParen ctxt_prec pREC_FUN $
ppLContext ctxt unicode qual emptyCtxts <+> ppr_mono_lty pREC_TOP ty unicode qual emptyCtxts
-- UnicodeSyntax alternatives
-ppr_mono_ty _ (HsTyVar _ (L _ name)) True _ _
+ppr_mono_ty _ (HsTyVar _ _ (L _ name)) True _ _
| getOccString (getName name) == "*" = toHtml "★"
| getOccString (getName name) == "(->)" = toHtml "(→)"
-ppr_mono_ty _ (HsBangTy b ty) u q _ = ppBang b +++ ppLParendType u q HideEmptyContexts ty
-ppr_mono_ty _ (HsTyVar _ (L _ name)) _ q _ = ppDocName q Prefix True name
-ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u q e = ppr_fun_ty ctxt_prec ty1 ty2 u q e
-ppr_mono_ty _ (HsTupleTy con tys) u q _ = tupleParens con (map (ppLType u q HideEmptyContexts) tys)
-ppr_mono_ty _ (HsSumTy tys) u q _ = sumParens (map (ppLType u q HideEmptyContexts) tys)
-ppr_mono_ty _ (HsKindSig ty kind) u q e =
+ppr_mono_ty _ (HsBangTy _ b ty) u q _ = ppBang b +++ ppLParendType u q HideEmptyContexts ty
+ppr_mono_ty _ (HsTyVar _ _ (L _ name)) _ q _ = ppDocName q Prefix True name
+ppr_mono_ty ctxt_prec (HsFunTy _ ty1 ty2) u q e = ppr_fun_ty ctxt_prec ty1 ty2 u q e
+ppr_mono_ty _ (HsTupleTy _ con tys) u q _ = tupleParens con (map (ppLType u q HideEmptyContexts) tys)
+ppr_mono_ty _ (HsSumTy _ tys) u q _ = sumParens (map (ppLType u q HideEmptyContexts) tys)
+ppr_mono_ty _ (HsKindSig _ ty kind) u q e =
parens (ppr_mono_lty pREC_TOP ty u q e <+> dcolon u <+> ppLKind u q kind)
-ppr_mono_ty _ (HsListTy ty) u q _ = brackets (ppr_mono_lty pREC_TOP ty u q HideEmptyContexts)
-ppr_mono_ty _ (HsPArrTy ty) u q _ = pabrackets (ppr_mono_lty pREC_TOP ty u q HideEmptyContexts)
-ppr_mono_ty ctxt_prec (HsIParamTy (L _ n) ty) u q _ =
+ppr_mono_ty _ (HsListTy _ ty) u q _ = brackets (ppr_mono_lty pREC_TOP ty u q HideEmptyContexts)
+ppr_mono_ty _ (HsPArrTy _ ty) u q _ = pabrackets (ppr_mono_lty pREC_TOP ty u q HideEmptyContexts)
+ppr_mono_ty ctxt_prec (HsIParamTy _ (L _ n) ty) u q _ =
maybeParen ctxt_prec pREC_CTX $ ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q HideEmptyContexts
ppr_mono_ty _ (HsSpliceTy {}) _ _ _ = error "ppr_mono_ty HsSpliceTy"
ppr_mono_ty _ (HsRecTy {}) _ _ _ = toHtml "{..}"
-- Can now legally occur in ConDeclGADT, the output here is to provide a
-- placeholder in the signature, which is followed by the field
-- declarations.
-ppr_mono_ty _ (HsCoreTy {}) _ _ _ = error "ppr_mono_ty HsCoreTy"
-ppr_mono_ty _ (HsExplicitListTy Promoted _ tys) u q _ = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys
-ppr_mono_ty _ (HsExplicitListTy NotPromoted _ tys) u q _ = brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys
+ppr_mono_ty _ (XHsType (NHsCoreTy {})) _ _ _ = error "ppr_mono_ty HsCoreTy"
+ppr_mono_ty _ (HsExplicitListTy _ Promoted tys) u q _ = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys
+ppr_mono_ty _ (HsExplicitListTy _ NotPromoted tys) u q _ = brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys
ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q _ = promoQuote $ parenList $ map (ppLType u q HideEmptyContexts) tys
ppr_mono_ty _ (HsAppsTy {}) _ _ _ = error "ppr_mono_ty HsAppsTy"
-ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode qual _
+ppr_mono_ty ctxt_prec (HsEqTy _ ty1 ty2) unicode qual _
= maybeParen ctxt_prec pREC_CTX $
ppr_mono_lty pREC_OP ty1 unicode qual HideEmptyContexts <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode qual HideEmptyContexts
-ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode qual _
+ppr_mono_ty ctxt_prec (HsAppTy _ fun_ty arg_ty) unicode qual _
= maybeParen ctxt_prec pREC_CON $
hsep [ppr_mono_lty pREC_FUN fun_ty unicode qual HideEmptyContexts, ppr_mono_lty pREC_CON arg_ty unicode qual HideEmptyContexts]
-ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode qual _
+ppr_mono_ty ctxt_prec (HsOpTy _ ty1 op ty2) unicode qual _
= maybeParen ctxt_prec pREC_FUN $
ppr_mono_lty pREC_OP ty1 unicode qual HideEmptyContexts <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual HideEmptyContexts
where
@@ -1084,15 +1236,15 @@ ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode qual _
| otherwise = ppr_op'
ppr_op' = ppLDocName qual Infix op
-ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual emptyCtxts
+ppr_mono_ty ctxt_prec (HsParTy _ ty) unicode qual emptyCtxts
-- = parens (ppr_mono_lty pREC_TOP ty)
= ppr_mono_lty ctxt_prec ty unicode qual emptyCtxts
-ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual emptyCtxts
+ppr_mono_ty ctxt_prec (HsDocTy _ ty _) unicode qual emptyCtxts
= ppr_mono_lty ctxt_prec ty unicode qual emptyCtxts
ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ _ _ = char '_'
-ppr_mono_ty _ (HsTyLit n) _ _ _ = ppr_tylit n
+ppr_mono_ty _ (HsTyLit _ n) _ _ _ = ppr_tylit n
ppr_tylit :: HsTyLit -> Html
ppr_tylit (HsNumTy _ n) = toHtml (show n)
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
index a75c4b9a..7fbaec6d 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
@@ -110,7 +110,7 @@ renderToString debug html
hsep :: [Html] -> Html
hsep [] = noHtml
-hsep htmls = foldr1 (\a b -> a+++" "+++b) htmls
+hsep htmls = foldr1 (<+>) htmls
-- | Concatenate a series of 'Html' values vertically, with linebreaks in between.
vcat :: [Html] -> Html
@@ -232,4 +232,4 @@ collapseToggle id_ classes = [ theclass cs, strAttr "data-details-id" id_ ]
-- and displays a control.
collapseControl :: String -> String -> [HtmlAttr]
collapseControl id_ classes = collapseToggle id_ cs
- where cs = unwords (words classes ++ ["details-toggle-control"]) \ No newline at end of file
+ where cs = unwords (words classes ++ ["details-toggle-control"])
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 8b227c50..4635c076 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, PatternGuards #-}
+{-# LANGUAGE CPP, PatternGuards, TypeFamilies #-}
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Convert
@@ -61,14 +61,14 @@ tyThingToLHsDecl t = case t of
-- in a future code version we could turn idVarDetails = foreign-call
-- into a ForD instead of a SigD if we wanted. Haddock doesn't
-- need to care.
- AnId i -> allOK $ SigD (synifyIdSig ImplicitizeForAll i)
+ AnId i -> allOK $ SigD noExt (synifyIdSig ImplicitizeForAll i)
-- type-constructors (e.g. Maybe) are complicated, put the definition
-- later in the file (also it's used for class associated-types too.)
ATyCon tc
| Just cl <- tyConClass_maybe tc -- classes are just a little tedious
-> let extractFamilyDecl :: TyClDecl a -> Either ErrMsg (LFamilyDecl a)
- extractFamilyDecl (FamDecl d) = return $ noLoc d
+ extractFamilyDecl (FamDecl _ d) = return $ noLoc d
extractFamilyDecl _ =
Left "tyThingToLHsDecl: impossible associated tycon"
@@ -76,7 +76,7 @@ tyThingToLHsDecl t = case t of
atFamDecls = map extractFamilyDecl (rights atTyClDecls)
tyClErrors = lefts atTyClDecls
famDeclErrors = lefts atFamDecls
- in withErrs (tyClErrors ++ famDeclErrors) . TyClD $ ClassDecl
+ in withErrs (tyClErrors ++ famDeclErrors) . TyClD noExt $ ClassDecl
{ tcdCtxt = synifyCtx (classSCTheta cl)
, tcdLName = synifyName cl
, tcdTyVars = synifyTyVars (tyConVisibleTyVars (classTyCon cl))
@@ -84,7 +84,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 NoSourceText . noLoc . fmap noLoc $ classMinimalDef cl) :
+ , tcdSigs = noLoc (MinimalSig noExt NoSourceText . noLoc . fmap noLoc $ classMinimalDef cl) :
map (noLoc . synifyTcIdSig DeleteTopLevelQuantification)
(classMethods cl)
, tcdMeths = emptyBag --ignore default method definitions, they don't affect signature
@@ -92,20 +92,20 @@ tyThingToLHsDecl t = case t of
, tcdATs = rights atFamDecls
, tcdATDefs = [] --ignore associated type defaults
, tcdDocs = [] --we don't have any docs at this point
- , tcdFVs = placeHolderNamesTc }
+ , tcdCExt = placeHolderNamesTc }
| otherwise
- -> synifyTyCon Nothing tc >>= allOK . TyClD
+ -> synifyTyCon Nothing tc >>= allOK . TyClD noExt
-- type-constructors (e.g. Maybe) are complicated, put the definition
-- later in the file (also it's used for class associated-types too.)
ACoAxiom ax -> synifyAxiom ax >>= allOK
-- a data-constructor alone just gets rendered as a function:
- AConLike (RealDataCon dc) -> allOK $ SigD (TypeSig [synifyName dc]
+ AConLike (RealDataCon dc) -> allOK $ SigD noExt (TypeSig noExt [synifyName dc]
(synifySigWcType ImplicitizeForAll (dataConUserType dc)))
AConLike (PatSynCon ps) ->
- allOK . SigD $ PatSynSig [synifyName ps] (synifyPatSynSigType ps)
+ allOK . SigD noExt $ PatSynSig noExt [synifyName ps] (synifyPatSynSigType ps)
where
withErrs e x = return (e, x)
allOK x = return (mempty, x)
@@ -118,9 +118,10 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs })
annot_typats = zipWith3 annotHsType (mkIsPolyTvs fam_tvs)
args_types_only typats
hs_rhs = synifyType WithinType rhs
- in HsIB { hsib_vars = map tyVarName tkvs
- , hsib_closed = True
- , hsib_body = FamEqn { feqn_tycon = name
+ in HsIB { hsib_ext = HsIBRn { hsib_vars = map tyVarName tkvs
+ , hsib_closed = True }
+ , hsib_body = FamEqn { feqn_ext = noExt
+ , feqn_tycon = name
, feqn_pats = annot_typats
, feqn_fixity = Prefix
, feqn_rhs = hs_rhs } }
@@ -131,13 +132,13 @@ synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl GhcRn)
synifyAxiom ax@(CoAxiom { co_ax_tc = tc })
| isOpenTypeFamilyTyCon tc
, Just branch <- coAxiomSingleBranch_maybe ax
- = return $ InstD
- $ TyFamInstD
+ = return $ InstD noExt
+ $ TyFamInstD noExt
$ TyFamInstDecl { tfid_eqn = synifyAxBranch tc branch }
| Just ax' <- isClosedSynFamilyTyConWithAxiom_maybe tc
, getUnique ax' == getUnique ax -- without the getUniques, type error
- = synifyTyCon (Just ax) tc >>= return . TyClD
+ = synifyTyCon (Just ax) tc >>= return . TyClD noExt
| otherwise
= Left "synifyAxiom: closed/open family confusion"
@@ -150,16 +151,19 @@ 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 (noLoc (getName fakeTyVar))
+ = noLoc $ KindedTyVar noExt (noLoc (getName fakeTyVar))
(synifyKindSig realKind)
- in HsQTvs { hsq_implicit = [] -- No kind polymorphism
+ in HsQTvs { hsq_ext =
+ HsQTvsRn { hsq_implicit = [] -- No kind polymorphism
+ , hsq_dependent = emptyNameSet }
, hsq_explicit = zipWith mk_hs_tv (fst (splitFunTys (tyConKind tc)))
alphaTyVars --a, b, c... which are unfortunately all kind *
- , hsq_dependent = emptyNameSet }
+ }
, tcdFixity = Prefix
- , tcdDataDefn = HsDataDefn { dd_ND = DataType -- arbitrary lie, they are neither
+ , tcdDataDefn = HsDataDefn { dd_ext = noExt
+ , dd_ND = DataType -- arbitrary lie, they are neither
-- algebraic data nor newtype:
, dd_ctxt = noLoc []
, dd_cType = Nothing
@@ -167,8 +171,7 @@ synifyTyCon _coax tc
-- we have their kind accurately:
, dd_cons = [] -- No constructors
, dd_derivs = noLoc [] }
- , tcdDataCusk = False
- , tcdFVs = placeHolderNamesTc }
+ , tcdDExt = DataDeclRn False placeHolderNamesTc }
synifyTyCon _coax tc
| Just flav <- famTyConFlav_maybe tc
@@ -189,8 +192,9 @@ synifyTyCon _coax tc
-> mkFamDecl DataFamily
where
resultVar = famTcResVar tc
- mkFamDecl i = return $ FamDecl $
- FamilyDecl { fdInfo = i
+ mkFamDecl i = return $ FamDecl noExt $
+ FamilyDecl { fdExt = noExt
+ , fdInfo = i
, fdLName = synifyName tc
, fdTyVars = synifyTyVars (tyConVisibleTyVars tc)
, fdFixity = Prefix
@@ -203,11 +207,11 @@ synifyTyCon _coax tc
synifyTyCon coax tc
| Just ty <- synTyConRhs_maybe tc
- = return $ SynDecl { tcdLName = synifyName tc
+ = return $ SynDecl { tcdSExt = emptyNameSet
+ , tcdLName = synifyName tc
, tcdTyVars = synifyTyVars (tyConVisibleTyVars tc)
, tcdFixity = Prefix
- , tcdRhs = synifyType WithinType ty
- , tcdFVs = placeHolderNamesTc }
+ , tcdRhs = synifyType WithinType ty }
| otherwise =
-- (closed) newtype and data
let
@@ -240,7 +244,8 @@ synifyTyCon coax tc
cons = rights consRaw
-- "deriving" doesn't affect the signature, no need to specify any.
alg_deriv = noLoc []
- defn = HsDataDefn { dd_ND = alg_nd
+ defn = HsDataDefn { dd_ext = noExt
+ , dd_ND = alg_nd
, dd_ctxt = alg_ctx
, dd_cType = Nothing
, dd_kindSig = kindSig
@@ -250,7 +255,7 @@ synifyTyCon coax tc
[] -> return $
DataDecl { tcdLName = name, tcdTyVars = tyvars, tcdFixity = Prefix
, tcdDataDefn = defn
- , tcdDataCusk = False, tcdFVs = placeHolderNamesTc }
+ , tcdDExt = DataDeclRn False placeHolderNamesTc }
dataConErrs -> Left $ unlines dataConErrs
-- In this module, every TyCon being considered has come from an interface
@@ -284,9 +289,9 @@ synifyInjectivityAnn (Just lhs) tvs (Injective inj) =
synifyFamilyResultSig :: Maybe Name -> Kind -> LFamilyResultSig GhcRn
synifyFamilyResultSig Nothing kind =
- noLoc $ KindSig (synifyKindSig kind)
+ noLoc $ KindSig noExt (synifyKindSig kind)
synifyFamilyResultSig (Just name) kind =
- noLoc $ TyVarSig (noLoc $ KindedTyVar (noLoc name) (synifyKindSig kind))
+ noLoc $ TyVarSig noExt (noLoc $ KindedTyVar noExt (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
@@ -304,10 +309,6 @@ synifyDataCon use_gadt_syntax dc =
-- con_qvars means a different thing depending on gadt-syntax
(univ_tvs, ex_tvs, _eq_spec, theta, arg_tys, res_ty) = dataConFullSig dc
- qvars = if use_gadt_syntax
- then synifyTyVars (univ_tvs ++ ex_tvs)
- else synifyTyVars ex_tvs
-
-- skip any EqTheta, use 'orig'inal syntax
ctx = synifyCtx theta
@@ -316,12 +317,12 @@ synifyDataCon use_gadt_syntax dc =
let tySyn = synifyType WithinType ty
in case bang of
(HsSrcBang _ NoSrcUnpack NoSrcStrict) -> tySyn
- bang' -> noLoc $ HsBangTy bang' tySyn)
+ bang' -> noLoc $ HsBangTy noExt bang' tySyn)
arg_tys (dataConSrcBangs dc)
field_tys = zipWith con_decl_field (dataConFieldLabels dc) linear_tys
con_decl_field fl synTy = noLoc $
- ConDeclField [noLoc $ FieldOcc (noLoc $ mkVarUnqual $ flLabel fl) (flSelector fl)] synTy
+ ConDeclField noExt [noLoc $ FieldOcc (flSelector fl) (noLoc $ mkVarUnqual $ flLabel fl)] synTy
Nothing
hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of
(True,True) -> Left "synifyDataCon: contradiction!"
@@ -330,45 +331,51 @@ 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) False
-- finally we get synifyDataCon's result!
in hs_arg_tys >>=
\hat ->
if use_gadt_syntax
then return $ noLoc $
- ConDeclGADT { con_names = [name]
- , con_type = gadt_ty
- , con_doc = Nothing }
+ ConDeclGADT { con_g_ext = noExt
+ , con_names = [name]
+ , con_forall = True
+ , con_qvars = synifyTyVars (univ_tvs ++ ex_tvs)
+ , con_mb_cxt = Just ctx
+ , con_args = hat
+ , con_res_ty = synifyType WithinType res_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 }
+ ConDeclH98 { con_ext = noExt
+ , con_name = name
+ , con_forall = True
+ , con_ex_tvs = map synifyTyVar ex_tvs
+ , con_mb_cxt = Just ctx
+ , con_args = hat
+ , con_doc = Nothing }
synifyName :: NamedThing n => n -> Located Name
synifyName n = L (srcLocSpan (getSrcLoc n)) (getName n)
synifyIdSig :: SynifyTypeState -> Id -> Sig GhcRn
-synifyIdSig s i = TypeSig [synifyName i] (synifySigWcType s (varType i))
+synifyIdSig s i = TypeSig noExt [synifyName i] (synifySigWcType s (varType i))
synifyTcIdSig :: SynifyTypeState -> Id -> Sig GhcRn
-synifyTcIdSig s i = ClassOpSig False [synifyName i] (synifySigType s (varType i))
+synifyTcIdSig s i = ClassOpSig noExt False [synifyName i] (synifySigType s (varType i))
synifyCtx :: [PredType] -> LHsContext GhcRn
synifyCtx = noLoc . map (synifyType WithinType)
synifyTyVars :: [TyVar] -> LHsQTyVars GhcRn
-synifyTyVars ktvs = HsQTvs { hsq_implicit = []
- , hsq_explicit = map synifyTyVar ktvs
- , hsq_dependent = emptyNameSet }
+synifyTyVars ktvs = HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = []
+ , hsq_dependent = emptyNameSet }
+ , hsq_explicit = map synifyTyVar ktvs }
synifyTyVar :: TyVar -> LHsTyVarBndr GhcRn
synifyTyVar tv
- | isLiftedTypeKind kind = noLoc (UserTyVar (noLoc name))
- | otherwise = noLoc (KindedTyVar (noLoc name) (synifyKindSig kind))
+ | isLiftedTypeKind kind = noLoc (UserTyVar noExt (noLoc name))
+ | otherwise = noLoc (KindedTyVar noExt (noLoc name) (synifyKindSig kind))
where
kind = tyVarKind tv
name = getName tv
@@ -385,7 +392,7 @@ annotHsType True ty hs_ty
| not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType ty
= let ki = typeKind ty
hs_ki = synifyType WithinType ki
- in noLoc (HsKindSig hs_ty hs_ki)
+ in noLoc (HsKindSig noExt hs_ty hs_ki)
annotHsType _ _ hs_ty = hs_ty
-- | For every type variable in the input,
@@ -430,7 +437,7 @@ synifyPatSynSigType :: PatSyn -> LHsSigType GhcRn
synifyPatSynSigType ps = mkEmptyImplicitBndrs (synifyPatSynType ps)
synifyType :: SynifyTypeState -> Type -> LHsType GhcRn
-synifyType _ (TyVarTy tv) = noLoc $ HsTyVar NotPromoted $ noLoc (getName tv)
+synifyType _ (TyVarTy tv) = noLoc $ HsTyVar noExt NotPromoted $ noLoc (getName tv)
synifyType _ (TyConApp tc tys)
= maybe_sig res_ty
where
@@ -440,41 +447,43 @@ synifyType _ (TyConApp tc tys)
| tc `hasKey` tYPETyConKey
, [TyConApp lev []] <- tys
, lev `hasKey` liftedRepDataConKey
- = noLoc (HsTyVar NotPromoted (noLoc starKindTyConName))
+ = noLoc (HsTyVar noExt NotPromoted (noLoc starKindTyConName))
-- Use non-prefix tuple syntax where possible, because it looks nicer.
| Just sort <- tyConTuple_maybe tc
, tyConArity tc == length tys
- = noLoc $ HsTupleTy (case sort of
+ = noLoc $ HsTupleTy noExt
+ (case sort of
BoxedTuple -> HsBoxedTuple
ConstraintTuple -> HsConstraintTuple
UnboxedTuple -> HsUnboxedTuple)
(map (synifyType WithinType) vis_tys)
-- ditto for lists
| getName tc == listTyConName, [ty] <- tys =
- noLoc $ HsListTy (synifyType WithinType ty)
+ noLoc $ HsListTy noExt (synifyType WithinType ty)
-- ditto for implicit parameter tycons
| tc `hasKey` ipClassKey
, [name, ty] <- tys
, Just x <- isStrLitTy name
- = noLoc $ HsIParamTy (noLoc $ HsIPName x) (synifyType WithinType ty)
+ = noLoc $ HsIParamTy noExt (noLoc $ HsIPName x) (synifyType WithinType ty)
-- and equalities
| tc `hasKey` eqTyConKey
, [ty1, ty2] <- tys
- = noLoc $ HsEqTy (synifyType WithinType ty1) (synifyType WithinType ty2)
+ = noLoc $ HsEqTy noExt (synifyType WithinType ty1) (synifyType WithinType ty2)
-- and infix type operators
| isSymOcc (nameOccName (getName tc))
, ty1:ty2:tys_rest <- vis_tys
- = mk_app_tys (HsOpTy (synifyType WithinType ty1)
+ = mk_app_tys (HsOpTy noExt
+ (synifyType WithinType ty1)
(noLoc $ getName tc)
(synifyType WithinType ty2))
tys_rest
-- Most TyCons:
| otherwise
- = mk_app_tys (HsTyVar NotPromoted $ noLoc (getName tc))
+ = mk_app_tys (HsTyVar noExt NotPromoted $ noLoc (getName tc))
vis_tys
where
mk_app_tys ty_app ty_args =
- foldl (\t1 t2 -> noLoc $ HsAppTy t1 t2)
+ foldl (\t1 t2 -> noLoc $ HsAppTy noExt t1 t2)
(noLoc ty_app)
(map (synifyType WithinType) $
filterOut isCoercionTy ty_args)
@@ -488,7 +497,7 @@ synifyType _ (TyConApp tc tys)
| needs_kind_sig
= let full_kind = typeKind (mkTyConApp tc tys)
full_kind' = synifyType WithinType full_kind
- in noLoc $ HsKindSig ty' full_kind'
+ in noLoc $ HsKindSig noExt ty' full_kind'
| otherwise = ty'
needs_kind_sig :: Bool
@@ -509,22 +518,24 @@ 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
+ in noLoc $ HsAppTy noExt s1 s2
synifyType _ (FunTy t1 t2) = let
s1 = synifyType WithinType t1
s2 = synifyType WithinType t2
- in noLoc $ HsFunTy s1 s2
+ in noLoc $ HsFunTy noExt s1 s2
synifyType s forallty@(ForAllTy _tv _ty) =
let (tvs, ctx, tau) = tcSplitSigmaTy forallty
sPhi = HsQualTy { hst_ctxt = synifyCtx ctx
+ , hst_xqual = noExt
, hst_body = synifyType WithinType tau }
in case s of
DeleteTopLevelQuantification -> synifyType ImplicitizeForAll tau
WithinType -> noLoc $ HsForAllTy { hst_bndrs = map synifyTyVar tvs
+ , hst_xforall = noExt
, hst_body = noLoc sPhi }
ImplicitizeForAll -> noLoc sPhi
-synifyType _ (LitTy t) = noLoc $ HsTyLit $ synifyTyLit t
+synifyType _ (LitTy t) = noLoc $ HsTyLit noExt $ synifyTyLit t
synifyType s (CastTy t _) = synifyType s t
synifyType _ (CoercionTy {}) = error "synifyType:Coercion"
@@ -537,10 +548,12 @@ synifyPatSynType ps = let
-- possible by taking theta = [], as that will print no context at all
| otherwise = req_theta
sForAll [] s = s
- sForAll tvs s = HsForAllTy { hst_bndrs = map synifyTyVar tvs
- , hst_body = noLoc s }
- sQual theta s = HsQualTy { hst_ctxt = synifyCtx theta
- , hst_body = noLoc s }
+ sForAll tvs s = HsForAllTy { hst_bndrs = map synifyTyVar tvs
+ , hst_xforall = noExt
+ , hst_body = noLoc s }
+ sQual theta s = HsQualTy { hst_ctxt = synifyCtx theta
+ , hst_xqual = noExt
+ , hst_body = noLoc s }
sTau = unLoc $ synifyType WithinType $ mkFunTys arg_tys res_ty
in noLoc $ sForAll univ_tvs $ sQual req_theta' $ sForAll ex_tvs $ sQual prov_theta sTau
@@ -560,7 +573,7 @@ synifyInstHead (_, preds, cls, types) = specializeInstHead $ InstHead
, clsiTyVars = synifyTyVars (tyConVisibleTyVars cls_tycon)
, clsiSigs = map synifyClsIdSig $ classMethods cls
, clsiAssocTys = do
- (Right (FamDecl fam)) <- map (synifyTyCon Nothing) $ classATs cls
+ (Right (FamDecl _ fam)) <- map (synifyTyCon Nothing) $ classATs cls
pure $ mkPseudoFamilyDecl fam
}
}
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index a1009c1f..2d254414 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE BangPatterns, FlexibleInstances, ViewPatterns #-}
+{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_HADDOCK hide #-}
-----------------------------------------------------------------------------
@@ -17,6 +18,7 @@ module Haddock.GhcUtils where
import Control.Arrow
+import Haddock.Types( DocNameI )
import Exception
import Outputable
@@ -27,6 +29,7 @@ import Module
import HscTypes
import GHC
import Class
+import DynFlags
moduleString :: Module -> String
@@ -44,57 +47,65 @@ isConSym = isLexConSym . occNameFS
getMainDeclBinder :: HsDecl name -> [IdP name]
-getMainDeclBinder (TyClD d) = [tcdName d]
-getMainDeclBinder (ValD d) =
+getMainDeclBinder (TyClD _ d) = [tcdName d]
+getMainDeclBinder (ValD _ d) =
case collectHsBindBinders d of
[] -> []
(name:_) -> [name]
-getMainDeclBinder (SigD d) = sigNameNoLoc d
-getMainDeclBinder (ForD (ForeignImport name _ _ _)) = [unLoc name]
-getMainDeclBinder (ForD (ForeignExport _ _ _ _)) = []
+getMainDeclBinder (SigD _ d) = sigNameNoLoc d
+getMainDeclBinder (ForD _ (ForeignImport _ name _ _)) = [unLoc name]
+getMainDeclBinder (ForD _ (ForeignExport _ _ _ _)) = []
getMainDeclBinder _ = []
-- Extract the source location where an instance is defined. This is used
-- to correlate InstDecls with their Instance/CoAxiom Names, via the
-- instanceMap.
getInstLoc :: InstDecl name -> SrcSpan
-getInstLoc (ClsInstD (ClsInstDecl { cid_poly_ty = ty })) = getLoc (hsSigType ty)
-getInstLoc (DataFamInstD (DataFamInstDecl
+getInstLoc (ClsInstD _ (ClsInstDecl { cid_poly_ty = ty })) = getLoc (hsSigType ty)
+getInstLoc (DataFamInstD _ (DataFamInstDecl
{ dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = L l _ }}})) = l
-getInstLoc (TyFamInstD (TyFamInstDecl
+getInstLoc (TyFamInstD _ (TyFamInstDecl
-- Since CoAxioms' Names refer to the whole line for type family instances
-- in particular, we need to dig a bit deeper to pull out the entire
-- equation. This does not happen for data family instances, for some reason.
{ tfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = L l _ }}})) = l
+getInstLoc (ClsInstD _ (XClsInstDecl _)) = panic "getInstLoc"
+getInstLoc (DataFamInstD _ (DataFamInstDecl (HsIB _ (XFamEqn _)))) = panic "getInstLoc"
+getInstLoc (TyFamInstD _ (TyFamInstDecl (HsIB _ (XFamEqn _)))) = panic "getInstLoc"
+getInstLoc (XInstDecl _) = panic "getInstLoc"
+getInstLoc (DataFamInstD _ (DataFamInstDecl (XHsImplicitBndrs _))) = panic "getInstLoc"
+getInstLoc (TyFamInstD _ (TyFamInstDecl (XHsImplicitBndrs _))) = panic "getInstLoc"
+
+
-- Useful when there is a signature with multiple names, e.g.
-- foo, bar :: Types..
-- but only one of the names is exported and we have to change the
-- type signature to only include the exported names.
-filterLSigNames :: (IdP name -> Bool) -> LSig name -> Maybe (LSig name)
+filterLSigNames :: (IdP (GhcPass p) -> Bool) -> LSig (GhcPass p) -> Maybe (LSig (GhcPass p))
filterLSigNames p (L loc sig) = L loc <$> (filterSigNames p sig)
-filterSigNames :: (IdP name -> Bool) -> Sig name -> Maybe (Sig name)
-filterSigNames p orig@(SpecSig n _ _) = ifTrueJust (p $ unLoc n) orig
-filterSigNames p orig@(InlineSig n _) = ifTrueJust (p $ unLoc n) orig
-filterSigNames p (FixSig (FixitySig ns ty)) =
+filterSigNames :: (IdP (GhcPass p) -> Bool) -> Sig (GhcPass p) -> Maybe (Sig (GhcPass p))
+filterSigNames p orig@(SpecSig _ n _ _) = ifTrueJust (p $ unLoc n) orig
+filterSigNames p orig@(InlineSig _ n _) = ifTrueJust (p $ unLoc n) orig
+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) =
+ filtered -> Just (FixSig noExt (FixitySig noExt filtered ty))
+filterSigNames _ orig@(MinimalSig _ _ _) = Just orig
+filterSigNames p (TypeSig _ ns ty) =
case filter (p . unLoc) ns of
[] -> Nothing
- filtered -> Just (TypeSig filtered ty)
-filterSigNames p (ClassOpSig is_default ns ty) =
+ filtered -> Just (TypeSig noExt filtered ty)
+filterSigNames p (ClassOpSig _ is_default ns ty) =
case filter (p . unLoc) ns of
[] -> Nothing
- filtered -> Just (ClassOpSig is_default filtered ty)
-filterSigNames p (PatSynSig ns ty) =
+ filtered -> Just (ClassOpSig noExt is_default filtered ty)
+filterSigNames p (PatSynSig _ ns ty) =
case filter (p . unLoc) ns of
[] -> Nothing
- filtered -> Just (PatSynSig filtered ty)
-filterSigNames _ _ = Nothing
+ filtered -> Just (PatSynSig noExt filtered ty)
+filterSigNames _ _ = Nothing
ifTrueJust :: Bool -> name -> Maybe name
ifTrueJust True = Just
@@ -104,13 +115,13 @@ sigName :: LSig name -> [IdP name]
sigName (L _ sig) = sigNameNoLoc sig
sigNameNoLoc :: Sig name -> [IdP name]
-sigNameNoLoc (TypeSig ns _) = map unLoc ns
-sigNameNoLoc (ClassOpSig _ ns _) = map unLoc ns
-sigNameNoLoc (PatSynSig ns _) = map unLoc ns
-sigNameNoLoc (SpecSig n _ _) = [unLoc n]
-sigNameNoLoc (InlineSig n _) = [unLoc n]
-sigNameNoLoc (FixSig (FixitySig ns _)) = map unLoc ns
-sigNameNoLoc _ = []
+sigNameNoLoc (TypeSig _ ns _) = map unLoc ns
+sigNameNoLoc (ClassOpSig _ _ ns _) = map unLoc ns
+sigNameNoLoc (PatSynSig _ ns _) = map unLoc ns
+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
@@ -121,16 +132,16 @@ isUserLSig _ = False
isClassD :: HsDecl a -> Bool
-isClassD (TyClD d) = isClassDecl d
+isClassD (TyClD _ d) = isClassDecl d
isClassD _ = False
isValD :: HsDecl a -> Bool
-isValD (ValD _) = True
+isValD (ValD _ _) = True
isValD _ = False
declATs :: HsDecl a -> [IdP a]
-declATs (TyClD d) | isClassDecl d = map (unL . fdLName . unL) $ tcdATs d
+declATs (TyClD _ d) | isClassDecl d = map (unL . fdLName . unL) $ tcdATs d
declATs _ = []
@@ -148,6 +159,73 @@ nubByName f ns = go emptyNameSet ns
where
y = f x
+-- ---------------------------------------------------------------------
+
+-- This function is duplicated as getGADTConType and getGADTConTypeG,
+-- as I can't get the types to line up otherwise. AZ.
+
+getGADTConType :: ConDecl DocNameI -> LHsType DocNameI
+-- The full type of a GADT data constructor We really only get this in
+-- order to pretty-print it, and currently only in Haddock's code. So
+-- we are cavalier about locations and extensions, hence the
+-- 'undefined's
+getGADTConType (ConDeclGADT { con_forall = has_forall
+ , con_qvars = qtvs
+ , con_mb_cxt = mcxt, con_args = args
+ , con_res_ty = res_ty })
+ | has_forall = noLoc (HsForAllTy { hst_xforall = NoExt
+ , hst_bndrs = hsQTvExplicit qtvs
+ , hst_body = theta_ty })
+ | otherwise = theta_ty
+ where
+ theta_ty | Just theta <- mcxt
+ = noLoc (HsQualTy { hst_xqual = NoExt, hst_ctxt = theta, hst_body = tau_ty })
+ | otherwise
+ = tau_ty
+
+ tau_ty = case args of
+ RecCon flds -> noLoc (HsFunTy noExt (noLoc (HsRecTy noExt (unLoc flds))) res_ty)
+ PrefixCon pos_args -> foldr mkFunTy res_ty pos_args
+ InfixCon arg1 arg2 -> arg1 `mkFunTy` (arg2 `mkFunTy` res_ty)
+
+ mkFunTy a b = noLoc (HsFunTy noExt a b)
+
+getGADTConType (ConDeclH98 {}) = panic "getGADTConType"
+ -- Should only be called on ConDeclGADT
+getGADTConType (XConDecl {}) = panic "getGADTConType"
+
+-- -------------------------------------
+
+getGADTConTypeG :: ConDecl (GhcPass p) -> LHsType (GhcPass p)
+-- The full type of a GADT data constructor We really only get this in
+-- order to pretty-print it, and currently only in Haddock's code. So
+-- we are cavalier about locations and extensions, hence the
+-- 'undefined's
+getGADTConTypeG (ConDeclGADT { con_forall = has_forall
+ , con_qvars = qtvs
+ , con_mb_cxt = mcxt, con_args = args
+ , con_res_ty = res_ty })
+ | has_forall = noLoc (HsForAllTy { hst_xforall = NoExt
+ , hst_bndrs = hsQTvExplicit qtvs
+ , hst_body = theta_ty })
+ | otherwise = theta_ty
+ where
+ theta_ty | Just theta <- mcxt
+ = noLoc (HsQualTy { hst_xqual = NoExt, hst_ctxt = theta, hst_body = tau_ty })
+ | otherwise
+ = tau_ty
+
+ tau_ty = case args of
+ RecCon flds -> noLoc (HsFunTy noExt (noLoc (HsRecTy noExt (unLoc flds))) res_ty)
+ PrefixCon pos_args -> foldr mkFunTy res_ty pos_args
+ InfixCon arg1 arg2 -> arg1 `mkFunTy` (arg2 `mkFunTy` res_ty)
+
+ mkFunTy a b = noLoc (HsFunTy noExt a b)
+
+getGADTConTypeG (ConDeclH98 {}) = panic "getGADTConTypeG"
+ -- Should only be called on ConDeclGADT
+getGADTConTypeG (XConDecl {}) = panic "getGADTConTypeG"
+
-------------------------------------------------------------------------------
-- * Located
-------------------------------------------------------------------------------
@@ -179,8 +257,8 @@ class Parent a where
instance Parent (ConDecl GhcRn) where
children con =
- case getConDetails con of
- RecCon fields -> map (selectorFieldOcc . unL) $
+ case con_args con of
+ RecCon fields -> map (extFieldOcc . unL) $
concatMap (cd_fld_names . unL) (unL fields)
_ -> []
@@ -190,7 +268,7 @@ instance Parent (TyClDecl GhcRn) 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 = []
@@ -218,7 +296,7 @@ parentMap d = [ (c, p) | (p, cs) <- families d, c <- cs ]
-- | The parents of a subordinate in a declaration
parents :: Name -> HsDecl GhcRn -> [Name]
-parents n (TyClD d) = [ p | (c, p) <- parentMap d, c == n ]
+parents n (TyClD _ d) = [ p | (c, p) <- parentMap d, c == n ]
parents _ _ = []
@@ -255,7 +333,10 @@ minimalDef n = do
setObjectDir, setHiDir, setStubDir, setOutputDir :: String -> DynFlags -> DynFlags
setObjectDir f d = d{ objectDir = Just f}
setHiDir f d = d{ hiDir = Just f}
-setStubDir f d = d{ stubDir = Just f, includePaths = f : includePaths d }
+setStubDir f d = d{ stubDir = Just f
+ , includePaths = addGlobalInclude (includePaths d) [f] }
-- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file
-- \#included from the .hc file when compiling with -fvia-C.
setOutputDir f = setObjectDir f . setHiDir f . setStubDir f
+
+
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index d0ed1698..bf50ded3 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -86,7 +86,7 @@ attachToExportItem
-> Ghc (ExportItem GhcRn)
attachToExportItem index expInfo iface ifaceMap instIfaceMap export =
case attachFixities export of
- e@ExportDecl { expItemDecl = L eSpan (TyClD d) } -> do
+ e@ExportDecl { expItemDecl = L eSpan (TyClD _ d) } -> do
insts <-
let mb_instances = lookupNameEnv index (tcdName d)
cls_instances = maybeToList mb_instances >>= fst
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index a35e2053..8b929e15 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -61,7 +61,7 @@ import TcRnTypes
import FastString ( concatFS, unpackFS )
import BasicTypes ( StringLiteral(..), SourceText(..) )
import qualified Outputable as O
-import HsDecls ( getConDetails )
+import HsDecls ( getConArgs )
-- | Use a 'TypecheckedModule' to produce an 'Interface'.
@@ -135,7 +135,7 @@ createInterface tm flags modMap instIfaceMap = do
$ map getName instances
++ map getName fam_instances
-- Locations of all TH splices
- splices = [ l | L l (SpliceD _) <- hsmodDecls hsm ]
+ splices = [ l | L l (SpliceD _ _) <- hsmodDecls hsm ]
warningMap <- liftErrMsg (mkWarningMap dflags warnings gre exportedNames)
@@ -393,7 +393,7 @@ mkMaps dflags pkgName gre instances decls = do
m' <- traverse (processDocStringParas dflags pkgName gre) m
pure (doc', m')
- (doc, args) <- declDoc docStrs (typeDocs decl)
+ (doc, args) <- declDoc docStrs (declTypeDocs decl)
let
subs :: [(Name, [HsDocString], Map Int HsDocString)]
@@ -419,9 +419,9 @@ mkMaps dflags pkgName gre instances decls = do
instanceMap = M.fromList [ (getSrcSpan n, n) | n <- instances ]
names :: SrcSpan -> HsDecl GhcRn -> [Name]
- names l (InstD d) = maybeToList (M.lookup loc instanceMap) -- See note [2].
+ names l (InstD _ d) = maybeToList (M.lookup loc instanceMap) -- See note [2].
where loc = case d of
- TyFamInstD _ -> l -- The CoAx's loc is the whole line, but only for TFs
+ TyFamInstD _ _ -> l -- The CoAx's loc is the whole line, but only for TFs
_ -> getInstLoc d
names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See note [2].
names _ decl = getMainDeclBinder decl
@@ -446,67 +446,82 @@ subordinates :: InstMap
-> HsDecl GhcRn
-> [(Name, [HsDocString], Map Int HsDocString)]
subordinates instMap decl = case decl of
- InstD (ClsInstD d) -> do
+ InstD _ (ClsInstD _ d) -> do
DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
FamEqn { feqn_tycon = L l _
, feqn_rhs = defn }}} <- unLoc <$> cid_datafam_insts d
[ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs defn
- InstD (DataFamInstD (DataFamInstDecl (HsIB { hsib_body = d })))
+ InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body = d })))
-> dataSubs (feqn_rhs d)
- TyClD d | isClassDecl d -> classSubs d
- | isDataDecl d -> dataSubs (tcdDataDefn d)
+ TyClD _ d | isClassDecl d -> classSubs d
+ | isDataDecl d -> dataSubs (tcdDataDefn d)
_ -> []
where
- classSubs dd = [ (name, doc, typeDocs d) | (L _ d, doc) <- classDecls dd
+ classSubs dd = [ (name, doc, declTypeDocs d) | (L _ d, doc) <- classDecls dd
, name <- getMainDeclBinder d, not (isValD d)
]
dataSubs :: HsDataDefn GhcRn -> [(Name, [HsDocString], Map Int HsDocString)]
dataSubs dd = constrs ++ fields ++ derivs
where
cons = map unL $ (dd_cons dd)
- constrs = [ (unL cname, maybeToList $ fmap unL $ con_doc c, M.empty)
+ constrs = [ (unL cname, maybeToList $ fmap unL $ con_doc c, conArgDocs c)
| c <- cons, cname <- getConNames c ]
- fields = [ (selectorFieldOcc n, maybeToList $ fmap unL doc, M.empty)
- | RecCon flds <- map getConDetails cons
- , L _ (ConDeclField ns _ doc) <- (unLoc flds)
+ fields = [ (extFieldOcc n, maybeToList $ fmap unL doc, M.empty)
+ | RecCon flds <- map getConArgs cons
+ , L _ (ConDeclField _ ns _ doc) <- (unLoc flds)
, L _ n <- ns ]
derivs = [ (instName, [unL doc], M.empty)
- | HsIB { hsib_body = L l (HsDocTy _ doc) }
+ | HsIB { hsib_body = L l (HsDocTy _ _ doc) }
<- concatMap (unLoc . deriv_clause_tys . unLoc) $
unLoc $ dd_derivs dd
, Just instName <- [M.lookup l instMap] ]
+-- | Extract constructor argument docs from inside constructor decls.
+conArgDocs :: ConDecl GhcRn -> Map Int HsDocString
+conArgDocs con = case getConArgs con of
+ PrefixCon args -> go 0 (map unLoc args ++ ret)
+ InfixCon arg1 arg2 -> go 0 ([unLoc arg1, unLoc arg2] ++ ret)
+ RecCon _ -> go 1 ret
+ where
+ go n (HsDocTy _ _ (L _ ds) : tys) = M.insert n ds $ go (n+1) tys
+ go n (_ : tys) = go (n+1) tys
+ go _ [] = M.empty
+
+ ret = case con of
+ ConDeclGADT { con_res_ty = res_ty } -> [ unLoc res_ty ]
+ _ -> []
+
+-- | Extract function argument docs from inside top-level decls.
+declTypeDocs :: HsDecl GhcRn -> Map Int HsDocString
+declTypeDocs (SigD _ (TypeSig _ _ ty)) = typeDocs (unLoc (hsSigWcType ty))
+declTypeDocs (SigD _ (ClassOpSig _ _ _ ty)) = typeDocs (unLoc (hsSigType ty))
+declTypeDocs (SigD _ (PatSynSig _ _ ty)) = typeDocs (unLoc (hsSigType ty))
+declTypeDocs (ForD _ (ForeignImport _ _ ty _)) = typeDocs (unLoc (hsSigType ty))
+declTypeDocs (TyClD _ (SynDecl { tcdRhs = ty })) = typeDocs (unLoc ty)
+declTypeDocs _ = M.empty
+
-- | Extract function argument docs from inside types.
-typeDocs :: HsDecl GhcRn -> Map Int HsDocString
-typeDocs d =
- let docs = go 0 in
- case d of
- SigD (TypeSig _ ty) -> docs (unLoc (hsSigWcType ty))
- SigD (ClassOpSig _ _ ty) -> docs (unLoc (hsSigType ty))
- SigD (PatSynSig _ ty) -> docs (unLoc (hsSigType ty))
- ForD (ForeignImport _ ty _ _) -> docs (unLoc (hsSigType ty))
- TyClD (SynDecl { tcdRhs = ty }) -> docs (unLoc ty)
- _ -> M.empty
+typeDocs :: HsType GhcRn -> Map Int HsDocString
+typeDocs = go 0
where
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
+ 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
go _ _ = M.empty
-
-- | All the sub declarations of a class (that we handle), ordered by
-- source location, with documentation attached if it exists.
classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])]
classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls
where
decls = docs ++ defs ++ sigs ++ ats
- docs = mkDecls tcdDocs DocD class_
- defs = mkDecls (bagToList . tcdMeths) ValD class_
- sigs = mkDecls tcdSigs SigD class_
- ats = mkDecls tcdATs (TyClD . FamDecl) class_
+ docs = mkDecls tcdDocs (DocD noExt) class_
+ defs = mkDecls (bagToList . tcdMeths) (ValD noExt) class_
+ sigs = mkDecls tcdSigs (SigD noExt) class_
+ ats = mkDecls tcdATs (TyClD noExt . FamDecl noExt) class_
-- | The top-level declarations of a module that we care about,
@@ -518,26 +533,26 @@ topDecls =
-- | Extract a map of fixity declarations only
mkFixMap :: HsGroup GhcRn -> FixMap
mkFixMap group_ = M.fromList [ (n,f)
- | L _ (FixitySig ns f) <- hs_fixds group_,
+ | L _ (FixitySig _ ns f) <- hs_fixds group_,
L _ n <- ns ]
-- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'.
ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn]
ungroup group_ =
- mkDecls (tyClGroupTyClDecls . hs_tyclds) TyClD group_ ++
- mkDecls hs_derivds DerivD group_ ++
- mkDecls hs_defds DefD group_ ++
- mkDecls hs_fords ForD group_ ++
- mkDecls hs_docs DocD group_ ++
- mkDecls (tyClGroupInstDecls . hs_tyclds) InstD group_ ++
- mkDecls (typesigs . hs_valds) SigD group_ ++
- mkDecls (valbinds . hs_valds) ValD group_
+ mkDecls (tyClGroupTyClDecls . hs_tyclds) (TyClD noExt) group_ ++
+ mkDecls hs_derivds (DerivD noExt) group_ ++
+ mkDecls hs_defds (DefD noExt) group_ ++
+ mkDecls hs_fords (ForD noExt) group_ ++
+ mkDecls hs_docs (DocD noExt) group_ ++
+ mkDecls (tyClGroupInstDecls . hs_tyclds) (InstD noExt) group_ ++
+ mkDecls (typesigs . hs_valds) (SigD noExt) group_ ++
+ mkDecls (valbinds . hs_valds) (ValD noExt) group_
where
- typesigs (ValBindsOut _ sigs) = filter isUserLSig sigs
+ typesigs (XValBindsLR (NValBinds _ sigs)) = filter isUserLSig sigs
typesigs _ = error "expected ValBindsOut"
- valbinds (ValBindsOut binds _) = concatMap bagToList . snd . unzip $ binds
+ valbinds (XValBindsLR (NValBinds binds _)) = concatMap bagToList . snd . unzip $ binds
valbinds _ = error "expected ValBindsOut"
@@ -563,14 +578,14 @@ sortByLoc = sortBy (comparing getLoc)
filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]
filterDecls = filter (isHandled . unL . fst)
where
- isHandled (ForD (ForeignImport {})) = True
+ isHandled (ForD _ (ForeignImport {})) = True
isHandled (TyClD {}) = True
isHandled (InstD {}) = True
isHandled (DerivD {}) = True
- isHandled (SigD d) = isUserLSig (reL d)
- isHandled (ValD _) = True
+ isHandled (SigD _ d) = isUserLSig (reL d)
+ isHandled (ValD {}) = True
-- we keep doc declarations to be able to get at named docs
- isHandled (DocD _) = True
+ isHandled (DocD {}) = True
isHandled _ = False
-- | Go through all class declarations and filter their sub-declarations
@@ -578,8 +593,8 @@ filterClasses :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]
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 (||) isUserLSig isMinimalLSig) $ tcdSigs c }
+ filterClass (TyClD x c) =
+ TyClD x $ c { tcdSigs = filter (liftA2 (||) isUserLSig isMinimalLSig) $ tcdSigs c }
filterClass _ = error "expected TyClD"
@@ -598,10 +613,10 @@ collectDocs = go Nothing []
where
go Nothing _ [] = []
go (Just prev) docs [] = finished prev docs []
- go prev docs (L _ (DocD (DocCommentNext str)) : ds)
+ go prev docs (L _ (DocD _ (DocCommentNext str)) : ds)
| Nothing <- prev = go Nothing (str:docs) ds
| Just decl <- prev = finished decl docs (go Nothing [str] ds)
- go prev docs (L _ (DocD (DocCommentPrev str)) : ds) = go prev (str:docs) ds
+ go prev docs (L _ (DocD _ (DocCommentPrev str)) : ds) = go prev (str:docs) ds
go Nothing docs (d:ds) = go (Just d) docs ds
go (Just prev) docs (d:ds) = finished prev docs (go (Just d) [] ds)
@@ -644,22 +659,22 @@ mkExportItems
allExports
Just exports -> liftM concat $ mapM lookupExport exports
where
- lookupExport (IEGroup lev docStr, _) = liftErrMsg $ do
+ lookupExport (IEGroup _ lev docStr, _) = liftErrMsg $ do
doc <- processDocString dflags gre docStr
return [ExportGroup lev "" doc]
- lookupExport (IEDoc docStr, _) = liftErrMsg $ do
+ lookupExport (IEDoc _ docStr, _) = liftErrMsg $ do
doc <- processDocStringParas dflags pkgName gre docStr
return [ExportDoc doc]
- lookupExport (IEDocNamed str, _) = liftErrMsg $
+ lookupExport (IEDocNamed _ str, _) = liftErrMsg $
findNamedDoc str [ unL d | d <- decls ] >>= \case
Nothing -> return []
Just docStr -> do
doc <- processDocStringParas dflags pkgName gre docStr
return [ExportDoc doc]
- lookupExport (IEModuleContents (L _ mod_name), _)
+ lookupExport (IEModuleContents _ (L _ mod_name), _)
-- only consider exporting a module if we are sure we
-- are really exporting the whole module and not some
-- subset. We also look through module aliases here.
@@ -696,7 +711,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
let t = availName avail
r <- findDecl avail
case r of
- ([L l (ValD _)], (doc, _)) -> do
+ ([L l (ValD _ _)], (doc, _)) -> do
-- Top-level binding without type signature
export <- hiValExportItem dflags t l doc (l `elem` splices) $ M.lookup t fixMap
return [export]
@@ -721,17 +736,17 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
-- A single signature might refer to many names, but we
-- create an export item for a single name only. So we
-- modify the signature to contain only that single name.
- L loc (SigD sig) ->
+ L loc (SigD _ sig) ->
-- fromJust is safe since we already checked in guards
-- that 't' is a name declared in this declaration.
- let newDecl = L loc . SigD . fromJust $ filterSigNames (== t) sig
+ let newDecl = L loc . SigD noExt . fromJust $ filterSigNames (== t) sig
in availExportDecl avail newDecl docs_
- L loc (TyClD cl@ClassDecl{}) -> do
+ L loc (TyClD _ cl@ClassDecl{}) -> do
mdef <- liftGhcToErrMsgGhc $ minimalDef t
- let sig = maybeToList $ fmap (noLoc . MinimalSig NoSourceText . noLoc . fmap noLoc) mdef
+ let sig = maybeToList $ fmap (noLoc . MinimalSig noExt NoSourceText . noLoc . fmap noLoc) mdef
availExportDecl avail
- (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_
+ (L loc $ TyClD noExt cl { tcdSigs = sig ++ tcdSigs cl }) docs_
_ -> availExportDecl avail decl docs_
@@ -994,13 +1009,13 @@ fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre exportedNam
let availEnv = availsToNameEnv (nubAvails avails)
(concat . concat) `fmap` (for decls $ \decl -> do
case decl of
- (L _ (DocD (DocGroup lev docStr))) -> do
+ (L _ (DocD _ (DocGroup lev docStr))) -> do
doc <- liftErrMsg (processDocString dflags gre docStr)
return [[ExportGroup lev "" doc]]
- (L _ (DocD (DocCommentNamed _ docStr))) -> do
+ (L _ (DocD _ (DocCommentNamed _ docStr))) -> do
doc <- liftErrMsg (processDocStringParas dflags pkgName gre docStr)
return [[ExportDoc doc]]
- (L _ (ValD valDecl))
+ (L _ (ValD _ valDecl))
| name:_ <- collectHsBindBinders valDecl
, Just (L _ SigD{}:_) <- filter isSigD <$> M.lookup name declMap
-> return []
@@ -1025,12 +1040,12 @@ extractDecl declMap name decl
| name `elem` getMainDeclBinder (unLoc decl) = decl
| otherwise =
case unLoc decl of
- TyClD d@ClassDecl {} ->
+ TyClD _ d@ClassDecl {} ->
let
matchesMethod =
[ lsig
| lsig <- tcdSigs d
- , ClassOpSig False _ _ <- pure $ unLoc lsig
+ , ClassOpSig _ False _ _ <- pure $ unLoc lsig
-- Note: exclude `default` declarations (see #505)
, name `elem` sigName lsig
]
@@ -1045,8 +1060,8 @@ extractDecl declMap name decl
in case (matchesMethod, matchesAssociatedType) of
([s0], _) -> let (n, tyvar_names) = (tcdName d, tyClDeclTyVars d)
L pos sig = addClassContext n tyvar_names s0
- in L pos (SigD sig)
- (_, [L pos fam_decl]) -> L pos (TyClD (FamDecl fam_decl))
+ in L pos (SigD noExt sig)
+ (_, [L pos fam_decl]) -> L pos (TyClD noExt (FamDecl noExt fam_decl))
([], [])
| Just (famInstDecl:_) <- M.lookup name declMap
@@ -1055,23 +1070,23 @@ extractDecl declMap name decl
O.$$ O.nest 4 (O.ppr d)
O.$$ O.text "Matches:"
O.$$ O.nest 4 (O.ppr matchesMethod O.<+> O.ppr matchesAssociatedType))
- TyClD d@DataDecl {} ->
+ TyClD _ d@DataDecl {} ->
let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars d))
in if isDataConName name
- then SigD <$> extractPatternSyn name n tyvar_tys (dd_cons (tcdDataDefn d))
- else SigD <$> extractRecSel name n tyvar_tys (dd_cons (tcdDataDefn d))
- TyClD FamDecl {}
+ then SigD noExt <$> extractPatternSyn name n tyvar_tys (dd_cons (tcdDataDefn d))
+ else SigD noExt <$> extractRecSel name n tyvar_tys (dd_cons (tcdDataDefn d))
+ TyClD _ FamDecl {}
| isValName name
, Just (famInst:_) <- M.lookup name declMap
-> extractDecl declMap name famInst
- InstD (DataFamInstD (DataFamInstDecl (HsIB { hsib_body =
+ InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body =
FamEqn { feqn_tycon = L _ n
, feqn_pats = tys
, feqn_rhs = defn }}))) ->
if isDataConName name
- then SigD <$> extractPatternSyn name n tys (dd_cons defn)
- else SigD <$> extractRecSel name n tys (dd_cons defn)
- InstD (ClsInstD ClsInstDecl { cid_datafam_insts = insts })
+ then SigD noExt <$> extractPatternSyn name n tys (dd_cons defn)
+ else SigD noExt <$> extractRecSel name n tys (dd_cons defn)
+ InstD _ (ClsInstD _ ClsInstDecl { cid_datafam_insts = insts })
| isDataConName name ->
let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body =
FamEqn { feqn_rhs = dd
@@ -1080,19 +1095,19 @@ extractDecl declMap name decl
, name `elem` map unLoc (concatMap (getConNames . unLoc) (dd_cons dd))
]
in case matches of
- [d0] -> extractDecl declMap name (noLoc (InstD (DataFamInstD d0)))
+ [d0] -> extractDecl declMap name (noLoc (InstD noExt (DataFamInstD noExt d0)))
_ -> error "internal: extractDecl (ClsInstD)"
| otherwise ->
let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body = d }))
<- insts
-- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (feqn_rhs d)
- , RecCon rec <- map (getConDetails . unLoc) (dd_cons (feqn_rhs d))
+ , RecCon rec <- map (getConArgs . unLoc) (dd_cons (feqn_rhs d))
, ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec)
, L _ n <- ns
- , selectorFieldOcc n == name
+ , extFieldOcc n == name
]
in case matches of
- [d0] -> extractDecl declMap name (noLoc . InstD $ DataFamInstD d0)
+ [d0] -> extractDecl declMap name (noLoc . InstD noExt $ DataFamInstD noExt d0)
_ -> error "internal: extractDecl (ClsInstD)"
_ -> error "internal: extractDecl"
@@ -1108,42 +1123,42 @@ extractPatternSyn nm t tvs cons =
extract :: ConDecl GhcRn -> Sig GhcRn
extract con =
let args =
- case getConDetails con of
+ case getConArgs con of
PrefixCon args' -> args'
RecCon (L _ fields) -> cd_fld_type . unLoc <$> fields
InfixCon arg1 arg2 -> [arg1, arg2]
typ = longArrow args (data_ty con)
typ' =
case con of
- ConDeclH98 { con_cxt = Just cxt } -> noLoc (HsQualTy cxt typ)
+ ConDeclH98 { con_mb_cxt = Just cxt } -> noLoc (HsQualTy noExt cxt typ)
_ -> typ
- typ'' = noLoc (HsQualTy (noLoc []) typ')
- in PatSynSig [noLoc nm] (mkEmptyImplicitBndrs typ'')
+ typ'' = noLoc (HsQualTy noExt (noLoc []) typ')
+ in PatSynSig noExt [noLoc nm] (mkEmptyImplicitBndrs typ'')
- longArrow :: [LHsType name] -> LHsType name -> LHsType name
- longArrow inputs output = foldr (\x y -> noLoc (HsFunTy x y)) output inputs
+ longArrow :: [LHsType GhcRn] -> LHsType GhcRn -> LHsType GhcRn
+ longArrow inputs output = foldr (\x y -> noLoc (HsFunTy noExt x y)) output inputs
data_ty con
- | ConDeclGADT{} <- con = hsib_body $ con_type con
- | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar NotPromoted (noLoc t))) tvs
+ | ConDeclGADT{} <- con = con_res_ty con
+ | otherwise = foldl' (\x y -> noLoc (HsAppTy noExt x y)) (noLoc (HsTyVar noExt NotPromoted (noLoc t))) tvs
extractRecSel :: Name -> Name -> [LHsType GhcRn] -> [LConDecl GhcRn]
-> LSig GhcRn
extractRecSel _ _ _ [] = error "extractRecSel: selector not found"
extractRecSel nm t tvs (L _ con : rest) =
- case getConDetails con of
- RecCon (L _ fields) | ((l,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields ->
- L l (TypeSig [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy data_ty (getBangType ty)))))
+ case getConArgs con of
+ RecCon (L _ fields) | ((l,L _ (ConDeclField _ _nn ty _)) : _) <- matching_fields fields ->
+ L l (TypeSig noExt [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExt data_ty (getBangType ty)))))
_ -> extractRecSel nm t tvs rest
where
matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)]
- matching_fields flds = [ (l,f) | f@(L _ (ConDeclField ns _ _)) <- flds
- , L l n <- ns, selectorFieldOcc n == nm ]
+ matching_fields flds = [ (l,f) | f@(L _ (ConDeclField _ ns _ _)) <- flds
+ , L l n <- ns, extFieldOcc n == nm ]
data_ty
-- ResTyGADT _ ty <- con_res con = ty
- | ConDeclGADT{} <- con = hsib_body $ con_type con
- | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar NotPromoted (noLoc t))) tvs
+ | ConDeclGADT{} <- con = con_res_ty con
+ | otherwise = foldl' (\x y -> noLoc (HsAppTy noExt x y)) (noLoc (HsTyVar noExt NotPromoted (noLoc t))) tvs
-- | Keep export items with docs.
pruneExportItems :: [ExportItem GhcRn] -> [ExportItem GhcRn]
@@ -1163,8 +1178,8 @@ mkVisibleNames (_, _, _, instMap) exports opts
where subs = map fst (expItemSubDocs e)
patsyns = concatMap (getMainDeclBinder . fst) (expItemPats e)
name = case unLoc $ expItemDecl e of
- InstD d -> maybeToList $ M.lookup (getInstLoc d) instMap
- decl -> getMainDeclBinder decl
+ InstD _ d -> maybeToList $ M.lookup (getInstLoc d) instMap
+ decl -> getMainDeclBinder decl
exportName ExportNoDecl {} = [] -- we don't count these as visible, since
-- we don't want links to go to them.
exportName _ = []
@@ -1208,7 +1223,7 @@ findNamedDoc name = search
search [] = do
tell ["Cannot find documentation for: $" ++ name]
return Nothing
- search (DocD (DocCommentNamed name' doc) : rest)
+ search (DocD _ (DocCommentNamed name' doc) : rest)
| name == name' = return (Just doc)
| otherwise = search rest
search (_other_decl : rest) = search rest
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index b2d0e1e1..7fb1f4b7 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -21,6 +21,7 @@ import Haddock.Types
import Bag (emptyBag)
import GHC hiding (NoLink)
import Name
+import Outputable ( panic )
import RdrName (RdrName(Exact))
import PrelNames (eqTyCon_RDR)
@@ -197,14 +198,15 @@ renameMaybeLKind :: Maybe (LHsKind GhcRn) -> RnM (Maybe (LHsKind DocNameI))
renameMaybeLKind = traverse renameLKind
renameFamilyResultSig :: LFamilyResultSig GhcRn -> RnM (LFamilyResultSig DocNameI)
-renameFamilyResultSig (L loc NoSig)
- = return (L loc NoSig)
-renameFamilyResultSig (L loc (KindSig ki))
+renameFamilyResultSig (L loc (NoSig _))
+ = return (L loc (NoSig noExt))
+renameFamilyResultSig (L loc (KindSig _ ki))
= do { ki' <- renameLKind ki
- ; return (L loc (KindSig ki')) }
-renameFamilyResultSig (L loc (TyVarSig bndr))
+ ; return (L loc (KindSig noExt ki')) }
+renameFamilyResultSig (L loc (TyVarSig _ bndr))
= do { bndr' <- renameLTyVarBndr bndr
- ; return (L loc (TyVarSig bndr')) }
+ ; return (L loc (TyVarSig noExt bndr')) }
+renameFamilyResultSig (L _ (XFamilyResultSig _)) = panic "haddock:renameFamilyResultSig"
renameInjectivityAnn :: LInjectivityAnn GhcRn -> RnM (LInjectivityAnn DocNameI)
renameInjectivityAnn (L loc (InjectivityAnn lhs rhs))
@@ -221,61 +223,61 @@ renameType t = case t of
HsForAllTy { hst_bndrs = tyvars, hst_body = ltype } -> do
tyvars' <- mapM renameLTyVarBndr tyvars
ltype' <- renameLType ltype
- return (HsForAllTy { hst_bndrs = tyvars', hst_body = ltype' })
+ return (HsForAllTy { hst_xforall = NoExt, hst_bndrs = tyvars', hst_body = ltype' })
HsQualTy { hst_ctxt = lcontext , hst_body = ltype } -> do
lcontext' <- renameLContext lcontext
ltype' <- renameLType ltype
- return (HsQualTy { hst_ctxt = lcontext', hst_body = ltype' })
+ return (HsQualTy { hst_xqual = NoExt, hst_ctxt = lcontext', hst_body = ltype' })
- HsTyVar ip (L l n) -> return . HsTyVar ip . L l =<< rename n
- HsBangTy b ltype -> return . HsBangTy b =<< renameLType ltype
+ HsTyVar _ ip (L l n) -> return . HsTyVar NoExt ip . L l =<< rename n
+ HsBangTy _ b ltype -> return . HsBangTy NoExt b =<< renameLType ltype
- HsAppTy a b -> do
+ HsAppTy _ a b -> do
a' <- renameLType a
b' <- renameLType b
- return (HsAppTy a' b')
+ return (HsAppTy NoExt a' b')
- HsFunTy a b -> do
+ HsFunTy _ a b -> do
a' <- renameLType a
b' <- renameLType b
- return (HsFunTy a' b')
+ return (HsFunTy NoExt a' b')
- HsListTy ty -> return . HsListTy =<< renameLType ty
- HsPArrTy ty -> return . HsPArrTy =<< renameLType ty
- HsIParamTy n ty -> liftM (HsIParamTy n) (renameLType ty)
- HsEqTy ty1 ty2 -> liftM2 HsEqTy (renameLType ty1) (renameLType ty2)
+ HsListTy _ ty -> return . (HsListTy NoExt) =<< renameLType ty
+ HsPArrTy _ ty -> return . (HsPArrTy NoExt) =<< renameLType ty
+ HsIParamTy _ n ty -> liftM (HsIParamTy NoExt n) (renameLType ty)
+ HsEqTy _ ty1 ty2 -> liftM2 (HsEqTy NoExt) (renameLType ty1) (renameLType ty2)
- HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts
- HsSumTy ts -> HsSumTy <$> mapM renameLType ts
+ HsTupleTy _ b ts -> return . HsTupleTy NoExt b =<< mapM renameLType ts
+ HsSumTy _ ts -> HsSumTy NoExt <$> mapM renameLType ts
- HsOpTy a (L loc op) b -> do
+ HsOpTy _ a (L loc op) b -> do
op' <- rename op
a' <- renameLType a
b' <- renameLType b
- return (HsOpTy a' (L loc op') b')
+ return (HsOpTy NoExt a' (L loc op') b')
- HsParTy ty -> return . HsParTy =<< renameLType ty
+ HsParTy _ ty -> return . (HsParTy NoExt) =<< renameLType ty
- HsKindSig ty k -> do
+ HsKindSig _ ty k -> do
ty' <- renameLType ty
k' <- renameLKind k
- return (HsKindSig ty' k')
+ return (HsKindSig NoExt ty' k')
- HsDocTy ty doc -> do
+ HsDocTy _ ty doc -> do
ty' <- renameLType ty
doc' <- renameLDocHsSyn doc
- return (HsDocTy ty' doc')
+ return (HsDocTy NoExt ty' doc')
- HsTyLit x -> return (HsTyLit x)
+ HsTyLit _ x -> return (HsTyLit NoExt x)
- HsRecTy a -> HsRecTy <$> mapM renameConDeclFieldField a
- HsCoreTy a -> pure (HsCoreTy a)
+ HsRecTy _ a -> HsRecTy NoExt <$> mapM renameConDeclFieldField a
+ (XHsType (NHsCoreTy a)) -> pure (XHsType (NHsCoreTy a))
HsExplicitListTy i a b -> HsExplicitListTy i a <$> mapM renameLType b
HsExplicitTupleTy a b -> HsExplicitTupleTy a <$> mapM renameLType b
- HsSpliceTy s _ -> renameHsSpliceTy s
+ HsSpliceTy _ s -> renameHsSpliceTy s
HsWildCardTy a -> HsWildCardTy <$> renameWildCardInfo a
- HsAppsTy _ -> error "renameType: HsAppsTy"
+ HsAppsTy _ _ -> error "renameType: HsAppsTy"
-- | Rename splices, but _only_ those that turn out to be for types.
-- I think this is actually safe for our possible inputs:
@@ -284,32 +286,34 @@ renameType t = case t of
-- * the input is typechecked, and only 'HsSplicedTy' should get through that
--
renameHsSpliceTy :: HsSplice GhcRn -> RnM (HsType DocNameI)
-renameHsSpliceTy (HsSpliced _ (HsSplicedTy t)) = renameType t
-renameHsSpliceTy (HsSpliced _ _) = error "renameHsSpliceTy: not an HsSplicedTy"
+renameHsSpliceTy (HsSpliced _ _ (HsSplicedTy t)) = renameType t
+renameHsSpliceTy (HsSpliced _ _ _) = error "renameHsSpliceTy: not an HsSplicedTy"
renameHsSpliceTy _ = error "renameHsSpliceTy: not an HsSpliced"
renameLHsQTyVars :: LHsQTyVars GhcRn -> RnM (LHsQTyVars DocNameI)
-renameLHsQTyVars (HsQTvs { hsq_implicit = _, hsq_explicit = tvs })
+renameLHsQTyVars (HsQTvs { hsq_explicit = tvs })
= do { tvs' <- mapM renameLTyVarBndr tvs
- ; return (HsQTvs { hsq_implicit = error "haddock:renameLHsQTyVars", hsq_explicit = tvs', hsq_dependent = error "haddock:renameLHsQTyVars" }) }
- -- This is rather bogus, but I'm not sure what else to do
+ ; return (HsQTvs { hsq_ext = noExt
+ , hsq_explicit = tvs' }) }
+renameLHsQTyVars (XLHsQTyVars _) = panic "haddock:renameLHsQTyVars"
renameLTyVarBndr :: LHsTyVarBndr GhcRn -> RnM (LHsTyVarBndr DocNameI)
-renameLTyVarBndr (L loc (UserTyVar (L l n)))
+renameLTyVarBndr (L loc (UserTyVar x (L l n)))
= do { n' <- rename n
- ; return (L loc (UserTyVar (L l n'))) }
-renameLTyVarBndr (L loc (KindedTyVar (L lv n) kind))
+ ; return (L loc (UserTyVar x (L l n'))) }
+renameLTyVarBndr (L loc (KindedTyVar x (L lv n) kind))
= do { n' <- rename n
; kind' <- renameLKind kind
- ; return (L loc (KindedTyVar (L lv n') kind')) }
+ ; return (L loc (KindedTyVar x (L lv n') kind')) }
+renameLTyVarBndr (L _ (XTyVarBndr _ )) = error "haddock:renameLTyVarBndr"
renameLContext :: Located [LHsType GhcRn] -> RnM (Located [LHsType DocNameI])
renameLContext (L loc context) = do
context' <- mapM renameLType context
return (L loc context')
-renameWildCardInfo :: HsWildCardInfo GhcRn -> RnM (HsWildCardInfo DocNameI)
-renameWildCardInfo (AnonWildCard (L l name)) = AnonWildCard . L l <$> rename name
+renameWildCardInfo :: HsWildCardInfo -> RnM HsWildCardInfo
+renameWildCardInfo (AnonWildCard (L l name)) = return (AnonWildCard (L l name))
renameInstHead :: InstHead GhcRn -> RnM (InstHead DocNameI)
renameInstHead InstHead {..} = do
@@ -340,21 +344,21 @@ renamePats = mapM
renameDecl :: HsDecl GhcRn -> RnM (HsDecl DocNameI)
renameDecl decl = case decl of
- TyClD d -> do
+ TyClD _ d -> do
d' <- renameTyClD d
- return (TyClD d')
- SigD s -> do
+ return (TyClD noExt d')
+ SigD _ s -> do
s' <- renameSig s
- return (SigD s')
- ForD d -> do
+ return (SigD noExt s')
+ ForD _ d -> do
d' <- renameForD d
- return (ForD d')
- InstD d -> do
+ return (ForD noExt d')
+ InstD _ d -> do
d' <- renameInstD d
- return (InstD d')
- DerivD d -> do
+ return (InstD noExt d')
+ DerivD _ d -> do
d' <- renameDerivD d
- return (DerivD d')
+ return (DerivD noExt d')
_ -> error "renameDecl"
renameLThing :: (a GhcRn -> RnM (a DocNameI)) -> Located (a GhcRn) -> RnM (Located (a DocNameI))
@@ -365,19 +369,21 @@ renameTyClD d = case d of
-- TyFamily flav lname ltyvars kind tckind -> do
FamDecl { tcdFam = decl } -> do
decl' <- renameFamilyDecl decl
- return (FamDecl { tcdFam = decl' })
+ return (FamDecl { tcdFExt = noExt, tcdFam = decl' })
- SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdRhs = rhs, tcdFVs = _fvs } -> do
+ SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdRhs = rhs } -> do
lname' <- renameL lname
tyvars' <- renameLHsQTyVars tyvars
rhs' <- renameLType rhs
- return (SynDecl { tcdLName = lname', tcdTyVars = tyvars', tcdFixity = fixity, tcdRhs = rhs', tcdFVs = placeHolderNames })
+ return (SynDecl { tcdSExt = noExt, tcdLName = lname', tcdTyVars = tyvars'
+ , tcdFixity = fixity, tcdRhs = rhs' })
- DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdDataDefn = defn, tcdFVs = _fvs } -> do
+ DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdDataDefn = defn } -> do
lname' <- renameL lname
tyvars' <- renameLHsQTyVars tyvars
defn' <- renameDataDefn defn
- return (DataDecl { tcdLName = lname', tcdTyVars = tyvars', tcdFixity = fixity, tcdDataDefn = defn', tcdDataCusk = PlaceHolder, tcdFVs = placeHolderNames })
+ return (DataDecl { tcdDExt = noExt, tcdLName = lname', tcdTyVars = tyvars'
+ , tcdFixity = fixity, tcdDataDefn = defn' })
ClassDecl { tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars, tcdFixity = fixity
, tcdFDs = lfundeps, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs } -> do
@@ -392,7 +398,8 @@ renameTyClD d = case d of
return (ClassDecl { tcdCtxt = lcontext', tcdLName = lname', tcdTyVars = ltyvars'
, tcdFixity = fixity
, tcdFDs = lfundeps', tcdSigs = lsigs', tcdMeths= emptyBag
- , tcdATs = ats', tcdATDefs = at_defs', tcdDocs = [], tcdFVs = placeHolderNames })
+ , tcdATs = ats', tcdATDefs = at_defs', tcdDocs = [], tcdCExt = NoExt })
+ XTyClDecl _ -> panic "haddock:renameTyClD"
where
renameLFunDep (L loc (xs, ys)) = do
@@ -413,11 +420,12 @@ renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname
ltyvars' <- renameLHsQTyVars ltyvars
result' <- renameFamilyResultSig result
injectivity' <- renameMaybeInjectivityAnn injectivity
- return (FamilyDecl { fdInfo = info', fdLName = lname'
+ return (FamilyDecl { fdExt = noExt, fdInfo = info', fdLName = lname'
, fdTyVars = ltyvars'
, fdFixity = fixity
, fdResultSig = result'
, fdInjectivityAnn = injectivity' })
+renameFamilyDecl (XFamilyDecl _) = panic "renameFamilyDecl"
renamePseudoFamilyDecl :: PseudoFamilyDecl GhcRn
@@ -443,107 +451,122 @@ renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType
k' <- renameMaybeLKind k
cons' <- mapM (mapM renameCon) cons
-- I don't think we need the derivings, so we return Nothing
- return (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext', dd_cType = cType
+ return (HsDataDefn { dd_ext = noExt
+ , dd_ND = nd, dd_ctxt = lcontext', dd_cType = cType
, dd_kindSig = k', dd_cons = cons'
, dd_derivs = noLoc [] })
+renameDataDefn (XHsDataDefn _) = panic "haddock:renameDataDefn"
renameCon :: ConDecl GhcRn -> RnM (ConDecl DocNameI)
-renameCon decl@(ConDeclH98 { con_name = lname, con_qvars = ltyvars
- , con_cxt = lcontext, con_details = details
+renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars
+ , con_mb_cxt = lcontext, con_args = details
, con_doc = mbldoc }) = do
lname' <- renameL lname
- ltyvars' <- traverse renameLHsQTyVars ltyvars
+ ltyvars' <- mapM renameLTyVarBndr ltyvars
lcontext' <- traverse renameLContext lcontext
details' <- renameDetails details
mbldoc' <- mapM renameLDocHsSyn mbldoc
- return (decl { con_name = lname', con_qvars = ltyvars', con_cxt = lcontext'
- , con_details = details', con_doc = mbldoc' })
+ return (decl { con_ext = noExt, con_name = lname', con_ex_tvs = ltyvars'
+ , con_mb_cxt = lcontext'
+ , con_args = details', con_doc = mbldoc' })
- where
- renameDetails (RecCon (L l fields)) = do
- fields' <- mapM renameConDeclFieldField fields
- return (RecCon (L l fields'))
- renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps
- renameDetails (InfixCon a b) = do
- a' <- renameLType a
- b' <- renameLType b
- return (InfixCon a' b')
-
-renameCon decl@(ConDeclGADT { con_names = lnames
- , con_type = lty
+renameCon decl@(ConDeclGADT { con_names = lnames, con_qvars = ltyvars
+ , con_mb_cxt = lcontext, con_args = details
+ , con_res_ty = res_ty
, con_doc = mbldoc }) = do
lnames' <- mapM renameL lnames
- lty' <- renameLSigType lty
+ ltyvars' <- renameLHsQTyVars ltyvars
+ lcontext' <- traverse renameLContext lcontext
+ details' <- renameDetails details
+ res_ty' <- renameLType res_ty
mbldoc' <- mapM renameLDocHsSyn mbldoc
- return (decl { con_names = lnames'
- , con_type = lty', con_doc = mbldoc' })
+ return (decl { con_g_ext = noExt, con_names = lnames', con_qvars = ltyvars'
+ , con_mb_cxt = lcontext', con_args = details'
+ , con_res_ty = res_ty', con_doc = mbldoc' })
+renameCon (XConDecl _) = panic "haddock:renameCon"
+
+renameDetails :: HsConDeclDetails GhcRn -> RnM (HsConDeclDetails DocNameI)
+renameDetails (RecCon (L l fields)) = do
+ fields' <- mapM renameConDeclFieldField fields
+ return (RecCon (L l fields'))
+renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps
+renameDetails (InfixCon a b) = do
+ a' <- renameLType a
+ b' <- renameLType b
+ return (InfixCon a' b')
renameConDeclFieldField :: LConDeclField GhcRn -> RnM (LConDeclField DocNameI)
-renameConDeclFieldField (L l (ConDeclField names t doc)) = do
+renameConDeclFieldField (L l (ConDeclField _ names t doc)) = do
names' <- mapM renameLFieldOcc names
t' <- renameLType t
doc' <- mapM renameLDocHsSyn doc
- return $ L l (ConDeclField names' t' doc')
+ return $ L l (ConDeclField noExt names' t' doc')
+renameConDeclFieldField (L _ (XConDeclField _)) = panic "haddock:renameConDeclFieldField"
renameLFieldOcc :: LFieldOcc GhcRn -> RnM (LFieldOcc DocNameI)
-renameLFieldOcc (L l (FieldOcc lbl sel)) = do
+renameLFieldOcc (L l (FieldOcc sel lbl)) = do
sel' <- rename sel
- return $ L l (FieldOcc lbl sel')
+ return $ L l (FieldOcc sel' lbl)
+renameLFieldOcc (L _ (XFieldOcc _)) = error "haddock:renameLFieldOcc"
renameSig :: Sig GhcRn -> RnM (Sig DocNameI)
renameSig sig = case sig of
- TypeSig lnames ltype -> do
+ TypeSig _ lnames ltype -> do
lnames' <- mapM renameL lnames
ltype' <- renameLSigWcType ltype
- return (TypeSig lnames' ltype')
- ClassOpSig is_default lnames sig_ty -> do
+ return (TypeSig noExt lnames' ltype')
+ ClassOpSig _ is_default lnames sig_ty -> do
lnames' <- mapM renameL lnames
ltype' <- renameLSigType sig_ty
- return (ClassOpSig is_default lnames' ltype')
- PatSynSig lnames sig_ty -> do
+ return (ClassOpSig noExt is_default lnames' ltype')
+ PatSynSig _ lnames sig_ty -> do
lnames' <- mapM renameL lnames
sig_ty' <- renameLSigType sig_ty
- return $ PatSynSig lnames' sig_ty'
- FixSig (FixitySig lnames fixity) -> do
+ return $ PatSynSig noExt lnames' sig_ty'
+ FixSig _ (FixitySig _ lnames fixity) -> do
lnames' <- mapM renameL lnames
- return $ FixSig (FixitySig lnames' fixity)
- MinimalSig src (L l s) -> do
+ return $ FixSig noExt (FixitySig noExt lnames' fixity)
+ MinimalSig _ src (L l s) -> do
s' <- traverse renameL s
- return $ MinimalSig src (L l s')
+ return $ MinimalSig noExt src (L l s')
-- we have filtered out all other kinds of signatures in Interface.Create
_ -> error "expected TypeSig"
renameForD :: ForeignDecl GhcRn -> RnM (ForeignDecl DocNameI)
-renameForD (ForeignImport lname ltype co x) = do
+renameForD (ForeignImport _ lname ltype x) = do
lname' <- renameL lname
ltype' <- renameLSigType ltype
- return (ForeignImport lname' ltype' co x)
-renameForD (ForeignExport lname ltype co x) = do
+ return (ForeignImport noExt lname' ltype' x)
+renameForD (ForeignExport _ lname ltype x) = do
lname' <- renameL lname
ltype' <- renameLSigType ltype
- return (ForeignExport lname' ltype' co x)
+ return (ForeignExport noExt lname' ltype' x)
+renameForD (XForeignDecl _) = panic "haddock:renameForD"
renameInstD :: InstDecl GhcRn -> RnM (InstDecl DocNameI)
renameInstD (ClsInstD { cid_inst = d }) = do
d' <- renameClsInstD d
- return (ClsInstD { cid_inst = d' })
+ return (ClsInstD { cid_d_ext = noExt, cid_inst = d' })
renameInstD (TyFamInstD { tfid_inst = d }) = do
d' <- renameTyFamInstD d
- return (TyFamInstD { tfid_inst = d' })
+ return (TyFamInstD { tfid_ext = noExt, tfid_inst = d' })
renameInstD (DataFamInstD { dfid_inst = d }) = do
d' <- renameDataFamInstD d
- return (DataFamInstD { dfid_inst = d' })
+ return (DataFamInstD { dfid_ext = noExt, dfid_inst = d' })
+renameInstD (XInstDecl _) = panic "haddock:renameInstD"
renameDerivD :: DerivDecl GhcRn -> RnM (DerivDecl DocNameI)
renameDerivD (DerivDecl { deriv_type = ty
, deriv_strategy = strat
, deriv_overlap_mode = omode }) = do
- ty' <- renameLSigType ty
- return (DerivDecl { deriv_type = ty'
+ ty' <- renameLSigWcType ty
+ return (DerivDecl { deriv_ext = noExt
+ , deriv_type = ty'
, deriv_strategy = strat
, deriv_overlap_mode = omode })
+renameDerivD (XDerivDecl _) = panic "haddock:renameDerivD"
renameClsInstD :: ClsInstDecl GhcRn -> RnM (ClsInstDecl DocNameI)
renameClsInstD (ClsInstDecl { cid_overlap_mode = omode
@@ -552,10 +575,11 @@ renameClsInstD (ClsInstDecl { cid_overlap_mode = omode
ltype' <- renameLSigType ltype
lATs' <- mapM (mapM renameTyFamInstD) lATs
lADTs' <- mapM (mapM renameDataFamInstD) lADTs
- return (ClsInstDecl { cid_overlap_mode = omode
+ return (ClsInstDecl { cid_ext = noExt, cid_overlap_mode = omode
, cid_poly_ty = ltype', cid_binds = emptyBag
, cid_sigs = []
, cid_tyfam_insts = lATs', cid_datafam_insts = lADTs' })
+renameClsInstD (XClsInstDecl _) = panic "haddock:renameClsInstD"
renameTyFamInstD :: TyFamInstDecl GhcRn -> RnM (TyFamInstDecl DocNameI)
@@ -575,10 +599,12 @@ renameTyFamInstEqn eqn
= do { tc' <- renameL tc
; pats' <- mapM renameLType pats
; rhs' <- renameLType rhs
- ; return (FamEqn { feqn_tycon = tc'
+ ; return (FamEqn { feqn_ext = noExt
+ , feqn_tycon = tc'
, feqn_pats = pats'
, feqn_fixity = fixity
, feqn_rhs = rhs' }) }
+ rename_ty_fam_eqn (XFamEqn _) = panic "haddock:renameTyFamInstEqn"
renameLTyFamDefltEqn :: LTyFamDefltEqn GhcRn -> RnM (LTyFamDefltEqn DocNameI)
renameLTyFamDefltEqn (L loc (FamEqn { feqn_tycon = tc, feqn_pats = tvs
@@ -586,10 +612,12 @@ renameLTyFamDefltEqn (L loc (FamEqn { feqn_tycon = tc, feqn_pats = tvs
= do { tc' <- renameL tc
; tvs' <- renameLHsQTyVars tvs
; rhs' <- renameLType rhs
- ; return (L loc (FamEqn { feqn_tycon = tc'
+ ; return (L loc (FamEqn { feqn_ext = noExt
+ , feqn_tycon = tc'
, feqn_pats = tvs'
, feqn_fixity = fixity
, feqn_rhs = rhs' })) }
+renameLTyFamDefltEqn (L _ (XFamEqn _)) = panic "haddock:renameLTyFamDefltEqn"
renameDataFamInstD :: DataFamInstDecl GhcRn -> RnM (DataFamInstDecl DocNameI)
renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn })
@@ -604,10 +632,12 @@ renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn })
= do { tc' <- renameL tc
; pats' <- mapM renameLType pats
; defn' <- renameDataDefn defn
- ; return (FamEqn { feqn_tycon = tc'
+ ; return (FamEqn { feqn_ext = noExt
+ , feqn_tycon = tc'
, feqn_pats = pats'
, feqn_fixity = fixity
, feqn_rhs = defn' }) }
+ rename_data_fam_eqn (XFamEqn _) = panic "haddock:renameDataFamInstD"
renameImplicit :: (in_thing -> RnM out_thing)
-> HsImplicitBndrs GhcRn in_thing
@@ -615,8 +645,8 @@ renameImplicit :: (in_thing -> RnM out_thing)
renameImplicit rn_thing (HsIB { hsib_body = thing })
= do { thing' <- rn_thing thing
; return (HsIB { hsib_body = thing'
- , hsib_vars = PlaceHolder
- , hsib_closed = PlaceHolder }) }
+ , hsib_ext = noExt }) }
+renameImplicit _ (XHsImplicitBndrs _) = panic "haddock:renameImplicit"
renameWc :: (in_thing -> RnM out_thing)
-> HsWildCardBndrs GhcRn in_thing
@@ -624,7 +654,8 @@ renameWc :: (in_thing -> RnM out_thing)
renameWc rn_thing (HsWC { hswc_body = thing })
= do { thing' <- rn_thing thing
; return (HsWC { hswc_body = thing'
- , hswc_wcs = PlaceHolder }) }
+ , hswc_ext = noExt }) }
+renameWc _ (XHsWildCardBndrs _) = panic "haddock:renameWc"
renameDocInstance :: DocInstance GhcRn -> RnM (DocInstance DocNameI)
renameDocInstance (inst, idoc, L l n, m) = do
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index a54aad90..80fbc714 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -28,20 +28,18 @@ import Data.Set (Set)
import qualified Data.Set as Set
-- | Instantiate all occurrences of given names with corresponding types.
-specialize :: forall name a. (Ord (IdP name), DataId name, NamedThing (IdP name))
- => Data a
- => [(IdP name, HsType name)] -> a -> a
+specialize :: Data a => [(Name, HsType GhcRn)] -> a -> a
specialize specs = go spec_map0
where
- go :: forall x. Data x => Map (IdP name) (HsType name) -> x -> x
- go spec_map = everywhereButType @name $ mkT $ sugar . strip_kind_sig . specialize_ty_var spec_map
+ go :: forall x. Data x => Map Name (HsType GhcRn) -> x -> x
+ go spec_map = everywhereButType @Name $ mkT $ sugar . strip_kind_sig . specialize_ty_var spec_map
strip_kind_sig :: HsType name -> HsType name
- strip_kind_sig (HsKindSig (L _ t) _) = t
+ strip_kind_sig (HsKindSig _ (L _ t) _) = t
strip_kind_sig typ = typ
- specialize_ty_var :: Map (IdP name) (HsType name) -> HsType name -> HsType name
- specialize_ty_var spec_map (HsTyVar _ (L _ name'))
+ specialize_ty_var :: Map Name (HsType GhcRn) -> HsType GhcRn -> HsType GhcRn
+ specialize_ty_var spec_map (HsTyVar _ _ (L _ name'))
| Just t <- Map.lookup name' spec_map = t
specialize_ty_var _ typ = typ
@@ -54,35 +52,33 @@ specialize specs = go spec_map0
--
-- Again, it is just a convenience function around 'specialize'. Note that
-- length of type list should be the same as the number of binders.
-specializeTyVarBndrs :: (Ord (IdP name), DataId name, NamedThing (IdP name))
- => Data a
- => LHsQTyVars name -> [HsType name]
+specializeTyVarBndrs :: Data a
+ => LHsQTyVars GhcRn -> [HsType GhcRn]
-> a -> a
specializeTyVarBndrs bndrs typs =
specialize $ zip bndrs' typs
where
bndrs' = map (bname . unLoc) . hsq_explicit $ bndrs
- bname (UserTyVar (L _ name)) = name
- bname (KindedTyVar (L _ name) _) = name
+ bname (UserTyVar _ (L _ name)) = name
+ bname (KindedTyVar _ (L _ name) _) = name
+ bname (XTyVarBndr _) = error "haddock:specializeTyVarBndrs"
-specializePseudoFamilyDecl :: (Ord (IdP name), DataId name, NamedThing (IdP name))
- => LHsQTyVars name -> [HsType name]
- -> PseudoFamilyDecl name
- -> PseudoFamilyDecl name
+specializePseudoFamilyDecl :: LHsQTyVars GhcRn -> [HsType GhcRn]
+ -> PseudoFamilyDecl GhcRn
+ -> PseudoFamilyDecl GhcRn
specializePseudoFamilyDecl bndrs typs decl =
decl {pfdTyVars = map (specializeTyVarBndrs bndrs typs) (pfdTyVars decl)}
-specializeSig :: forall name . (Ord (IdP name), DataId name, SetName (IdP name), NamedThing (IdP name))
- => LHsQTyVars name -> [HsType name]
- -> Sig name
- -> Sig name
-specializeSig bndrs typs (TypeSig lnames typ) =
- TypeSig lnames (typ {hswc_body = (hswc_body typ) {hsib_body = noLoc typ'}})
+specializeSig :: LHsQTyVars GhcRn -> [HsType GhcRn]
+ -> Sig GhcRn
+ -> Sig GhcRn
+specializeSig bndrs typs (TypeSig _ lnames typ) =
+ TypeSig noExt lnames (typ {hswc_body = (hswc_body typ) {hsib_body = noLoc typ'}})
where
- true_type :: HsType name
+ true_type :: HsType GhcRn
true_type = unLoc (hsSigWcType typ)
- typ' :: HsType name
+ typ' :: HsType GhcRn
typ' = rename fv $ specializeTyVarBndrs bndrs typs true_type
fv = foldr Set.union Set.empty . map freeVariables $ typs
specializeSig _ _ sig = sig
@@ -90,8 +86,7 @@ specializeSig _ _ sig = sig
-- | Make all details of instance head (signatures, associated types)
-- specialized to that particular instance type.
-specializeInstHead :: (Ord (IdP name), DataId name, SetName (IdP name), NamedThing (IdP name))
- => InstHead name -> InstHead name
+specializeInstHead :: InstHead GhcRn -> InstHead GhcRn
specializeInstHead ihd@InstHead { ihdInstType = clsi@ClassInst { .. }, .. } =
ihd { ihdInstType = instType' }
where
@@ -110,27 +105,26 @@ specializeInstHead ihd = ihd
-- and tuple literals resulting in types like @[] a@ or @(,,) a b c@. This
-- can be fixed using 'sugar' function, that will turn such types into @[a]@
-- and @(a, b, c)@.
-sugar :: forall name. (NamedThing (IdP name), DataId name)
- => HsType name -> HsType name
+sugar :: HsType GhcRn -> HsType GhcRn
sugar = sugarOperators . sugarTuples . sugarLists
-sugarLists :: NamedThing (IdP name) => HsType name -> HsType name
-sugarLists (HsAppTy (L _ (HsTyVar _ (L _ name))) ltyp)
- | isBuiltInSyntax name' && strName == "[]" = HsListTy ltyp
+sugarLists :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p)
+sugarLists (HsAppTy _ (L _ (HsTyVar _ _ (L _ name))) ltyp)
+ | isBuiltInSyntax name' && strName == "[]" = HsListTy NoExt ltyp
where
name' = getName name
strName = occNameString . nameOccName $ name'
sugarLists typ = typ
-sugarTuples :: NamedThing (IdP name) => HsType name -> HsType name
+sugarTuples :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p)
sugarTuples typ =
aux [] typ
where
- aux apps (HsAppTy (L _ ftyp) atyp) = aux (atyp:apps) ftyp
- aux apps (HsParTy (L _ typ')) = aux apps typ'
- aux apps (HsTyVar _ (L _ name))
- | isBuiltInSyntax name' && suitable = HsTupleTy HsBoxedTuple apps
+ aux apps (HsAppTy _ (L _ ftyp) atyp) = aux (atyp:apps) ftyp
+ aux apps (HsParTy _ (L _ typ')) = aux apps typ'
+ aux apps (HsTyVar _ _ (L _ name))
+ | isBuiltInSyntax name' && suitable = HsTupleTy NoExt HsBoxedTuple apps
where
name' = getName name
strName = occNameString . nameOccName $ name'
@@ -140,10 +134,10 @@ sugarTuples typ =
aux _ _ = typ
-sugarOperators :: NamedThing (IdP name) => HsType name -> HsType name
-sugarOperators (HsAppTy (L _ (HsAppTy (L _ (HsTyVar _ (L l name))) la)) lb)
+sugarOperators :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p)
+sugarOperators (HsAppTy _ (L _ (HsAppTy _ (L _ (HsTyVar _ _ (L l name))) la)) lb)
| isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb
- | isBuiltInSyntax name' && getOccString name == "(->)" = HsFunTy la lb
+ | isBuiltInSyntax name' && getOccString name == "(->)" = HsFunTy NoExt la lb
where
name' = getName name
sugarOperators typ = typ
@@ -208,15 +202,14 @@ setInternalOccName occ name =
-- | Compute set of free variables of given type.
-freeVariables :: forall name. (NamedThing (IdP name), DataId name)
- => HsType name -> Set Name
+freeVariables :: HsType GhcRn -> Set Name
freeVariables =
everythingWithState Set.empty Set.union query
where
- query term ctx = case cast term :: Maybe (HsType name) of
- Just (HsForAllTy bndrs _) ->
+ query term ctx = case cast term :: Maybe (HsType GhcRn) of
+ Just (HsForAllTy _ bndrs _) ->
(Set.empty, Set.union ctx (bndrsNames bndrs))
- Just (HsTyVar _ (L _ name))
+ Just (HsTyVar _ _ (L _ name))
| getName name `Set.member` ctx -> (Set.empty, ctx)
| otherwise -> (Set.singleton $ getName name, ctx)
_ -> (Set.empty, ctx)
@@ -231,8 +224,7 @@ freeVariables =
-- different type variable than latter one. Applying 'rename' function
-- will fix that type to be visually unambiguous again (making it something
-- like @(a -> b0) -> b@).
-rename :: (Eq (IdP name), DataId name, SetName (IdP name))
- => Set Name-> HsType name -> HsType name
+rename :: Set Name -> HsType GhcRn -> HsType GhcRn
rename fv typ = evalState (renameType typ) env
where
env = RenameEnv
@@ -252,63 +244,58 @@ data RenameEnv name = RenameEnv
}
-renameType :: (Eq (IdP name), SetName (IdP name))
- => HsType name -> Rename (IdP name) (HsType name)
-renameType (HsForAllTy bndrs lt) =
- HsForAllTy
+renameType :: HsType GhcRn -> Rename (IdP GhcRn) (HsType GhcRn)
+renameType (HsForAllTy x bndrs lt) =
+ HsForAllTy x
<$> mapM (located renameBinder) bndrs
<*> renameLType lt
-renameType (HsQualTy lctxt lt) =
- HsQualTy
+renameType (HsQualTy x lctxt lt) =
+ HsQualTy x
<$> located renameContext lctxt
<*> renameLType lt
-renameType (HsTyVar ip name) = HsTyVar ip <$> 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 (HsSumTy lt) = HsSumTy <$> mapM renameLType lt
-renameType (HsOpTy la lop 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 (HsTyVar x ip name) = HsTyVar x ip <$> located renameName name
+renameType (HsAppTy x lf la) = HsAppTy x <$> renameLType lf <*> renameLType la
+renameType (HsFunTy x la lr) = HsFunTy x <$> renameLType la <*> renameLType lr
+renameType (HsListTy x lt) = HsListTy x <$> renameLType lt
+renameType (HsPArrTy x lt) = HsPArrTy x <$> renameLType lt
+renameType (HsTupleTy x srt lt) = HsTupleTy x srt <$> mapM renameLType lt
+renameType (HsSumTy x lt) = HsSumTy x <$> mapM renameLType lt
+renameType (HsOpTy x la lop lb) =
+ HsOpTy x <$> renameLType la <*> located renameName lop <*> renameLType lb
+renameType (HsParTy x lt) = HsParTy x <$> renameLType lt
+renameType (HsIParamTy x ip lt) = HsIParamTy x ip <$> renameLType lt
+renameType (HsEqTy x la lb) = HsEqTy x <$> renameLType la <*> renameLType lb
+renameType (HsKindSig x lt lk) = HsKindSig x <$> renameLType lt <*> pure lk
renameType t@(HsSpliceTy _ _) = pure t
-renameType (HsDocTy lt doc) = HsDocTy <$> renameLType lt <*> pure doc
-renameType (HsBangTy bang lt) = HsBangTy bang <$> renameLType lt
-renameType t@(HsRecTy _) = pure t
-renameType t@(HsCoreTy _) = pure t
-renameType (HsExplicitListTy ip ph ltys) =
- HsExplicitListTy ip ph <$> renameLTypes ltys
-renameType (HsExplicitTupleTy phs ltys) =
- HsExplicitTupleTy phs <$> renameLTypes ltys
-renameType t@(HsTyLit _) = pure t
+renameType (HsDocTy x lt doc) = HsDocTy x <$> renameLType lt <*> pure doc
+renameType (HsBangTy x bang lt) = HsBangTy x bang <$> renameLType lt
+renameType t@(HsRecTy _ _) = pure t
+renameType t@(XHsType (NHsCoreTy _)) = pure t
+renameType (HsExplicitListTy x ip ltys) =
+ HsExplicitListTy x ip <$> renameLTypes ltys
+renameType (HsExplicitTupleTy x ltys) =
+ HsExplicitTupleTy x <$> renameLTypes ltys
+renameType t@(HsTyLit _ _) = pure t
renameType (HsWildCardTy wc) = pure (HsWildCardTy wc)
-renameType (HsAppsTy _) = error "HsAppsTy: Only used before renaming"
+renameType (HsAppsTy _ _) = error "HsAppsTy: Only used before renaming"
-renameLType :: (Eq (IdP name), SetName (IdP name))
- => LHsType name -> Rename (IdP name) (LHsType name)
+renameLType :: LHsType GhcRn -> Rename (IdP GhcRn) (LHsType GhcRn)
renameLType = located renameType
-renameLTypes :: (Eq (IdP name), SetName (IdP name))
- => [LHsType name] -> Rename (IdP name) [LHsType name]
+renameLTypes :: [LHsType GhcRn] -> Rename (IdP GhcRn) [LHsType GhcRn]
renameLTypes = mapM renameLType
-renameContext :: (Eq (IdP name), SetName (IdP name))
- => HsContext name -> Rename (IdP name) (HsContext name)
+renameContext :: HsContext GhcRn -> Rename (IdP GhcRn) (HsContext GhcRn)
renameContext = renameLTypes
-renameBinder :: (Eq (IdP name), SetName (IdP name))
- => HsTyVarBndr name -> Rename (IdP name) (HsTyVarBndr name)
-renameBinder (UserTyVar lname) = UserTyVar <$> located renameName lname
-renameBinder (KindedTyVar lname lkind) =
- KindedTyVar <$> located renameName lname <*> located renameType lkind
-
+renameBinder :: HsTyVarBndr GhcRn -> Rename (IdP GhcRn) (HsTyVarBndr GhcRn)
+renameBinder (UserTyVar x lname) = UserTyVar x <$> located renameName lname
+renameBinder (KindedTyVar x lname lkind) =
+ KindedTyVar x <$> located renameName lname <*> located renameType lkind
+renameBinder (XTyVarBndr _) = error "haddock:renameBinder"
-- | Core renaming logic.
renameName :: (Eq name, SetName name) => name -> Rename name name
@@ -363,5 +350,6 @@ located f (L loc e) = L loc <$> f e
tyVarName :: HsTyVarBndr name -> IdP name
-tyVarName (UserTyVar name) = unLoc name
-tyVarName (KindedTyVar (L _ name) _) = name
+tyVarName (UserTyVar _ name) = unLoc name
+tyVarName (KindedTyVar _ (L _ name) _) = name
+tyVarName (XTyVarBndr _ ) = error "haddock:tyVarName"
diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs
index d5bbce2c..ce6ecc78 100644
--- a/haddock-api/src/Haddock/InterfaceFile.hs
+++ b/haddock-api/src/Haddock/InterfaceFile.hs
@@ -82,7 +82,7 @@ binaryInterfaceMagic = 0xD0Cface
-- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion]
--
binaryInterfaceVersion :: Word16
-#if (__GLASGOW_HASKELL__ >= 803) && (__GLASGOW_HASKELL__ < 805)
+#if (__GLASGOW_HASKELL__ >= 805) && (__GLASGOW_HASKELL__ < 807)
binaryInterfaceVersion = 33
binaryInterfaceVersionCompatibility :: [Word16]
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 36ed7baf..1115e829 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -347,7 +347,7 @@ data InstType name
| TypeInst (Maybe (HsType name)) -- ^ Body (right-hand side)
| DataInst (TyClDecl name) -- ^ Data constructors
-instance (SourceTextX a, OutputableBndrId a)
+instance (a ~ GhcPass p,OutputableBndrId a)
=> Outputable (InstType a) where
ppr (ClassInst { .. }) = text "ClassInst"
<+> ppr clsiCtx
@@ -372,7 +372,7 @@ data PseudoFamilyDecl name = PseudoFamilyDecl
}
-mkPseudoFamilyDecl :: FamilyDecl name -> PseudoFamilyDecl name
+mkPseudoFamilyDecl :: FamilyDecl (GhcPass p) -> PseudoFamilyDecl (GhcPass p)
mkPseudoFamilyDecl (FamilyDecl { .. }) = PseudoFamilyDecl
{ pfdInfo = fdInfo
, pfdLName = fdLName
@@ -380,11 +380,13 @@ mkPseudoFamilyDecl (FamilyDecl { .. }) = PseudoFamilyDecl
, pfdKindSig = fdResultSig
}
where
- mkType (KindedTyVar (L loc name) lkind) =
- HsKindSig tvar lkind
+ mkType (KindedTyVar _ (L loc name) lkind) =
+ HsKindSig NoExt tvar lkind
where
- tvar = L loc (HsTyVar NotPromoted (L loc name))
- mkType (UserTyVar name) = HsTyVar NotPromoted name
+ tvar = L loc (HsTyVar NoExt NotPromoted (L loc name))
+ mkType (UserTyVar _ name) = HsTyVar NoExt NotPromoted name
+ mkType (XTyVarBndr _ ) = panic "haddock:mkPseudoFamilyDecl"
+mkPseudoFamilyDecl (XFamilyDecl {}) = panic "haddock:mkPseudoFamilyDecl"
-- | An instance head that may have documentation and a source location.
@@ -666,14 +668,77 @@ instance Monad ErrMsgGhc where
-- * Pass sensitive types
-----------------------------------------------------------------------------
-type instance PostRn DocNameI NameSet = PlaceHolder
-type instance PostRn DocNameI Fixity = PlaceHolder
-type instance PostRn DocNameI Bool = PlaceHolder
-type instance PostRn DocNameI Name = DocName
-type instance PostRn DocNameI (Located Name) = Located DocName
-type instance PostRn DocNameI [Name] = PlaceHolder
-type instance PostRn DocNameI DocName = DocName
-
-type instance PostTc DocNameI Kind = PlaceHolder
-type instance PostTc DocNameI Type = PlaceHolder
-type instance PostTc DocNameI Coercion = PlaceHolder
+type instance XForAllTy DocNameI = NoExt
+type instance XQualTy DocNameI = NoExt
+type instance XTyVar DocNameI = NoExt
+type instance XAppsTy DocNameI = NoExt
+type instance XAppTy DocNameI = NoExt
+type instance XFunTy DocNameI = NoExt
+type instance XListTy DocNameI = NoExt
+type instance XPArrTy DocNameI = NoExt
+type instance XTupleTy DocNameI = NoExt
+type instance XSumTy DocNameI = NoExt
+type instance XOpTy DocNameI = NoExt
+type instance XParTy DocNameI = NoExt
+type instance XIParamTy DocNameI = NoExt
+type instance XEqTy DocNameI = NoExt
+type instance XKindSig DocNameI = NoExt
+type instance XSpliceTy DocNameI = NoExt
+type instance XDocTy DocNameI = NoExt
+type instance XBangTy DocNameI = NoExt
+type instance XRecTy DocNameI = NoExt
+type instance XExplicitListTy DocNameI = NoExt
+type instance XExplicitTupleTy DocNameI = NoExt
+type instance XTyLit DocNameI = NoExt
+type instance XWildCardTy DocNameI = HsWildCardInfo
+type instance XXType DocNameI = NewHsTypeX
+
+type instance XUserTyVar DocNameI = NoExt
+type instance XKindedTyVar DocNameI = NoExt
+type instance XXTyVarBndr DocNameI = NoExt
+
+type instance XFieldOcc DocNameI = DocName
+type instance XXFieldOcc DocNameI = NoExt
+
+type instance XFixitySig DocNameI = NoExt
+type instance XFixSig DocNameI = NoExt
+type instance XPatSynSig DocNameI = NoExt
+type instance XClassOpSig DocNameI = NoExt
+type instance XTypeSig DocNameI = NoExt
+type instance XMinimalSig DocNameI = NoExt
+
+type instance XForeignExport DocNameI = NoExt
+type instance XForeignImport DocNameI = NoExt
+type instance XConDeclGADT DocNameI = NoExt
+type instance XConDeclH98 DocNameI = NoExt
+
+type instance XDerivD DocNameI = NoExt
+type instance XInstD DocNameI = NoExt
+type instance XForD DocNameI = NoExt
+type instance XSigD DocNameI = NoExt
+type instance XTyClD DocNameI = NoExt
+
+type instance XNoSig DocNameI = NoExt
+type instance XCKindSig DocNameI = NoExt
+type instance XTyVarSig DocNameI = NoExt
+
+type instance XCFamEqn DocNameI _ _ = NoExt
+
+type instance XCClsInstDecl DocNameI = NoExt
+type instance XCDerivDecl DocNameI = NoExt
+type instance XDataFamInstD DocNameI = NoExt
+type instance XTyFamInstD DocNameI = NoExt
+type instance XClsInstD DocNameI = NoExt
+type instance XCHsDataDefn DocNameI = NoExt
+type instance XCFamilyDecl DocNameI = NoExt
+type instance XClassDecl DocNameI = NoExt
+type instance XDataDecl DocNameI = NoExt
+type instance XSynDecl DocNameI = NoExt
+type instance XFamDecl DocNameI = NoExt
+
+type instance XHsIB DocNameI _ = NoExt
+type instance XHsWC DocNameI _ = NoExt
+
+type instance XHsQTvs DocNameI = NoExt
+type instance XConDeclField DocNameI = NoExt
+
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index 84f58ab8..e3cc9655 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -63,7 +63,8 @@ import Haddock.GhcUtils
import GHC
import Name
import NameSet ( emptyNameSet )
-import HsTypes (selectorFieldOcc)
+import HsTypes (extFieldOcc)
+import Outputable ( panic )
import Control.Monad ( liftM )
import Data.Char ( isAlpha, isAlphaNum, isAscii, ord, chr )
@@ -131,16 +132,19 @@ mkEmptySigWcType ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs ty)
addClassContext :: Name -> LHsQTyVars GhcRn -> LSig GhcRn -> LSig GhcRn
-- Add the class context to a class-op signature
-addClassContext cls tvs0 (L pos (ClassOpSig _ lname ltype))
- = L pos (TypeSig lname (mkEmptySigWcType (go (hsSigType ltype))))
+addClassContext cls tvs0 (L pos (ClassOpSig _ _ lname ltype))
+ = L pos (TypeSig noExt 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 })
+ = L loc (HsForAllTy { hst_xforall = noExt
+ , 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 })
+ = L loc (HsQualTy { hst_xqual = noExt
+ , 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 })
+ = L loc (HsQualTy { hst_xqual = noExt
+ , 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)
@@ -149,7 +153,7 @@ addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine
lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsType GhcRn]
lHsQTyVarsToTypes tvs
- = [ noLoc (HsTyVar NotPromoted (noLoc (hsLTyVarName tv)))
+ = [ noLoc (HsTyVar NoExt NotPromoted (noLoc (hsLTyVarName tv)))
| tv <- hsQTvExplicit tvs ]
--------------------------------------------------------------------------------
@@ -159,10 +163,10 @@ lHsQTyVarsToTypes tvs
restrictTo :: [Name] -> LHsDecl GhcRn -> LHsDecl GhcRn
restrictTo names (L loc decl) = L loc $ case decl of
- TyClD d | isDataDecl d ->
- TyClD (d { tcdDataDefn = restrictDataDefn names (tcdDataDefn d) })
- TyClD d | isClassDecl d ->
- TyClD (d { tcdSigs = restrictDecls names (tcdSigs d),
+ TyClD x d | isDataDecl d ->
+ TyClD x (d { tcdDataDefn = restrictDataDefn names (tcdDataDefn d) })
+ TyClD x d | isClassDecl d ->
+ TyClD x (d { tcdSigs = restrictDecls names (tcdSigs d),
tcdATs = restrictATs names (tcdATs d) })
_ -> decl
@@ -175,42 +179,28 @@ restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons })
[] -> defn { dd_ND = DataType, dd_cons = [] }
[con] -> defn { dd_cons = [con] }
_ -> error "Should not happen"
+restrictDataDefn _ (XHsDataDefn _) = error "restrictDataDefn"
restrictCons :: [Name] -> [LConDecl GhcRn] -> [LConDecl GhcRn]
restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]
where
keep d | any (\n -> n `elem` names) (map unLoc $ getConNames d) =
- case getConDetails h98d of
+ case con_args d of
PrefixCon _ -> Just d
RecCon fields
| all field_avail (unL fields) -> Just d
- | otherwise -> Just (h98d { con_details = PrefixCon (field_types (map unL (unL fields))) })
+ | otherwise -> Just (d { con_args = 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 GhcRn
- c' = ConDeclH98
- { con_name = head (con_names c)
- , con_qvars = Just $ HsQTvs { hsq_implicit = mempty
- , hsq_explicit = tvs
- , hsq_dependent = emptyNameSet }
- , con_cxt = Just cxt
- , con_details = details
- , con_doc = con_doc c
- }
-
field_avail :: LConDeclField GhcRn -> Bool
- field_avail (L _ (ConDeclField fs _ _))
- = all (\f -> selectorFieldOcc (unLoc f) `elem` names) fs
- field_types flds = [ t | ConDeclField _ t _ <- flds ]
+ field_avail (L _ (ConDeclField _ fs _ _))
+ = all (\f -> extFieldOcc (unLoc f) `elem` names) fs
+ field_avail (L _ (XConDeclField _)) = panic "haddock:field_avail"
+ field_types flds = [ t | ConDeclField _ _ t _ <- flds ]
keep _ = Nothing
@@ -221,13 +211,14 @@ restrictDecls names = mapMaybe (filterLSigNames (`elem` names))
restrictATs :: [Name] -> [LFamilyDecl GhcRn] -> [LFamilyDecl GhcRn]
restrictATs names ats = [ at | at <- ats , unL (fdLName (unL at)) `elem` names ]
-emptyHsQTvs :: LHsQTyVars Name
+emptyHsQTvs :: LHsQTyVars GhcRn
-- 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_implicit = error "haddock:emptyHsQTvs"
- , hsq_explicit = []
- , hsq_dependent = error "haddock:emptyHsQTvs" }
+emptyHsQTvs = HsQTvs { hsq_ext = HsQTvsRn
+ { hsq_implicit = error "haddock:emptyHsQTvs"
+ , hsq_dependent = error "haddock:emptyHsQTvs" }
+ , hsq_explicit = [] }
--------------------------------------------------------------------------------
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-15 14:34:56 +0000