aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Backends
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock/Backends')
-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
6 files changed, 710 insertions, 547 deletions
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"])