1{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
2{-# LANGUAGE RecordWildCards #-}
3{-# LANGUAGE TypeFamilies #-}
4
5-----------------------------------------------------------------------------
6-- |
7-- Module      :  Haddock.Backends.LaTeX
8-- Copyright   :  (c) Simon Marlow      2010,
9--                    Mateusz Kowalczyk 2013
10-- License     :  BSD-like
11--
12-- Maintainer  :  haddock@projects.haskell.org
13-- Stability   :  experimental
14-- Portability :  portable
15-----------------------------------------------------------------------------
16module Haddock.Backends.LaTeX (
17  ppLaTeX,
18) where
19
20import Documentation.Haddock.Markup
21import Haddock.Types
22import Haddock.Utils
23import Haddock.GhcUtils
24import Pretty hiding (Doc, quote)
25import qualified Pretty
26
27import BasicTypes           ( PromotionFlag(..) )
28import GHC
29import OccName
30import Name                 ( nameOccName )
31import RdrName              ( rdrNameOcc )
32import FastString           ( unpackFS )
33import Outputable           ( panic)
34
35import qualified Data.Map as Map
36import System.Directory
37import System.FilePath
38import Data.Char
39import Control.Monad
40import Data.Maybe
41import Data.List            ( sort )
42import Data.Void            ( absurd )
43import Prelude hiding ((<>))
44
45import Haddock.Doc (combineDocumentation)
46
47-- import Debug.Trace
48
49{- SAMPLE OUTPUT
50
51\haddockmoduleheading{\texttt{Data.List}}
52\hrulefill
53{\haddockverb\begin{verbatim}
54module Data.List (
55    (++),  head,  last,  tail,  init,  null,  length,  map,  reverse,
56  ) where\end{verbatim}}
57\hrulefill
58
59\section{Basic functions}
60\begin{haddockdesc}
61\item[\begin{tabular}{@{}l}
62head\ ::\ {\char 91}a{\char 93}\ ->\ a
63\end{tabular}]\haddockbegindoc
64Extract the first element of a list, which must be non-empty.
65\par
66
67\end{haddockdesc}
68\begin{haddockdesc}
69\item[\begin{tabular}{@{}l}
70last\ ::\ {\char 91}a{\char 93}\ ->\ a
71\end{tabular}]\haddockbegindoc
72Extract the last element of a list, which must be finite and non-empty.
73\par
74
75\end{haddockdesc}
76-}
77
78
79{- TODO
80 * don't forget fixity!!
81-}
82
83ppLaTeX :: String                       -- Title
84        -> Maybe String                 -- Package name
85        -> [Interface]
86        -> FilePath                     -- destination directory
87        -> Maybe (Doc GHC.RdrName)      -- prologue text, maybe
88        -> Maybe String                 -- style file
89        -> FilePath
90        -> IO ()
91
92ppLaTeX title packageStr visible_ifaces odir prologue maybe_style libdir
93 = do
94   createDirectoryIfMissing True odir
95   when (isNothing maybe_style) $
96     copyFile (libdir </> "latex" </> haddockSty) (odir </> haddockSty)
97   ppLaTeXTop title packageStr odir prologue maybe_style visible_ifaces
98   mapM_ (ppLaTeXModule title odir) visible_ifaces
99
100
101haddockSty :: FilePath
102haddockSty = "haddock.sty"
103
104
105type LaTeX = Pretty.Doc
106
107-- | Default way of rendering a 'LaTeX'. The width is 90 by default (since 100
108-- often overflows the line).
109latex2String :: LaTeX -> String
110latex2String = fullRender PageMode 90 1 txtPrinter ""
111
112ppLaTeXTop
113   :: String
114   -> Maybe String
115   -> FilePath
116   -> Maybe (Doc GHC.RdrName)
117   -> Maybe String
118   -> [Interface]
119   -> IO ()
120
121ppLaTeXTop doctitle packageStr odir prologue maybe_style ifaces = do
122
123  let tex = vcat [
124        text "\\documentclass{book}",
125        text "\\usepackage" <> braces (maybe (text "haddock") text maybe_style),
126        text "\\begin{document}",
127        text "\\begin{titlepage}",
128        text "\\begin{haddocktitle}",
129        text doctitle,
130        text "\\end{haddocktitle}",
131        case prologue of
132           Nothing -> empty
133           Just d  -> vcat [text "\\begin{haddockprologue}",
134                            rdrDocToLaTeX d,
135                            text "\\end{haddockprologue}"],
136        text "\\end{titlepage}",
137        text "\\tableofcontents",
138        vcat [ text "\\input" <> braces (text mdl) | mdl <- mods ],
139        text "\\end{document}"
140        ]
141
142      mods = sort (map (moduleBasename.ifaceMod) ifaces)
143
144      filename = odir </> (fromMaybe "haddock" packageStr <.> "tex")
145
146  writeUtf8File filename (show tex)
147
148
149ppLaTeXModule :: String -> FilePath -> Interface -> IO ()
150ppLaTeXModule _title odir iface = do
151  createDirectoryIfMissing True odir
152  let
153      mdl = ifaceMod iface
154      mdl_str = moduleString mdl
155
156      exports = ifaceRnExportItems iface
157
158      tex = vcat [
159        text "\\haddockmoduleheading" <> braces (text mdl_str),
160        text "\\label{module:" <> text mdl_str <> char '}',
161        text "\\haddockbeginheader",
162        verb $ vcat [
163           text "module" <+> text mdl_str <+> lparen,
164           text "    " <> fsep (punctuate (char ',') $
165                               map exportListItem $
166                               filter forSummary exports),
167           text "  ) where"
168         ],
169        text "\\haddockendheader" $$ text "",
170        description,
171        body
172       ]
173
174      description
175          = (fromMaybe empty . documentationToLaTeX . ifaceRnDoc) iface
176
177      body = processExports exports
178  --
179  writeUtf8File (odir </> moduleLaTeXFile mdl) (show tex)
180
181-- | Prints out an entry in a module export list.
182exportListItem :: ExportItem DocNameI -> LaTeX
183exportListItem ExportDecl { expItemDecl = decl, expItemSubDocs = subdocs }
184  = let (leader, names) = declNames decl
185    in sep (punctuate comma [ leader <+> ppDocBinder name | name <- names ]) <>
186         case subdocs of
187           [] -> empty
188           _  -> parens (sep (punctuate comma (map (ppDocBinder . fst) subdocs)))
189exportListItem (ExportNoDecl y [])
190  = ppDocBinder y
191exportListItem (ExportNoDecl y subs)
192  = ppDocBinder y <> parens (sep (punctuate comma (map ppDocBinder subs)))
193exportListItem (ExportModule mdl)
194  = text "module" <+> text (moduleString mdl)
195exportListItem _
196  = error "exportListItem"
197
198
199-- Deal with a group of undocumented exports together, to avoid lots
200-- of blank vertical space between them.
201processExports :: [ExportItem DocNameI] -> LaTeX
202processExports [] = empty
203processExports (decl : es)
204  | Just sig <- isSimpleSig decl
205  = multiDecl [ ppTypeSig (map getName names) typ False
206              | (names,typ) <- sig:sigs ] $$
207    processExports es'
208  where (sigs, es') = spanWith isSimpleSig es
209processExports (ExportModule mdl : es)
210  = declWithDoc (vcat [ text "module" <+> text (moduleString m) | m <- mdl:mdls ]) Nothing $$
211    processExports es'
212  where (mdls, es') = spanWith isExportModule es
213processExports (e : es) =
214  processExport e $$ processExports es
215
216
217isSimpleSig :: ExportItem DocNameI -> Maybe ([DocName], HsType DocNameI)
218isSimpleSig ExportDecl { expItemDecl = L _ (SigD _ (TypeSig _ lnames t))
219                       , expItemMbDoc = (Documentation Nothing Nothing, argDocs) }
220  | Map.null argDocs = Just (map unLoc lnames, unLoc (hsSigWcType t))
221isSimpleSig _ = Nothing
222
223
224isExportModule :: ExportItem DocNameI -> Maybe Module
225isExportModule (ExportModule m) = Just m
226isExportModule _ = Nothing
227
228
229processExport :: ExportItem DocNameI -> LaTeX
230processExport (ExportGroup lev _id0 doc)
231  = ppDocGroup lev (docToLaTeX doc)
232processExport (ExportDecl decl pats doc subdocs insts fixities _splice)
233  = ppDecl decl pats doc insts subdocs fixities
234processExport (ExportNoDecl y [])
235  = ppDocName y
236processExport (ExportNoDecl y subs)
237  = ppDocName y <> parens (sep (punctuate comma (map ppDocName subs)))
238processExport (ExportModule mdl)
239  = declWithDoc (text "module" <+> text (moduleString mdl)) Nothing
240processExport (ExportDoc doc)
241  = docToLaTeX $ _doc doc
242
243
244ppDocGroup :: Int -> LaTeX -> LaTeX
245ppDocGroup lev doc = sec lev <> braces doc
246  where sec 1 = text "\\section"
247        sec 2 = text "\\subsection"
248        sec 3 = text "\\subsubsection"
249        sec _ = text "\\paragraph"
250
251
252-- | Given a declaration, extract out the names being declared
253declNames :: LHsDecl DocNameI
254          -> ( LaTeX           --   to print before each name in an export list
255             , [DocName]       --   names being declared
256             )
257declNames (L _ decl) = case decl of
258  TyClD _ d  -> (empty, [tcdNameI d])
259  SigD _ (TypeSig _ lnames _ ) -> (empty, map unLoc lnames)
260  SigD _ (PatSynSig _ lnames _) -> (text "pattern", map unLoc lnames)
261  ForD _ (ForeignImport _ (L _ n) _ _) -> (empty, [n])
262  ForD _ (ForeignExport _ (L _ n) _ _) -> (empty, [n])
263  _ -> error "declaration not supported by declNames"
264
265
266forSummary :: (ExportItem DocNameI) -> Bool
267forSummary (ExportGroup _ _ _) = False
268forSummary (ExportDoc _)       = False
269forSummary _                    = True
270
271
272moduleLaTeXFile :: Module -> FilePath
273moduleLaTeXFile mdl = moduleBasename mdl ++ ".tex"
274
275
276moduleBasename :: Module -> FilePath
277moduleBasename mdl = map (\c -> if c == '.' then '-' else c)
278                         (moduleNameString (moduleName mdl))
279
280
281-------------------------------------------------------------------------------
282-- * Decls
283-------------------------------------------------------------------------------
284
285-- | Pretty print a declaration
286ppDecl :: LHsDecl DocNameI                         -- ^ decl to print
287       -> [(HsDecl DocNameI, DocForDecl DocName)]  -- ^ all pattern decls
288       -> DocForDecl DocName                       -- ^ documentation for decl
289       -> [DocInstance DocNameI]                   -- ^ all instances
290       -> [(DocName, DocForDecl DocName)]          -- ^ all subdocs
291       -> [(DocName, Fixity)]                      -- ^ all fixities
292       -> LaTeX
293
294ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of
295  TyClD _ d@FamDecl {}         -> ppFamDecl False doc instances d unicode
296  TyClD _ d@DataDecl {}        -> ppDataDecl pats instances subdocs (Just doc) d unicode
297  TyClD _ d@SynDecl {}         -> ppTySyn (doc, fnArgsDoc) d unicode
298-- Family instances happen via FamInst now
299--  TyClD _ d@TySynonym{}
300--    | Just _  <- tcdTyPats d    -> ppTyInst False loc doc d unicode
301-- Family instances happen via FamInst now
302  TyClD _ d@ClassDecl{}          -> ppClassDecl instances doc subdocs d unicode
303  SigD _ (TypeSig _ lnames ty)   -> ppFunSig Nothing (doc, fnArgsDoc) (map unLoc lnames) (hsSigWcType ty) unicode
304  SigD _ (PatSynSig _ lnames ty) -> ppLPatSig (doc, fnArgsDoc) (map unLoc lnames) ty unicode
305  ForD _ d                       -> ppFor (doc, fnArgsDoc) d unicode
306  InstD _ _                      -> empty
307  DerivD _ _                     -> empty
308  _                              -> error "declaration not supported by ppDecl"
309  where
310    unicode = False
311
312
313ppFor :: DocForDecl DocName -> ForeignDecl DocNameI -> Bool -> LaTeX
314ppFor doc (ForeignImport _ (L _ name) typ _) unicode =
315  ppFunSig Nothing doc [name] (hsSigTypeI typ) unicode
316ppFor _ _ _ = error "ppFor error in Haddock.Backends.LaTeX"
317--  error "foreign declarations are currently not supported by --latex"
318
319
320-------------------------------------------------------------------------------
321-- * Type families
322-------------------------------------------------------------------------------
323
324-- | Pretty-print a data\/type family declaration
325ppFamDecl :: Bool                     -- ^ is the family associated?
326          -> Documentation DocName    -- ^ this decl's docs
327          -> [DocInstance DocNameI]   -- ^ relevant instances
328          -> TyClDecl DocNameI        -- ^ family to print
329          -> Bool                     -- ^ unicode
330          -> LaTeX
331ppFamDecl associated doc instances decl unicode =
332  declWithDoc (ppFamHeader (tcdFam decl) unicode associated <+> whereBit)
333              (if null body then Nothing else Just (vcat body))
334  $$ instancesBit
335  where
336    body = catMaybes [familyEqns, documentationToLaTeX doc]
337
338    whereBit = case fdInfo (tcdFam decl) of
339      ClosedTypeFamily _ -> keyword "where"
340      _                  -> empty
341
342    familyEqns
343      | FamilyDecl { fdInfo = ClosedTypeFamily (Just eqns) } <- tcdFam decl
344      , not (null eqns)
345      = Just (text "\\haddockbeginargs" $$
346              vcat [ decltt (ppFamDeclEqn eqn) <+> nl | L _ eqn <- eqns ] $$
347              text "\\end{tabulary}\\par")
348      | otherwise = Nothing
349
350    -- Individual equations of a closed type family
351    ppFamDeclEqn :: TyFamInstEqn DocNameI -> LaTeX
352    ppFamDeclEqn (HsIB { hsib_body = FamEqn { feqn_tycon = L _ n
353                                            , feqn_rhs = rhs
354                                            , feqn_pats = ts } })
355      = hsep [ ppAppNameTypeArgs n ts unicode
356             , equals
357             , ppType unicode (unLoc rhs)
358             ]
359    ppFamDeclEqn (XHsImplicitBndrs nec) = noExtCon nec
360    ppFamDeclEqn (HsIB { hsib_body = XFamEqn nec}) = noExtCon nec
361
362    instancesBit = ppDocInstances unicode instances
363
364-- | Print the LHS of a type\/data family declaration.
365ppFamHeader :: FamilyDecl DocNameI  -- ^ family header to print
366            -> Bool                 -- ^ unicode
367            -> Bool                 -- ^ is the family associated?
368            -> LaTeX
369ppFamHeader (XFamilyDecl nec) _ _ = noExtCon nec
370ppFamHeader (FamilyDecl { fdLName = L _ name
371                        , fdTyVars = tvs
372                        , fdInfo = info
373                        , fdResultSig = L _ result
374                        , fdInjectivityAnn = injectivity })
375              unicode associated =
376  famly leader <+> famName <+> famSig <+> injAnn
377  where
378    leader = case info of
379      OpenTypeFamily     -> keyword "type"
380      ClosedTypeFamily _ -> keyword "type"
381      DataFamily         -> keyword "data"
382
383    famly | associated = id
384          | otherwise = (<+> keyword "family")
385
386    famName = ppAppDocNameTyVarBndrs unicode name (hsq_explicit tvs)
387
388    famSig = case result of
389      NoSig _               -> empty
390      KindSig _ kind        -> dcolon unicode <+> ppLKind unicode kind
391      TyVarSig _ (L _ bndr) -> equals <+> ppHsTyVarBndr unicode bndr
392      XFamilyResultSig nec  -> noExtCon nec
393
394    injAnn = case injectivity of
395      Nothing -> empty
396      Just (L _ (InjectivityAnn lhs rhs)) -> hsep ( decltt (text "|")
397                                                  : ppLDocName lhs
398                                                  : arrow unicode
399                                                  : map ppLDocName rhs)
400
401
402
403-------------------------------------------------------------------------------
404-- * Type Synonyms
405-------------------------------------------------------------------------------
406
407
408-- we skip type patterns for now
409ppTySyn :: DocForDecl DocName -> TyClDecl DocNameI -> Bool -> LaTeX
410
411ppTySyn doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars
412                         , tcdRhs = ltype }) unicode
413  = ppTypeOrFunSig (unLoc ltype) doc (full, hdr, char '=') unicode
414  where
415    hdr  = hsep (keyword "type"
416                 : ppDocBinder name
417                 : map ppSymName (tyvarNames ltyvars))
418    full = hdr <+> char '=' <+> ppLType unicode ltype
419
420ppTySyn _ _ _ = error "declaration not supported by ppTySyn"
421
422
423-------------------------------------------------------------------------------
424-- * Function signatures
425-------------------------------------------------------------------------------
426
427
428ppFunSig
429  :: Maybe LaTeX         -- ^ a prefix to put right before the signature
430  -> DocForDecl DocName  -- ^ documentation
431  -> [DocName]           -- ^ pattern names in the pattern signature
432  -> LHsType DocNameI    -- ^ type of the pattern synonym
433  -> Bool                -- ^ unicode
434  -> LaTeX
435ppFunSig leader doc docnames (L _ typ) unicode =
436  ppTypeOrFunSig typ doc
437    ( lead $ ppTypeSig names typ False
438    , lead $ hsep . punctuate comma $ map ppSymName names
439    , dcolon unicode
440    )
441    unicode
442 where
443   names = map getName docnames
444   lead = maybe id (<+>) leader
445
446-- | Pretty-print a pattern synonym
447ppLPatSig :: DocForDecl DocName  -- ^ documentation
448          -> [DocName]           -- ^ pattern names in the pattern signature
449          -> LHsSigType DocNameI -- ^ type of the pattern synonym
450          -> Bool                -- ^ unicode
451          -> LaTeX
452ppLPatSig doc docnames ty unicode
453  = ppFunSig (Just (keyword "pattern")) doc docnames (hsSigTypeI ty) unicode
454
455-- | Pretty-print a type, adding documentation to the whole type and its
456-- arguments as needed.
457ppTypeOrFunSig :: HsType DocNameI
458               -> DocForDecl DocName  -- ^ documentation
459               -> ( LaTeX             --   first-line (no-argument docs only)
460                  , LaTeX             --   first-line (argument docs only)
461                  , LaTeX             --   type prefix (argument docs only)
462                  )
463               -> Bool                -- ^ unicode
464               -> LaTeX
465ppTypeOrFunSig typ (doc, argDocs) (pref1, pref2, sep0) unicode
466  | Map.null argDocs = declWithDoc pref1 (documentationToLaTeX doc)
467  | otherwise        = declWithDoc pref2 $ Just $
468        text "\\haddockbeginargs" $$
469        vcat (map (uncurry (<->)) (ppSubSigLike unicode typ argDocs [] sep0)) $$
470        text "\\end{tabulary}\\par" $$
471        fromMaybe empty (documentationToLaTeX doc)
472
473-- | This splits up a type signature along @->@ and adds docs (when they exist)
474-- to the arguments. The output is a list of (leader/seperator, argument and
475-- its doc)
476ppSubSigLike :: Bool                  -- ^ unicode
477             -> HsType DocNameI       -- ^ type signature
478             -> FnArgsDoc DocName     -- ^ docs to add
479             -> [(DocName, DocForDecl DocName)] -- ^ all subdocs (useful when we have `HsRecTy`)
480             -> LaTeX                 -- ^ seperator (beginning of first line)
481             -> [(LaTeX, LaTeX)]      -- ^ arguments (leader/sep, type)
482ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ
483  where
484    do_largs n leader (L _ t) = do_args n leader t
485
486    arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs
487
488    do_args :: Int -> LaTeX -> HsType DocNameI -> [(LaTeX, LaTeX)]
489    do_args _n leader (HsForAllTy _ fvf tvs ltype)
490      = [ ( decltt leader
491          , decltt (ppForAllPart unicode tvs fvf)
492              <+> ppLType unicode ltype
493          ) ]
494    do_args n leader (HsQualTy _ lctxt ltype)
495      = ( decltt leader
496        , decltt (ppLContextNoArrow lctxt unicode) <+> nl
497        ) : do_largs n (darrow unicode) ltype
498
499    do_args n leader (HsFunTy _ (L _ (HsRecTy _ fields)) r)
500      = [ (decltt ldr, latex <+> nl)
501        | (L _ field, ldr) <- zip fields (leader <+> gadtOpen : repeat gadtComma)
502        , let latex = ppSideBySideField subdocs unicode field
503        ]
504        ++ do_largs (n+1) (gadtEnd <+> arrow unicode) r
505    do_args n leader (HsFunTy _ lt r)
506      = (decltt leader, decltt (ppLFunLhType unicode lt) <-> arg_doc n <+> nl)
507        : do_largs (n+1) (arrow unicode) r
508    do_args n leader t
509      = [ (decltt leader, decltt (ppType unicode t) <-> arg_doc n <+> nl) ]
510
511    -- FIXME: this should be done more elegantly
512    --
513    -- We need 'gadtComma' and 'gadtEnd' to line up with the `{` from
514    -- 'gadtOpen', so we add 3 spaces to cover for `-> `/`:: ` (3 in unicode
515    -- mode since `->` and `::` are rendered as single characters.
516    gadtComma = hcat (replicate (if unicode then 3 else 4) (char ' ')) <> char ','
517    gadtEnd = hcat (replicate (if unicode then 3 else 4) (char ' ')) <> char '}'
518    gadtOpen = char '{'
519
520
521ppTypeSig :: [Name] -> HsType DocNameI  -> Bool -> LaTeX
522ppTypeSig nms ty unicode =
523  hsep (punctuate comma $ map ppSymName nms)
524    <+> dcolon unicode
525    <+> ppType unicode ty
526
527
528-- | Pretty-print type variables.
529ppTyVars :: Bool -> [LHsTyVarBndr DocNameI] -> [LaTeX]
530ppTyVars unicode = map (ppHsTyVarBndr unicode . unLoc)
531
532
533tyvarNames :: LHsQTyVars DocNameI -> [Name]
534tyvarNames = map (getName . hsTyVarBndrName . unLoc) . hsQTvExplicit
535
536
537declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX
538declWithDoc decl doc =
539   text "\\begin{haddockdesc}" $$
540   text "\\item[\\begin{tabular}{@{}l}" $$
541   text (latexMonoFilter (latex2String decl)) $$
542   text "\\end{tabular}]" $$
543   maybe empty (\x -> text "{\\haddockbegindoc" $$ x <> text "}") doc $$
544   text "\\end{haddockdesc}"
545
546
547-- in a group of decls, we don't put them all in the same tabular,
548-- because that would prevent the group being broken over a page
549-- boundary (breaks Foreign.C.Error for example).
550multiDecl :: [LaTeX] -> LaTeX
551multiDecl decls =
552   text "\\begin{haddockdesc}" $$
553   vcat [
554      text "\\item[\\begin{tabular}{@{}l}" $$
555      text (latexMonoFilter (latex2String decl)) $$
556      text "\\end{tabular}]"
557      | decl <- decls ] $$
558   text "\\end{haddockdesc}"
559
560
561-------------------------------------------------------------------------------
562-- * Rendering Doc
563-------------------------------------------------------------------------------
564
565
566maybeDoc :: Maybe (Doc DocName) -> LaTeX
567maybeDoc = maybe empty docToLaTeX
568
569
570-- for table cells, we strip paragraphs out to avoid extra vertical space
571-- and don't add a quote environment.
572rDoc  :: Maybe (Doc DocName) -> LaTeX
573rDoc = maybeDoc . fmap latexStripTrailingWhitespace
574
575
576-------------------------------------------------------------------------------
577-- * Class declarations
578-------------------------------------------------------------------------------
579
580
581ppClassHdr :: Bool -> Located [LHsType DocNameI] -> DocName
582           -> LHsQTyVars DocNameI -> [Located ([Located DocName], [Located DocName])]
583           -> Bool -> LaTeX
584ppClassHdr summ lctxt n tvs fds unicode =
585  keyword "class"
586  <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode else empty)
587  <+> ppAppDocNameNames summ n (tyvarNames tvs)
588  <+> ppFds fds unicode
589
590
591ppFds :: [Located ([Located DocName], [Located DocName])] -> Bool -> LaTeX
592ppFds fds unicode =
593  if null fds then empty else
594    char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds))
595  where
596    fundep (vars1,vars2) = hsep (map (ppDocName . unLoc) vars1) <+> arrow unicode <+>
597                           hsep (map (ppDocName . unLoc) vars2)
598
599
600-- TODO: associated type defaults, docs on default methods
601ppClassDecl :: [DocInstance DocNameI]
602            -> Documentation DocName -> [(DocName, DocForDecl DocName)]
603            -> TyClDecl DocNameI -> Bool -> LaTeX
604ppClassDecl instances doc subdocs
605  (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars, tcdFDs = lfds
606             , tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs }) unicode
607  = declWithDoc classheader (if null body then Nothing else Just (vcat body)) $$
608    instancesBit
609  where
610    classheader
611      | null lsigs = hdr unicode
612      | otherwise  = hdr unicode <+> keyword "where"
613
614    hdr = ppClassHdr False lctxt (unLoc lname) ltyvars lfds
615
616    body = catMaybes [documentationToLaTeX doc, body_]
617
618    body_
619      | null lsigs, null ats, null at_defs = Nothing
620      | null ats, null at_defs = Just methodTable
621      | otherwise = Just (atTable $$ methodTable)
622
623    atTable =
624      text "\\haddockpremethods{}" <> emph (text "Associated Types") $$
625      vcat  [ ppFamDecl True (fst doc) [] (FamDecl noExtField decl) True
626            | L _ decl <- ats
627            , let name = unLoc . fdLName $ decl
628                  doc = lookupAnySubdoc name subdocs
629            ]
630
631
632    methodTable =
633      text "\\haddockpremethods{}" <> emph (text "Methods") $$
634      vcat  [ ppFunSig leader doc names (hsSigTypeI typ) unicode
635            | L _ (ClassOpSig _ is_def lnames typ) <- lsigs
636            , let doc | is_def = noDocForDecl
637                      | otherwise = lookupAnySubdoc (head names) subdocs
638                  names = map unLoc lnames
639                  leader = if is_def then Just (keyword "default") else Nothing
640            ]
641            -- N.B. taking just the first name is ok. Signatures with multiple
642            -- names are expanded so that each name gets its own signature.
643
644    instancesBit = ppDocInstances unicode instances
645
646ppClassDecl _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
647
648ppDocInstances :: Bool -> [DocInstance DocNameI] -> LaTeX
649ppDocInstances _unicode [] = empty
650ppDocInstances unicode (i : rest)
651  | Just ihead <- isUndocdInstance i
652  = declWithDoc (vcat (map (ppInstDecl unicode) (ihead:is))) Nothing $$
653    ppDocInstances unicode rest'
654  | otherwise
655  = ppDocInstance unicode i $$ ppDocInstances unicode rest
656  where
657    (is, rest') = spanWith isUndocdInstance rest
658
659isUndocdInstance :: DocInstance a -> Maybe (InstHead a)
660isUndocdInstance (i,Nothing,_,_) = Just i
661isUndocdInstance (i,Just (MetaDoc _ DocEmpty),_,_) = Just i
662isUndocdInstance _ = Nothing
663
664-- | Print a possibly commented instance. The instance header is printed inside
665-- an 'argBox'. The comment is printed to the right of the box in normal comment
666-- style.
667ppDocInstance :: Bool -> DocInstance DocNameI -> LaTeX
668ppDocInstance unicode (instHead, doc, _, _) =
669  declWithDoc (ppInstDecl unicode instHead) (fmap docToLaTeX $ fmap _doc doc)
670
671
672ppInstDecl :: Bool -> InstHead DocNameI -> LaTeX
673ppInstDecl unicode (InstHead {..}) = case ihdInstType of
674  ClassInst ctx _ _ _ -> keyword "instance" <+> ppContextNoLocs ctx unicode <+> typ
675  TypeInst rhs -> keyword "type" <+> keyword "instance" <+> typ <+> tibody rhs
676  DataInst dd ->
677    let nd = dd_ND (tcdDataDefn dd)
678        pref = case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }
679    in pref <+> keyword "instance" <+> typ
680  where
681    typ = ppAppNameTypes ihdClsName ihdTypes unicode
682    tibody = maybe empty (\t -> equals <+> ppType unicode t)
683
684lookupAnySubdoc :: (Eq name1) =>
685                   name1 -> [(name1, DocForDecl name2)] -> DocForDecl name2
686lookupAnySubdoc n subdocs = case lookup n subdocs of
687  Nothing -> noDocForDecl
688  Just docs -> docs
689
690
691-------------------------------------------------------------------------------
692-- * Data & newtype declarations
693-------------------------------------------------------------------------------
694
695-- | Pretty-print a data declaration
696ppDataDecl :: [(HsDecl DocNameI, DocForDecl DocName)] -- ^ relevant patterns
697           -> [DocInstance DocNameI]                  -- ^ relevant instances
698           -> [(DocName, DocForDecl DocName)]         -- ^ relevant decl docs
699           -> Maybe (Documentation DocName)           -- ^ this decl's docs
700           -> TyClDecl DocNameI                       -- ^ data decl to print
701           -> Bool                                    -- ^ unicode
702           -> LaTeX
703ppDataDecl pats instances subdocs doc dataDecl unicode =
704   declWithDoc (ppDataHeader dataDecl unicode <+> whereBit)
705               (if null body then Nothing else Just (vcat body))
706   $$ instancesBit
707
708  where
709    cons      = dd_cons (tcdDataDefn dataDecl)
710    resTy     = (unLoc . head) cons
711
712    body = catMaybes [doc >>= documentationToLaTeX, constrBit,patternBit]
713
714    (whereBit, leaders)
715      | null cons
716      , null pats = (empty,[])
717      | null cons = (text "where", repeat empty)
718      | otherwise = case resTy of
719        ConDeclGADT{} -> (text "where", repeat empty)
720        _             -> (empty, (decltt (text "=") : repeat (decltt (text "|"))))
721
722    constrBit
723      | null cons = Nothing
724      | otherwise = Just $
725          text "\\enspace" <+> emph (text "Constructors") <> text "\\par" $$
726          text "\\haddockbeginconstrs" $$
727          vcat (zipWith (ppSideBySideConstr subdocs unicode) leaders cons) $$
728          text "\\end{tabulary}\\par"
729
730    patternBit
731      | null pats = Nothing
732      | otherwise = Just $
733          text "\\enspace" <+> emph (text "Bundled Patterns") <> text "\\par" $$
734          text "\\haddockbeginconstrs" $$
735          vcat [ empty <-> ppSideBySidePat lnames typ d unicode
736               | (SigD _ (PatSynSig _ lnames typ), d) <- pats
737               ] $$
738          text "\\end{tabulary}\\par"
739
740    instancesBit = ppDocInstances unicode instances
741
742
743-- ppConstrHdr is for (non-GADT) existentials constructors' syntax
744ppConstrHdr
745  :: Bool                    -- ^ print explicit foralls
746  -> [LHsTyVarBndr DocNameI] -- ^ type variables
747  -> HsContext DocNameI      -- ^ context
748  -> Bool                    -- ^ unicode
749  -> LaTeX
750ppConstrHdr forall_ tvs ctxt unicode = ppForall <> ppCtxt
751  where
752    ppForall
753      | null tvs || not forall_ = empty
754      | otherwise = ppForAllPart unicode tvs ForallInvis
755
756    ppCtxt
757      | null ctxt = empty
758      | otherwise = ppContextNoArrow ctxt unicode <+> darrow unicode <> space
759
760
761-- | Pretty-print a constructor
762ppSideBySideConstr :: [(DocName, DocForDecl DocName)]  -- ^ all decl docs
763                   -> Bool                             -- ^ unicode
764                   -> LaTeX                            -- ^ prefix to decl
765                   -> LConDecl DocNameI                -- ^ constructor decl
766                   -> LaTeX
767ppSideBySideConstr subdocs unicode leader (L _ con) =
768  leader <-> decltt decl <-> rDoc mbDoc <+> nl
769  $$ fieldPart
770  where
771    -- Find the name of a constructors in the decl (`getConName` always returns
772    -- a non-empty list)
773    aConName = unLoc (head (getConNamesI con))
774
775    occ      = map (nameOccName . getName . unLoc) $ getConNamesI con
776
777    ppOcc      = cat (punctuate comma (map ppBinder occ))
778    ppOccInfix = cat (punctuate comma (map ppBinderInfix occ))
779
780    -- Extract out the map of of docs corresponding to the constructors arguments
781    argDocs = maybe Map.empty snd (lookup aConName subdocs)
782    hasArgDocs = not $ Map.null argDocs
783
784    -- First line of the constructor (no doc, no fields, single-line)
785    decl = case con of
786      ConDeclH98{ con_args = det
787                , con_ex_tvs = tyVars
788                , con_forall = L _ forall_
789                , con_mb_cxt = cxt
790                } -> let context = unLoc (fromMaybe (noLoc []) cxt)
791                         header_ = ppConstrHdr forall_ tyVars context unicode
792                     in case det of
793        -- Prefix constructor, e.g. 'Just a'
794        PrefixCon args
795          | hasArgDocs -> header_ <+> ppOcc
796          | otherwise -> hsep [ header_
797                              , ppOcc
798                              , hsep (map (ppLParendType unicode) args)
799                              ]
800
801        -- Record constructor, e.g. 'Identity { runIdentity :: a }'
802        RecCon _ ->  header_ <+> ppOcc
803
804        -- Infix constructor, e.g. 'a :| [a]'
805        InfixCon arg1 arg2
806          | hasArgDocs -> header_ <+> ppOcc
807          | otherwise -> hsep [ header_
808                              , ppLParendType unicode arg1
809                              , ppOccInfix
810                              , ppLParendType unicode arg2
811                              ]
812
813      ConDeclGADT{}
814        | hasArgDocs || not (isEmpty fieldPart) -> ppOcc
815        | otherwise -> hsep [ ppOcc
816                            , dcolon unicode
817                            -- ++AZ++ make this prepend "{..}" when it is a record style GADT
818                            , ppLType unicode (getGADTConType con)
819                            ]
820      XConDecl nec -> noExtCon nec
821
822    fieldPart = case (con, getConArgs con) of
823        -- Record style GADTs
824        (ConDeclGADT{}, RecCon _)            -> doConstrArgsWithDocs []
825
826        -- Regular record declarations
827        (_, RecCon (L _ fields))             -> doRecordFields fields
828
829        -- Any GADT or a regular H98 prefix data constructor
830        (_, PrefixCon args)     | hasArgDocs -> doConstrArgsWithDocs args
831
832        -- An infix H98 data constructor
833        (_, InfixCon arg1 arg2) | hasArgDocs -> doConstrArgsWithDocs [arg1,arg2]
834
835        _ -> empty
836
837    doRecordFields fields =
838      vcat [ empty <-> tt (text begin) <+> ppSideBySideField subdocs unicode field <+> nl
839           | (begin, L _ field) <- zip ("\\qquad \\{" : repeat "\\qquad ,") fields
840           ]
841      $$
842      empty <-> tt (text "\\qquad \\}") <+> nl
843
844    doConstrArgsWithDocs args = vcat $ map (\l -> empty <-> text "\\qquad" <+> l) $ case con of
845      ConDeclH98{} ->
846        [ decltt (ppLParendType unicode arg) <-> rDoc (fmap _doc mdoc) <+> nl
847        | (i, arg) <- zip [0..] args
848        , let mdoc = Map.lookup i argDocs
849        ]
850      ConDeclGADT{} ->
851        [ l <+> text "\\enspace" <+> r
852        | (l,r) <- ppSubSigLike unicode (unLoc (getGADTConType con)) argDocs subdocs (dcolon unicode)
853        ]
854      XConDecl nec -> noExtCon nec
855
856
857    -- don't use "con_doc con", in case it's reconstructed from a .hi file,
858    -- or also because we want Haddock to do the doc-parsing, not GHC.
859    mbDoc = case getConNamesI con of
860              [] -> panic "empty con_names"
861              (cn:_) -> lookup (unLoc cn) subdocs >>=
862                        fmap _doc . combineDocumentation . fst
863
864
865-- | Pretty-print a record field
866ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocNameI ->  LaTeX
867ppSideBySideField subdocs unicode (ConDeclField _ names ltype _) =
868  decltt (cat (punctuate comma (map (ppBinder . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names))
869    <+> dcolon unicode <+> ppLType unicode ltype) <-> rDoc mbDoc
870  where
871    -- don't use cd_fld_doc for same reason we don't use con_doc above
872    -- Where there is more than one name, they all have the same documentation
873    mbDoc = lookup (extFieldOcc $ unLoc $ head names) subdocs >>= fmap _doc . combineDocumentation . fst
874ppSideBySideField _ _ (XConDeclField nec) = noExtCon nec
875
876
877-- | Pretty-print a bundled pattern synonym
878ppSideBySidePat :: [Located DocName]    -- ^ pattern name(s)
879                -> LHsSigType DocNameI  -- ^ type of pattern(s)
880                -> DocForDecl DocName   -- ^ doc map
881                -> Bool                 -- ^ unicode
882                -> LaTeX
883ppSideBySidePat lnames typ (doc, argDocs) unicode =
884  decltt decl <-> rDoc mDoc <+> nl
885  $$ fieldPart
886  where
887    hasArgDocs = not $ Map.null argDocs
888    ppOcc = hsep (punctuate comma (map (ppDocBinder . unLoc) lnames))
889
890    decl | hasArgDocs = keyword "pattern" <+> ppOcc
891         | otherwise = hsep [ keyword "pattern"
892                            , ppOcc
893                            , dcolon unicode
894                            , ppLType unicode (hsSigTypeI typ)
895                            ]
896
897    fieldPart
898      | not hasArgDocs = empty
899      | otherwise = vcat
900          [ empty <-> text "\\qquad" <+> l <+> text "\\enspace" <+> r
901          | (l,r) <- ppSubSigLike unicode (unLoc patTy) argDocs [] (dcolon unicode)
902          ]
903
904    patTy = hsSigTypeI typ
905
906    mDoc = fmap _doc $ combineDocumentation doc
907
908
909-- | Print the LHS of a data\/newtype declaration.
910-- Currently doesn't handle 'data instance' decls or kind signatures
911ppDataHeader :: TyClDecl DocNameI -> Bool -> LaTeX
912ppDataHeader (DataDecl { tcdLName = L _ name, tcdTyVars = tyvars
913                       , tcdDataDefn = HsDataDefn { dd_ND = nd, dd_ctxt = ctxt } }) unicode
914  = -- newtype or data
915    (case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }) <+>
916    -- context
917    ppLContext ctxt unicode <+>
918    -- T a b c ..., or a :+: b
919    ppAppDocNameNames False name (tyvarNames tyvars)
920ppDataHeader _ _ = error "ppDataHeader: illegal argument"
921
922
923--------------------------------------------------------------------------------
924-- * Type applications
925--------------------------------------------------------------------------------
926
927ppAppDocNameTyVarBndrs :: Bool -> DocName -> [LHsTyVarBndr DocNameI] -> LaTeX
928ppAppDocNameTyVarBndrs unicode n vs =
929    ppTypeApp n vs ppDN (ppHsTyVarBndr unicode . unLoc)
930  where
931    ppDN = ppBinder . nameOccName . getName
932
933
934-- | Print an application of a DocName to its list of HsTypes
935ppAppNameTypes :: DocName -> [HsType DocNameI] -> Bool -> LaTeX
936ppAppNameTypes n ts unicode = ppTypeApp n ts ppDocName (ppParendType unicode)
937
938ppAppNameTypeArgs :: DocName -> [LHsTypeArg DocNameI] -> Bool -> LaTeX
939ppAppNameTypeArgs n args@(HsValArg _:HsValArg _:_) unicode
940  = ppTypeApp n args ppDocName (ppLHsTypeArg unicode)
941ppAppNameTypeArgs n args unicode
942  = ppDocName n <+> hsep (map (ppLHsTypeArg unicode) args)
943
944-- | Print an application of a DocName and a list of Names
945ppAppDocNameNames :: Bool -> DocName -> [Name] -> LaTeX
946ppAppDocNameNames _summ n ns =
947  ppTypeApp n ns (ppBinder . nameOccName . getName) ppSymName
948
949
950-- | General printing of type applications
951ppTypeApp :: DocName -> [a] -> (DocName -> LaTeX) -> (a -> LaTeX) -> LaTeX
952ppTypeApp n (t1:t2:rest) ppDN ppT
953  | operator, not . null $ rest = parens opApp <+> hsep (map ppT rest)
954  | operator                    = opApp
955  where
956    operator = isNameSym . getName $ n
957    opApp = ppT t1 <+> ppDN n <+> ppT t2
958
959ppTypeApp n ts ppDN ppT = ppDN n <+> hsep (map ppT ts)
960
961-------------------------------------------------------------------------------
962-- * Contexts
963-------------------------------------------------------------------------------
964
965
966ppLContext, ppLContextNoArrow :: Located (HsContext DocNameI) -> Bool -> LaTeX
967ppLContext        = ppContext        . unLoc
968ppLContextNoArrow = ppContextNoArrow . unLoc
969
970ppContextNoLocsMaybe :: [HsType DocNameI] -> Bool -> Maybe LaTeX
971ppContextNoLocsMaybe [] _ = Nothing
972ppContextNoLocsMaybe cxt unicode = Just $ pp_hs_context cxt unicode
973
974ppContextNoArrow :: HsContext DocNameI -> Bool -> LaTeX
975ppContextNoArrow cxt unicode = fromMaybe empty $
976                               ppContextNoLocsMaybe (map unLoc cxt) unicode
977
978
979ppContextNoLocs :: [HsType DocNameI] -> Bool -> LaTeX
980ppContextNoLocs cxt unicode = maybe empty (<+> darrow unicode) $
981                              ppContextNoLocsMaybe cxt unicode
982
983
984ppContext :: HsContext DocNameI -> Bool -> LaTeX
985ppContext cxt unicode = ppContextNoLocs (map unLoc cxt) unicode
986
987
988pp_hs_context :: [HsType DocNameI] -> Bool -> LaTeX
989pp_hs_context []  _       = empty
990pp_hs_context [p] unicode = ppCtxType unicode p
991pp_hs_context cxt unicode = parenList (map (ppType unicode) cxt)
992
993
994-------------------------------------------------------------------------------
995-- * Types and contexts
996-------------------------------------------------------------------------------
997
998
999ppBang :: HsSrcBang -> LaTeX
1000ppBang (HsSrcBang _ _ SrcStrict) = char '!'
1001ppBang (HsSrcBang _ _ SrcLazy)   = char '~'
1002ppBang _                         = empty
1003
1004
1005tupleParens :: HsTupleSort -> [LaTeX] -> LaTeX
1006tupleParens HsUnboxedTuple = ubxParenList
1007tupleParens _              = parenList
1008
1009
1010sumParens :: [LaTeX] -> LaTeX
1011sumParens = ubxparens . hsep . punctuate (text " |")
1012
1013
1014-------------------------------------------------------------------------------
1015-- * Rendering of HsType
1016--
1017-- Stolen from Html and tweaked for LaTeX generation
1018-------------------------------------------------------------------------------
1019
1020ppLType, ppLParendType, ppLFunLhType :: Bool -> Located (HsType DocNameI) -> LaTeX
1021ppLType       unicode y = ppType unicode (unLoc y)
1022ppLParendType unicode y = ppParendType unicode (unLoc y)
1023ppLFunLhType  unicode y = ppFunLhType unicode (unLoc y)
1024
1025ppType, ppParendType, ppFunLhType, ppCtxType :: Bool -> HsType DocNameI -> LaTeX
1026ppType       unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode
1027ppParendType unicode ty = ppr_mono_ty (reparenTypePrec PREC_CON ty) unicode
1028ppFunLhType  unicode ty = ppr_mono_ty (reparenTypePrec PREC_FUN ty) unicode
1029ppCtxType    unicode ty = ppr_mono_ty (reparenTypePrec PREC_CTX ty) unicode
1030
1031ppLHsTypeArg :: Bool -> LHsTypeArg DocNameI -> LaTeX
1032ppLHsTypeArg unicode (HsValArg ty) = ppLParendType unicode ty
1033ppLHsTypeArg unicode (HsTypeArg _ ki) = atSign unicode <>
1034                                       ppLParendType unicode ki
1035ppLHsTypeArg _ (HsArgPar _) = text ""
1036
1037ppHsTyVarBndr :: Bool -> HsTyVarBndr DocNameI -> LaTeX
1038ppHsTyVarBndr _ (UserTyVar _ (L _ name)) = ppDocName name
1039ppHsTyVarBndr unicode (KindedTyVar _ (L _ name) kind) =
1040  parens (ppDocName name <+> dcolon unicode <+> ppLKind unicode kind)
1041ppHsTyVarBndr _ (XTyVarBndr nec) = noExtCon nec
1042
1043ppLKind :: Bool -> LHsKind DocNameI -> LaTeX
1044ppLKind unicode y = ppKind unicode (unLoc y)
1045
1046ppKind :: Bool -> HsKind DocNameI -> LaTeX
1047ppKind unicode ki = ppr_mono_ty (reparenTypePrec PREC_TOP ki) unicode
1048
1049
1050-- Drop top-level for-all type variables in user style
1051-- since they are implicit in Haskell
1052
1053ppForAllPart :: Bool -> [LHsTyVarBndr DocNameI] -> ForallVisFlag -> LaTeX
1054ppForAllPart unicode tvs fvf = hsep (forallSymbol unicode : tvs') <> fv
1055  where
1056    tvs' = ppTyVars unicode tvs
1057    fv = case fvf of
1058           ForallVis   -> text "\\ " <> arrow unicode
1059           ForallInvis -> dot
1060
1061ppr_mono_lty :: LHsType DocNameI -> Bool -> LaTeX
1062ppr_mono_lty ty unicode = ppr_mono_ty (unLoc ty) unicode
1063
1064
1065ppr_mono_ty :: HsType DocNameI -> Bool -> LaTeX
1066ppr_mono_ty (HsForAllTy _ fvf tvs ty) unicode
1067  = sep [ ppForAllPart unicode tvs fvf
1068        , ppr_mono_lty ty unicode ]
1069ppr_mono_ty (HsQualTy _ ctxt ty) unicode
1070  = sep [ ppLContext ctxt unicode
1071        , ppr_mono_lty ty unicode ]
1072ppr_mono_ty (HsFunTy _ ty1 ty2)   u
1073  = sep [ ppr_mono_lty ty1 u
1074        , arrow u <+> ppr_mono_lty ty2 u ]
1075
1076ppr_mono_ty (HsBangTy _ b ty)     u = ppBang b <> ppLParendType u ty
1077ppr_mono_ty (HsTyVar _ NotPromoted (L _ name)) _ = ppDocName name
1078ppr_mono_ty (HsTyVar _ IsPromoted  (L _ name)) _ = char '\'' <> ppDocName name
1079ppr_mono_ty (HsTupleTy _ con tys) u = tupleParens con (map (ppLType u) tys)
1080ppr_mono_ty (HsSumTy _ tys) u       = sumParens (map (ppLType u) tys)
1081ppr_mono_ty (HsKindSig _ ty kind) u = ppr_mono_lty ty u <+> dcolon u <+> ppLKind u kind
1082ppr_mono_ty (HsListTy _ ty)       u = brackets (ppr_mono_lty ty u)
1083ppr_mono_ty (HsIParamTy _ (L _ n) ty) u = ppIPName n <+> dcolon u <+> ppr_mono_lty ty u
1084ppr_mono_ty (HsSpliceTy v _)    _ = absurd v
1085ppr_mono_ty (HsRecTy {})        _ = text "{..}"
1086ppr_mono_ty (XHsType (NHsCoreTy {}))  _ = error "ppr_mono_ty HsCoreTy"
1087ppr_mono_ty (HsExplicitListTy _ IsPromoted tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys
1088ppr_mono_ty (HsExplicitListTy _ NotPromoted tys) u = brackets $ hsep $ punctuate comma $ map (ppLType u) tys
1089ppr_mono_ty (HsExplicitTupleTy _ tys) u = Pretty.quote $ parenList $ map (ppLType u) tys
1090
1091ppr_mono_ty (HsAppTy _ fun_ty arg_ty) unicode
1092  = hsep [ppr_mono_lty fun_ty unicode, ppr_mono_lty arg_ty unicode]
1093
1094ppr_mono_ty (HsAppKindTy _ fun_ty arg_ki) unicode
1095  = hsep [ppr_mono_lty fun_ty unicode, atSign unicode <> ppr_mono_lty arg_ki unicode]
1096
1097ppr_mono_ty (HsOpTy _ ty1 op ty2) unicode
1098  = ppr_mono_lty ty1 unicode <+> ppr_op <+> ppr_mono_lty ty2 unicode
1099  where
1100    ppr_op | isSymOcc (getOccName op) = ppLDocName op
1101           | otherwise = char '`' <> ppLDocName op <> char '`'
1102
1103ppr_mono_ty (HsParTy _ ty) unicode
1104  = parens (ppr_mono_lty ty unicode)
1105--  = ppr_mono_lty ty unicode
1106
1107ppr_mono_ty (HsDocTy _ ty _) unicode
1108  = ppr_mono_lty ty unicode
1109
1110ppr_mono_ty (HsWildCardTy _) _ = char '_'
1111
1112ppr_mono_ty (HsTyLit _ t) u = ppr_tylit t u
1113ppr_mono_ty (HsStarTy _ isUni) unicode = starSymbol (isUni || unicode)
1114
1115
1116ppr_tylit :: HsTyLit -> Bool -> LaTeX
1117ppr_tylit (HsNumTy _ n) _ = integer n
1118ppr_tylit (HsStrTy _ s) _ = text (show s)
1119  -- XXX: Ok in verbatim, but not otherwise
1120  -- XXX: Do something with Unicode parameter?
1121
1122
1123-------------------------------------------------------------------------------
1124-- * Names
1125-------------------------------------------------------------------------------
1126
1127
1128ppBinder :: OccName -> LaTeX
1129ppBinder n
1130  | isSymOcc n = parens $ ppOccName n
1131  | otherwise  = ppOccName n
1132
1133ppBinderInfix :: OccName -> LaTeX
1134ppBinderInfix n
1135  | isSymOcc n = ppOccName n
1136  | otherwise  = cat [ char '`', ppOccName n, char '`' ]
1137
1138ppSymName :: Name -> LaTeX
1139ppSymName name
1140  | isNameSym name = parens $ ppName name
1141  | otherwise = ppName name
1142
1143
1144ppIPName :: HsIPName -> LaTeX
1145ppIPName = text . ('?':) . unpackFS . hsIPNameFS
1146
1147ppOccName :: OccName -> LaTeX
1148ppOccName = text . occNameString
1149
1150
1151ppDocName :: DocName -> LaTeX
1152ppDocName = ppOccName . nameOccName . getName
1153
1154ppLDocName :: Located DocName -> LaTeX
1155ppLDocName (L _ d) = ppDocName d
1156
1157
1158ppDocBinder :: DocName -> LaTeX
1159ppDocBinder = ppBinder . nameOccName . getName
1160
1161
1162ppName :: Name -> LaTeX
1163ppName = ppOccName . nameOccName
1164
1165
1166latexFilter :: String -> String
1167latexFilter = foldr latexMunge ""
1168
1169
1170latexMonoFilter :: String -> String
1171latexMonoFilter = foldr latexMonoMunge ""
1172
1173
1174latexMunge :: Char -> String -> String
1175latexMunge '#'  s = "{\\char '43}" ++ s
1176latexMunge '$'  s = "{\\char '44}" ++ s
1177latexMunge '%'  s = "{\\char '45}" ++ s
1178latexMunge '&'  s = "{\\char '46}" ++ s
1179latexMunge '~'  s = "{\\char '176}" ++ s
1180latexMunge '_'  s = "{\\char '137}" ++ s
1181latexMunge '^'  s = "{\\char '136}" ++ s
1182latexMunge '\\' s = "{\\char '134}" ++ s
1183latexMunge '{'  s = "{\\char '173}" ++ s
1184latexMunge '}'  s = "{\\char '175}" ++ s
1185latexMunge '['  s = "{\\char 91}" ++ s
1186latexMunge ']'  s = "{\\char 93}" ++ s
1187latexMunge c    s = c : s
1188
1189
1190latexMonoMunge :: Char -> String -> String
1191latexMonoMunge ' '      (' ':s) = "\\ \\ " ++ s
1192latexMonoMunge ' ' ('\\':' ':s) = "\\ \\ " ++ s
1193latexMonoMunge '\n' s = '\\' : '\\' : s
1194latexMonoMunge c s = latexMunge c s
1195
1196
1197-------------------------------------------------------------------------------
1198-- * Doc Markup
1199-------------------------------------------------------------------------------
1200
1201
1202latexMarkup :: HasOccName a => DocMarkup (Wrap a) (StringContext -> LaTeX -> LaTeX)
1203latexMarkup = Markup
1204  { markupParagraph            = \p v -> blockElem (p v (text "\\par"))
1205  , markupEmpty                = \_ -> id
1206  , markupString               = \s v -> inlineElem (text (fixString v s))
1207  , markupAppend               = \l r v -> l v . r v
1208  , markupIdentifier           = \i v -> inlineElem (markupId v (fmap occName i))
1209  , markupIdentifierUnchecked  = \i v -> inlineElem (markupId v (fmap snd i))
1210  , markupModule               =
1211      \(ModLink m mLabel) v ->
1212        case mLabel of
1213          Just lbl -> inlineElem . tt $ lbl v empty
1214          Nothing -> inlineElem (let (mdl,_ref) = break (=='#') m
1215                                 in (tt (text mdl)))
1216  , markupWarning              = \p v -> p v
1217  , markupEmphasis             = \p v -> inlineElem (emph (p v empty))
1218  , markupBold                 = \p v -> inlineElem (bold (p v empty))
1219  , markupMonospaced           = \p v -> inlineElem (markupMonospace p v)
1220  , markupUnorderedList        = \p v -> blockElem (itemizedList (map (\p' -> p' v empty) p))
1221  , markupPic                  = \p _ -> inlineElem (markupPic p)
1222  , markupMathInline           = \p _ -> inlineElem (markupMathInline p)
1223  , markupMathDisplay          = \p _ -> blockElem (markupMathDisplay p)
1224  , markupOrderedList          = \p v -> blockElem (enumeratedList (map (\p' -> p' v empty) p))
1225  , markupDefList              = \l v -> blockElem (descriptionList (map (\(a,b) -> (a v empty, b v empty)) l))
1226  , markupCodeBlock            = \p _ -> blockElem (quote (verb (p Verb empty)))
1227  , markupHyperlink            = \(Hyperlink u l) v -> inlineElem (markupLink u (fmap (\x -> x v empty) l))
1228  , markupAName                = \_ _ -> id -- TODO
1229  , markupProperty             = \p _ -> blockElem (quote (verb (text p)))
1230  , markupExample              = \e _ -> blockElem (quote (verb (text $ unlines $ map exampleToString e)))
1231  , markupHeader               = \(Header l h) p -> blockElem (header l (h p empty))
1232  , markupTable                = \(Table h b) p -> blockElem (table h b p)
1233  }
1234  where
1235    blockElem :: LaTeX -> LaTeX -> LaTeX
1236    blockElem = ($$)
1237
1238    inlineElem :: LaTeX -> LaTeX -> LaTeX
1239    inlineElem = (<>)
1240
1241    header 1 d = text "\\section*" <> braces d
1242    header 2 d = text "\\subsection*" <> braces d
1243    header l d
1244      | l > 0 && l <= 6 = text "\\subsubsection*" <> braces d
1245    header l _ = error $ "impossible header level in LaTeX generation: " ++ show l
1246
1247    table _ _ _ = text "{TODO: Table}"
1248
1249    fixString Plain s = latexFilter s
1250    fixString Verb  s = s
1251    fixString Mono  s = latexMonoFilter s
1252
1253    markupMonospace p Verb = p Verb empty
1254    markupMonospace p _ = tt (p Mono empty)
1255
1256    markupLink url mLabel = case mLabel of
1257      Just label -> text "\\href" <> braces (text url) <> braces label
1258      Nothing    -> text "\\url"  <> braces (text url)
1259
1260    -- Is there a better way of doing this? Just a space is an aribtrary choice.
1261    markupPic (Picture uri title) = parens (imageText title)
1262      where
1263        imageText Nothing = beg
1264        imageText (Just t) = beg <> text " " <> text t
1265
1266        beg = text "image: " <> text uri
1267
1268    markupMathInline mathjax = text "\\(" <> text mathjax <> text "\\)"
1269
1270    markupMathDisplay mathjax = text "\\[" <> text mathjax <> text "\\]"
1271
1272    markupId v wrappedOcc =
1273      case v of
1274        Verb  -> text i
1275        Mono  -> text "\\haddockid" <> braces (text . latexMonoFilter $ i)
1276        Plain -> text "\\haddockid" <> braces (text . latexFilter $ i)
1277      where i = showWrapped occNameString wrappedOcc
1278
1279docToLaTeX :: Doc DocName -> LaTeX
1280docToLaTeX doc = markup latexMarkup doc Plain empty
1281
1282documentationToLaTeX :: Documentation DocName -> Maybe LaTeX
1283documentationToLaTeX = fmap docToLaTeX . fmap _doc . combineDocumentation
1284
1285
1286rdrDocToLaTeX :: Doc RdrName -> LaTeX
1287rdrDocToLaTeX doc = markup latexMarkup doc Plain empty
1288
1289
1290data StringContext
1291  = Plain  -- ^ all special characters have to be escape
1292  | Mono   -- ^ on top of special characters, escape space chraacters
1293  | Verb   -- ^ don't escape anything
1294
1295
1296latexStripTrailingWhitespace :: Doc a -> Doc a
1297latexStripTrailingWhitespace (DocString s)
1298  | null s'   = DocEmpty
1299  | otherwise = DocString s
1300  where s' = reverse (dropWhile isSpace (reverse s))
1301latexStripTrailingWhitespace (DocAppend l r)
1302  | DocEmpty <- r' = latexStripTrailingWhitespace l
1303  | otherwise      = DocAppend l r'
1304  where
1305    r' = latexStripTrailingWhitespace r
1306latexStripTrailingWhitespace (DocParagraph p) =
1307  latexStripTrailingWhitespace p
1308latexStripTrailingWhitespace other = other
1309
1310
1311-------------------------------------------------------------------------------
1312-- * LaTeX utils
1313-------------------------------------------------------------------------------
1314
1315
1316itemizedList :: [LaTeX] -> LaTeX
1317itemizedList items =
1318  text "\\vbox{\\begin{itemize}" $$
1319  vcat (map (text "\\item" $$) items) $$
1320  text "\\end{itemize}}"
1321
1322
1323enumeratedList :: [LaTeX] -> LaTeX
1324enumeratedList items =
1325  text "\\vbox{\\begin{enumerate}" $$
1326  vcat (map (text "\\item " $$) items) $$
1327  text "\\end{enumerate}}"
1328
1329
1330descriptionList :: [(LaTeX,LaTeX)] -> LaTeX
1331descriptionList items =
1332  text "\\vbox{\\begin{description}" $$
1333  vcat (map (\(a,b) -> text "\\item" <> brackets a <> text "\\hfill \\par" $$ b) items) $$
1334  text "\\end{description}}"
1335
1336
1337tt :: LaTeX -> LaTeX
1338tt ltx = text "\\haddocktt" <> braces ltx
1339
1340
1341decltt :: LaTeX -> LaTeX
1342decltt ltx = text "\\haddockdecltt" <> braces (text filtered)
1343  where filtered = latexMonoFilter (latex2String ltx)
1344
1345emph :: LaTeX -> LaTeX
1346emph ltx = text "\\emph" <> braces ltx
1347
1348bold :: LaTeX -> LaTeX
1349bold ltx = text "\\textbf" <> braces ltx
1350
1351-- TODO: @verbatim@ is too much since
1352--
1353--   * Haddock supports markup _inside_ of codeblocks. Right now, the LaTeX
1354--     representing that markup gets printed verbatim
1355--   * Verbatim environments are not supported everywhere (example: not nested
1356--     inside a @tabulary@ environment)
1357verb :: LaTeX -> LaTeX
1358verb doc = text "{\\haddockverb\\begin{verbatim}" $$ doc <> text "\\end{verbatim}}"
1359   -- NB. swallow a trailing \n in the verbatim text by appending the
1360   -- \end{verbatim} directly, otherwise we get spurious blank lines at the
1361   -- end of code blocks.
1362
1363
1364quote :: LaTeX -> LaTeX
1365quote doc = text "\\begin{quote}" $$ doc $$ text "\\end{quote}"
1366
1367
1368dcolon, arrow, darrow, forallSymbol, starSymbol, atSign :: Bool -> LaTeX
1369dcolon unicode = text (if unicode then "∷" else "::")
1370arrow  unicode = text (if unicode then "→" else "->")
1371darrow unicode = text (if unicode then "⇒" else "=>")
1372forallSymbol unicode = text (if unicode then "∀" else "forall")
1373starSymbol unicode = text (if unicode then "★" else "*")
1374atSign unicode = text (if unicode then "@" else "@")
1375
1376dot :: LaTeX
1377dot = char '.'
1378
1379
1380parenList :: [LaTeX] -> LaTeX
1381parenList = parens . hsep . punctuate comma
1382
1383
1384ubxParenList :: [LaTeX] -> LaTeX
1385ubxParenList = ubxparens . hsep . punctuate comma
1386
1387
1388ubxparens :: LaTeX -> LaTeX
1389ubxparens h = text "(#" <+> h <+> text "#)"
1390
1391
1392nl :: LaTeX
1393nl = text "\\\\"
1394
1395
1396keyword :: String -> LaTeX
1397keyword = text
1398
1399
1400infixr 4 <->  -- combining table cells
1401(<->) :: LaTeX -> LaTeX -> LaTeX
1402a <-> b = a <+> char '&' <+> b
1403