diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Haddock/Backends/LaTeX.hs | 1082 | ||||
| -rw-r--r-- | src/Haddock/Options.hs | 8 | ||||
| -rw-r--r-- | src/Haddock/Utils.hs | 6 | ||||
| -rw-r--r-- | src/Main.hs | 5 |
4 files changed, 1101 insertions, 0 deletions
diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs new file mode 100644 index 00000000..78baedbc --- /dev/null +++ b/src/Haddock/Backends/LaTeX.hs @@ -0,0 +1,1082 @@ +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Backends.LaTeX +-- Copyright : (c) Simon Marlow 2010 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- + +module Haddock.Backends.LaTeX ( + ppLaTeX +) where + +import Haddock.Types +import Haddock.Utils +import Haddock.GhcUtils +import Pretty hiding (Doc) +import qualified Pretty + +import GHC +import OccName +import Name ( isTyConName, nameOccName ) +import RdrName ( rdrNameOcc, isRdrTc ) +import BasicTypes ( IPName(..), Boxity(..) ) +import Outputable ( Outputable, ppr, showSDoc ) +import FastString ( unpackFS, unpackLitString ) + +import qualified Data.Map as Map +import System.Directory +import System.FilePath +import Data.Char +import Control.Monad +import Data.Maybe +import Data.List +-- 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 = "haddock.sty" + +type LaTeX = Pretty.Doc + +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") + + writeFile filename (render 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 (text ", ") $ + map exportListItem $ + filter forSummary exports), + text " ) where" + ], + text "\\haddockendheader" $$ text "", + description, + body + ] + + description + = case ifaceRnDoc iface of + Nothing -> empty + Just doc -> docToLaTeX doc + + body = processExports exports + -- + writeFile (odir </> moduleLaTeXFile mdl) (fullRender PageMode 80 1 string_txt "" tex) + + +string_txt :: TextDetails -> String -> String +string_txt (Chr c) s = c:s +string_txt (Str s1) s2 = s1 ++ s2 +string_txt (PStr s1) s2 = unpackFS s1 ++ s2 +string_txt (LStr s1 _) s2 = unpackLitString s1 ++ s2 + +exportListItem :: ExportItem DocName -> LaTeX +exportListItem (ExportDecl decl _doc subdocs _insts) + = ppDocBinder (declName decl) <> + case subdocs of + [] -> empty + xs -> 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 DocName] -> LaTeX +processExports [] = empty +processExports (decl : es) + | Just sig <- isSimpleSig decl + = multiDecl [ ppTypeSig (getName name) typ False + | (name,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 DocName -> Maybe (DocName, HsType DocName) +isSimpleSig (ExportDecl (L _ (SigD (TypeSig (L _ n) (L _ t)))) + (Nothing, argDocs) _ _) + | Map.null argDocs = Just (n, t) +isSimpleSig _ = Nothing + +isExportModule :: ExportItem DocName -> Maybe Module +isExportModule (ExportModule m) = Just m +isExportModule _ = Nothing + +processExport :: ExportItem DocName -> LaTeX +processExport (ExportGroup lev _id0 doc) + = ppDocGroup lev (docToLaTeX doc) +processExport (ExportDecl decl doc subdocs insts) + = ppDecl decl doc insts subdocs +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 + +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" + +declName :: LHsDecl DocName -> DocName +declName (L _ decl) = case decl of + TyClD d -> unLoc $ tcdLName d + SigD (TypeSig (L _ n) _) -> n + _ -> error "declaration not supported by declName" + +forSummary :: (ExportItem DocName) -> 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 + +ppDecl :: LHsDecl DocName + -> DocForDecl DocName + -> [DocInstance DocName] + -> [(DocName, DocForDecl DocName)] + -> LaTeX + +ppDecl (L loc decl) (mbDoc, fnArgsDoc) instances subdocs = case decl of + TyClD d@(TyFamily {}) -> ppTyFam False loc mbDoc d unicode + TyClD d@(TyData {}) + | Nothing <- tcdTyPats d -> ppDataDecl instances subdocs loc mbDoc d unicode + | Just _ <- tcdTyPats d -> ppDataInst loc mbDoc d + TyClD d@(TySynonym {}) + | Nothing <- tcdTyPats d -> ppTySyn loc (mbDoc, fnArgsDoc) d unicode + | Just _ <- tcdTyPats d -> ppTyInst False loc mbDoc d unicode + TyClD d@(ClassDecl {}) -> ppClassDecl instances loc mbDoc subdocs d unicode + SigD (TypeSig (L _ n) (L _ t)) -> ppFunSig loc (mbDoc, fnArgsDoc) n t unicode False + ForD d -> ppFor loc (mbDoc, fnArgsDoc) d unicode + InstD _ -> empty + _ -> error "declaration not supported by ppDecl" + where + unicode = False + +ppTyFam _ _ _ _ _ = + error "type family declarations are currently not supported by --latex" + +ppDataInst _ _ _ = + error "data instance declarations are currently not supported by --latex" + +ppTyInst _ _ _ _ _ = + error "type instance declarations are currently not supported by --latex" + +ppFor _ _ _ _ = + error "foreign declarations are currently not supported by --latex" + +-- ----------------------------------------------------------------------------- +-- Type Synonyms + +-- we skip type patterns for now +ppTySyn :: SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool -> LaTeX + +ppTySyn loc doc (TySynonym (L _ name) ltyvars _ ltype) unicode + = ppTypeOrFunSig loc name (unLoc ltype) doc + (full, hdr, char '=') unicode False + where + hdr = hsep (keyword "type" : ppDocBinder name : ppTyVars ltyvars) + full = hdr <+> char '=' <+> ppLType unicode ltype + +ppTySyn _ _ _ _ = error "declaration not supported by ppTySyn" + +-- ----------------------------------------------------------------------------- +-- Function signatures + +ppFunSig :: SrcSpan -> DocForDecl DocName -> DocName -> HsType DocName + -> Bool -> Bool + -> LaTeX +ppFunSig loc doc docname typ unicode methods = + ppTypeOrFunSig loc docname typ doc + (ppTypeSig name typ False, ppSymName name, dcolon unicode) + unicode methods + where + name = getName docname + +ppTypeOrFunSig :: SrcSpan -> DocName -> HsType DocName -> + DocForDecl DocName -> (LaTeX, LaTeX, LaTeX) + -> Bool -> Bool -> LaTeX +ppTypeOrFunSig _loc _docname typ (doc, argDocs) (pref1, pref2, sep0) + unicode methods + | Map.null argDocs = + declWithDoc pref1 (fmap docToLaTeX doc) + | otherwise = + declWithDoc pref2 $ Just $ + text "\\haddockbeginargs" $$ + do_args 0 sep0 typ $$ + text "\\end{tabulary}\\par" $$ + maybe empty docToLaTeX doc + where + do_largs n leader (L _ t) = do_args n leader t + + arg_doc n = rDoc (Map.lookup n argDocs) + + do_args :: Int -> LaTeX -> (HsType DocName) -> LaTeX + do_args n leader (HsForAllTy Explicit tvs lctxt ltype) + = decltt leader <-> + decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]) <+> + ppLContextNoArrow lctxt unicode) <+> nl $$ + do_largs n (darrow unicode) ltype + + do_args n leader (HsForAllTy Implicit _ lctxt ltype) + | not (null (unLoc lctxt)) + = decltt leader <-> decltt (ppLContextNoArrow lctxt unicode) <+> nl $$ + do_largs n (darrow unicode) ltype + -- if we're not showing any 'forall' or class constraints or + -- anything, skip having an empty line for the context. + | otherwise + = do_largs n leader 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 + +ppTypeSig :: Name -> HsType DocName -> Bool -> LaTeX +ppTypeSig nm ty unicode = + ppSymName nm <+> dcolon unicode <+> ppType unicode ty + +ppTyVars :: [LHsTyVarBndr DocName] -> [LaTeX] +ppTyVars tvs = map ppSymName (tyvarNames tvs) + +tyvarNames :: [LHsTyVarBndr DocName] -> [Name] +tyvarNames = map (getName . hsTyVarName . unLoc) + +declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX +declWithDoc decl doc = + text "\\begin{haddockdesc}" $$ + text "\\item[\\begin{tabular}{@{}l}" $$ + text (latexMonoFilter (render decl)) $$ + text "\\end{tabular}]" <> + (if isNothing doc then empty else text "\\haddockbegindoc") $$ + maybe empty id 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[" $$ + text (latexMonoFilter (render decl)) $$ + text "]" + | 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 -> Located [LHsPred DocName] -> DocName + -> [Located (HsTyVarBndr DocName)] -> [Located ([DocName], [DocName])] + -> Bool -> LaTeX +ppClassHdr summ lctxt n tvs fds unicode = + keyword "class" + <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode else empty) + <+> ppAppDocNameNames summ n (tyvarNames $ tvs) + <+> ppFds fds unicode + + +ppFds :: [Located ([DocName], [DocName])] -> Bool -> LaTeX +ppFds fds unicode = + if null fds then empty else + char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds)) + where + fundep (vars1,vars2) = hsep (map ppDocName vars1) <+> arrow unicode <+> + hsep (map ppDocName vars2) + + +ppClassDecl :: [DocInstance DocName] -> SrcSpan + -> Maybe (Doc DocName) -> [(DocName, DocForDecl DocName)] + -> TyClDecl DocName -> Bool -> LaTeX +ppClassDecl instances loc mbDoc subdocs + decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ ats _) unicode + = declWithDoc classheader (if null body then Nothing else Just (vcat body)) $$ + instancesBit + where + classheader + | null lsigs = hdr unicode + | otherwise = hdr unicode <+> keyword "where" + + nm = unLoc $ tcdLName decl + + hdr = ppClassHdr False lctxt (unLoc lname) ltyvars lfds + + body = catMaybes [fmap docToLaTeX mbDoc, body_] + + body_ + | null lsigs, null ats = Nothing + | null ats = Just methodTable +-- | otherwise = atTable $$ methodTable + + methodTable = + text "\\haddockpremethods{}\\textbf{Methods}" $$ + vcat [ ppFunSig loc doc n typ unicode True + | L _ (TypeSig (L _ n) (L _ typ)) <- lsigs + , let doc = lookupAnySubdoc n subdocs ] + +-- atTable = abovesSep s8 $ [ ppAssocType summary links doc at unicode | at <- ats +-- , let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ] + + instancesBit + | null instances = empty + | all (isNothing . snd) instances = + declWithDoc (vcat (map (ppInstDecl unicode) (map fst instances))) Nothing + | otherwise = vcat (map (ppDocInstance unicode) instances) + +ppClassDecl _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" + + +-- | 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 DocName -> LaTeX +ppDocInstance unicode (instHead, mbDoc) = + declWithDoc (ppInstDecl unicode instHead) (fmap docToLaTeX mbDoc) + +ppInstDecl :: Bool -> InstHead DocName -> LaTeX +ppInstDecl unicode instHead = keyword "instance" <+> ppInstHead unicode instHead + +ppInstHead :: Bool -> InstHead DocName -> LaTeX +ppInstHead unicode ([], n, ts) = ppAppNameTypes n ts unicode +ppInstHead unicode (ctxt, n, ts) = ppContextNoLocs ctxt unicode <+> ppAppNameTypes n ts unicode + +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 + + +ppDataDecl :: [DocInstance DocName] -> + [(DocName, DocForDecl DocName)] -> + SrcSpan -> Maybe (Doc DocName) -> TyClDecl DocName -> Bool -> + LaTeX +ppDataDecl instances subdocs loc mbDoc dataDecl unicode + + = declWithDoc (ppDataHeader dataDecl unicode <+> whereBit) + (if null body then Nothing else Just (vcat body)) + $$ instancesBit + + where + docname = unLoc . tcdLName $ dataDecl + cons = tcdCons dataDecl + resTy = (con_res . unLoc . head) cons + + body = catMaybes [constrBit, fmap docToLaTeX mbDoc] + + (whereBit, leaders) + | null cons = (empty,[]) + | otherwise = case resTy of + ResTyGADT _ -> (decltt (keyword "where"), repeat empty) + _ -> (empty, (decltt (text "=") : repeat (decltt (text "|")))) + + constrBit + | null cons = Nothing + | otherwise = Just $ + text "\\haddockbeginconstrs" $$ + vcat (zipWith (ppSideBySideConstr subdocs unicode) leaders cons) $$ + text "\\end{tabulary}\\par" + + instancesBit + | null instances = empty + | all (isNothing . snd) instances = + declWithDoc (vcat (map (ppInstDecl unicode) (map fst instances))) Nothing + | otherwise = vcat (map (ppDocInstance unicode) instances) + +isRecCon :: Located (ConDecl a) -> Bool +isRecCon lcon = case con_details (unLoc lcon) of + RecCon _ -> True + _ -> False + + +-- ppConstrHdr is for (non-GADT) existentials constructors' syntax +#if __GLASGOW_HASKELL__ == 612 +ppConstrHdr :: HsExplicitForAll -> [Name] -> HsContext DocName -> Bool -> LaTeX +#else +ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Bool -> LaTeX +#endif +ppConstrHdr forall tvs ctxt unicode + = (if null tvs then empty else ppForall) + <+> + (if null ctxt then empty else ppContextNoArrow ctxt unicode <+> darrow unicode <+> text " ") + where + ppForall = case forall of + Explicit -> forallSymbol unicode <+> hsep (map ppName tvs) <+> text ". " + Implicit -> empty + +ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LaTeX + -> LConDecl DocName -> LaTeX +ppSideBySideConstr subdocs unicode leader (L _ con) = + leader <-> + case con_res con of + ResTyH98 -> case con_details con of + + PrefixCon args -> + decltt (hsep ((header_ unicode <+> ppBinder occ) : + map (ppLParendType unicode) args)) + <-> rDoc mbDoc <+> nl + + RecCon fields -> + (decltt (header_ unicode <+> ppBinder occ) + <-> rDoc mbDoc <+> nl) + $$ + doRecordFields fields + + InfixCon arg1 arg2 -> + decltt (hsep [ header_ unicode <+> ppLParendType unicode arg1, + ppBinder occ, + 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 fields) -> doGADTCon (hsConDeclArgTys cd) resTy <+> nl $$ + doRecordFields fields + InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy + + where + doRecordFields fields = + vcat (map (ppSideBySideField subdocs unicode) fields) + + doGADTCon args resTy = decltt (ppBinder occ <+> dcolon unicode <+> hsep [ + ppForAll forall ltvs (con_cxt con) unicode, + ppLType unicode (foldr mkFunTy resTy args) ] + ) <-> rDoc mbDoc + + + header_ = ppConstrHdr forall tyVars context + occ = docNameOcc . unLoc . con_name $ con + ltvs = con_qvars con + tyVars = tyvarNames (con_qvars con) + context = unLoc (con_cxt con) + forall = con_explicit 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. + -- 'join' is in Maybe. + mbDoc = join $ fmap fst $ lookup (unLoc $ con_name con) subdocs + mkFunTy a b = noLoc (HsFunTy a b) + +ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName -> LaTeX +ppSideBySideField subdocs unicode (ConDeclField (L _ name) ltype _) = + decltt (ppBinder (docNameOcc name) + <+> dcolon unicode <+> ppLType unicode ltype) <-> rDoc mbDoc + where + -- don't use cd_fld_doc for same reason we don't use con_doc above + mbDoc = join $ fmap fst $ lookup name subdocs + +-- {- +-- 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 ] +-- -} + +-- | Print the LHS of a data\/newtype declaration. +-- Currently doesn't handle 'data instance' decls or kind signatures +ppDataHeader :: TyClDecl DocName -> Bool -> LaTeX +ppDataHeader decl unicode + | not (isDataDecl decl) = error "ppDataHeader: illegal argument" + | otherwise = + -- newtype or data + (if tcdND decl == NewType then keyword "newtype" else keyword "data") <+> + -- context + ppLContext (tcdCtxt decl) unicode <+> + -- T a b c ..., or a :+: b + ppTyClBinderWithVars False decl + + +-------------------------------------------------------------------------------- +-- TyClDecl helpers +-------------------------------------------------------------------------------- + + +-- | Print a type family / newtype / data / class binder and its variables +ppTyClBinderWithVars :: Bool -> TyClDecl DocName -> LaTeX +ppTyClBinderWithVars summ decl = + ppAppDocNameNames summ (unLoc $ tcdLName decl) (tyvarNames $ tcdTyVars decl) + + +-------------------------------------------------------------------------------- +-- Type applications +-------------------------------------------------------------------------------- + + +-- | Print an application of a DocName and a list of HsTypes +ppAppNameTypes :: DocName -> [HsType DocName] -> Bool -> LaTeX +ppAppNameTypes n ts unicode = ppTypeApp n ts ppDocName (ppParendType unicode) + + +-- | Print an application of a DocName and a list of Names +ppAppDocNameNames :: Bool -> DocName -> [Name] -> LaTeX +ppAppDocNameNames _summ n ns = + ppTypeApp n ns (ppBinder . docNameOcc) 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, ppLContextNoArrow :: Located (HsContext DocName) -> Bool -> LaTeX +ppLContext = ppContext . unLoc +ppLContextNoArrow = ppContextNoArrow . unLoc + + +ppContextNoArrow :: HsContext DocName -> Bool -> LaTeX +ppContextNoArrow [] _ = empty +ppContextNoArrow cxt unicode = pp_hs_context (map unLoc cxt) unicode + + +ppContextNoLocs :: [HsPred DocName] -> Bool -> LaTeX +ppContextNoLocs [] _ = empty +ppContextNoLocs cxt unicode = pp_hs_context cxt unicode <+> darrow unicode + + +ppContext :: HsContext DocName -> Bool -> LaTeX +ppContext cxt unicode = ppContextNoLocs (map unLoc cxt) unicode + + +pp_hs_context :: [HsPred DocName] -> Bool -> LaTeX +pp_hs_context [] _ = empty +pp_hs_context [p] unicode = ppPred unicode p +pp_hs_context cxt unicode = parenList (map (ppPred unicode) cxt) + + +ppPred :: Bool -> HsPred DocName -> LaTeX +ppPred unicode (HsClassP n ts) = ppAppNameTypes n (map unLoc ts) unicode +ppPred unicode (HsEqualP t1 t2) = ppLType unicode t1 <> text "~" <> ppLType unicode t2 +ppPred unicode (HsIParam (IPName n) t) + = char '?' <> ppDocName n <> dcolon unicode <> ppLType unicode t + + +-- ---------------------------------------------------------------------------- +-- Types and contexts + +ppKind :: Outputable a => a -> LaTeX +ppKind k = text (showSDoc (ppr k)) + +ppBang :: HsBang -> LaTeX +ppBang HsNoBang = empty +ppBang _ = char '!' -- Unpacked args is an implementation detail, + +tupleParens :: Boxity -> [LaTeX] -> LaTeX +tupleParens Boxed = parenList +tupleParens Unboxed = ubxParenList + +-- ----------------------------------------------------------------------------- +-- Rendering of HsType +-- +-- Stolen from Html and tweaked for LaTeX generation + +pREC_TOP, pREC_FUN, pREC_OP, pREC_CON :: Int + +pREC_TOP = (0 :: Int) -- type in ParseIface.y in GHC +pREC_FUN = (1 :: Int) -- btype in ParseIface.y in GHC + -- Used for LH arg of (->) +pREC_OP = (2 :: Int) -- Used for arg of any infix operator + -- (we don't keep their fixities around) +pREC_CON = (3 :: Int) -- Used for arg of type applicn: + -- always parenthesise unless atomic + +maybeParen :: Int -- Precedence of context + -> Int -- Precedence of top-level operator + -> LaTeX -> LaTeX -- Wrap in parens if (ctxt >= op) +maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p + | otherwise = p + + +ppLType, ppLParendType, ppLFunLhType :: Bool -> Located (HsType DocName) -> LaTeX +ppLType unicode y = ppType unicode (unLoc y) +ppLParendType unicode y = ppParendType unicode (unLoc y) +ppLFunLhType unicode y = ppFunLhType unicode (unLoc y) + + +ppType, ppParendType, ppFunLhType :: Bool -> HsType DocName -> LaTeX +ppType unicode ty = ppr_mono_ty pREC_TOP ty unicode +ppParendType unicode ty = ppr_mono_ty pREC_CON ty unicode +ppFunLhType unicode ty = ppr_mono_ty pREC_FUN ty unicode + + +-- Drop top-level for-all type variables in user style +-- since they are implicit in Haskell + +#if __GLASGOW_HASKELL__ == 612 +ppForAll :: HsExplicitForAll -> [Located (HsTyVarBndr DocName)] +#else +ppForAll :: HsExplicitFlag -> [Located (HsTyVarBndr DocName)] +#endif + -> Located (HsContext DocName) -> Bool -> LaTeX +ppForAll expl tvs cxt unicode + | show_forall = forall_part <+> ppLContext cxt unicode + | otherwise = ppLContext cxt unicode + where + show_forall = not (null tvs) && is_explicit + is_explicit = case expl of {Explicit -> True; Implicit -> False} + forall_part = hsep (forallSymbol unicode : ppTyVars tvs) <> dot + + +ppr_mono_lty :: Int -> LHsType DocName -> Bool -> LaTeX +ppr_mono_lty ctxt_prec ty unicode = ppr_mono_ty ctxt_prec (unLoc ty) unicode + + +ppr_mono_ty :: Int -> HsType DocName -> Bool -> LaTeX +ppr_mono_ty ctxt_prec (HsForAllTy expl tvs ctxt ty) unicode + = maybeParen ctxt_prec pREC_FUN $ + hsep [ppForAll expl tvs 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 name) _ = 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 _ (HsKindSig ty kind) u = parens (ppr_mono_lty pREC_TOP ty u <+> dcolon u <+> ppKind 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 _ (HsPredTy p) u = parens (ppPred u p) +ppr_mono_ty _ (HsNumTy n) _ = text (show n) -- generics only +ppr_mono_ty _ (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy" +#if __GLASGOW_HASKELL__ == 612 +ppr_mono_ty _ (HsSpliceTyOut {}) _ = error "ppr_mono_ty HsQuasiQuoteTy" +#else +ppr_mono_ty _ (HsQuasiQuoteTy {}) _ = error "ppr_mono_ty HsQuasiQuoteTy" +#endif +ppr_mono_ty _ (HsRecTy {}) _ = error "ppr_mono_ty HsRecTy" + +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 + = 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 = docNameOcc . unLoc $ op + +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_lty ctxt_prec ty unicode + + +ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Bool -> LaTeX +ppr_fun_ty ctxt_prec ty1 ty2 unicode + = let p1 = ppr_mono_lty pREC_FUN ty1 unicode + p2 = ppr_mono_lty pREC_TOP ty2 unicode + in + maybeParen ctxt_prec pREC_FUN $ + sep [p1, arrow unicode <+> p2] + +-- ----------------------------------------------------------------------------- +-- Names + +ppBinder :: OccName -> LaTeX +ppBinder n + | isVarSym n = parens $ ppOccName n + | otherwise = ppOccName n + +ppVerbBinder :: OccName -> LaTeX +ppVerbBinder n + | isVarSym n = parens $ ppVerbOccName n + | otherwise = ppVerbOccName n + +ppSymName :: Name -> LaTeX +ppSymName name + | isNameSym name = parens $ ppName name + | otherwise = ppName name + +ppVerbOccName :: OccName -> LaTeX +ppVerbOccName = text . latexFilter . occNameString + +ppOccName :: OccName -> LaTeX +ppOccName = text . occNameString + +ppVerbDocName :: DocName -> LaTeX +ppVerbDocName = ppVerbOccName . docNameOcc + +ppVerbRdrName :: RdrName -> LaTeX +ppVerbRdrName = ppVerbOccName . rdrNameOcc + +ppDocName :: DocName -> LaTeX +ppDocName = ppOccName . docNameOcc + +ppLDocName :: Located DocName -> LaTeX +ppLDocName (L _ d) = ppDocName d + +ppDocBinder :: DocName -> LaTeX +ppDocBinder = ppBinder . docNameOcc + +ppVerbDocBinder :: DocName -> LaTeX +ppVerbDocBinder = ppVerbBinder . docNameOcc + +ppName :: Name -> LaTeX +ppName = ppOccName . nameOccName + +ppVerbName :: Name -> LaTeX +ppVerbName = ppVerbOccName . nameOccName + +latexFilter :: String -> String +latexFilter = foldr latexMunge "" + +latexMonoFilter :: String -> String +latexMonoFilter = foldr latexMonoMunge "" + +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 ' ' s = '\\' : ' ' : s +latexMonoMunge '\n' s = '\\' : '\\' : s +latexMonoMunge c s = latexMunge c s + +-- ----------------------------------------------------------------------------- +-- Doc Markup + +parLatexMarkup :: (a -> LaTeX) -> (a -> Bool) + -> DocMarkup a (StringContext -> LaTeX) +parLatexMarkup ppId isTyCon = Markup { + markupParagraph = \p v -> p v <> text "\\par" $$ text "", + markupEmpty = \_ -> empty, + markupString = \s v -> text (fixString v s), + markupAppend = \l r v -> l v <> r v, + markupIdentifier = markupId, + markupModule = \m v -> let (mdl,_ref) = break (=='#') m in tt (text mdl), + markupEmphasis = \p v -> emph (p v), + markupMonospaced = \p v -> tt (p Mono), + markupUnorderedList = \p v -> itemizedList (map ($v) p) $$ text "", + markupPic = \path v -> parens (text "image: " <> text path), + markupOrderedList = \p v -> enumeratedList (map ($v) p) $$ text "", + markupDefList = \l v -> descriptionList (map (\(a,b) -> (a v, b v)) l), + markupCodeBlock = \p _ -> quote (verb (p Verb)) $$ text "", + markupURL = \u _ -> text "\\url" <> braces (text u), + markupAName = \_ _ -> empty, + markupExample = \e _ -> quote $ verb $ text $ unlines $ map exampleToString e + } + where + fixString Plain s = latexFilter s + fixString Verb s = s + fixString Mono s = latexMonoFilter s + + markupId id v = + case v of + Verb -> theid + Mono -> theid + Plain -> text "\\haddockid" <> braces theid + where theid = ppId (choose id) + + -- If an id can refer to multiple things, we give precedence to type + -- constructors. This should ideally be done during renaming from RdrName + -- to Name, but since we will move this process from GHC into Haddock in + -- the future, we fix it here in the meantime. + -- TODO: mention this rule in the documentation. + choose [] = error "empty identifier list in HsDoc" + choose [x] = x + choose (x:y:_) + | isTyCon x = x + | otherwise = y + +latexMarkup :: DocMarkup DocName (StringContext -> LaTeX) +latexMarkup = parLatexMarkup ppVerbDocName (isTyConName . getName) + +rdrLatexMarkup :: DocMarkup RdrName (StringContext -> LaTeX) +rdrLatexMarkup = parLatexMarkup ppVerbRdrName isRdrTc + +docToLaTeX :: Doc DocName -> LaTeX +docToLaTeX doc = markup latexMarkup doc Plain + +rdrDocToLaTeX :: Doc RdrName -> LaTeX +rdrDocToLaTeX doc = markup rdrLatexMarkup doc Plain + +data StringContext = Plain | Verb | Mono + +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 + +latexStripLeadingPara :: Doc a -> Doc a +latexStripLeadingPara (DocParagraph p) = p +latexStripLeadingPara (DocAppend l r) = DocAppend (latexStripLeadingPara l) r +latexStripLeadingPara d = d + +-- ----------------------------------------------------------------------------- +-- LaTeX utils + +itemizedList :: [LaTeX] -> LaTeX +itemizedList items = + text "\\begin{itemize}" $$ + vcat (map (text "\\item" $$) items) $$ + text "\\end{itemize}" + +enumeratedList :: [LaTeX] -> LaTeX +enumeratedList items = + text "\\begin{enumerate}" $$ + vcat (map (text "\\item " $$) items) $$ + text "\\end{enumerate}" + +descriptionList :: [(LaTeX,LaTeX)] -> LaTeX +descriptionList items = + text "\\begin{description}" $$ + vcat (map (\(a,b) -> text "\\item" <> brackets a <+> b) items) $$ + text "\\end{description}" + +tt :: LaTeX -> LaTeX +tt ltx = text "\\haddocktt" <> braces ltx + +decltt :: LaTeX -> LaTeX +decltt ltx = text "\\haddockdecltt" <> braces ltx + +emph :: LaTeX -> LaTeX +emph ltx = text "\\emph" <> braces ltx + +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, darrow, forallSymbol :: Bool -> LaTeX +dcolon unicode = text (if unicode then "∷" else "::") +arrow unicode = text (if unicode then "→" else "->") +darrow unicode = text (if unicode then "⇒" else "=>") +forallSymbol unicode = text (if unicode then "∀" else "forall") + +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 "#)" + +pabrackets :: LaTeX -> LaTeX +pabrackets 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 diff --git a/src/Haddock/Options.hs b/src/Haddock/Options.hs index c180c182..f2718e86 100644 --- a/src/Haddock/Options.hs +++ b/src/Haddock/Options.hs @@ -24,6 +24,7 @@ module Haddock.Options ( optSourceUrls, optWikiUrls, optDumpInterfaceFile, + optLaTeXStyle, verbosity, ghcFlags, ifacePairs @@ -57,6 +58,8 @@ data Flag | Flag_WikiModuleURL String | Flag_WikiEntityURL String | Flag_Xhtml + | Flag_LaTeX + | Flag_LaTeXStyle String | Flag_Help | Flag_Verbosity String | Flag_Version @@ -94,6 +97,8 @@ options backwardsCompat = Option ['h'] ["html"] (NoArg Flag_Html) "output in HTML", Option [] ["xhtml"] (NoArg Flag_Xhtml) "use experimental XHTML rendering", + Option [] ["latex"] (NoArg Flag_LaTeX) "use experimental LaTeX rendering", + Option [] ["latex-style"] (ReqArg Flag_LaTeXStyle "FILE") "provide your own LaTeX style in FILE", Option ['U'] ["use-unicode"] (NoArg Flag_UseUnicode) "use Unicode in HTML output", Option [] ["hoogle"] (NoArg Flag_Hoogle) "output for Hoogle", @@ -216,6 +221,9 @@ optDumpInterfaceFile :: [Flag] -> Maybe FilePath optDumpInterfaceFile flags = optLast [ str | Flag_DumpInterface str <- flags ] +optLaTeXStyle :: [Flag] -> Maybe String +optLaTeXStyle flags = optLast [ str | Flag_LaTeXStyle str <- flags ] + verbosity :: [Flag] -> Verbosity verbosity flags = case [ str | Flag_Verbosity str <- flags ] of diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs index 18d56c51..5bdae25f 100644 --- a/src/Haddock/Utils.hs +++ b/src/Haddock/Utils.hs @@ -37,6 +37,7 @@ module Haddock.Utils ( -- * List utilities replace, + spanWith, -- * MTL stuff MonadIO(..), @@ -325,6 +326,11 @@ html_xrefs = unsafePerformIO (readIORef html_xrefs_ref) replace :: Eq a => a -> a -> [a] -> [a] replace a b = map (\x -> if x == a then b else x) +spanWith :: (a -> Maybe b) -> [a] -> ([b],[a]) +spanWith p [] = ([],[]) +spanWith p xs@(a:as) + | Just b <- p a = let (bs,cs) = spanWith p as in (b:bs,cs) + | otherwise = ([],xs) ----------------------------------------------------------------------------- -- put here temporarily diff --git a/src/Main.hs b/src/Main.hs index 1bf2b717..f6f899f3 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -20,6 +20,7 @@ module Main (main) where import qualified Haddock.Backends.Html as Html import qualified Haddock.Backends.Xhtml as Xhtml +import qualified Haddock.Backends.LaTeX as LaTeX import Haddock.Backends.Hoogle import Haddock.Interface import Haddock.Lex @@ -179,6 +180,7 @@ render flags ifaces installedIfaces = do opt_html_help_format = optHtmlHelpFormat flags css_file = optCssFile flags odir = outputDir flags + opt_latex_style = optLaTeXStyle flags visibleIfaces = [ i | i <- ifaces, OptHide `notElem` ifaceOptions i ] @@ -227,6 +229,9 @@ render flags ifaces installedIfaces = do let pkgName2 = if pkgName == "main" && title /= [] then title else pkgName ppHoogle pkgName2 pkgVer title prologue visibleIfaces odir + when (Flag_LaTeX `elem` flags) $ do + LaTeX.ppLaTeX title packageStr visibleIfaces odir prologue opt_latex_style + libDir ------------------------------------------------------------------------------- -- Reading and dumping interface files |