path: root/haddock-api/src/Haddock/Backends/LaTeX.hs

{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Haddock.Backends.LaTeX
-- Copyright   :  (c) Simon Marlow      2010,
--                    Mateusz Kowalczyk 2013
-- License     :  BSD-like
--
-- Maintainer  :  haddock@projects.haskell.org
-- Stability   :  experimental
-- Portability :  portable
-----------------------------------------------------------------------------
module Haddock.Backends.LaTeX (
  ppLaTeX,
) where

import Documentation.Haddock.Markup
import Haddock.Types
import Haddock.Utils
import Haddock.GhcUtils
import GHC.Utils.Ppr hiding (Doc, quote)
import qualified GHC.Utils.Ppr as Pretty

import GHC.Types.Basic        ( PromotionFlag(..) )
import GHC hiding (fromMaybeContext )
import GHC.Types.Name.Occurrence
import GHC.Types.Name        ( nameOccName )
import GHC.Types.Name.Reader ( rdrNameOcc )
import GHC.Core.Type         ( Specificity(..) )
import GHC.Data.FastString   ( unpackFS )
import GHC.Utils.Panic       ( panic)

import qualified Data.Map as Map
import System.Directory
import System.FilePath
import Data.Char
import Control.Monad
import Data.Maybe
import Data.List            ( sort )
import Data.Void            ( absurd )
import Prelude hiding ((<>))

import Haddock.Doc (combineDocumentation)

-- import Debug.Trace

{- SAMPLE OUTPUT

\haddockmoduleheading{\texttt{Data.List}}
\hrulefill
{\haddockverb\begin{verbatim}
module Data.List (
    (++),  head,  last,  tail,  init,  null,  length,  map,  reverse,
  ) where\end{verbatim}}
\hrulefill

\section{Basic functions}
\begin{haddockdesc}
\item[\begin{tabular}{@{}l}
head\ ::\ {\char 91}a{\char 93}\ ->\ a
\end{tabular}]\haddockbegindoc
Extract the first element of a list, which must be non-empty.
\par

\end{haddockdesc}
\begin{haddockdesc}
\item[\begin{tabular}{@{}l}
last\ ::\ {\char 91}a{\char 93}\ ->\ a
\end{tabular}]\haddockbegindoc
Extract the last element of a list, which must be finite and non-empty.
\par

\end{haddockdesc}
-}


{- TODO
 * don't forget fixity!!
-}

ppLaTeX :: String                       -- Title
        -> Maybe String                 -- Package name
        -> [Interface]
        -> FilePath                     -- destination directory
        -> Maybe (Doc GHC.RdrName)      -- prologue text, maybe
        -> Maybe String                 -- style file
        -> FilePath
        -> IO ()

ppLaTeX title packageStr visible_ifaces odir prologue maybe_style libdir
 = do
   createDirectoryIfMissing True odir
   when (isNothing maybe_style) $
     copyFile (libdir </> "latex" </> haddockSty) (odir </> haddockSty)
   ppLaTeXTop title packageStr odir prologue maybe_style visible_ifaces
   mapM_ (ppLaTeXModule title odir) visible_ifaces


haddockSty :: FilePath
haddockSty = "haddock.sty"


type LaTeX = Pretty.Doc

-- | Default way of rendering a 'LaTeX'. The width is 90 by default (since 100
-- often overflows the line).
latex2String :: LaTeX -> String
latex2String = fullRender (PageMode True) 90 1 txtPrinter ""

ppLaTeXTop
   :: String
   -> Maybe String
   -> FilePath
   -> Maybe (Doc GHC.RdrName)
   -> Maybe String
   -> [Interface]
   -> IO ()

ppLaTeXTop doctitle packageStr odir prologue maybe_style ifaces = do

  let tex = vcat [
        text "\\documentclass{book}",
        text "\\usepackage" <> braces (maybe (text "haddock") text maybe_style),
        text "\\begin{document}",
        text "\\begin{titlepage}",
        text "\\begin{haddocktitle}",
        text doctitle,
        text "\\end{haddocktitle}",
        case prologue of
           Nothing -> empty
           Just d  -> vcat [text "\\begin{haddockprologue}",
                            rdrDocToLaTeX d,
                            text "\\end{haddockprologue}"],
        text "\\end{titlepage}",
        text "\\tableofcontents",
        vcat [ text "\\input" <> braces (text mdl) | mdl <- mods ],
        text "\\end{document}"
        ]

      mods = sort (map (moduleBasename.ifaceMod) ifaces)

      filename = odir </> (fromMaybe "haddock" packageStr <.> "tex")

  writeUtf8File filename (show tex)


ppLaTeXModule :: String -> FilePath -> Interface -> IO ()
ppLaTeXModule _title odir iface = do
  createDirectoryIfMissing True odir
  let
      mdl = ifaceMod iface
      mdl_str = moduleString mdl

      exports = ifaceRnExportItems iface

      tex = vcat [
        text "\\haddockmoduleheading" <> braces (text mdl_str),
        text "\\label{module:" <> text mdl_str <> char '}',
        text "\\haddockbeginheader",
        verb $ vcat [
           text "module" <+> text mdl_str <+> lparen,
           text "    " <> fsep (punctuate (char ',') $
                               map exportListItem $
                               filter forSummary exports),
           text "  ) where"
         ],
        text "\\haddockendheader" $$ text "",
        description,
        body
       ]

      description
          = (fromMaybe empty . documentationToLaTeX . ifaceRnDoc) iface

      body = processExports exports
  --
  writeUtf8File (odir </> moduleLaTeXFile mdl) (fullRender (PageMode True) 80 1 txtPrinter "" tex)

-- | Prints out an entry in a module export list.
exportListItem :: ExportItem DocNameI -> LaTeX
exportListItem ExportDecl { expItemDecl = decl, expItemSubDocs = subdocs }
  = let (leader, names) = declNames decl
    in sep (punctuate comma [ leader <+> ppDocBinder name | name <- names ]) <>
         case subdocs of
           [] -> empty
           _  -> parens (sep (punctuate comma (map (ppDocBinder . fst) subdocs)))
exportListItem (ExportNoDecl y [])
  = ppDocBinder y
exportListItem (ExportNoDecl y subs)
  = ppDocBinder y <> parens (sep (punctuate comma (map ppDocBinder subs)))
exportListItem (ExportModule mdl)
  = text "module" <+> text (moduleString mdl)
exportListItem _
  = error "exportListItem"


-- Deal with a group of undocumented exports together, to avoid lots
-- of blank vertical space between them.
processExports :: [ExportItem DocNameI] -> LaTeX
processExports [] = empty
processExports (decl : es)
  | Just sig <- isSimpleSig decl
  = multiDecl [ ppTypeSig (map getName names) typ False
              | (names,typ) <- sig:sigs ] $$
    processExports es'
  where (sigs, es') = spanWith isSimpleSig es
processExports (ExportModule mdl : es)
  = declWithDoc (vcat [ text "module" <+> text (moduleString m) | m <- mdl:mdls ]) Nothing $$
    processExports es'
  where (mdls, es') = spanWith isExportModule es
processExports (e : es) =
  processExport e $$ processExports es


isSimpleSig :: ExportItem DocNameI -> Maybe ([DocName], HsSigType DocNameI)
isSimpleSig ExportDecl { expItemDecl = L _ (SigD _ (TypeSig _ lnames t))
                       , expItemMbDoc = (Documentation Nothing Nothing, argDocs) }
  | Map.null argDocs = Just (map unLoc lnames, unLoc (dropWildCards t))
isSimpleSig _ = Nothing


isExportModule :: ExportItem DocNameI -> Maybe Module
isExportModule (ExportModule m) = Just m
isExportModule _ = Nothing


processExport :: ExportItem DocNameI -> LaTeX
processExport (ExportGroup lev _id0 doc)
  = ppDocGroup lev (docToLaTeX doc)
processExport (ExportDecl decl pats doc subdocs insts fixities _splice)
  = ppDecl decl pats doc insts subdocs fixities
processExport (ExportNoDecl y [])
  = ppDocName y
processExport (ExportNoDecl y subs)
  = ppDocName y <> parens (sep (punctuate comma (map ppDocName subs)))
processExport (ExportModule mdl)
  = declWithDoc (text "module" <+> text (moduleString mdl)) Nothing
processExport (ExportDoc doc)
  = docToLaTeX $ _doc doc


ppDocGroup :: Int -> LaTeX -> LaTeX
ppDocGroup lev doc = sec lev <> braces doc
  where sec 1 = text "\\section"
        sec 2 = text "\\subsection"
        sec 3 = text "\\subsubsection"
        sec _ = text "\\paragraph"


-- | Given a declaration, extract out the names being declared
declNames :: LHsDecl DocNameI
          -> ( LaTeX           --   to print before each name in an export list
             , [DocName]       --   names being declared
             )
declNames (L _ decl) = case decl of
  TyClD _ d  -> (empty, [tcdNameI d])
  SigD _ (TypeSig _ lnames _ ) -> (empty, map unLoc lnames)
  SigD _ (PatSynSig _ lnames _) -> (text "pattern", map unLoc lnames)
  ForD _ (ForeignImport _ (L _ n) _ _) -> (empty, [n])
  ForD _ (ForeignExport _ (L _ n) _ _) -> (empty, [n])
  _ -> error "declaration not supported by declNames"


forSummary :: (ExportItem DocNameI) -> Bool
forSummary (ExportGroup _ _ _) = False
forSummary (ExportDoc _)       = False
forSummary _                    = True


moduleLaTeXFile :: Module -> FilePath
moduleLaTeXFile mdl = moduleBasename mdl ++ ".tex"


moduleBasename :: Module -> FilePath
moduleBasename mdl = map (\c -> if c == '.' then '-' else c)
                         (moduleNameString (moduleName mdl))


-------------------------------------------------------------------------------
-- * Decls
-------------------------------------------------------------------------------

-- | Pretty print a declaration
ppDecl :: LHsDecl DocNameI                         -- ^ decl to print
       -> [(HsDecl DocNameI, DocForDecl DocName)]  -- ^ all pattern decls
       -> DocForDecl DocName                       -- ^ documentation for decl
       -> [DocInstance DocNameI]                   -- ^ all instances
       -> [(DocName, DocForDecl DocName)]          -- ^ all subdocs
       -> [(DocName, Fixity)]                      -- ^ all fixities
       -> LaTeX

ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of
  TyClD _ d@FamDecl {}         -> ppFamDecl False doc instances d unicode
  TyClD _ d@DataDecl {}        -> ppDataDecl pats instances subdocs (Just doc) d unicode
  TyClD _ d@SynDecl {}         -> ppTySyn (doc, fnArgsDoc) d unicode
-- Family instances happen via FamInst now
--  TyClD _ d@TySynonym{}
--    | Just _  <- tcdTyPats d    -> ppTyInst False loc doc d unicode
-- Family instances happen via FamInst now
  TyClD _ d@ClassDecl{}          -> ppClassDecl instances doc subdocs d unicode
  SigD _ (TypeSig _ lnames ty)   -> ppFunSig Nothing (doc, fnArgsDoc) (map unLoc lnames) (dropWildCards ty) unicode
  SigD _ (PatSynSig _ lnames ty) -> ppLPatSig (doc, fnArgsDoc) (map unLoc lnames) ty unicode
  ForD _ d                       -> ppFor (doc, fnArgsDoc) d unicode
  InstD _ _                      -> empty
  DerivD _ _                     -> empty
  _                              -> error "declaration not supported by ppDecl"
  where
    unicode = False


ppFor :: DocForDecl DocName -> ForeignDecl DocNameI -> Bool -> LaTeX
ppFor doc (ForeignImport _ (L _ name) typ _) unicode =
  ppFunSig Nothing doc [name] typ unicode
ppFor _ _ _ = error "ppFor error in Haddock.Backends.LaTeX"
--  error "foreign declarations are currently not supported by --latex"


-------------------------------------------------------------------------------
-- * Type families
-------------------------------------------------------------------------------

-- | Pretty-print a data\/type family declaration
ppFamDecl :: Bool                     -- ^ is the family associated?
          -> Documentation DocName    -- ^ this decl's docs
          -> [DocInstance DocNameI]   -- ^ relevant instances
          -> TyClDecl DocNameI        -- ^ family to print
          -> Bool                     -- ^ unicode
          -> LaTeX
ppFamDecl associated doc instances decl unicode =
  declWithDoc (ppFamHeader (tcdFam decl) unicode associated <+> whereBit)
              (if null body then Nothing else Just (vcat body))
  $$ instancesBit
  where
    body = catMaybes [familyEqns, documentationToLaTeX doc]

    whereBit = case fdInfo (tcdFam decl) of
      ClosedTypeFamily _ -> keyword "where"
      _                  -> empty

    familyEqns
      | FamilyDecl { fdInfo = ClosedTypeFamily (Just eqns) } <- tcdFam decl
      , not (null eqns)
      = Just (text "\\haddockbeginargs" $$
              vcat [ decltt (ppFamDeclEqn eqn) <+> nl | L _ eqn <- eqns ] $$
              text "\\end{tabulary}\\par")
      | otherwise = Nothing

    -- Individual equations of a closed type family
    ppFamDeclEqn :: TyFamInstEqn DocNameI -> LaTeX
    ppFamDeclEqn (FamEqn { feqn_tycon = L _ n
                         , feqn_rhs = rhs
                         , feqn_pats = ts })
      = hsep [ ppAppNameTypeArgs n ts unicode
             , equals
             , ppType unicode (unLoc rhs)
             ]

    instancesBit = ppDocInstances unicode instances

-- | Print the LHS of a type\/data family declaration.
ppFamHeader :: FamilyDecl DocNameI  -- ^ family header to print
            -> Bool                 -- ^ unicode
            -> Bool                 -- ^ is the family associated?
            -> LaTeX
ppFamHeader (FamilyDecl { fdLName = L _ name
                        , fdTyVars = tvs
                        , fdInfo = info
                        , fdResultSig = L _ result
                        , fdInjectivityAnn = injectivity })
              unicode associated =
  famly leader <+> famName <+> famSig <+> injAnn
  where
    leader = case info of
      OpenTypeFamily     -> keyword "type"
      ClosedTypeFamily _ -> keyword "type"
      DataFamily         -> keyword "data"

    famly | associated = id
          | otherwise = (<+> keyword "family")

    famName = ppAppDocNameTyVarBndrs unicode name (hsq_explicit tvs)

    famSig = case result of
      NoSig _               -> empty
      KindSig _ kind        -> dcolon unicode <+> ppLKind unicode kind
      TyVarSig _ (L _ bndr) -> equals <+> ppHsTyVarBndr unicode bndr

    injAnn = case injectivity of
      Nothing -> empty
      Just (L _ (InjectivityAnn _ lhs rhs)) -> hsep ( decltt (text "|")
                                                    : ppLDocName lhs
                                                    : arrow unicode
                                                    : map ppLDocName rhs)
      Just _ -> empty



-------------------------------------------------------------------------------
-- * Type Synonyms
-------------------------------------------------------------------------------


-- we skip type patterns for now
ppTySyn :: DocForDecl DocName -> TyClDecl DocNameI -> Bool -> LaTeX

ppTySyn doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars
                         , tcdRhs = ltype }) unicode
  = ppTypeOrFunSig (mkHsImplicitSigTypeI ltype) doc (full, hdr, char '=') unicode
  where
    hdr  = hsep (keyword "type"
                 : ppDocBinder name
                 : map ppSymName (tyvarNames ltyvars))
    full = hdr <+> char '=' <+> ppLType unicode ltype

ppTySyn _ _ _ = error "declaration not supported by ppTySyn"


-------------------------------------------------------------------------------
-- * Function signatures
-------------------------------------------------------------------------------


ppFunSig
  :: Maybe LaTeX         -- ^ a prefix to put right before the signature
  -> DocForDecl DocName  -- ^ documentation
  -> [DocName]           -- ^ pattern names in the pattern signature
  -> LHsSigType DocNameI -- ^ type of the pattern synonym
  -> Bool                -- ^ unicode
  -> LaTeX
ppFunSig leader doc docnames (L _ typ) unicode =
  ppTypeOrFunSig typ doc
    ( lead $ ppTypeSig names typ False
    , lead $ hsep . punctuate comma $ map ppSymName names
    , dcolon unicode
    )
    unicode
 where
   names = map getName docnames
   lead = maybe id (<+>) leader

-- | Pretty-print a pattern synonym
ppLPatSig :: DocForDecl DocName  -- ^ documentation
          -> [DocName]           -- ^ pattern names in the pattern signature
          -> LHsSigType DocNameI -- ^ type of the pattern synonym
          -> Bool                -- ^ unicode
          -> LaTeX
ppLPatSig doc docnames ty unicode
  = ppFunSig (Just (keyword "pattern")) doc docnames ty unicode

-- | Pretty-print a type, adding documentation to the whole type and its
-- arguments as needed.
ppTypeOrFunSig :: HsSigType DocNameI
               -> DocForDecl DocName  -- ^ documentation
               -> ( LaTeX             --   first-line (no-argument docs only)
                  , LaTeX             --   first-line (argument docs only)
                  , LaTeX             --   type prefix (argument docs only)
                  )
               -> Bool                -- ^ unicode
               -> LaTeX
ppTypeOrFunSig typ (doc, argDocs) (pref1, pref2, sep0) unicode
  | Map.null argDocs = declWithDoc pref1 (documentationToLaTeX doc)
  | otherwise        = declWithDoc pref2 $ Just $
        text "\\haddockbeginargs" $$
        vcat (map (uncurry (<->)) (ppSubSigLike unicode typ argDocs [] sep0)) $$
        text "\\end{tabulary}\\par" $$
        fromMaybe empty (documentationToLaTeX doc)

-- | This splits up a type signature along @->@ and adds docs (when they exist)
-- to the arguments. The output is a list of (leader/seperator, argument and
-- its doc)
ppSubSigLike :: Bool                  -- ^ unicode
             -> HsSigType DocNameI    -- ^ type signature
             -> FnArgsDoc DocName     -- ^ docs to add
             -> [(DocName, DocForDecl DocName)] -- ^ all subdocs (useful when we have `HsRecTy`)
             -> LaTeX                 -- ^ seperator (beginning of first line)
             -> [(LaTeX, LaTeX)]      -- ^ arguments (leader/sep, type)
ppSubSigLike unicode typ argDocs subdocs leader = do_sig_args 0 leader typ
  where
    do_sig_args :: Int -> LaTeX -> HsSigType DocNameI -> [(LaTeX, LaTeX)]
    do_sig_args n leader (HsSig { sig_bndrs = outer_bndrs, sig_body = ltype }) =
      case outer_bndrs of
        HsOuterExplicit{hso_bndrs = bndrs} ->
          [ ( decltt leader
            , decltt (ppHsForAllTelescope (mkHsForAllInvisTeleI bndrs) unicode)
                <+> ppLType unicode ltype
            ) ]
        HsOuterImplicit{} -> do_largs n leader ltype

    do_largs :: Int -> LaTeX -> LHsType DocNameI -> [(LaTeX, LaTeX)]
    do_largs n leader (L _ t) = do_args n leader t

    arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs

    do_args :: Int -> LaTeX -> HsType DocNameI -> [(LaTeX, LaTeX)]
    do_args _n leader (HsForAllTy _ tele ltype)
      = [ ( decltt leader
          , decltt (ppHsForAllTelescope tele unicode)
              <+> ppLType unicode ltype
          ) ]
    do_args n leader (HsQualTy _ lctxt ltype)
      = ( decltt leader
        , decltt (ppLContextNoArrow lctxt unicode) <+> nl
        ) : do_largs n (darrow unicode) ltype

    do_args n leader (HsFunTy _ _w (L _ (HsRecTy _ fields)) r)
      = [ (decltt ldr, latex <+> nl)
        | (L _ field, ldr) <- zip fields (leader <+> gadtOpen : repeat gadtComma)
        , let latex = ppSideBySideField subdocs unicode field
        ]
        ++ do_largs (n+1) (gadtEnd <+> arrow unicode) r
    do_args n leader (HsFunTy _ _w lt r)
      = (decltt leader, decltt (ppLFunLhType unicode lt) <-> arg_doc n <+> nl)
        : do_largs (n+1) (arrow unicode) r
    do_args n leader t
      = [ (decltt leader, decltt (ppType unicode t) <-> arg_doc n <+> nl) ]

    -- FIXME: this should be done more elegantly
    --
    -- We need 'gadtComma' and 'gadtEnd' to line up with the `{` from
    -- 'gadtOpen', so we add 3 spaces to cover for `-> `/`:: ` (3 in unicode
    -- mode since `->` and `::` are rendered as single characters.
    gadtComma = hcat (replicate (if unicode then 3 else 4) (char ' ')) <> char ','
    gadtEnd = hcat (replicate (if unicode then 3 else 4) (char ' ')) <> char '}'
    gadtOpen = char '{'


ppTypeSig :: [Name] -> HsSigType DocNameI  -> Bool -> LaTeX
ppTypeSig nms ty unicode =
  hsep (punctuate comma $ map ppSymName nms)
    <+> dcolon unicode
    <+> ppSigType unicode ty

ppHsOuterTyVarBndrs :: HsOuterTyVarBndrs flag DocNameI -> Bool -> LaTeX
ppHsOuterTyVarBndrs (HsOuterImplicit{}) _ = empty
ppHsOuterTyVarBndrs (HsOuterExplicit{hso_bndrs = bndrs}) unicode =
    hsep (forallSymbol unicode : ppTyVars bndrs) <> dot

ppHsForAllTelescope :: HsForAllTelescope DocNameI -> Bool -> LaTeX
ppHsForAllTelescope tele unicode = case tele of
  HsForAllVis { hsf_vis_bndrs = bndrs } ->
    hsep (forallSymbol unicode : ppTyVars bndrs) <> text "\\" <> arrow unicode
  HsForAllInvis { hsf_invis_bndrs = bndrs } ->
    hsep (forallSymbol unicode : ppTyVars bndrs) <> dot


ppTyVars :: [LHsTyVarBndr flag DocNameI] -> [LaTeX]
ppTyVars = map (ppSymName . getName . hsLTyVarNameI)


tyvarNames :: LHsQTyVars DocNameI -> [Name]
tyvarNames = map (getName . hsLTyVarNameI) . hsQTvExplicit


declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX
declWithDoc decl doc =
   text "\\begin{haddockdesc}" $$
   text "\\item[\\begin{tabular}{@{}l}" $$
   text (latexMonoFilter (latex2String decl)) $$
   text "\\end{tabular}]" $$
   maybe empty (\x -> text "{\\haddockbegindoc" $$ x <> text "}") doc $$
   text "\\end{haddockdesc}"


-- in a group of decls, we don't put them all in the same tabular,
-- because that would prevent the group being broken over a page
-- boundary (breaks Foreign.C.Error for example).
multiDecl :: [LaTeX] -> LaTeX
multiDecl decls =
   text "\\begin{haddockdesc}" $$
   vcat [
      text "\\item[\\begin{tabular}{@{}l}" $$
      text (latexMonoFilter (latex2String decl)) $$
      text "\\end{tabular}]"
      | decl <- decls ] $$
   text "\\end{haddockdesc}"


-------------------------------------------------------------------------------
-- * Rendering Doc
-------------------------------------------------------------------------------


maybeDoc :: Maybe (Doc DocName) -> LaTeX
maybeDoc = maybe empty docToLaTeX


-- for table cells, we strip paragraphs out to avoid extra vertical space
-- and don't add a quote environment.
rDoc  :: Maybe (Doc DocName) -> LaTeX
rDoc = maybeDoc . fmap latexStripTrailingWhitespace


-------------------------------------------------------------------------------
-- * Class declarations
-------------------------------------------------------------------------------


ppClassHdr :: Bool -> Maybe (LocatedC [LHsType DocNameI]) -> DocName
           -> LHsQTyVars DocNameI -> [LHsFunDep DocNameI]
           -> Bool -> LaTeX
ppClassHdr summ lctxt n tvs fds unicode =
  keyword "class"
  <+> (if not (null $ fromMaybeContext lctxt) then ppLContext lctxt unicode else empty)
  <+> ppAppDocNameNames summ n (tyvarNames tvs)
  <+> ppFds fds unicode

-- ppFds :: [Located ([LocatedA DocName], [LocatedA DocName])] -> Bool -> LaTeX
ppFds :: [LHsFunDep DocNameI] -> Bool -> LaTeX
ppFds fds unicode =
  if null fds then empty else
    char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds))
  where
    fundep (FunDep _ vars1 vars2)
                         = hsep (map (ppDocName . unLoc) vars1) <+> arrow unicode <+>
                           hsep (map (ppDocName . unLoc) vars2)
    fundep (XFunDep _) = error "ppFds"


-- TODO: associated type defaults, docs on default methods
ppClassDecl :: [DocInstance DocNameI]
            -> Documentation DocName -> [(DocName, DocForDecl DocName)]
            -> TyClDecl DocNameI -> Bool -> LaTeX
ppClassDecl instances doc subdocs
  (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars, tcdFDs = lfds
             , tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs }) unicode
  = declWithDoc classheader (if null body then Nothing else Just (vcat body)) $$
    instancesBit
  where
    classheader
      | null lsigs = hdr unicode
      | otherwise  = hdr unicode <+> keyword "where"

    hdr = ppClassHdr False lctxt (unLoc lname) ltyvars lfds

    body = catMaybes [documentationToLaTeX doc, body_]

    body_
      | null lsigs, null ats, null at_defs = Nothing
      | null ats, null at_defs = Just methodTable
      | otherwise = Just (atTable $$ methodTable)

    atTable =
      text "\\haddockpremethods{}" <> emph (text "Associated Types") $$
      vcat  [ ppFamDecl True (fst doc) [] (FamDecl noExtField decl) True
            | L _ decl <- ats
            , let name = unLoc . fdLName $ decl
                  doc = lookupAnySubdoc name subdocs
            ]


    methodTable =
      text "\\haddockpremethods{}" <> emph (text "Methods") $$
      vcat  [ ppFunSig leader doc names typ unicode
            | L _ (ClassOpSig _ is_def lnames typ) <- lsigs
            , let doc | is_def = noDocForDecl
                      | otherwise = lookupAnySubdoc (head names) subdocs
                  names = map unLoc lnames
                  leader = if is_def then Just (keyword "default") else Nothing
            ]
            -- N.B. taking just the first name is ok. Signatures with multiple
            -- names are expanded so that each name gets its own signature.

    instancesBit = ppDocInstances unicode instances

ppClassDecl _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"

ppDocInstances :: Bool -> [DocInstance DocNameI] -> LaTeX
ppDocInstances _unicode [] = empty
ppDocInstances unicode (i : rest)
  | Just ihead <- isUndocdInstance i
  = declWithDoc (vcat (map (ppInstDecl unicode) (ihead:is))) Nothing $$
    ppDocInstances unicode rest'
  | otherwise
  = ppDocInstance unicode i $$ ppDocInstances unicode rest
  where
    (is, rest') = spanWith isUndocdInstance rest

isUndocdInstance :: DocInstance a -> Maybe (InstHead a)
isUndocdInstance (i,Nothing,_,_) = Just i
isUndocdInstance (i,Just (MetaDoc _ DocEmpty),_,_) = Just i
isUndocdInstance _ = Nothing

-- | Print a possibly commented instance. The instance header is printed inside
-- an 'argBox'. The comment is printed to the right of the box in normal comment
-- style.
ppDocInstance :: Bool -> DocInstance DocNameI -> LaTeX
ppDocInstance unicode (instHead, doc, _, _) =
  declWithDoc (ppInstDecl unicode instHead) (fmap docToLaTeX $ fmap _doc doc)


ppInstDecl :: Bool -> InstHead DocNameI -> LaTeX
ppInstDecl unicode (InstHead {..}) = case ihdInstType of
  ClassInst ctx _ _ _ -> keyword "instance" <+> ppContextNoLocs ctx unicode <+> typ
  TypeInst rhs -> keyword "type" <+> keyword "instance" <+> typ <+> tibody rhs
  DataInst dd ->
    let nd = dd_ND (tcdDataDefn dd)
        pref = case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }
    in pref <+> keyword "instance" <+> typ
  where
    typ = ppAppNameTypes ihdClsName ihdTypes unicode
    tibody = maybe empty (\t -> equals <+> ppType unicode t)

lookupAnySubdoc :: (Eq name1) =>
                   name1 -> [(name1, DocForDecl name2)] -> DocForDecl name2
lookupAnySubdoc n subdocs = case lookup n subdocs of
  Nothing -> noDocForDecl
  Just docs -> docs


-------------------------------------------------------------------------------
-- * Data & newtype declarations
-------------------------------------------------------------------------------

-- | Pretty-print a data declaration
ppDataDecl :: [(HsDecl DocNameI, DocForDecl DocName)] -- ^ relevant patterns
           -> [DocInstance DocNameI]                  -- ^ relevant instances
           -> [(DocName, DocForDecl DocName)]         -- ^ relevant decl docs
           -> Maybe (Documentation DocName)           -- ^ this decl's docs
           -> TyClDecl DocNameI                       -- ^ data decl to print
           -> Bool                                    -- ^ unicode
           -> LaTeX
ppDataDecl pats instances subdocs doc dataDecl unicode =
   declWithDoc (ppDataHeader dataDecl unicode <+> whereBit)
               (if null body then Nothing else Just (vcat body))
   $$ instancesBit

  where
    cons      = dd_cons (tcdDataDefn dataDecl)
    resTy     = (unLoc . head) cons

    body = catMaybes [doc >>= documentationToLaTeX, constrBit,patternBit]

    (whereBit, leaders)
      | null cons
      , null pats = (empty,[])
      | null cons = (text "where", repeat empty)
      | otherwise = case resTy of
        ConDeclGADT{} -> (text "where", repeat empty)
        _             -> (empty, (decltt (text "=") : repeat (decltt (text "|"))))

    constrBit
      | null cons = Nothing
      | otherwise = Just $
          text "\\enspace" <+> emph (text "Constructors") <> text "\\par" $$
          text "\\haddockbeginconstrs" $$
          vcat (zipWith (ppSideBySideConstr subdocs unicode) leaders cons) $$
          text "\\end{tabulary}\\par"

    patternBit
      | null pats = Nothing
      | otherwise = Just $
          text "\\enspace" <+> emph (text "Bundled Patterns") <> text "\\par" $$
          text "\\haddockbeginconstrs" $$
          vcat [ empty <-> ppSideBySidePat lnames typ d unicode
               | (SigD _ (PatSynSig _ lnames typ), d) <- pats
               ] $$
          text "\\end{tabulary}\\par"

    instancesBit = ppDocInstances unicode instances


-- ppConstrHdr is for (non-GADT) existentials constructors' syntax
ppConstrHdr
  :: Bool                    -- ^ print explicit foralls
  -> [LHsTyVarBndr Specificity DocNameI] -- ^ type variables
  -> HsContext DocNameI      -- ^ context
  -> Bool                    -- ^ unicode
  -> LaTeX
ppConstrHdr forall_ tvs ctxt unicode = ppForall <> ppCtxt
  where
    ppForall
      | null tvs || not forall_ = empty
      | otherwise = ppHsForAllTelescope (mkHsForAllInvisTeleI tvs) unicode

    ppCtxt
      | null ctxt = empty
      | otherwise = ppContextNoArrow ctxt unicode <+> darrow unicode <> space


-- | Pretty-print a constructor
ppSideBySideConstr :: [(DocName, DocForDecl DocName)]  -- ^ all decl docs
                   -> Bool                             -- ^ unicode
                   -> LaTeX                            -- ^ prefix to decl
                   -> LConDecl DocNameI                -- ^ constructor decl
                   -> LaTeX
ppSideBySideConstr subdocs unicode leader (L _ con) =
  leader <-> decltt decl <-> rDoc mbDoc <+> nl
  $$ fieldPart
  where
    -- Find the name of a constructors in the decl (`getConName` always returns
    -- a non-empty list)
    aConName = unLoc (head (getConNamesI con))

    occ      = map (nameOccName . getName . unLoc) $ getConNamesI con

    ppOcc      = cat (punctuate comma (map ppBinder occ))
    ppOccInfix = cat (punctuate comma (map ppBinderInfix occ))

    -- Extract out the map of of docs corresponding to the constructors arguments
    argDocs = maybe Map.empty snd (lookup aConName subdocs)
    hasArgDocs = not $ Map.null argDocs

    -- First line of the constructor (no doc, no fields, single-line)
    decl = case con of
      ConDeclH98{ con_args = det
                , con_ex_tvs = tyVars
                , con_forall = forall_
                , con_mb_cxt = cxt
                } -> let context = fromMaybeContext cxt
                         header_ = ppConstrHdr forall_ tyVars context unicode
                     in case det of
        -- Prefix constructor, e.g. 'Just a'
        PrefixCon _ args
          | hasArgDocs -> header_ <+> ppOcc
          | otherwise -> hsep [ header_
                              , ppOcc
                              , hsep (map (ppLParendType unicode . hsScaledThing) args)
                              ]

        -- Record constructor, e.g. 'Identity { runIdentity :: a }'
        RecCon _ ->  header_ <+> ppOcc

        -- Infix constructor, e.g. 'a :| [a]'
        InfixCon arg1 arg2
          | hasArgDocs -> header_ <+> ppOcc
          | otherwise -> hsep [ header_
                              , ppLParendType unicode (hsScaledThing arg1)
                              , ppOccInfix
                              , ppLParendType unicode (hsScaledThing arg2)
                              ]

      ConDeclGADT{}
        | hasArgDocs || not (isEmpty fieldPart) -> ppOcc
        | otherwise -> hsep [ ppOcc
                            , dcolon unicode
                            -- ++AZ++ make this prepend "{..}" when it is a record style GADT
                            , ppLSigType unicode (getGADTConType con)
                            ]

    fieldPart = case con of
        ConDeclGADT{con_g_args = con_args'} -> case con_args' of
          -- GADT record declarations
          RecConGADT _                    -> doConstrArgsWithDocs []
          -- GADT prefix data constructors
          PrefixConGADT args | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing args)
          _                               -> empty

        ConDeclH98{con_args = con_args'} -> case con_args' of
          -- H98 record declarations
          RecCon (L _ fields)             -> doRecordFields fields
          -- H98 prefix data constructors
          PrefixCon _ args | hasArgDocs   -> doConstrArgsWithDocs (map hsScaledThing args)
          -- H98 infix data constructor
          InfixCon arg1 arg2 | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing [arg1,arg2])
          _                               -> empty

    doRecordFields fields =
      vcat [ empty <-> tt (text begin) <+> ppSideBySideField subdocs unicode field <+> nl
           | (begin, L _ field) <- zip ("\\qquad \\{" : repeat "\\qquad ,") fields
           ]
      $$
      empty <-> tt (text "\\qquad \\}") <+> nl

    doConstrArgsWithDocs args = vcat $ map (\l -> empty <-> text "\\qquad" <+> l) $ case con of
      ConDeclH98{} ->
        [ decltt (ppLParendType unicode arg) <-> rDoc (fmap _doc mdoc) <+> nl
        | (i, arg) <- zip [0..] args
        , let mdoc = Map.lookup i argDocs
        ]
      ConDeclGADT{} ->
        [ l <+> text "\\enspace" <+> r
        | (l,r) <- ppSubSigLike unicode (unLoc (getGADTConType con)) argDocs subdocs (dcolon unicode)
        ]


    -- don't use "con_doc con", in case it's reconstructed from a .hi file,
    -- or also because we want Haddock to do the doc-parsing, not GHC.
    mbDoc = case getConNamesI con of
              [] -> panic "empty con_names"
              (cn:_) -> lookup (unLoc cn) subdocs >>=
                        fmap _doc . combineDocumentation . fst


-- | Pretty-print a record field
ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocNameI ->  LaTeX
ppSideBySideField subdocs unicode (ConDeclField _ names ltype _) =
  decltt (cat (punctuate comma (map (ppBinder . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names))
    <+> dcolon unicode <+> ppLType unicode ltype) <-> rDoc mbDoc
  where
    -- don't use cd_fld_doc for same reason we don't use con_doc above
    -- Where there is more than one name, they all have the same documentation
    mbDoc = lookup (extFieldOcc $ unLoc $ head names) subdocs >>= fmap _doc . combineDocumentation . fst


-- | Pretty-print a bundled pattern synonym
ppSideBySidePat :: [LocatedN DocName]   -- ^ pattern name(s)
                -> LHsSigType DocNameI  -- ^ type of pattern(s)
                -> DocForDecl DocName   -- ^ doc map
                -> Bool                 -- ^ unicode
                -> LaTeX
ppSideBySidePat lnames typ (doc, argDocs) unicode =
  decltt decl <-> rDoc mDoc <+> nl
  $$ fieldPart
  where
    hasArgDocs = not $ Map.null argDocs
    ppOcc = hsep (punctuate comma (map (ppDocBinder . unLoc) lnames))

    decl | hasArgDocs = keyword "pattern" <+> ppOcc
         | otherwise = hsep [ keyword "pattern"
                            , ppOcc
                            , dcolon unicode
                            , ppLSigType unicode typ
                            ]

    fieldPart
      | not hasArgDocs = empty
      | otherwise = vcat
          [ empty <-> text "\\qquad" <+> l <+> text "\\enspace" <+> r
          | (l,r) <- ppSubSigLike unicode (unLoc typ) argDocs [] (dcolon unicode)
          ]

    mDoc = fmap _doc $ combineDocumentation doc


-- | Print the LHS of a data\/newtype declaration.
-- Currently doesn't handle 'data instance' decls or kind signatures
ppDataHeader :: TyClDecl DocNameI -> Bool -> LaTeX
ppDataHeader (DataDecl { tcdLName = L _ name, tcdTyVars = tyvars
                       , tcdDataDefn = HsDataDefn { dd_ND = nd, dd_ctxt = ctxt } }) unicode
  = -- newtype or data
    (case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }) <+>
    -- context
    ppLContext ctxt unicode <+>
    -- T a b c ..., or a :+: b
    ppAppDocNameNames False name (tyvarNames tyvars)
ppDataHeader _ _ = error "ppDataHeader: illegal argument"


--------------------------------------------------------------------------------
-- * Type applications
--------------------------------------------------------------------------------

ppAppDocNameTyVarBndrs :: RenderableBndrFlag flag =>
  Bool -> DocName -> [LHsTyVarBndr flag DocNameI] -> LaTeX
ppAppDocNameTyVarBndrs unicode n vs =
    ppTypeApp n vs ppDN (ppHsTyVarBndr unicode . unLoc)
  where
    ppDN = ppBinder . nameOccName . getName


-- | Print an application of a DocName to its list of HsTypes
ppAppNameTypes :: DocName -> [HsType DocNameI] -> Bool -> LaTeX
ppAppNameTypes n ts unicode = ppTypeApp n ts ppDocName (ppParendType unicode)

ppAppNameTypeArgs :: DocName -> [LHsTypeArg DocNameI] -> Bool -> LaTeX
ppAppNameTypeArgs n args@(HsValArg _:HsValArg _:_) unicode
  = ppTypeApp n args ppDocName (ppLHsTypeArg unicode)
ppAppNameTypeArgs n args unicode
  = ppDocName n <+> hsep (map (ppLHsTypeArg unicode) args)

-- | Print an application of a DocName and a list of Names
ppAppDocNameNames :: Bool -> DocName -> [Name] -> LaTeX
ppAppDocNameNames _summ n ns =
  ppTypeApp n ns (ppBinder . nameOccName . getName) ppSymName


-- | General printing of type applications
ppTypeApp :: DocName -> [a] -> (DocName -> LaTeX) -> (a -> LaTeX) -> LaTeX
ppTypeApp n (t1:t2:rest) ppDN ppT
  | operator, not . null $ rest = parens opApp <+> hsep (map ppT rest)
  | operator                    = opApp
  where
    operator = isNameSym . getName $ n
    opApp = ppT t1 <+> ppDN n <+> ppT t2

ppTypeApp n ts ppDN ppT = ppDN n <+> hsep (map ppT ts)

-------------------------------------------------------------------------------
-- * Contexts
-------------------------------------------------------------------------------


ppLContext, ppLContextNoArrow :: Maybe (LHsContext DocNameI) -> Bool -> LaTeX
ppLContext        Nothing _ = empty
ppLContext        (Just ctxt) unicode  = ppContext        (unLoc ctxt) unicode
ppLContextNoArrow Nothing _ = empty
ppLContextNoArrow (Just ctxt) unicode = ppContextNoArrow (unLoc ctxt) unicode

ppContextNoLocsMaybe :: [HsType DocNameI] -> Bool -> Maybe LaTeX
ppContextNoLocsMaybe [] _ = Nothing
ppContextNoLocsMaybe cxt unicode = Just $ pp_hs_context cxt unicode

ppContextNoArrow :: HsContext DocNameI -> Bool -> LaTeX
ppContextNoArrow cxt unicode = fromMaybe empty $
                               ppContextNoLocsMaybe (map unLoc cxt) unicode


ppContextNoLocs :: [HsType DocNameI] -> Bool -> LaTeX
ppContextNoLocs cxt unicode = maybe empty (<+> darrow unicode) $
                              ppContextNoLocsMaybe cxt unicode


ppContext :: HsContext DocNameI -> Bool -> LaTeX
ppContext cxt unicode = ppContextNoLocs (map unLoc cxt) unicode


pp_hs_context :: [HsType DocNameI] -> Bool -> LaTeX
pp_hs_context []  _       = empty
pp_hs_context [p] unicode = ppCtxType unicode p
pp_hs_context cxt unicode = parenList (map (ppType unicode) cxt)


-------------------------------------------------------------------------------
-- * Types and contexts
-------------------------------------------------------------------------------


ppBang :: HsSrcBang -> LaTeX
ppBang (HsSrcBang _ _ SrcStrict) = char '!'
ppBang (HsSrcBang _ _ SrcLazy)   = char '~'
ppBang _                         = empty


tupleParens :: HsTupleSort -> [LaTeX] -> LaTeX
tupleParens HsUnboxedTuple = ubxParenList
tupleParens _              = parenList


sumParens :: [LaTeX] -> LaTeX
sumParens = ubxparens . hsep . punctuate (text " |")


-------------------------------------------------------------------------------
-- * Rendering of HsType
--
-- Stolen from Html and tweaked for LaTeX generation
-------------------------------------------------------------------------------

ppLType, ppLParendType, ppLFunLhType :: Bool -> LHsType DocNameI -> LaTeX
ppLType       unicode y = ppType unicode (unLoc y)
ppLParendType unicode y = ppParendType unicode (unLoc y)
ppLFunLhType  unicode y = ppFunLhType unicode (unLoc y)

ppLSigType :: Bool -> LHsSigType DocNameI -> LaTeX
ppLSigType unicode y = ppSigType unicode (unLoc y)

ppType, ppParendType, ppFunLhType, ppCtxType :: Bool -> HsType DocNameI -> LaTeX
ppType       unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode
ppParendType unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode
ppFunLhType  unicode ty = ppr_mono_ty (reparenTypePrec PREC_FUN ty) unicode
ppCtxType    unicode ty = ppr_mono_ty (reparenTypePrec PREC_CTX ty) unicode

ppSigType :: Bool -> HsSigType DocNameI -> LaTeX
ppSigType unicode sig_ty = ppr_sig_ty (reparenSigType sig_ty) unicode

ppLHsTypeArg :: Bool -> LHsTypeArg DocNameI -> LaTeX
ppLHsTypeArg unicode (HsValArg ty) = ppLParendType unicode ty
ppLHsTypeArg unicode (HsTypeArg _ ki) = atSign unicode <>
                                       ppLParendType unicode ki
ppLHsTypeArg _ (HsArgPar _) = text ""

class RenderableBndrFlag flag where
  ppHsTyVarBndr :: Bool -> HsTyVarBndr flag DocNameI -> LaTeX

instance RenderableBndrFlag () where
  ppHsTyVarBndr _ (UserTyVar _ _ (L _ name)) = ppDocName name
  ppHsTyVarBndr unicode (KindedTyVar _ _ (L _ name) kind) =
    parens (ppDocName name) <+> dcolon unicode <+> ppLKind unicode kind

instance RenderableBndrFlag Specificity where
  ppHsTyVarBndr _ (UserTyVar _ SpecifiedSpec (L _ name)) = ppDocName name
  ppHsTyVarBndr _ (UserTyVar _ InferredSpec (L _ name)) = braces $ ppDocName name
  ppHsTyVarBndr unicode (KindedTyVar _ SpecifiedSpec (L _ name) kind) =
    parens (ppDocName name) <+> dcolon unicode <+> ppLKind unicode kind
  ppHsTyVarBndr unicode (KindedTyVar _ InferredSpec (L _ name) kind) =
    braces (ppDocName name) <+> dcolon unicode <+> ppLKind unicode kind

ppLKind :: Bool -> LHsKind DocNameI -> LaTeX
ppLKind unicode y = ppKind unicode (unLoc y)

ppKind :: Bool -> HsKind DocNameI -> LaTeX
ppKind unicode ki = ppr_mono_ty (reparenTypePrec PREC_TOP ki) unicode

-- Drop top-level for-all type variables in user style
-- since they are implicit in Haskell

ppr_sig_ty :: HsSigType DocNameI -> Bool -> LaTeX
ppr_sig_ty (HsSig { sig_bndrs = outer_bndrs, sig_body = ltype }) unicode
  = sep [ ppHsOuterTyVarBndrs outer_bndrs unicode
        , ppr_mono_lty ltype unicode ]

ppr_mono_lty :: LHsType DocNameI -> Bool -> LaTeX
ppr_mono_lty ty unicode = ppr_mono_ty (unLoc ty) unicode


ppr_mono_ty :: HsType DocNameI -> Bool -> LaTeX
ppr_mono_ty (HsForAllTy _ tele ty) unicode
  = sep [ ppHsForAllTelescope tele unicode
        , ppr_mono_lty ty unicode ]
ppr_mono_ty (HsQualTy _ ctxt ty) unicode
  = sep [ ppLContext ctxt unicode
        , ppr_mono_lty ty unicode ]
ppr_mono_ty (HsFunTy _ mult ty1 ty2)   u
  = sep [ ppr_mono_lty ty1 u
        , arr <+> ppr_mono_lty ty2 u ]
   where arr = case mult of
                 HsLinearArrow _ _ -> lollipop u
                 HsUnrestrictedArrow _ -> arrow u
                 HsExplicitMult _ _ m -> multAnnotation <> ppr_mono_lty m u <+> arrow u

ppr_mono_ty (HsBangTy _ b ty)     u = ppBang b <> ppLParendType u ty
ppr_mono_ty (HsTyVar _ NotPromoted (L _ name)) _ = ppDocName name
ppr_mono_ty (HsTyVar _ IsPromoted  (L _ name)) _ = char '\'' <> ppDocName name
ppr_mono_ty (HsTupleTy _ con tys) u = tupleParens con (map (ppLType u) tys)
ppr_mono_ty (HsSumTy _ tys) u       = sumParens (map (ppLType u) tys)
ppr_mono_ty (HsKindSig _ ty kind) u = parens (ppr_mono_lty ty u <+> dcolon u <+> ppLKind u kind)
ppr_mono_ty (HsListTy _ ty)       u = brackets (ppr_mono_lty ty u)
ppr_mono_ty (HsIParamTy _ (L _ n) ty) u = ppIPName n <+> dcolon u <+> ppr_mono_lty ty u
ppr_mono_ty (HsSpliceTy v _)    _ = absurd v
ppr_mono_ty (HsRecTy {})        _ = text "{..}"
ppr_mono_ty (XHsType {})        _ = error "ppr_mono_ty HsCoreTy"
ppr_mono_ty (HsExplicitListTy _ IsPromoted tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys
ppr_mono_ty (HsExplicitListTy _ NotPromoted tys) u = brackets $ hsep $ punctuate comma $ map (ppLType u) tys
ppr_mono_ty (HsExplicitTupleTy _ tys) u = Pretty.quote $ parenList $ map (ppLType u) tys

ppr_mono_ty (HsAppTy _ fun_ty arg_ty) unicode
  = hsep [ppr_mono_lty fun_ty unicode, ppr_mono_lty arg_ty unicode]

ppr_mono_ty (HsAppKindTy _ fun_ty arg_ki) unicode
  = hsep [ppr_mono_lty fun_ty unicode, atSign unicode <> ppr_mono_lty arg_ki unicode]

ppr_mono_ty (HsOpTy _ ty1 op ty2) unicode
  = ppr_mono_lty ty1 unicode <+> ppr_op <+> ppr_mono_lty ty2 unicode
  where
    ppr_op | isSymOcc (getOccName op) = ppLDocName op
           | otherwise = char '`' <> ppLDocName op <> char '`'

ppr_mono_ty (HsParTy _ ty) unicode
  = parens (ppr_mono_lty ty unicode)
--  = ppr_mono_lty ty unicode

ppr_mono_ty (HsDocTy _ ty _) unicode
  = ppr_mono_lty ty unicode

ppr_mono_ty (HsWildCardTy _) _ = char '_'

ppr_mono_ty (HsTyLit _ t) u = ppr_tylit t u
ppr_mono_ty (HsStarTy _ isUni) unicode = starSymbol (isUni || unicode)


ppr_tylit :: HsTyLit -> Bool -> LaTeX
ppr_tylit (HsNumTy _ n) _ = integer n
ppr_tylit (HsStrTy _ s) _ = text (show s)
ppr_tylit (HsCharTy _ c) _ = text (show c)
  -- XXX: Ok in verbatim, but not otherwise
  -- XXX: Do something with Unicode parameter?


-------------------------------------------------------------------------------
-- * Names
-------------------------------------------------------------------------------


ppBinder :: OccName -> LaTeX
ppBinder n
  | isSymOcc n = parens $ ppOccName n
  | otherwise  = ppOccName n

ppBinderInfix :: OccName -> LaTeX
ppBinderInfix n
  | isSymOcc n = ppOccName n
  | otherwise  = cat [ char '`', ppOccName n, char '`' ]

ppSymName :: Name -> LaTeX
ppSymName name
  | isNameSym name = parens $ ppName name
  | otherwise = ppName name


ppIPName :: HsIPName -> LaTeX
ppIPName = text . ('?':) . unpackFS . hsIPNameFS

ppOccName :: OccName -> LaTeX
ppOccName = text . occNameString


ppDocName :: DocName -> LaTeX
ppDocName = ppOccName . nameOccName . getName

ppLDocName :: GenLocated l DocName -> LaTeX
ppLDocName (L _ d) = ppDocName d


ppDocBinder :: DocName -> LaTeX
ppDocBinder = ppBinder . nameOccName . getName


ppName :: Name -> LaTeX
ppName = ppOccName . nameOccName


latexFilter :: String -> String
latexFilter = foldr latexMunge ""


latexMonoFilter :: String -> String
latexMonoFilter = foldr latexMonoMunge ""


latexMunge :: Char -> String -> String
latexMunge '#'  s = "{\\char '43}" ++ s
latexMunge '$'  s = "{\\char '44}" ++ s
latexMunge '%'  s = "{\\char '45}" ++ s
latexMunge '&'  s = "{\\char '46}" ++ s
latexMunge '~'  s = "{\\char '176}" ++ s
latexMunge '_'  s = "{\\char '137}" ++ s
latexMunge '^'  s = "{\\char '136}" ++ s
latexMunge '\\' s = "{\\char '134}" ++ s
latexMunge '{'  s = "{\\char '173}" ++ s
latexMunge '}'  s = "{\\char '175}" ++ s
latexMunge '['  s = "{\\char 91}" ++ s
latexMunge ']'  s = "{\\char 93}" ++ s
latexMunge c    s = c : s


latexMonoMunge :: Char -> String -> String
latexMonoMunge ' '      (' ':s) = "\\ \\ " ++ s
latexMonoMunge ' ' ('\\':' ':s) = "\\ \\ " ++ s
latexMonoMunge '\n' s = '\\' : '\\' : s
latexMonoMunge c s = latexMunge c s


-------------------------------------------------------------------------------
-- * Doc Markup
-------------------------------------------------------------------------------


latexMarkup :: HasOccName a => DocMarkup (Wrap a) (StringContext -> LaTeX -> LaTeX)
latexMarkup = Markup
  { markupParagraph            = \p v -> blockElem (p v (text "\\par"))
  , markupEmpty                = \_ -> id
  , markupString               = \s v -> inlineElem (text (fixString v s))
  , markupAppend               = \l r v -> l v . r v
  , markupIdentifier           = \i v -> inlineElem (markupId v (fmap occName i))
  , markupIdentifierUnchecked  = \i v -> inlineElem (markupId v (fmap snd i))
  , markupModule               =
      \(ModLink m mLabel) v ->
        case mLabel of
          Just lbl -> inlineElem . tt $ lbl v empty
          Nothing -> inlineElem (let (mdl,_ref) = break (=='#') m
                                 in (tt (text mdl)))
  , markupWarning              = \p v -> p v
  , markupEmphasis             = \p v -> inlineElem (emph (p v empty))
  , markupBold                 = \p v -> inlineElem (bold (p v empty))
  , markupMonospaced           = \p v -> inlineElem (markupMonospace p v)
  , markupUnorderedList        = \p v -> blockElem (itemizedList (map (\p' -> p' v empty) p))
  , markupPic                  = \p _ -> inlineElem (markupPic p)
  , markupMathInline           = \p _ -> inlineElem (markupMathInline p)
  , markupMathDisplay          = \p _ -> blockElem (markupMathDisplay p)
  , markupOrderedList          = \p v -> blockElem (enumeratedList (map (\(_, p') -> p' v empty) p))
  , markupDefList              = \l v -> blockElem (descriptionList (map (\(a,b) -> (a v empty, b v empty)) l))
  , markupCodeBlock            = \p _ -> blockElem (quote (verb (p Verb empty)))
  , markupHyperlink            = \(Hyperlink u l) v -> inlineElem (markupLink u (fmap (\x -> x v empty) l))
  , markupAName                = \_ _ -> id -- TODO
  , markupProperty             = \p _ -> blockElem (quote (verb (text p)))
  , markupExample              = \e _ -> blockElem (quote (verb (text $ unlines $ map exampleToString e)))
  , markupHeader               = \(Header l h) p -> blockElem (header l (h p empty))
  , markupTable                = \(Table h b) p -> blockElem (table h b p)
  }
  where
    blockElem :: LaTeX -> LaTeX -> LaTeX
    blockElem = ($$)

    inlineElem :: LaTeX -> LaTeX -> LaTeX
    inlineElem = (<>)

    header 1 d = text "\\section*" <> braces d
    header 2 d = text "\\subsection*" <> braces d
    header l d
      | l > 0 && l <= 6 = text "\\subsubsection*" <> braces d
    header l _ = error $ "impossible header level in LaTeX generation: " ++ show l

    table _ _ _ = text "{TODO: Table}"

    fixString Plain s = latexFilter s
    fixString Verb  s = s
    fixString Mono  s = latexMonoFilter s

    markupMonospace p Verb = p Verb empty
    markupMonospace p _ = tt (p Mono empty)

    markupLink url mLabel = case mLabel of
      Just label -> text "\\href" <> braces (text url) <> braces label
      Nothing    -> text "\\url"  <> braces (text url)

    -- Is there a better way of doing this? Just a space is an arbitrary choice.
    markupPic (Picture uri title) = parens (imageText title)
      where
        imageText Nothing = beg
        imageText (Just t) = beg <> text " " <> text t

        beg = text "image: " <> text uri

    markupMathInline mathjax = text "\\(" <> text mathjax <> text "\\)"

    markupMathDisplay mathjax = text "\\[" <> text mathjax <> text "\\]"

    markupId v wrappedOcc =
      case v of
        Verb  -> text i
        Mono  -> text "\\haddockid" <> braces (text . latexMonoFilter $ i)
        Plain -> text "\\haddockid" <> braces (text . latexFilter $ i)
      where i = showWrapped occNameString wrappedOcc

docToLaTeX :: Doc DocName -> LaTeX
docToLaTeX doc = markup latexMarkup doc Plain empty

documentationToLaTeX :: Documentation DocName -> Maybe LaTeX
documentationToLaTeX = fmap docToLaTeX . fmap _doc . combineDocumentation


rdrDocToLaTeX :: Doc RdrName -> LaTeX
rdrDocToLaTeX doc = markup latexMarkup doc Plain empty


data StringContext
  = Plain  -- ^ all special characters have to be escape
  | Mono   -- ^ on top of special characters, escape space characters
  | Verb   -- ^ don't escape anything


latexStripTrailingWhitespace :: Doc a -> Doc a
latexStripTrailingWhitespace (DocString s)
  | null s'   = DocEmpty
  | otherwise = DocString s
  where s' = reverse (dropWhile isSpace (reverse s))
latexStripTrailingWhitespace (DocAppend l r)
  | DocEmpty <- r' = latexStripTrailingWhitespace l
  | otherwise      = DocAppend l r'
  where
    r' = latexStripTrailingWhitespace r
latexStripTrailingWhitespace (DocParagraph p) =
  latexStripTrailingWhitespace p
latexStripTrailingWhitespace other = other


-------------------------------------------------------------------------------
-- * LaTeX utils
-------------------------------------------------------------------------------


itemizedList :: [LaTeX] -> LaTeX
itemizedList items =
  text "\\vbox{\\begin{itemize}" $$
  vcat (map (text "\\item" $$) items) $$
  text "\\end{itemize}}"


enumeratedList :: [LaTeX] -> LaTeX
enumeratedList items =
  text "\\vbox{\\begin{enumerate}" $$
  vcat (map (text "\\item " $$) items) $$
  text "\\end{enumerate}}"


descriptionList :: [(LaTeX,LaTeX)] -> LaTeX
descriptionList items =
  text "\\vbox{\\begin{description}" $$
  vcat (map (\(a,b) -> text "\\item" <> brackets a <> text "\\hfill \\par" $$ b) items) $$
  text "\\end{description}}"


tt :: LaTeX -> LaTeX
tt ltx = text "\\haddocktt" <> braces ltx


decltt :: LaTeX -> LaTeX
decltt ltx = text "\\haddockdecltt" <> braces (text filtered)
  where filtered = latexMonoFilter (latex2String ltx)

emph :: LaTeX -> LaTeX
emph ltx = text "\\emph" <> braces ltx

bold :: LaTeX -> LaTeX
bold ltx = text "\\textbf" <> braces ltx

-- TODO: @verbatim@ is too much since
--
--   * Haddock supports markup _inside_ of code blocks. Right now, the LaTeX
--     representing that markup gets printed verbatim
--   * Verbatim environments are not supported everywhere (example: not nested
--     inside a @tabulary@ environment)
verb :: LaTeX -> LaTeX
verb doc = text "{\\haddockverb\\begin{verbatim}" $$ doc <> text "\\end{verbatim}}"
   -- NB. swallow a trailing \n in the verbatim text by appending the
   -- \end{verbatim} directly, otherwise we get spurious blank lines at the
   -- end of code blocks.


quote :: LaTeX -> LaTeX
quote doc = text "\\begin{quote}" $$ doc $$ text "\\end{quote}"


dcolon, arrow, lollipop, darrow, forallSymbol, starSymbol, atSign :: Bool -> LaTeX
dcolon unicode = text (if unicode then "∷" else "::")
arrow  unicode = text (if unicode then "→" else "->")
lollipop unicode = text (if unicode then "⊸" else "%1 ->")
darrow unicode = text (if unicode then "⇒" else "=>")
forallSymbol unicode = text (if unicode then "∀" else "forall")
starSymbol unicode = text (if unicode then "★" else "*")
atSign unicode = text (if unicode then "@" else "@")

multAnnotation :: LaTeX
multAnnotation = text "%"

dot :: LaTeX
dot = char '.'


parenList :: [LaTeX] -> LaTeX
parenList = parens . hsep . punctuate comma


ubxParenList :: [LaTeX] -> LaTeX
ubxParenList = ubxparens . hsep . punctuate comma


ubxparens :: LaTeX -> LaTeX
ubxparens h = text "(#" <+> h <+> text "#)"


nl :: LaTeX
nl = text "\\\\"


keyword :: String -> LaTeX
keyword = text


infixr 4 <->  -- combining table cells
(<->) :: LaTeX -> LaTeX -> LaTeX
a <-> b = a <+> char '&' <+> b