{-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Backends.LaTeX -- Copyright : (c) Simon Marlow 2010, -- Mateusz Kowalczyk 2013 -- License : BSD-like -- -- Maintainer : haddock@projects.haskell.org -- Stability : experimental -- Portability : portable ----------------------------------------------------------------------------- module Haddock.Backends.LaTeX ( ppLaTeX, ) where import Documentation.Haddock.Markup import Haddock.Types import Haddock.Utils import Haddock.GhcUtils import GHC.Utils.Ppr hiding (Doc, quote) import qualified GHC.Utils.Ppr as Pretty import GHC.Types.Basic ( PromotionFlag(..), isPromoted ) import GHC hiding (fromMaybeContext ) import GHC.Types.Name.Occurrence import GHC.Types.Name ( nameOccName ) import GHC.Types.Name.Reader ( rdrNameOcc ) import GHC.Core.Type ( Specificity(..) ) import GHC.Data.FastString ( unpackFS ) import GHC.Utils.Panic ( panic) import qualified Data.Map as Map import System.Directory import System.FilePath import Data.Char import Control.Monad import Data.Maybe import Data.List ( sort ) import Prelude hiding ((<>)) import Haddock.Doc (combineDocumentation) -- import Debug.Trace {- SAMPLE OUTPUT \haddockmoduleheading{\texttt{Data.List}} \hrulefill {\haddockverb\begin{verbatim} module Data.List ( (++), head, last, tail, init, null, length, map, reverse, ) where\end{verbatim}} \hrulefill \section{Basic functions} \begin{haddockdesc} \item[\begin{tabular}{@{}l} head\ ::\ {\char 91}a{\char 93}\ ->\ a \end{tabular}]\haddockbegindoc Extract the first element of a list, which must be non-empty. \par \end{haddockdesc} \begin{haddockdesc} \item[\begin{tabular}{@{}l} last\ ::\ {\char 91}a{\char 93}\ ->\ a \end{tabular}]\haddockbegindoc Extract the last element of a list, which must be finite and non-empty. \par \end{haddockdesc} -} {- TODO * don't forget fixity!! -} ppLaTeX :: String -- Title -> Maybe String -- Package name -> [Interface] -> FilePath -- destination directory -> Maybe (Doc GHC.RdrName) -- prologue text, maybe -> Maybe String -- style file -> FilePath -> IO () ppLaTeX title packageStr visible_ifaces odir prologue maybe_style libdir = do createDirectoryIfMissing True odir when (isNothing maybe_style) $ copyFile (libdir "latex" haddockSty) (odir haddockSty) ppLaTeXTop title packageStr odir prologue maybe_style visible_ifaces mapM_ (ppLaTeXModule title odir) visible_ifaces haddockSty :: FilePath haddockSty = "haddock.sty" type LaTeX = Pretty.Doc -- | Default way of rendering a 'LaTeX'. The width is 90 by default (since 100 -- often overflows the line). latex2String :: LaTeX -> String latex2String = fullRender (PageMode True) 90 1 txtPrinter "" ppLaTeXTop :: String -> Maybe String -> FilePath -> Maybe (Doc GHC.RdrName) -> Maybe String -> [Interface] -> IO () ppLaTeXTop doctitle packageStr odir prologue maybe_style ifaces = do let tex = vcat [ text "\\documentclass{book}", text "\\usepackage" <> braces (maybe (text "haddock") text maybe_style), text "\\begin{document}", text "\\begin{titlepage}", text "\\begin{haddocktitle}", text doctitle, text "\\end{haddocktitle}", case prologue of Nothing -> empty Just d -> vcat [text "\\begin{haddockprologue}", rdrDocToLaTeX d, text "\\end{haddockprologue}"], text "\\end{titlepage}", text "\\tableofcontents", vcat [ text "\\input" <> braces (text mdl) | mdl <- mods ], text "\\end{document}" ] mods = sort (map (moduleBasename.ifaceMod) ifaces) filename = odir (fromMaybe "haddock" packageStr <.> "tex") writeUtf8File filename (show tex) ppLaTeXModule :: String -> FilePath -> Interface -> IO () ppLaTeXModule _title odir iface = do createDirectoryIfMissing True odir let mdl = ifaceMod iface mdl_str = moduleString mdl exports = ifaceRnExportItems iface tex = vcat [ text "\\haddockmoduleheading" <> braces (text mdl_str), text "\\label{module:" <> text mdl_str <> char '}', text "\\haddockbeginheader", verb $ vcat [ text "module" <+> text mdl_str <+> lparen, text " " <> fsep (punctuate (char ',') $ map exportListItem $ filter forSummary exports), text " ) where" ], text "\\haddockendheader" $$ text "", description, body ] description = (fromMaybe empty . documentationToLaTeX . ifaceRnDoc) iface body = processExports exports -- writeUtf8File (odir moduleLaTeXFile mdl) (fullRender (PageMode True) 80 1 txtPrinter "" tex) -- | Prints out an entry in a module export list. exportListItem :: ExportItem DocNameI -> LaTeX exportListItem ExportDecl { expItemDecl = decl, expItemSubDocs = 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) = ppDocBinder y <> parens (sep (punctuate comma (map ppDocBinder subs))) exportListItem (ExportModule mdl) = text "module" <+> text (moduleString mdl) exportListItem _ = error "exportListItem" -- Deal with a group of undocumented exports together, to avoid lots -- of blank vertical space between them. processExports :: [ExportItem DocNameI] -> LaTeX processExports [] = empty processExports (decl : es) | Just sig <- isSimpleSig decl = multiDecl [ ppTypeSig (map getName names) typ False | (names,typ) <- sig:sigs ] $$ processExports es' where (sigs, es') = spanWith isSimpleSig es processExports (ExportModule mdl : es) = declWithDoc (vcat [ text "module" <+> text (moduleString m) | m <- mdl:mdls ]) Nothing $$ processExports es' where (mdls, es') = spanWith isExportModule es processExports (e : es) = processExport e $$ processExports es isSimpleSig :: ExportItem DocNameI -> Maybe ([DocName], HsSigType DocNameI) isSimpleSig ExportDecl { expItemDecl = L _ (SigD _ (TypeSig _ lnames t)) , expItemMbDoc = (Documentation Nothing Nothing, argDocs) } | Map.null argDocs = Just (map unLoc lnames, unLoc (dropWildCards t)) isSimpleSig _ = Nothing isExportModule :: ExportItem DocNameI -> Maybe Module isExportModule (ExportModule m) = Just m isExportModule _ = Nothing processExport :: ExportItem DocNameI -> LaTeX processExport (ExportGroup lev _id0 doc) = ppDocGroup lev (docToLaTeX doc) processExport (ExportDecl decl pats doc subdocs insts fixities _splice) = ppDecl decl pats doc insts subdocs fixities processExport (ExportNoDecl y []) = ppDocName y processExport (ExportNoDecl y subs) = ppDocName y <> parens (sep (punctuate comma (map ppDocName subs))) processExport (ExportModule mdl) = declWithDoc (text "module" <+> text (moduleString mdl)) Nothing processExport (ExportDoc doc) = docToLaTeX $ _doc doc ppDocGroup :: Int -> LaTeX -> LaTeX ppDocGroup lev doc = sec lev <> braces doc where sec 1 = text "\\section" sec 2 = text "\\subsection" sec 3 = text "\\subsubsection" sec _ = text "\\paragraph" -- | 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 -> (empty, [tcdNameI 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" forSummary :: (ExportItem DocNameI) -> Bool forSummary (ExportGroup _ _ _) = False forSummary (ExportDoc _) = False forSummary _ = True moduleLaTeXFile :: Module -> FilePath moduleLaTeXFile mdl = moduleBasename mdl ++ ".tex" moduleBasename :: Module -> FilePath moduleBasename mdl = map (\c -> if c == '.' then '-' else c) (moduleNameString (moduleName mdl)) ------------------------------------------------------------------------------- -- * Decls ------------------------------------------------------------------------------- -- | 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 decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of TyClD _ d@FamDecl {} -> ppFamDecl False 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 -- TyClD _ d@TySynonym{} -- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode -- Family instances happen via FamInst now TyClD _ d@ClassDecl{} -> ppClassDecl instances doc subdocs d unicode SigD _ (TypeSig _ lnames ty) -> ppFunSig Nothing (doc, fnArgsDoc) (map unLoc lnames) (dropWildCards 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 ppFor :: DocForDecl DocName -> ForeignDecl DocNameI -> Bool -> LaTeX ppFor doc (ForeignImport _ (L _ name) typ _) unicode = ppFunSig Nothing doc [name] typ unicode 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 :: Bool -- ^ is the family associated? -> Documentation DocName -- ^ this decl's docs -> [DocInstance DocNameI] -- ^ relevant instances -> TyClDecl DocNameI -- ^ family to print -> Bool -- ^ unicode -> LaTeX ppFamDecl associated doc instances decl unicode = declWithDoc (ppFamHeader (tcdFam decl) unicode associated <+> 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 , not (null eqns) = 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 (FamEqn { feqn_tycon = L _ n , feqn_rhs = rhs , feqn_pats = ts }) = hsep [ ppAppNameTypeArgs n ts unicode , equals , ppType unicode (unLoc rhs) ] instancesBit = ppDocInstances unicode instances -- | Print the LHS of a type\/data family declaration. ppFamHeader :: FamilyDecl DocNameI -- ^ family header to print -> Bool -- ^ unicode -> Bool -- ^ is the family associated? -> LaTeX ppFamHeader (FamilyDecl { fdLName = L _ name , fdTyVars = tvs , fdInfo = info , fdResultSig = L _ result , fdInjectivityAnn = injectivity }) unicode associated = famly leader <+> famName <+> famSig <+> injAnn where leader = case info of OpenTypeFamily -> keyword "type" ClosedTypeFamily _ -> keyword "type" DataFamily -> keyword "data" famly | associated = id | otherwise = (<+> keyword "family") 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 injAnn = case injectivity of Nothing -> empty Just (L _ (InjectivityAnn _ lhs rhs)) -> hsep ( decltt (text "|") : ppLDocName lhs : arrow unicode : map ppLDocName rhs) Just _ -> empty ------------------------------------------------------------------------------- -- * Type Synonyms ------------------------------------------------------------------------------- -- we skip type patterns for now ppTySyn :: DocForDecl DocName -> TyClDecl DocNameI -> Bool -> LaTeX ppTySyn doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars , tcdRhs = ltype }) unicode = ppTypeOrFunSig (mkHsImplicitSigTypeI 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" ------------------------------------------------------------------------------- -- * Function signatures ------------------------------------------------------------------------------- ppFunSig :: Maybe LaTeX -- ^ a prefix to put right before the signature -> DocForDecl DocName -- ^ documentation -> [DocName] -- ^ pattern names in the pattern signature -> LHsSigType DocNameI -- ^ type of the pattern synonym -> Bool -- ^ unicode -> LaTeX ppFunSig leader doc docnames (L _ typ) unicode = ppTypeOrFunSig typ doc ( lead $ ppTypeSig names typ False , lead $ hsep . punctuate comma $ map ppSymName names , dcolon unicode ) unicode where names = map getName docnames lead = maybe id (<+>) leader -- | 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 = ppFunSig (Just (keyword "pattern")) doc docnames ty unicode -- | Pretty-print a type, adding documentation to the whole type and its -- arguments as needed. ppTypeOrFunSig :: HsSigType 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" $$ 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 -> HsSigType 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_sig_args 0 leader typ where do_sig_args :: Int -> LaTeX -> HsSigType DocNameI -> [(LaTeX, LaTeX)] do_sig_args n leader (HsSig { sig_bndrs = outer_bndrs, sig_body = ltype }) = case outer_bndrs of HsOuterExplicit{hso_bndrs = bndrs} -> [ ( decltt leader , decltt (ppHsForAllTelescope (mkHsForAllInvisTeleI bndrs) unicode) <+> ppLType unicode ltype ) ] HsOuterImplicit{} -> do_largs n leader ltype do_largs :: Int -> LaTeX -> LHsType DocNameI -> [(LaTeX, LaTeX)] 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 _ tele ltype) = [ ( decltt leader , decltt (ppHsForAllTelescope tele unicode) <+> ppLType unicode ltype ) ] do_args n leader (HsQualTy _ lctxt ltype) = ( decltt leader , decltt (ppLContextNoArrow lctxt unicode) <+> nl ) : do_largs n (darrow unicode) ltype do_args n leader (HsFunTy _ _w (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 _ _w 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) (char ' ')) <> char ',' gadtEnd = hcat (replicate (if unicode then 3 else 4) (char ' ')) <> char '}' gadtOpen = char '{' ppTypeSig :: [Name] -> HsSigType DocNameI -> Bool -> LaTeX ppTypeSig nms ty unicode = hsep (punctuate comma $ map ppSymName nms) <+> dcolon unicode <+> ppSigType unicode ty ppHsOuterTyVarBndrs :: HsOuterTyVarBndrs flag DocNameI -> Bool -> LaTeX ppHsOuterTyVarBndrs (HsOuterImplicit{}) _ = empty ppHsOuterTyVarBndrs (HsOuterExplicit{hso_bndrs = bndrs}) unicode = hsep (forallSymbol unicode : ppTyVars bndrs) <> dot ppHsForAllTelescope :: HsForAllTelescope DocNameI -> Bool -> LaTeX ppHsForAllTelescope tele unicode = case tele of HsForAllVis { hsf_vis_bndrs = bndrs } -> hsep (forallSymbol unicode : ppTyVars bndrs) <> text "\\" <> arrow unicode HsForAllInvis { hsf_invis_bndrs = bndrs } -> hsep (forallSymbol unicode : ppTyVars bndrs) <> dot ppTyVars :: [LHsTyVarBndr flag DocNameI] -> [LaTeX] ppTyVars = map (ppSymName . getName . hsLTyVarNameI) tyvarNames :: LHsQTyVars DocNameI -> [Name] tyvarNames = map (getName . hsLTyVarNameI) . hsQTvExplicit declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX declWithDoc decl doc = text "\\begin{haddockdesc}" $$ text "\\item[\\begin{tabular}{@{}l}" $$ text (latexMonoFilter (latex2String decl)) $$ text "\\end{tabular}]" $$ maybe empty (\x -> text "{\\haddockbegindoc" $$ x <> text "}") doc $$ text "\\end{haddockdesc}" -- in a group of decls, we don't put them all in the same tabular, -- because that would prevent the group being broken over a page -- boundary (breaks Foreign.C.Error for example). multiDecl :: [LaTeX] -> LaTeX multiDecl decls = text "\\begin{haddockdesc}" $$ vcat [ text "\\item[\\begin{tabular}{@{}l}" $$ text (latexMonoFilter (latex2String decl)) $$ text "\\end{tabular}]" | decl <- decls ] $$ text "\\end{haddockdesc}" ------------------------------------------------------------------------------- -- * Rendering Doc ------------------------------------------------------------------------------- maybeDoc :: Maybe (Doc DocName) -> LaTeX maybeDoc = maybe empty docToLaTeX -- for table cells, we strip paragraphs out to avoid extra vertical space -- and don't add a quote environment. rDoc :: Maybe (Doc DocName) -> LaTeX rDoc = maybeDoc . fmap latexStripTrailingWhitespace ------------------------------------------------------------------------------- -- * Class declarations ------------------------------------------------------------------------------- ppClassHdr :: Bool -> Maybe (LocatedC [LHsType DocNameI]) -> DocName -> LHsQTyVars DocNameI -> [LHsFunDep DocNameI] -> Bool -> LaTeX ppClassHdr summ lctxt n tvs fds unicode = keyword "class" <+> (if not (null $ fromMaybeContext lctxt) then ppLContext lctxt unicode else empty) <+> ppAppDocNameNames summ n (tyvarNames tvs) <+> ppFds fds unicode -- ppFds :: [Located ([LocatedA DocName], [LocatedA DocName])] -> Bool -> LaTeX ppFds :: [LHsFunDep DocNameI] -> Bool -> LaTeX ppFds fds unicode = if null fds then empty else char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds)) where fundep (FunDep _ vars1 vars2) = hsep (map (ppDocName . unLoc) vars1) <+> arrow unicode <+> hsep (map (ppDocName . unLoc) vars2) fundep (XFunDep _) = error "ppFds" -- TODO: associated type defaults, docs on default methods ppClassDecl :: [DocInstance DocNameI] -> Documentation DocName -> [(DocName, DocForDecl DocName)] -> TyClDecl DocNameI -> Bool -> LaTeX 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)) $$ instancesBit where classheader | null lsigs = hdr unicode | otherwise = hdr unicode <+> keyword "where" hdr = ppClassHdr False lctxt (unLoc lname) ltyvars lfds body = catMaybes [documentationToLaTeX doc, body_] body_ | null lsigs, null ats, null at_defs = Nothing | null ats, null at_defs = Just methodTable | otherwise = Just (atTable $$ methodTable) atTable = text "\\haddockpremethods{}" <> emph (text "Associated Types") $$ vcat [ ppFamDecl True (fst doc) [] (FamDecl noExtField decl) True | L _ decl <- ats , let name = unLoc . fdLName $ decl doc = lookupAnySubdoc name subdocs ] methodTable = text "\\haddockpremethods{}" <> emph (text "Methods") $$ vcat [ ppFunSig leader doc names typ unicode | L _ (ClassOpSig _ is_def lnames typ) <- lsigs , let doc | is_def = noDocForDecl | otherwise = lookupAnySubdoc (head names) subdocs names = map unLoc lnames leader = if is_def then Just (keyword "default") else Nothing ] -- N.B. taking just the first name is ok. Signatures with multiple -- names are expanded so that each name gets its own signature. instancesBit = ppDocInstances unicode instances ppClassDecl _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" ppDocInstances :: Bool -> [DocInstance DocNameI] -> LaTeX ppDocInstances _unicode [] = empty ppDocInstances unicode (i : rest) | Just ihead <- isUndocdInstance i = declWithDoc (vcat (map (ppInstDecl unicode) (ihead:is))) Nothing $$ ppDocInstances unicode rest' | otherwise = ppDocInstance unicode i $$ ppDocInstances unicode rest where (is, rest') = spanWith isUndocdInstance rest isUndocdInstance :: DocInstance a -> Maybe (InstHead a) isUndocdInstance (i,Nothing,_,_) = Just i isUndocdInstance (i,Just (MetaDoc _ DocEmpty),_,_) = Just i isUndocdInstance _ = Nothing -- | Print a possibly commented instance. The instance header is printed inside -- an 'argBox'. The comment is printed to the right of the box in normal comment -- style. ppDocInstance :: Bool -> DocInstance DocNameI -> LaTeX ppDocInstance unicode (instHead, doc, _, _) = declWithDoc (ppInstDecl unicode instHead) (fmap docToLaTeX $ fmap _doc doc) ppInstDecl :: Bool -> InstHead DocNameI -> LaTeX 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) lookupAnySubdoc :: (Eq name1) => name1 -> [(name1, DocForDecl name2)] -> DocForDecl name2 lookupAnySubdoc n subdocs = case lookup n subdocs of Nothing -> noDocForDecl Just docs -> docs ------------------------------------------------------------------------------- -- * Data & newtype declarations ------------------------------------------------------------------------------- -- | 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 cons = dd_cons (tcdDataDefn dataDecl) resTy = (unLoc . head) cons body = catMaybes [doc >>= documentationToLaTeX, constrBit,patternBit] (whereBit, leaders) | null cons , null pats = (empty,[]) | null cons = (text "where", repeat empty) | otherwise = case resTy of 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 pats = Nothing | otherwise = Just $ text "\\enspace" <+> emph (text "Bundled Patterns") <> text "\\par" $$ text "\\haddockbeginconstrs" $$ vcat [ empty <-> ppSideBySidePat lnames typ d unicode | (SigD _ (PatSynSig _ lnames typ), d) <- pats ] $$ text "\\end{tabulary}\\par" instancesBit = ppDocInstances unicode instances -- ppConstrHdr is for (non-GADT) existentials constructors' syntax ppConstrHdr :: Bool -- ^ print explicit foralls -> [LHsTyVarBndr Specificity DocNameI] -- ^ type variables -> HsContext DocNameI -- ^ context -> Bool -- ^ unicode -> LaTeX ppConstrHdr forall_ tvs ctxt unicode = ppForall <> ppCtxt where ppForall | null tvs || not forall_ = empty | otherwise = ppHsForAllTelescope (mkHsForAllInvisTeleI tvs) unicode ppCtxt | null ctxt = empty | otherwise = ppContextNoArrow ctxt unicode <+> darrow unicode <> space -- | 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 (getConNamesI con)) occ = map (nameOccName . getName . unLoc) $ getConNamesI 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 = tyVars , con_forall = forall_ , con_mb_cxt = cxt } -> let context = fromMaybeContext cxt 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 . hsScaledThing) 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 (hsScaledThing arg1) , ppOccInfix , ppLParendType unicode (hsScaledThing arg2) ] ConDeclGADT{} | hasArgDocs || not (isEmpty fieldPart) -> ppOcc | otherwise -> hsep [ ppOcc , dcolon unicode -- ++AZ++ make this prepend "{..}" when it is a record style GADT , ppLSigType unicode (getGADTConType con) ] fieldPart = case con of ConDeclGADT{con_g_args = con_args'} -> case con_args' of -- GADT record declarations RecConGADT _ _ -> doConstrArgsWithDocs [] -- GADT prefix data constructors PrefixConGADT args | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing args) _ -> empty ConDeclH98{con_args = con_args'} -> case con_args' of -- H98 record declarations RecCon (L _ fields) -> doRecordFields fields -- H98 prefix data constructors PrefixCon _ args | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing args) -- H98 infix data constructor InfixCon arg1 arg2 | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing [arg1,arg2]) _ -> empty doRecordFields 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) ] -- 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 getConNamesI 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 . foLabel . 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 (foExt $ unLoc $ head names) subdocs >>= fmap _doc . combineDocumentation . fst -- | Pretty-print a bundled pattern synonym ppSideBySidePat :: [LocatedN 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 , ppLSigType unicode typ ] fieldPart | not hasArgDocs = empty | otherwise = vcat [ empty <-> text "\\qquad" <+> l <+> text "\\enspace" <+> r | (l,r) <- ppSubSigLike unicode (unLoc typ) argDocs [] (dcolon unicode) ] mDoc = fmap _doc $ combineDocumentation doc -- | Print the LHS of a data\/newtype declaration. -- Currently doesn't handle 'data instance' decls or kind signatures ppDataHeader :: TyClDecl DocNameI -> Bool -> LaTeX ppDataHeader (DataDecl { tcdLName = L _ name, tcdTyVars = tyvars , tcdDataDefn = HsDataDefn { dd_ND = nd, dd_ctxt = ctxt } }) unicode = -- newtype or data (case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }) <+> -- context ppLContext ctxt unicode <+> -- T a b c ..., or a :+: b ppAppDocNameNames False name (tyvarNames tyvars) ppDataHeader _ _ = error "ppDataHeader: illegal argument" -------------------------------------------------------------------------------- -- * Type applications -------------------------------------------------------------------------------- ppAppDocNameTyVarBndrs :: RenderableBndrFlag flag => Bool -> DocName -> [LHsTyVarBndr flag 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 ppAppNameTypes n ts unicode = ppTypeApp n ts ppDocName (ppParendType unicode) ppAppNameTypeArgs :: DocName -> [LHsTypeArg DocNameI] -> Bool -> LaTeX ppAppNameTypeArgs n args@(HsValArg _:HsValArg _:_) unicode = ppTypeApp n args ppDocName (ppLHsTypeArg unicode) ppAppNameTypeArgs n args unicode = ppDocName n <+> hsep (map (ppLHsTypeArg unicode) args) -- | Print an application of a DocName and a list of Names ppAppDocNameNames :: Bool -> DocName -> [Name] -> LaTeX ppAppDocNameNames _summ n ns = ppTypeApp n ns (ppBinder . nameOccName . getName) ppSymName -- | General printing of type applications ppTypeApp :: DocName -> [a] -> (DocName -> LaTeX) -> (a -> LaTeX) -> LaTeX ppTypeApp n (t1:t2:rest) ppDN ppT | operator, not . null $ rest = parens opApp <+> hsep (map ppT rest) | operator = opApp where operator = isNameSym . getName $ n opApp = ppT t1 <+> ppDN n <+> ppT t2 ppTypeApp n ts ppDN ppT = ppDN n <+> hsep (map ppT ts) ------------------------------------------------------------------------------- -- * Contexts ------------------------------------------------------------------------------- ppLContext :: Maybe (LHsContext DocNameI) -> Bool -> LaTeX ppLContext Nothing _ = empty ppLContext (Just ctxt) unicode = ppContext (unLoc ctxt) unicode ppLContextNoArrow :: LHsContext DocNameI -> Bool -> LaTeX ppLContextNoArrow ctxt unicode = ppContextNoArrow (unLoc ctxt) unicode ppContextNoLocsMaybe :: [HsType DocNameI] -> Bool -> Maybe LaTeX ppContextNoLocsMaybe [] _ = Nothing ppContextNoLocsMaybe cxt unicode = Just $ pp_hs_context cxt unicode ppContextNoArrow :: HsContext DocNameI -> Bool -> LaTeX ppContextNoArrow cxt unicode = fromMaybe empty $ ppContextNoLocsMaybe (map unLoc cxt) unicode ppContextNoLocs :: [HsType DocNameI] -> Bool -> LaTeX ppContextNoLocs cxt unicode = maybe empty (<+> darrow unicode) $ ppContextNoLocsMaybe cxt unicode ppContext :: HsContext DocNameI -> Bool -> LaTeX ppContext cxt unicode = ppContextNoLocs (map unLoc cxt) unicode pp_hs_context :: [HsType DocNameI] -> Bool -> LaTeX pp_hs_context [] _ = empty pp_hs_context [p] unicode = ppCtxType unicode p pp_hs_context cxt unicode = parenList (map (ppType unicode) cxt) ------------------------------------------------------------------------------- -- * Types and contexts ------------------------------------------------------------------------------- ppBang :: HsSrcBang -> LaTeX ppBang (HsSrcBang _ _ SrcStrict) = char '!' ppBang (HsSrcBang _ _ SrcLazy) = char '~' ppBang _ = empty tupleParens :: HsTupleSort -> [LaTeX] -> LaTeX tupleParens HsUnboxedTuple = ubxParenList tupleParens _ = parenList sumParens :: [LaTeX] -> LaTeX sumParens = ubxparens . hsep . punctuate (text " |") ------------------------------------------------------------------------------- -- * Rendering of HsType -- -- Stolen from Html and tweaked for LaTeX generation ------------------------------------------------------------------------------- ppLType, ppLParendType, ppLFunLhType :: Bool -> LHsType DocNameI -> LaTeX ppLType unicode y = ppType unicode (unLoc y) ppLParendType unicode y = ppParendType unicode (unLoc y) ppLFunLhType unicode y = ppFunLhType unicode (unLoc y) ppLSigType :: Bool -> LHsSigType DocNameI -> LaTeX ppLSigType unicode y = ppSigType unicode (unLoc y) ppType, ppParendType, ppFunLhType, ppCtxType :: Bool -> HsType DocNameI -> LaTeX 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 ppCtxType unicode ty = ppr_mono_ty (reparenTypePrec PREC_CTX ty) unicode ppSigType :: Bool -> HsSigType DocNameI -> LaTeX ppSigType unicode sig_ty = ppr_sig_ty (reparenSigType sig_ty) unicode ppLHsTypeArg :: Bool -> LHsTypeArg DocNameI -> LaTeX ppLHsTypeArg unicode (HsValArg ty) = ppLParendType unicode ty ppLHsTypeArg unicode (HsTypeArg _ ki) = atSign unicode <> ppLParendType unicode ki ppLHsTypeArg _ (HsArgPar _) = text "" class RenderableBndrFlag flag where ppHsTyVarBndr :: Bool -> HsTyVarBndr flag DocNameI -> LaTeX instance RenderableBndrFlag () where ppHsTyVarBndr _ (UserTyVar _ _ (L _ name)) = ppDocName name ppHsTyVarBndr unicode (KindedTyVar _ _ (L _ name) kind) = parens (ppDocName name) <+> dcolon unicode <+> ppLKind unicode kind instance RenderableBndrFlag Specificity where ppHsTyVarBndr _ (UserTyVar _ SpecifiedSpec (L _ name)) = ppDocName name ppHsTyVarBndr _ (UserTyVar _ InferredSpec (L _ name)) = braces $ ppDocName name ppHsTyVarBndr unicode (KindedTyVar _ SpecifiedSpec (L _ name) kind) = parens (ppDocName name) <+> dcolon unicode <+> ppLKind unicode kind ppHsTyVarBndr unicode (KindedTyVar _ InferredSpec (L _ name) kind) = braces (ppDocName name) <+> dcolon unicode <+> ppLKind unicode kind ppLKind :: Bool -> LHsKind DocNameI -> LaTeX ppLKind unicode y = ppKind unicode (unLoc y) ppKind :: Bool -> HsKind DocNameI -> LaTeX ppKind unicode ki = ppr_mono_ty (reparenTypePrec PREC_TOP ki) unicode -- Drop top-level for-all type variables in user style -- since they are implicit in Haskell ppr_sig_ty :: HsSigType DocNameI -> Bool -> LaTeX ppr_sig_ty (HsSig { sig_bndrs = outer_bndrs, sig_body = ltype }) unicode = sep [ ppHsOuterTyVarBndrs outer_bndrs unicode , ppr_mono_lty ltype unicode ] ppr_mono_lty :: LHsType DocNameI -> Bool -> LaTeX ppr_mono_lty ty unicode = ppr_mono_ty (unLoc ty) unicode ppr_mono_ty :: HsType DocNameI -> Bool -> LaTeX ppr_mono_ty (HsForAllTy _ tele ty) unicode = sep [ ppHsForAllTelescope tele unicode , ppr_mono_lty ty unicode ] ppr_mono_ty (HsQualTy _ ctxt ty) unicode = sep [ ppLContext (Just ctxt) unicode , ppr_mono_lty ty unicode ] ppr_mono_ty (HsFunTy _ mult ty1 ty2) u = sep [ ppr_mono_lty ty1 u , arr <+> ppr_mono_lty ty2 u ] where arr = case mult of HsLinearArrow _ -> lollipop u HsUnrestrictedArrow _ -> arrow u HsExplicitMult _ m _ -> multAnnotation <> ppr_mono_lty m u <+> arrow 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 _ IsPromoted (L _ name)) _ = char '\'' <> ppDocName name 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 ty u <+> dcolon u <+> ppLKind u kind) ppr_mono_ty (HsListTy _ ty) u = brackets (ppr_mono_lty ty u) ppr_mono_ty (HsIParamTy _ (L _ n) ty) u = ppIPName n <+> dcolon u <+> ppr_mono_lty ty u ppr_mono_ty (HsSpliceTy v _) _ = dataConCantHappen v ppr_mono_ty (HsRecTy {}) _ = text "{..}" ppr_mono_ty (XHsType {}) _ = error "ppr_mono_ty HsCoreTy" ppr_mono_ty (HsExplicitListTy _ IsPromoted 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 (HsAppTy _ fun_ty arg_ty) unicode = hsep [ppr_mono_lty fun_ty unicode, ppr_mono_lty arg_ty unicode] ppr_mono_ty (HsAppKindTy _ fun_ty arg_ki) unicode = hsep [ppr_mono_lty fun_ty unicode, atSign unicode <> ppr_mono_lty arg_ki unicode] ppr_mono_ty (HsOpTy _ prom ty1 op ty2) unicode = ppr_mono_lty ty1 unicode <+> ppr_op_prom <+> ppr_mono_lty ty2 unicode where ppr_op_prom | isPromoted prom = char '\'' <> ppr_op | otherwise = ppr_op ppr_op | isSymOcc (getOccName op) = ppLDocName op | otherwise = char '`' <> ppLDocName op <> char '`' ppr_mono_ty (HsParTy _ ty) unicode = parens (ppr_mono_lty ty unicode) -- = ppr_mono_lty ty unicode ppr_mono_ty (HsDocTy _ ty _) unicode = ppr_mono_lty ty unicode ppr_mono_ty (HsWildCardTy _) _ = char '_' ppr_mono_ty (HsTyLit _ t) u = ppr_tylit t u ppr_mono_ty (HsStarTy _ isUni) unicode = starSymbol (isUni || unicode) ppr_tylit :: HsTyLit -> Bool -> LaTeX ppr_tylit (HsNumTy _ n) _ = integer n ppr_tylit (HsStrTy _ s) _ = text (show s) ppr_tylit (HsCharTy _ c) _ = text (show c) -- XXX: Ok in verbatim, but not otherwise -- XXX: Do something with Unicode parameter? ------------------------------------------------------------------------------- -- * Names ------------------------------------------------------------------------------- ppBinder :: OccName -> LaTeX ppBinder n | isSymOcc n = parens $ ppOccName n | otherwise = ppOccName n ppBinderInfix :: OccName -> LaTeX ppBinderInfix n | isSymOcc n = ppOccName n | otherwise = cat [ char '`', ppOccName n, char '`' ] ppSymName :: Name -> LaTeX ppSymName name | isNameSym name = parens $ ppName name | otherwise = ppName name ppIPName :: HsIPName -> LaTeX ppIPName = text . ('?':) . unpackFS . hsIPNameFS ppOccName :: OccName -> LaTeX ppOccName = text . occNameString ppDocName :: DocName -> LaTeX ppDocName = ppOccName . nameOccName . getName ppLDocName :: GenLocated l DocName -> LaTeX ppLDocName (L _ d) = ppDocName d ppDocBinder :: DocName -> LaTeX ppDocBinder = ppBinder . nameOccName . getName ppName :: Name -> LaTeX ppName = ppOccName . nameOccName latexFilter :: String -> String latexFilter = foldr latexMunge "" latexMonoFilter :: String -> String latexMonoFilter = foldr latexMonoMunge "" latexMunge :: Char -> String -> String latexMunge '#' s = "{\\char '43}" ++ s latexMunge '$' s = "{\\char '44}" ++ s latexMunge '%' s = "{\\char '45}" ++ s latexMunge '&' s = "{\\char '46}" ++ s latexMunge '~' s = "{\\char '176}" ++ s latexMunge '_' s = "{\\char '137}" ++ s latexMunge '^' s = "{\\char '136}" ++ s latexMunge '\\' s = "{\\char '134}" ++ s latexMunge '{' s = "{\\char '173}" ++ s latexMunge '}' s = "{\\char '175}" ++ s latexMunge '[' s = "{\\char 91}" ++ s latexMunge ']' s = "{\\char 93}" ++ s latexMunge c s = c : s latexMonoMunge :: Char -> String -> String latexMonoMunge ' ' (' ':s) = "\\ \\ " ++ s latexMonoMunge ' ' ('\\':' ':s) = "\\ \\ " ++ s latexMonoMunge '\n' s = '\\' : '\\' : s latexMonoMunge c s = latexMunge c s ------------------------------------------------------------------------------- -- * Doc Markup ------------------------------------------------------------------------------- latexMarkup :: HasOccName a => DocMarkup (Wrap a) (StringContext -> LaTeX -> LaTeX) latexMarkup = Markup { markupParagraph = \p v -> blockElem (p v (text "\\par")) , markupEmpty = \_ -> id , markupString = \s v -> inlineElem (text (fixString v s)) , markupAppend = \l r v -> l v . r v , markupIdentifier = \i v -> inlineElem (markupId v (fmap occName i)) , markupIdentifierUnchecked = \i v -> inlineElem (markupId v (fmap snd i)) , markupModule = \(ModLink m mLabel) v -> case mLabel of Just lbl -> inlineElem . tt $ lbl v empty Nothing -> inlineElem (let (mdl,_ref) = break (=='#') m in (tt (text mdl))) , markupWarning = \p v -> p v , markupEmphasis = \p v -> inlineElem (emph (p v empty)) , markupBold = \p v -> inlineElem (bold (p v empty)) , markupMonospaced = \p v -> inlineElem (markupMonospace p v) , markupUnorderedList = \p v -> blockElem (itemizedList (map (\p' -> p' v empty) p)) , markupPic = \p _ -> inlineElem (markupPic p) , markupMathInline = \p _ -> inlineElem (markupMathInline p) , markupMathDisplay = \p _ -> blockElem (markupMathDisplay p) , markupOrderedList = \p v -> blockElem (enumeratedList (map (\p' -> p' v empty) p)) , markupDefList = \l v -> blockElem (descriptionList (map (\(a,b) -> (a v empty, b v empty)) l)) , markupCodeBlock = \p _ -> blockElem (quote (verb (p Verb empty))) , markupHyperlink = \(Hyperlink u l) v -> inlineElem (markupLink u (fmap (\x -> x v empty) l)) , markupAName = \_ _ -> id -- TODO , markupProperty = \p _ -> blockElem (quote (verb (text p))) , markupExample = \e _ -> blockElem (quote (verb (text $ unlines $ map exampleToString e))) , markupHeader = \(Header l h) p -> blockElem (header l (h p empty)) , markupTable = \(Table h b) p -> blockElem (table h b p) } where blockElem :: LaTeX -> LaTeX -> LaTeX blockElem = ($$) inlineElem :: LaTeX -> LaTeX -> LaTeX inlineElem = (<>) header 1 d = text "\\section*" <> braces d header 2 d = text "\\subsection*" <> braces d header l d | l > 0 && l <= 6 = text "\\subsubsection*" <> braces d header l _ = error $ "impossible header level in LaTeX generation: " ++ show l table _ _ _ = text "{TODO: Table}" fixString Plain s = latexFilter s fixString Verb s = s fixString Mono s = latexMonoFilter s markupMonospace p Verb = p Verb empty markupMonospace p _ = tt (p Mono empty) markupLink url mLabel = case mLabel of Just label -> text "\\href" <> braces (text url) <> braces label Nothing -> text "\\url" <> braces (text url) -- Is there a better way of doing this? Just a space is an aribtrary choice. markupPic (Picture uri title) = parens (imageText title) where imageText Nothing = beg imageText (Just t) = beg <> text " " <> text t beg = text "image: " <> text uri markupMathInline mathjax = text "\\(" <> text mathjax <> text "\\)" markupMathDisplay mathjax = text "\\[" <> text mathjax <> text "\\]" markupId v wrappedOcc = case v of Verb -> text i Mono -> text "\\haddockid" <> braces (text . latexMonoFilter $ i) Plain -> text "\\haddockid" <> braces (text . latexFilter $ i) where i = showWrapped occNameString wrappedOcc docToLaTeX :: Doc DocName -> LaTeX docToLaTeX doc = markup latexMarkup doc Plain empty documentationToLaTeX :: Documentation DocName -> Maybe LaTeX documentationToLaTeX = fmap docToLaTeX . fmap _doc . combineDocumentation rdrDocToLaTeX :: Doc RdrName -> LaTeX rdrDocToLaTeX doc = markup latexMarkup doc Plain empty data StringContext = Plain -- ^ all special characters have to be escape | Mono -- ^ on top of special characters, escape space chraacters | Verb -- ^ don't escape anything latexStripTrailingWhitespace :: Doc a -> Doc a latexStripTrailingWhitespace (DocString s) | null s' = DocEmpty | otherwise = DocString s where s' = reverse (dropWhile isSpace (reverse s)) latexStripTrailingWhitespace (DocAppend l r) | DocEmpty <- r' = latexStripTrailingWhitespace l | otherwise = DocAppend l r' where r' = latexStripTrailingWhitespace r latexStripTrailingWhitespace (DocParagraph p) = latexStripTrailingWhitespace p latexStripTrailingWhitespace other = other ------------------------------------------------------------------------------- -- * LaTeX utils ------------------------------------------------------------------------------- itemizedList :: [LaTeX] -> LaTeX itemizedList items = text "\\vbox{\\begin{itemize}" $$ vcat (map (text "\\item" $$) items) $$ text "\\end{itemize}}" enumeratedList :: [LaTeX] -> LaTeX enumeratedList items = text "\\vbox{\\begin{enumerate}" $$ vcat (map (text "\\item " $$) items) $$ text "\\end{enumerate}}" descriptionList :: [(LaTeX,LaTeX)] -> LaTeX descriptionList items = text "\\vbox{\\begin{description}" $$ vcat (map (\(a,b) -> text "\\item" <> brackets a <> text "\\hfill \\par" $$ b) items) $$ text "\\end{description}}" tt :: LaTeX -> LaTeX tt ltx = text "\\haddocktt" <> braces ltx decltt :: LaTeX -> LaTeX decltt ltx = text "\\haddockdecltt" <> braces (text filtered) where filtered = latexMonoFilter (latex2String ltx) emph :: LaTeX -> LaTeX emph ltx = text "\\emph" <> braces ltx bold :: LaTeX -> LaTeX bold ltx = text "\\textbf" <> braces ltx -- TODO: @verbatim@ is too much since -- -- * Haddock supports markup _inside_ of codeblocks. Right now, the LaTeX -- representing that markup gets printed verbatim -- * Verbatim environments are not supported everywhere (example: not nested -- inside a @tabulary@ environment) verb :: LaTeX -> LaTeX verb doc = text "{\\haddockverb\\begin{verbatim}" $$ doc <> text "\\end{verbatim}}" -- NB. swallow a trailing \n in the verbatim text by appending the -- \end{verbatim} directly, otherwise we get spurious blank lines at the -- end of code blocks. quote :: LaTeX -> LaTeX quote doc = text "\\begin{quote}" $$ doc $$ text "\\end{quote}" dcolon, arrow, lollipop, darrow, forallSymbol, starSymbol, atSign :: Bool -> LaTeX dcolon unicode = text (if unicode then "∷" else "::") arrow unicode = text (if unicode then "→" else "->") lollipop unicode = text (if unicode then "⊸" else "%1 ->") darrow unicode = text (if unicode then "⇒" else "=>") forallSymbol unicode = text (if unicode then "∀" else "forall") starSymbol unicode = text (if unicode then "★" else "*") atSign unicode = text (if unicode then "@" else "@") multAnnotation :: LaTeX multAnnotation = text "%" dot :: LaTeX dot = char '.' parenList :: [LaTeX] -> LaTeX parenList = parens . hsep . punctuate comma ubxParenList :: [LaTeX] -> LaTeX ubxParenList = ubxparens . hsep . punctuate comma ubxparens :: LaTeX -> LaTeX ubxparens h = text "(#" <+> h <+> text "#)" nl :: LaTeX nl = text "\\\\" keyword :: String -> LaTeX keyword = text infixr 4 <-> -- combining table cells (<->) :: LaTeX -> LaTeX -> LaTeX a <-> b = a <+> char '&' <+> b