aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Backends/LaTeX.hs
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock/Backends/LaTeX.hs')
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs483
1 files changed, 277 insertions, 206 deletions
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 793e40d8..51e183c7 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)
@@ -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
- _ -> error "declaration not supported by ppDecl"
+ 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,7 +547,7 @@ ppClassDecl instances loc doc subdocs
methodTable =
text "\\haddockpremethods{}\\textbf{Methods}" $$
- vcat [ ppFunSig loc doc names (hsSigWcType typ) unicode
+ vcat [ ppFunSig doc names (hsSigWcType typ) unicode
| L _ (TypeSig lnames typ) <- lsigs
, let doc = lookupAnySubdoc (head names) subdocs
names = map unLoc lnames ]
@@ -518,7 +557,7 @@ ppClassDecl instances loc doc 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
@@ -567,15 +606,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
@@ -587,28 +628,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"
@@ -627,41 +666,100 @@ 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_args 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)
+ ]
+
+ 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)
+ ]
- 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 = map (getName . hsLTyVarName) (con_ex_tvs con)
- context = unLoc (fromMaybe (noLoc []) (con_mb_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.
@@ -670,27 +768,8 @@ 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 (getGADTConType 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
+-- | Pretty-print a record field
ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocNameI -> LaTeX
ppSideBySideField subdocs unicode (ConDeclField names ltype _) =
decltt (cat (punctuate comma (map (ppBinder . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names))
@@ -700,51 +779,37 @@ ppSideBySideField subdocs unicode (ConDeclField names ltype _) =
-- 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 ]
--- -}
+
+-- | 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.
@@ -760,6 +825,7 @@ ppDataHeader (DataDecl { tcdLName = L _ name, tcdTyVars = tyvars
ppAppDocNameNames False name (tyvarNames tyvars)
ppDataHeader _ _ = error "ppDataHeader: illegal argument"
+
--------------------------------------------------------------------------------
-- * Type applications
--------------------------------------------------------------------------------
@@ -911,7 +977,7 @@ ppr_mono_ty _ (HsListTy ty) u = brackets (ppr_mono_lty pREC_TOP ty
ppr_mono_ty _ (HsPArrTy ty) u = pabrackets (ppr_mono_lty pREC_TOP ty u)
ppr_mono_ty _ (HsIParamTy (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 _ (HsRecTy {}) _ = text "{..}"
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
@@ -972,6 +1038,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