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.hs135
1 files changed, 109 insertions, 26 deletions
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 4a3e9d03..0c7747bd 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -12,10 +12,9 @@
-- Portability : portable
-----------------------------------------------------------------------------
module Haddock.Backends.LaTeX (
- ppLaTeX
+ ppLaTeX,
) where
-
import Documentation.Haddock.Markup
import Haddock.Types
import Haddock.Utils
@@ -285,7 +284,7 @@ ppDecl :: LHsDecl DocNameI -- ^ decl to print
-> LaTeX
ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of
- TyClD _ d@FamDecl {} -> ppTyFam False doc d unicode
+ TyClD _ d@FamDecl {} -> ppFamDecl doc instances 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
@@ -303,12 +302,6 @@ ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of
unicode = False
-ppTyFam :: Bool -> Documentation DocName ->
- TyClDecl DocNameI -> Bool -> LaTeX
-ppTyFam _ _ _ _ =
- error "type family declarations are currently not supported by --latex"
-
-
ppFor :: DocForDecl DocName -> ForeignDecl DocNameI -> Bool -> LaTeX
ppFor doc (ForeignImport _ (L _ name) typ _) unicode =
ppFunSig doc [name] (hsSigType typ) unicode
@@ -317,6 +310,83 @@ ppFor _ _ _ = error "ppFor error in Haddock.Backends.LaTeX"
-------------------------------------------------------------------------------
+-- * Type families
+-------------------------------------------------------------------------------
+
+-- | Pretty-print a data\/type family declaration
+ppFamDecl :: Documentation DocName -- ^ this decl's docs
+ -> [DocInstance DocNameI] -- ^ relevant instances
+ -> TyClDecl DocNameI -- ^ family to print
+ -> Bool -- ^ unicode
+ -> LaTeX
+ppFamDecl doc instances decl unicode =
+ declWithDoc (ppFamHeader (tcdFam decl) unicode <+> whereBit)
+ (if null body then Nothing else Just (vcat body))
+ $$ instancesBit
+ where
+ body = catMaybes [familyEqns, documentationToLaTeX doc]
+
+ whereBit = case fdInfo (tcdFam decl) of
+ ClosedTypeFamily _ -> keyword "where"
+ _ -> empty
+
+ familyEqns
+ | FamilyDecl { fdInfo = ClosedTypeFamily (Just eqns) } <- tcdFam decl
+ = Just (text "\\haddockbeginargs" $$
+ vcat [ decltt (ppFamDeclEqn eqn) <+> nl | L _ eqn <- eqns ] $$
+ text "\\end{tabulary}\\par")
+ | otherwise = Nothing
+
+ -- Individual equations of a closed type family
+ ppFamDeclEqn :: TyFamInstEqn DocNameI -> LaTeX
+ ppFamDeclEqn (HsIB { hsib_body = FamEqn { feqn_tycon = L _ n
+ , feqn_rhs = rhs
+ , feqn_pats = ts } })
+ = hsep [ ppAppNameTypes n (map unLoc ts) unicode
+ , equals
+ , ppType unicode (unLoc rhs)
+ ]
+ ppFamDeclEqn (XHsImplicitBndrs _) = panic "haddock:ppFamDecl"
+ ppFamDeclEqn (HsIB { hsib_body = XFamEqn _}) = panic "haddock:ppFamDecl"
+
+ instancesBit = ppDocInstances unicode instances
+
+-- | Print the LHS of a type\/data family declaration.
+ppFamHeader :: FamilyDecl DocNameI -- ^ family header to print
+ -> Bool -- ^ unicode
+ -> LaTeX
+ppFamHeader (XFamilyDecl _) _ = panic "haddock;ppFamHeader"
+ppFamHeader (FamilyDecl { fdLName = L _ name
+ , fdTyVars = tvs
+ , fdInfo = info
+ , fdResultSig = L _ result
+ , fdInjectivityAnn = injectivity })
+ unicode =
+ leader <+> keyword "family" <+> famName <+> famSig <+> injAnn
+ where
+ leader = case info of
+ OpenTypeFamily -> keyword "type"
+ ClosedTypeFamily _ -> keyword "type"
+ DataFamily -> keyword "data"
+
+ famName = ppAppDocNameTyVarBndrs unicode name (hsq_explicit tvs)
+
+ famSig = case result of
+ NoSig _ -> empty
+ KindSig _ kind -> dcolon unicode <+> ppLKind unicode kind
+ TyVarSig _ (L _ bndr) -> equals <+> ppHsTyVarBndr unicode bndr
+ XFamilyResultSig _ -> panic "haddock:ppFamHeader"
+
+ injAnn = case injectivity of
+ Nothing -> empty
+ Just (L _ (InjectivityAnn lhs rhs)) -> hsep ( decltt (text "|")
+ : ppLDocName lhs
+ : arrow unicode
+ : map ppLDocName rhs)
+
+
+
+-------------------------------------------------------------------------------
-- * Type Synonyms
-------------------------------------------------------------------------------
@@ -538,12 +608,14 @@ ppClassDecl instances doc subdocs
| otherwise = error "LaTeX.ppClassDecl"
methodTable =
- text "\\haddockpremethods{}\\textbf{Methods}" $$
- vcat [ ppFunSig doc [name] (hsSigWcType typ) unicode
+ text "\\haddockpremethods{}" <> emph (text "Methods") $$
+ vcat [ ppFunSig doc names (hsSigWcType typ) unicode
| L _ (TypeSig _ lnames typ) <- lsigs
- , name <- map unLoc lnames
- , let doc = lookupAnySubdoc name subdocs
- ]
+ , let doc = lookupAnySubdoc (head names) subdocs
+ names = map unLoc lnames ]
+ -- FIXME: is taking just the first name ok? Is it possible that
+ -- there are different subdocs for different names in a single
+ -- type signature?
instancesBit = ppDocInstances unicode instances
@@ -573,14 +645,13 @@ ppDocInstance unicode (instHead, doc, _, _) =
ppInstDecl :: Bool -> InstHead DocNameI -> LaTeX
-ppInstDecl unicode instHead = keyword "instance" <+> ppInstHead unicode instHead
-
-
-ppInstHead :: Bool -> InstHead DocNameI -> LaTeX
-ppInstHead unicode (InstHead {..}) = case ihdInstType of
- ClassInst ctx _ _ _ -> ppContextNoLocs ctx unicode <+> typ
- TypeInst rhs -> keyword "type" <+> typ <+> tibody rhs
- DataInst _ -> error "data instances not supported by --latex yet"
+ppInstDecl unicode (InstHead {..}) = case ihdInstType of
+ ClassInst ctx _ _ _ -> keyword "instance" <+> ppContextNoLocs ctx unicode <+> typ
+ TypeInst rhs -> keyword "type" <+> keyword "instance" <+> typ <+> tibody rhs
+ DataInst dd ->
+ let nd = dd_ND (tcdDataDefn dd)
+ pref = case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }
+ in pref <+> keyword "instance" <+> typ
where
typ = ppAppNameTypes ihdClsName ihdTypes unicode
tibody = maybe empty (\t -> equals <+> ppType unicode t)
@@ -613,7 +684,7 @@ ppDataDecl pats instances subdocs doc dataDecl unicode =
cons = dd_cons (tcdDataDefn dataDecl)
resTy = (unLoc . head) cons
- body = catMaybes [constrBit,patternBit, doc >>= documentationToLaTeX]
+ body = catMaybes [doc >>= documentationToLaTeX, constrBit,patternBit]
(whereBit, leaders)
| null cons
@@ -823,6 +894,12 @@ ppDataHeader _ _ = error "ppDataHeader: illegal argument"
-- * Type applications
--------------------------------------------------------------------------------
+ppAppDocNameTyVarBndrs :: Bool -> DocName -> [LHsTyVarBndr DocNameI] -> LaTeX
+ppAppDocNameTyVarBndrs unicode n vs =
+ ppTypeApp n vs ppDN (ppHsTyVarBndr unicode . unLoc)
+ where
+ ppDN = ppBinder . nameOccName . getName
+
-- | Print an application of a DocName to its list of HsTypes
ppAppNameTypes :: DocName -> [HsType DocNameI] -> Bool -> LaTeX
@@ -897,7 +974,7 @@ tupleParens _ = parenList
sumParens :: [LaTeX] -> LaTeX
-sumParens = ubxparens . hsep . punctuate (text " | ")
+sumParens = ubxparens . hsep . punctuate (text " |")
-------------------------------------------------------------------------------
@@ -917,6 +994,12 @@ ppType unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode
ppParendType unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode
ppFunLhType unicode ty = ppr_mono_ty (reparenTypePrec PREC_FUN ty) unicode
+ppHsTyVarBndr :: Bool -> HsTyVarBndr DocNameI -> LaTeX
+ppHsTyVarBndr _ (UserTyVar _ (L _ name)) = ppDocName name
+ppHsTyVarBndr unicode (KindedTyVar _ (L _ name) kind) =
+ parens (ppDocName name) <+> dcolon unicode <+> ppLKind unicode kind
+ppHsTyVarBndr _ (XTyVarBndr _) = panic "haddock:ppHsTyVarBndr"
+
ppLKind :: Bool -> LHsKind DocNameI -> LaTeX
ppLKind unicode y = ppKind unicode (unLoc y)
@@ -973,7 +1056,7 @@ ppr_mono_ty (HsParTy _ ty) unicode
ppr_mono_ty (HsDocTy _ ty _) unicode
= ppr_mono_lty ty unicode
-ppr_mono_ty (HsWildCardTy (AnonWildCard _)) _ = char '_'
+ppr_mono_ty (HsWildCardTy (AnonWildCard _)) _ = text "\\_"
ppr_mono_ty (HsTyLit _ t) u = ppr_tylit t u
ppr_mono_ty (HsStarTy _ isUni) unicode = starSymbol (isUni || unicode)
@@ -1252,7 +1335,7 @@ ubxParenList = ubxparens . hsep . punctuate comma
ubxparens :: LaTeX -> LaTeX
-ubxparens h = text "(#" <> h <> text "#)"
+ubxparens h = text "(#" <+> h <+> text "#)"
nl :: LaTeX
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 17:04:55 +0000