From 9f2d1b933897a6330e5c8f9fa904e56ab40050ef Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Sat, 4 Aug 2018 11:51:30 -0400 Subject: Latex type families (#734) * Support for type families in LaTeX The code is ported over from the XHTML backend. * Refactor XHTML and LaTeX family handling This is mostly a consolidation effort: stripping extra exports, inlining some short definitions, and trying to make the backends match. The LaTeX backend now has preliminary support for data families, although the only the data instance head is printed (not the actual constructors). Both backends also now use "newtype" for newtype data family instances. * Add some tests --- haddock-api/src/Haddock/Backends/LaTeX.hs | 131 ++++++++++++++++++++++++------ 1 file changed, 107 insertions(+), 24 deletions(-) (limited to 'haddock-api/src/Haddock/Backends/LaTeX.hs') diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 4a3e9d03..4e0e6eba 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 @@ -316,6 +309,83 @@ ppFor _ _ _ = error "ppFor error in Haddock.Backends.LaTeX" -- error "foreign declarations are currently not supported by --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 @@ -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) -- cgit v1.2.3