{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
{-# LANGUAGE RecordWildCards #-}
-----------------------------------------------------------------------------
-- |
-- 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 Pretty hiding (Doc, quote)
import qualified Pretty

import GHC
import OccName
import Name                 ( nameOccName )
import RdrName              ( rdrNameOcc )
import FastString           ( unpackFS, unpackLitString, zString )
import Outputable           ( 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
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

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

ppLaTeXTop doctitle packageStr odir prologue maybe_style ifaces = do

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

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

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

  writeFile filename (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 (text ", ") $
                               map exportListItem $
                               filter forSummary exports),
           text "  ) where"
         ],
        text "\\haddockendheader" $$ text "",
        description,
        body
       ]

      description
          = (fromMaybe empty . documentationToLaTeX . ifaceRnDoc) iface

      body = processExports exports
  --
  writeFile (odir </> moduleLaTeXFile mdl) (fullRender PageMode 80 1 string_txt "" tex)

string_txt :: TextDetails -> String -> String
string_txt (Chr c)   s  = c:s
string_txt (Str s1)  s2 = s1 ++ s2
string_txt (PStr s1) s2 = unpackFS s1 ++ s2
string_txt (ZStr s1) s2 = zString s1 ++ s2
string_txt (LStr s1 _) s2 = unpackLitString s1 ++ s2

exportListItem :: ExportItem DocNameI -> LaTeX
exportListItem ExportDecl { expItemDecl = decl, expItemSubDocs = subdocs }
  = sep (punctuate comma . map ppDocBinder $ declNames decl) <>
     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], HsType DocNameI)
isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig lnames t))
                       , expItemMbDoc = (Documentation Nothing Nothing, argDocs) }
  | Map.null argDocs = Just (map unLoc lnames, unLoc (hsSigWcType 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"

declNames :: LHsDecl DocNameI -> [DocName]
declNames (L _ decl) = case decl of
  TyClD d  -> [tcdName d]
  SigD (TypeSig lnames _ ) -> map unLoc lnames
  SigD (PatSynSig lnames _) -> map unLoc lnames
  ForD (ForeignImport (L _ n) _ _ _) -> [n]
  ForD (ForeignExport (L _ n) _ _ _) -> [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
-------------------------------------------------------------------------------

ppDecl :: LHsDecl DocNameI
       -> [(HsDecl DocNameI, DocForDecl DocName)]
       -> DocForDecl DocName
       -> [DocInstance DocNameI]
       -> [(DocName, DocForDecl DocName)]
       -> [(DocName, Fixity)]
       -> LaTeX

ppDecl (L loc decl) pats (doc, fnArgsDoc) instances subdocs _fixities = case decl of
  TyClD d@(FamDecl {})          -> ppTyFam False loc doc d unicode
  TyClD d@(DataDecl {})
                                -> ppDataDecl pats instances subdocs loc (Just doc) d unicode
  TyClD d@(SynDecl {})          -> ppTySyn loc (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 loc doc subdocs d unicode
  SigD (TypeSig lnames t)   -> ppFunSig loc (doc, fnArgsDoc) (map unLoc lnames)
                                        (hsSigWcType t) unicode
  SigD (PatSynSig lnames ty) ->
      ppLPatSig loc (doc, fnArgsDoc) (map unLoc lnames) ty unicode
  ForD d                         -> ppFor loc (doc, fnArgsDoc) d unicode
  InstD _                        -> empty
  DerivD _                       -> empty
  _                              -> error "declaration not supported by ppDecl"
  where
    unicode = False

ppTyFam :: Bool -> SrcSpan -> Documentation DocName ->
              TyClDecl DocNameI -> Bool -> LaTeX
ppTyFam _ _ _ _ _ =
  error "type family declarations are currently not supported by --latex"

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

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

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

ppTySyn loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars
                         , tcdRhs = ltype }) unicode
  = ppTypeOrFunSig loc [name] (unLoc 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 :: SrcSpan -> DocForDecl DocName -> [DocName] -> LHsType DocNameI
         -> Bool -> LaTeX
ppFunSig loc doc docnames (L _ typ) unicode =
  ppTypeOrFunSig loc docnames typ doc
    ( ppTypeSig names typ False
    , hsep . punctuate comma $ map ppSymName names
    , dcolon unicode)
    unicode
 where
   names = map getName docnames

ppLPatSig :: SrcSpan -> DocForDecl DocName -> [DocName]
          -> LHsSigType DocNameI
          -> Bool -> LaTeX
ppLPatSig _loc (doc, _argDocs) docnames ty unicode
  = declWithDoc pref1 (documentationToLaTeX doc)
  where
    pref1 = hsep [ keyword "pattern"
                 , hsep $ punctuate comma $ map ppDocBinder docnames
                 , dcolon unicode
                 , ppLType unicode (hsSigType ty)
                 ]

ppTypeOrFunSig :: SrcSpan -> [DocName] -> HsType DocNameI
               -> DocForDecl DocName -> (LaTeX, LaTeX, LaTeX)
               -> Bool -> LaTeX
ppTypeOrFunSig _ _ typ (doc, argDocs) (pref1, pref2, sep0)
               unicode
  | Map.null argDocs =
      declWithDoc pref1 (documentationToLaTeX doc)
  | otherwise        =
      declWithDoc pref2 $ Just $
        text "\\haddockbeginargs" $$
        do_args 0 sep0 typ $$
        text "\\end{tabulary}\\par" $$
        fromMaybe empty (documentationToLaTeX doc)
  where
     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
     do_args _n leader (HsForAllTy tvs ltype)
       = decltt leader
         <-> decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]))
         <+> ppLType unicode ltype
     do_args n leader (HsQualTy lctxt ltype)
       = decltt leader
         <-> ppLContextNoArrow lctxt unicode <+> nl $$
             do_largs n (darrow unicode) ltype
     do_args n leader (HsFunTy lt r)
       = decltt leader <-> decltt (ppLFunLhType unicode lt) <-> arg_doc n <+> nl $$
         do_largs (n+1) (arrow unicode) r
     do_args n leader t
       = decltt leader <-> decltt (ppType unicode t) <-> arg_doc n <+> nl

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

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

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

declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX
declWithDoc decl doc =
   text "\\begin{haddockdesc}" $$
   text "\\item[\\begin{tabular}{@{}l}" $$
   text (latexMonoFilter (show decl)) $$
   text "\\end{tabular}]" <>
       (if isNothing doc then empty else text "\\haddockbegindoc") $$
   maybe empty id doc $$
   text "\\end{haddockdesc}"

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

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

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

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

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

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

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

ppClassDecl :: [DocInstance DocNameI] -> SrcSpan
            -> Documentation DocName -> [(DocName, DocForDecl DocName)]
            -> TyClDecl DocNameI -> Bool -> LaTeX
ppClassDecl instances loc 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 = atTable $$ methodTable
      | otherwise = error "LaTeX.ppClassDecl"

    methodTable =
      text "\\haddockpremethods{}\\textbf{Methods}" $$
      vcat  [ ppFunSig loc doc [name] (hsSigWcType typ) unicode
            | L _ (TypeSig lnames typ) <- lsigs
            , name <- map unLoc lnames
            , let doc = lookupAnySubdoc name subdocs
            ]

    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 _ = 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 = keyword "instance" <+> ppInstHead unicode instHead

ppInstHead :: Bool -> InstHead DocNameI -> LaTeX
ppInstHead unicode (InstHead {..}) = case ihdInstType of
    ClassInst ctx _ _ _ -> ppContextNoLocs ctx unicode <+> typ
    TypeInst rhs -> keyword "type" <+> typ <+> tibody rhs
    DataInst _ -> error "data instances not supported by --latex yet"
  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
-------------------------------------------------------------------------------

ppDataDecl :: [(HsDecl DocNameI, DocForDecl DocName)] -> [DocInstance DocNameI] ->
              [(DocName, DocForDecl DocName)] -> SrcSpan ->
              Maybe (Documentation DocName) -> TyClDecl DocNameI -> Bool ->
              LaTeX
ppDataDecl pats instances subdocs _loc 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 [constrBit,patternBit, doc >>= documentationToLaTeX]

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

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

    patternBit
      | null cons = Nothing
      | otherwise = Just $
          text "\\haddockbeginconstrs" $$
          vcat [ hsep [ keyword "pattern"
                      , hsep $ punctuate comma $ map (ppDocBinder . unLoc) lnames
                      , dcolon unicode
                      , ppLType unicode (hsSigType ty)
                      ] <-> rDoc (fmap _doc . combineDocumentation . fst $ d)
               | (SigD (PatSynSig lnames ty),d) <- pats
               ] $$
          text "\\end{tabulary}\\par"

    instancesBit = ppDocInstances unicode instances

-- ppConstrHdr is for (non-GADT) existentials constructors' syntax
ppConstrHdr :: Bool -> [Name] -> HsContext DocNameI -> Bool -> LaTeX
ppConstrHdr forall tvs ctxt unicode
 = (if null tvs then empty else ppForall)
   <+>
   (if null ctxt then empty else ppContextNoArrow ctxt unicode <+> darrow unicode <+> text " ")
  where
    ppForall = case forall of
      True  -> forallSymbol unicode <+> hsep (map ppName tvs) <+> text ". "
      False -> empty

ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LaTeX
                   -> LConDecl DocNameI -> LaTeX
ppSideBySideConstr subdocs unicode leader (L _ con@(ConDeclH98 {})) =
  leader <->
  case con_details con of

    PrefixCon args ->
      decltt (hsep ((header_ unicode <+> ppOcc) :
                 map (ppLParendType unicode) args))
      <-> rDoc mbDoc <+> nl

    RecCon (L _ fields) ->
      (decltt (header_ unicode <+> ppOcc)
        <-> rDoc mbDoc <+> nl)
      $$
      doRecordFields fields

    InfixCon arg1 arg2 ->
      decltt (hsep [ header_ unicode <+> ppLParendType unicode arg1,
                 ppOcc,
                 ppLParendType unicode arg2 ])
      <-> rDoc mbDoc <+> nl

 where
    doRecordFields fields =
        vcat (map (ppSideBySideField subdocs unicode) (map unLoc fields))

    header_ = ppConstrHdr False tyVars context
    occ     = map (nameOccName . getName . unLoc) $ getConNames con
    ppOcc   = case occ of
      [one] -> ppBinder one
      _     -> cat (punctuate comma (map ppBinder occ))
    tyVars  = tyvarNames (fromMaybe (HsQTvs PlaceHolder [] PlaceHolder) (con_qvars con))
    context = unLoc (fromMaybe (noLoc []) (con_cxt con))

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

ppSideBySideConstr subdocs unicode leader (L _ con@(ConDeclGADT {})) =
  leader <->
  doGADTCon (hsib_body $ con_type con)

 where
    doGADTCon resTy = decltt (ppOcc <+> dcolon unicode <+>
                               ppLType unicode resTy
                            ) <-> rDoc mbDoc

    occ     = map (nameOccName . getName . unLoc) $ getConNames con
    ppOcc   = case occ of
      [one] -> ppBinder one
      _     -> cat (punctuate comma (map ppBinder occ))

    -- 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 getConNames con of
              [] -> panic "empty con_names"
              (cn:_) -> lookup (unLoc cn) subdocs >>=
                        fmap _doc . combineDocumentation . fst
{- old

ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LaTeX
                   -> LConDecl DocName -> LaTeX
ppSideBySideConstr subdocs unicode leader (L loc con) =
  leader <->
  case con_res con of
  ResTyH98 -> case con_details con of

    PrefixCon args ->
      decltt (hsep ((header_ unicode <+> ppOcc) :
                 map (ppLParendType unicode) args))
      <-> rDoc mbDoc <+> nl

    RecCon (L _ fields) ->
      (decltt (header_ unicode <+> ppOcc)
        <-> rDoc mbDoc <+> nl)
      $$
      doRecordFields fields

    InfixCon arg1 arg2 ->
      decltt (hsep [ header_ unicode <+> ppLParendType unicode arg1,
                 ppOcc,
                 ppLParendType unicode arg2 ])
      <-> rDoc mbDoc <+> nl

  ResTyGADT _ resTy -> case con_details con of
    -- prefix & infix could also use hsConDeclArgTys if it seemed to
    -- simplify the code.
    PrefixCon args -> doGADTCon args resTy
    cd@(RecCon (L _ fields)) -> doGADTCon (hsConDeclArgTys cd) resTy <+> nl $$
                                     doRecordFields fields
    InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy

 where
    doRecordFields fields =
        vcat (map (ppSideBySideField subdocs unicode) (map unLoc fields))

    doGADTCon args resTy = decltt (ppOcc <+> dcolon unicode <+>
                               ppLType unicode (mk_forall $ mk_phi $
                                                foldr mkFunTy resTy args)
                            ) <-> rDoc mbDoc

    header_ = ppConstrHdr (con_explicit con) tyVars context
    occ     = map (nameOccName . getName . unLoc) $ con_names con
    ppOcc   = case occ of
      [one] -> ppBinder one
      _     -> cat (punctuate comma (map ppBinder occ))
    ltvs    = con_qvars con
    tyVars  = tyvarNames (con_qvars con)
    context = unLoc (con_cxt con)

    mk_forall ty | con_explicit con = L loc (HsForAllTy (hsQTvExplicit ltvs) ty)
                 | otherwise        = ty
    mk_phi ty | null context = ty
              | otherwise    = L loc (HsQualTy (con_cxt con) ty)

    -- 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 con_names con of
              [] -> panic "empty con_names"
              (cn:_) -> lookup (unLoc cn) subdocs >>=
                        fmap _doc . combineDocumentation . fst
    mkFunTy a b = noLoc (HsFunTy a b)
-}

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 (selectorFieldOcc $ unLoc $ head names) subdocs >>= fmap _doc . combineDocumentation . fst

-- {-
-- ppHsFullConstr :: HsConDecl -> LaTeX
-- ppHsFullConstr (HsConDecl _ nm tvs ctxt typeList doc) =
--      declWithDoc False doc (
-- 	hsep ((ppHsConstrHdr tvs ctxt +++
-- 		ppHsBinder False nm) : map ppHsBangType typeList)
--       )
-- ppHsFullConstr (HsRecDecl _ nm tvs ctxt fields doc) =
--    td << vanillaTable << (
--      case doc of
--        Nothing -> aboves [hdr, fields_html]
--        Just _  -> aboves [hdr, constr_doc, fields_html]
--    )
--
--   where hdr = declBox (ppHsConstrHdr tvs ctxt +++ ppHsBinder False nm)
--
-- 	constr_doc
-- 	  | isJust doc = docBox (docToLaTeX (fromJust doc))
-- 	  | otherwise  = LaTeX.emptyTable
--
-- 	fields_html =
-- 	   td <<
-- 	      table ! [width "100%", cellpadding 0, cellspacing 8] << (
-- 		   aboves (map ppFullField (concat (map expandField fields)))
-- 		)
-- -}
--
-- ppShortField :: Bool -> Bool -> ConDeclField DocName -> LaTeX
-- ppShortField summary unicode (ConDeclField (L _ name) ltype _)
--   = tda [theclass "recfield"] << (
--       ppBinder summary (docNameOcc name)
--       <+> dcolon unicode <+> ppLType unicode ltype
--     )
--
-- {-
-- ppFullField :: HsFieldDecl -> LaTeX
-- ppFullField (HsFieldDecl [n] ty doc)
--   = declWithDoc False doc (
-- 	ppHsBinder False n <+> dcolon <+> ppHsBangType ty
--     )
-- ppFullField _ = error "ppFullField"
--
-- expandField :: HsFieldDecl -> [HsFieldDecl]
-- expandField (HsFieldDecl ns ty doc) = [ HsFieldDecl [n] ty doc | n <- ns ]
-- -}

-- | Print the LHS of a data\/newtype declaration.
-- Currently doesn't handle 'data instance' decls or kind signatures
ppDataHeader :: TyClDecl 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
--------------------------------------------------------------------------------

-- | 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)

-- | 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 :: Located (HsContext DocNameI) -> Bool -> LaTeX
ppLContext        = ppContext        . unLoc
ppLContextNoArrow = ppContextNoArrow . unLoc

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 = ppType 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
-------------------------------------------------------------------------------

pREC_TOP, pREC_FUN, pREC_OP, pREC_CON :: Int

pREC_TOP = (0 :: Int)   -- type in ParseIface.y in GHC
pREC_FUN = (1 :: Int)   -- btype in ParseIface.y in GHC
                        -- Used for LH arg of (->)
pREC_OP  = (2 :: Int)   -- Used for arg of any infix operator
                        -- (we don't keep their fixities around)
pREC_CON = (3 :: Int)   -- Used for arg of type applicn:
                        -- always parenthesise unless atomic

maybeParen :: Int           -- Precedence of context
           -> Int           -- Precedence of top-level operator
           -> LaTeX -> LaTeX  -- Wrap in parens if (ctxt >= op)
maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p
                               | otherwise            = p

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

ppType, ppParendType, ppFunLhType :: Bool -> HsType DocNameI -> LaTeX
ppType       unicode ty = ppr_mono_ty pREC_TOP ty unicode
ppParendType unicode ty = ppr_mono_ty pREC_CON ty unicode
ppFunLhType  unicode ty = ppr_mono_ty pREC_FUN ty unicode

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

ppKind :: Bool -> HsKind DocNameI -> LaTeX
ppKind unicode ki = ppr_mono_ty pREC_TOP ki unicode

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

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

ppr_mono_ty :: Int -> HsType DocNameI -> Bool -> LaTeX
ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode
  = maybeParen ctxt_prec pREC_FUN $
    sep [ hsep (forallSymbol unicode : ppTyVars tvs) <> dot
        , ppr_mono_lty pREC_TOP ty unicode ]
ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode
  = maybeParen ctxt_prec pREC_FUN $
    sep [ ppLContext ctxt unicode
        , ppr_mono_lty pREC_TOP ty unicode ]

ppr_mono_ty _         (HsBangTy b ty)     u = ppBang b <> ppLParendType u ty
ppr_mono_ty _         (HsTyVar NotPromoted (L _ name)) _ = ppDocName name
ppr_mono_ty _         (HsTyVar Promoted    (L _ name)) _ = char '\'' <> ppDocName name
ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2)   u = ppr_fun_ty ctxt_prec ty1 ty2 u
ppr_mono_ty _         (HsTupleTy con tys) u = tupleParens con (map (ppLType u) tys)
ppr_mono_ty _         (HsSumTy tys) u       = sumParens (map (ppLType u) tys)
ppr_mono_ty _         (HsKindSig ty kind) u = parens (ppr_mono_lty pREC_TOP ty u <+> dcolon u <+> ppLKind u kind)
ppr_mono_ty _         (HsListTy ty)       u = brackets (ppr_mono_lty pREC_TOP ty u)
ppr_mono_ty _         (HsPArrTy ty)       u = pabrackets (ppr_mono_lty pREC_TOP ty u)
ppr_mono_ty _         (HsIParamTy (L _ n) ty) u = brackets (ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u)
ppr_mono_ty _         (HsSpliceTy {})     _ = error "ppr_mono_ty HsSpliceTy"
ppr_mono_ty _         (HsRecTy {})        _ = error "ppr_mono_ty HsRecTy"
ppr_mono_ty _         (HsCoreTy {})       _ = error "ppr_mono_ty HsCoreTy"
ppr_mono_ty _         (HsExplicitListTy Promoted _ 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 ctxt_prec (HsEqTy ty1 ty2) unicode
  = maybeParen ctxt_prec pREC_OP $
    ppr_mono_lty pREC_OP ty1 unicode <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode

ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode
  = maybeParen ctxt_prec pREC_CON $
    hsep [ppr_mono_lty pREC_FUN fun_ty unicode, ppr_mono_lty pREC_CON arg_ty unicode]

ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode
  = maybeParen ctxt_prec pREC_FUN $
    ppr_mono_lty pREC_OP ty1 unicode <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode
  where
    ppr_op = if not (isSymOcc occName) then char '`' <> ppLDocName op <> char '`' else ppLDocName op
    occName = nameOccName . getName . unLoc $ op

ppr_mono_ty ctxt_prec (HsParTy ty) unicode
--  = parens (ppr_mono_lty pREC_TOP ty)
  = ppr_mono_lty ctxt_prec ty unicode

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

ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ = char '_'

ppr_mono_ty _ (HsTyLit t) u = ppr_tylit t u

ppr_mono_ty _ (HsAppsTy {}) _ = panic "ppr_mono_ty:HsAppsTy"

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

ppr_fun_ty :: Int -> LHsType DocNameI -> LHsType DocNameI -> Bool -> LaTeX
ppr_fun_ty ctxt_prec ty1 ty2 unicode
  = let p1 = ppr_mono_lty pREC_FUN ty1 unicode
        p2 = ppr_mono_lty pREC_TOP ty2 unicode
    in
    maybeParen ctxt_prec pREC_FUN $
    sep [p1, arrow unicode <+> p2]

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

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

isInfixName :: OccName -> Bool
isInfixName n = isVarSym n || isConSym n

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

ppVerbOccName :: OccName -> LaTeX
ppVerbOccName = text . latexFilter . occNameString

ppIPName :: HsIPName -> LaTeX
ppIPName ip = text $ unpackFS $ hsIPNameFS ip

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

ppVerbDocName :: DocName -> LaTeX
ppVerbDocName = ppVerbOccName . nameOccName . getName

ppVerbRdrName :: RdrName -> LaTeX
ppVerbRdrName = ppVerbOccName . rdrNameOcc

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

ppLDocName :: Located 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 '\n' s = '\\' : '\\' : s
latexMonoMunge c   s = latexMunge c s

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

parLatexMarkup :: (a -> LaTeX) -> DocMarkup a (StringContext -> LaTeX)
parLatexMarkup ppId = Markup {
  markupParagraph            = \p v -> p v <> text "\\par" $$ text "",
  markupEmpty                = \_ -> empty,
  markupString               = \s v -> text (fixString v s),
  markupAppend               = \l r v -> l v <> r v,
  markupIdentifier           = markupId ppId,
  markupIdentifierUnchecked  = markupId (ppVerbOccName . snd),
  markupModule               = \m _ -> let (mdl,_ref) = break (=='#') m in tt (text mdl),
  markupWarning              = \p v -> emph (p v),
  markupEmphasis             = \p v -> emph (p v),
  markupBold                 = \p v -> bold (p v),
  markupMonospaced           = \p _ -> tt (p Mono),
  markupUnorderedList        = \p v -> itemizedList (map ($v) p) $$ text "",
  markupPic                  = \p _ -> markupPic p,
  markupMathInline           = \p _ -> markupMathInline p,
  markupMathDisplay          = \p _ -> markupMathDisplay p,
  markupOrderedList          = \p v -> enumeratedList (map ($v) p) $$ text "",
  markupDefList              = \l v -> descriptionList (map (\(a,b) -> (a v, b v)) l),
  markupCodeBlock            = \p _ -> quote (verb (p Verb)) $$ text "",
  markupHyperlink            = \l _ -> markupLink l,
  markupAName                = \_ _ -> empty,
  markupProperty             = \p _ -> quote $ verb $ text p,
  markupExample              = \e _ -> quote $ verb $ text $ unlines $ map exampleToString e,
  markupHeader               = \(Header l h) p -> header l (h p),
  markupTable                = \(Table h b) p -> table h b p
  }
  where
    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

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

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

        beg = text "image: " <> text uri

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

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

    markupId ppId_ id v =
      case v of
        Verb  -> theid
        Mono  -> theid
        Plain -> text "\\haddockid" <> braces theid
      where theid = ppId_ id

latexMarkup :: DocMarkup DocName (StringContext -> LaTeX)
latexMarkup = parLatexMarkup ppVerbDocName

rdrLatexMarkup :: DocMarkup RdrName (StringContext -> LaTeX)
rdrLatexMarkup = parLatexMarkup ppVerbRdrName

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

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

rdrDocToLaTeX :: Doc RdrName -> LaTeX
rdrDocToLaTeX doc = markup rdrLatexMarkup doc Plain

data StringContext = Plain | Verb | Mono

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

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

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

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

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

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

decltt :: LaTeX -> LaTeX
decltt ltx = text "\\haddockdecltt" <> braces ltx

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

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

verb :: LaTeX -> LaTeX
verb doc = text "{\\haddockverb\\begin{verbatim}" $$ doc <> text "\\end{verbatim}}"
   -- NB. swallow a trailing \n in the verbatim text by appending the
   -- \end{verbatim} directly, otherwise we get spurious blank lines at the
   -- end of code blocks.

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

dcolon, arrow, darrow, forallSymbol :: Bool -> LaTeX
dcolon unicode = text (if unicode then "âˆ·" else "::")
arrow  unicode = text (if unicode then "â†’" else "->")
darrow unicode = text (if unicode then "â‡’" else "=>")
forallSymbol unicode = text (if unicode then "âˆ€" else "forall")

dot :: LaTeX
dot = char '.'

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

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

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

pabrackets :: LaTeX -> LaTeX
pabrackets h = text "[:" <> h <> text ":]"

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

keyword :: String -> LaTeX
keyword = text

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


-----------------------------------------------------------------------------
-- |
-- Module      :  Haddock.Backends.Html
-- Copyright   :  (c) Simon Marlow      2003-2006,
--                    David Waern       2006-2009,
--                    Mark Lentczner    2010,
--                    Mateusz Kowalczyk 2013
-- License     :  BSD-like
--
-- Maintainer  :  haddock@projects.haskell.org
-- Stability   :  experimental
-- Portability :  portable
-----------------------------------------------------------------------------
{-# LANGUAGE CPP, NamedFieldPuns #-}
module Haddock.Backends.Xhtml (
  ppHtml, copyHtmlBits,
  ppHtmlIndex, ppHtmlContents,
) where

import Prelude hiding (div)

import Haddock.Backends.Xhtml.Decl
import Haddock.Backends.Xhtml.DocMarkup
import Haddock.Backends.Xhtml.Layout
import Haddock.Backends.Xhtml.Names
import Haddock.Backends.Xhtml.Themes
import Haddock.Backends.Xhtml.Types
import Haddock.Backends.Xhtml.Utils
import Haddock.ModuleTree
import Haddock.Types
import Haddock.Version
import Haddock.Utils
import Haddock.Utils.Json
import Text.XHtml hiding ( name, title, p, quote )
import Haddock.GhcUtils

import Control.Monad         ( when, unless )
import qualified Data.ByteString.Builder as Builder
import Data.Char             ( toUpper, isSpace )
import Data.List             ( sortBy, isPrefixOf, intercalate, intersperse )
import Data.Maybe
import System.Directory
import System.FilePath hiding ( (</>) )
import qualified System.IO as IO
import Data.Map              ( Map )
import qualified Data.Map as Map hiding ( Map )
import qualified Data.Set as Set hiding ( Set )
import Data.Ord              ( comparing )

import DynFlags (Language(..))
import GHC hiding ( NoLink, moduleInfo,LexicalFixity(..) )
import Name

--------------------------------------------------------------------------------
-- * Generating HTML documentation
--------------------------------------------------------------------------------

ppHtml :: DynFlags
       -> String                       -- ^ Title
       -> Maybe String                 -- ^ Package
       -> [Interface]
       -> [InstalledInterface]         -- ^ Reexported interfaces
       -> FilePath                     -- ^ Destination directory
       -> Maybe (MDoc GHC.RdrName)     -- ^ Prologue text, maybe
       -> Themes                       -- ^ Themes
       -> Maybe String                 -- ^ The mathjax URL (--mathjax)
       -> SourceURLs                   -- ^ The source URL (--source)
       -> WikiURLs                     -- ^ The wiki URL (--wiki)
       -> Maybe String                 -- ^ The contents URL (--use-contents)
       -> Maybe String                 -- ^ The index URL (--use-index)
       -> Bool                         -- ^ Whether to use unicode in output (--use-unicode)
       -> Maybe String                 -- ^ Package name
       -> QualOption                   -- ^ How to qualify names
       -> Bool                         -- ^ Output pretty html (newlines and indenting)
       -> Bool                         -- ^ Also write Quickjump index
       -> IO ()

ppHtml dflags doctitle maybe_package ifaces reexported_ifaces odir prologue
        themes maybe_mathjax_url maybe_source_url maybe_wiki_url
        maybe_contents_url maybe_index_url unicode
        pkg qual debug withQuickjump = do
  let
    visible_ifaces = filter visible ifaces
    visible i = OptHide `notElem` ifaceOptions i

  when (isNothing maybe_contents_url) $
    ppHtmlContents dflags odir doctitle maybe_package
        themes maybe_mathjax_url maybe_index_url maybe_source_url maybe_wiki_url
        (map toInstalledIface visible_ifaces ++ reexported_ifaces)
        False -- we don't want to display the packages in a single-package contents
        prologue debug pkg (makeContentsQual qual)

  when (isNothing maybe_index_url) $ do
    ppHtmlIndex odir doctitle maybe_package
      themes maybe_mathjax_url maybe_contents_url maybe_source_url maybe_wiki_url
      (map toInstalledIface visible_ifaces ++ reexported_ifaces) debug

    when withQuickjump $
      ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual
        visible_ifaces

  mapM_ (ppHtmlModule odir doctitle themes
           maybe_mathjax_url maybe_source_url maybe_wiki_url
           maybe_contents_url maybe_index_url unicode pkg qual debug) visible_ifaces

copyHtmlBits :: FilePath -> FilePath -> Themes -> Bool -> IO ()
copyHtmlBits odir libdir themes withQuickjump = do
  let
    libhtmldir = joinPath [libdir, "html"]
    copyCssFile f = copyFile f (combine odir (takeFileName f))
    copyLibFile f = copyFile (joinPath [libhtmldir, f]) (joinPath [odir, f])
  mapM_ copyCssFile (cssFiles themes)
  copyLibFile haddockJsFile
  copyCssFile (joinPath [libhtmldir, quickJumpCssFile])
  when withQuickjump (copyLibFile jsQuickJumpFile)
  return ()

headHtml :: String -> Themes -> Maybe String -> Html
headHtml docTitle themes mathjax_url =
  header << [
    meta ! [httpequiv "Content-Type", content "text/html; charset=UTF-8"],
    thetitle << docTitle,
    styleSheet themes,
    thelink ! [ rel "stylesheet", thetype "text/css", href quickJumpCssFile] << noHtml,
    script ! [src haddockJsFile, emptyAttr "async", thetype "text/javascript"] << noHtml,
    script ! [src mjUrl, thetype "text/javascript"] << noHtml
    ]
  where
    mjUrl = maybe "https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.0/MathJax.js?config=TeX-AMS-MML_HTMLorMML" id mathjax_url

srcButton :: SourceURLs -> Maybe Interface -> Maybe Html
srcButton (Just src_base_url, _, _, _) Nothing =
  Just (anchor ! [href src_base_url] << "Source")
srcButton (_, Just src_module_url, _, _) (Just iface) =
  let url = spliceURL (Just $ ifaceOrigFilename iface)
                      (Just $ ifaceMod iface) Nothing Nothing src_module_url
   in Just (anchor ! [href url] << "Source")
srcButton _ _ =
  Nothing

wikiButton :: WikiURLs -> Maybe Module -> Maybe Html
wikiButton (Just wiki_base_url, _, _) Nothing =
  Just (anchor ! [href wiki_base_url] << "User Comments")

wikiButton (_, Just wiki_module_url, _) (Just mdl) =
  let url = spliceURL Nothing (Just mdl) Nothing Nothing wiki_module_url
   in Just (anchor ! [href url] << "User Comments")

wikiButton _ _ =
  Nothing

contentsButton :: Maybe String -> Maybe Html
contentsButton maybe_contents_url
  = Just (anchor ! [href url] << "Contents")
  where url = fromMaybe contentsHtmlFile maybe_contents_url

indexButton :: Maybe String -> Maybe Html
indexButton maybe_index_url
  = Just (anchor ! [href url] << "Index")
  where url = fromMaybe indexHtmlFile maybe_index_url

bodyHtml :: String -> Maybe Interface
    -> SourceURLs -> WikiURLs
    -> Maybe String -> Maybe String
    -> Html -> Html
bodyHtml doctitle iface
           maybe_source_url maybe_wiki_url
           maybe_contents_url maybe_index_url
           pageContent =
  body << [
    divPackageHeader << [
      unordList (catMaybes [
        srcButton maybe_source_url iface,
        wikiButton maybe_wiki_url (ifaceMod <$> iface),
        contentsButton maybe_contents_url,
        indexButton maybe_index_url])
            ! [theclass "links", identifier "page-menu"],
      nonEmptySectionName << doctitle
      ],
    divContent << pageContent,
    divFooter << paragraph << (
      "Produced by " +++
      (anchor ! [href projectUrl] << toHtml projectName) +++
      (" version " ++ projectVersion)
      )
    ]

moduleInfo :: Interface -> Html
moduleInfo iface =
   let
      info = ifaceInfo iface

      doOneEntry :: (String, HaddockModInfo GHC.Name -> Maybe String) -> Maybe HtmlTable
      doOneEntry (fieldName, field) =
        field info >>= \a -> return (th << fieldName <-> td << a)

      entries :: [HtmlTable]
      entries = maybeToList copyrightsTable ++ mapMaybe doOneEntry [
          ("License",hmi_license),
          ("Maintainer",hmi_maintainer),
          ("Stability",hmi_stability),
          ("Portability",hmi_portability),
          ("Safe Haskell",hmi_safety),
          ("Language", lg)
          ] ++ extsForm
        where
          lg inf = case hmi_language inf of
            Nothing -> Nothing
            Just Haskell98 -> Just "Haskell98"
            Just Haskell2010 -> Just "Haskell2010"

          multilineRow :: String -> [String] -> HtmlTable
          multilineRow title xs = (th ! [valign "top"]) << title <-> td << (toLines xs)
            where toLines = mconcat . intersperse br . map toHtml

          copyrightsTable :: Maybe HtmlTable
          copyrightsTable = fmap (multilineRow "Copyright" . split) (hmi_copyright info)
            where split = map (trim . filter (/= ',')) . lines

          extsForm
            | OptShowExtensions `elem` ifaceOptions iface =
              let fs = map (dropOpt . show) (hmi_extensions info)
              in case map stringToHtml fs of
                [] -> []
                [x] -> extField x -- don't use a list for a single extension
                xs -> extField $ unordList xs ! [theclass "extension-list"]
            | otherwise = []
            where
              extField x = return $ th << "Extensions" <-> td << x
              dropOpt x = if "Opt_" `isPrefixOf` x then drop 4 x else x
   in
      case entries of
         [] -> noHtml
         _ -> table ! [theclass "info"] << aboves entries

--------------------------------------------------------------------------------
-- * Generate the module contents
--------------------------------------------------------------------------------

ppHtmlContents
   :: DynFlags
   -> FilePath
   -> String
   -> Maybe String
   -> Themes
   -> Maybe String
   -> Maybe String
   -> SourceURLs
   -> WikiURLs
   -> [InstalledInterface] -> Bool -> Maybe (MDoc GHC.RdrName)
   -> Bool
   -> Maybe Package  -- ^ Current package
   -> Qualification  -- ^ How to qualify names
   -> IO ()
ppHtmlContents dflags odir doctitle _maybe_package
  themes mathjax_url maybe_index_url
  maybe_source_url maybe_wiki_url ifaces showPkgs prologue debug pkg qual = do
  let tree = mkModuleTree dflags showPkgs
         [(instMod iface, toInstalledDescription iface)
         | iface <- ifaces
         , not (instIsSig iface)]
      sig_tree = mkModuleTree dflags showPkgs
         [(instMod iface, toInstalledDescription iface)
         | iface <- ifaces
         , instIsSig iface]
      html =
        headHtml doctitle themes mathjax_url +++
        bodyHtml doctitle Nothing
          maybe_source_url maybe_wiki_url
          Nothing maybe_index_url << [
            ppPrologue pkg qual doctitle prologue,
            ppSignatureTree pkg qual sig_tree,
            ppModuleTree pkg qual tree
          ]
  createDirectoryIfMissing True odir
  writeFile (joinPath [odir, contentsHtmlFile]) (renderToString debug html)

ppPrologue :: Maybe Package -> Qualification -> String -> Maybe (MDoc GHC.RdrName) -> Html
ppPrologue _ _ _ Nothing = noHtml
ppPrologue pkg qual title (Just doc) =
  divDescription << (h1 << title +++ docElement thediv (rdrDocToHtml pkg qual doc))

ppSignatureTree :: Maybe Package -> Qualification -> [ModuleTree] -> Html
ppSignatureTree pkg qual ts =
  divModuleList << (sectionName << "Signatures" +++ mkNodeList pkg qual [] "n" ts)

ppModuleTree :: Maybe Package -> Qualification -> [ModuleTree] -> Html
ppModuleTree _ _ [] = mempty
ppModuleTree pkg qual ts =
  divModuleList << (sectionName << "Modules" +++ mkNodeList pkg qual [] "n" ts)

mkNodeList :: Maybe Package -> Qualification -> [String] -> String -> [ModuleTree] -> Html
mkNodeList pkg qual ss p ts = case ts of
  [] -> noHtml
  _ -> unordList (zipWith (mkNode pkg qual ss) ps ts)
  where
    ps = [ p ++ '.' : show i | i <- [(1::Int)..]]

mkNode :: Maybe Package -> Qualification -> [String] -> String -> ModuleTree -> Html
mkNode pkg qual ss p (Node s leaf _pkg srcPkg short ts) =
  htmlModule <+> shortDescr +++ htmlPkg +++ subtree
  where
    modAttrs = case (ts, leaf) of
      (_:_, Nothing) -> collapseControl p "module"
      (_,   _    ) -> [theclass "module"]

    cBtn = case (ts, leaf) of
      (_:_, Just _) -> thespan ! collapseControl p "" << spaceHtml
      (_,   _   ) -> noHtml
      -- We only need an explicit collapser button when the module name
      -- is also a leaf, and so is a link to a module page. Indeed, the
      -- spaceHtml is a minor hack and does upset the layout a fraction.

    htmlModule = thespan ! modAttrs << (cBtn +++
      case leaf of
        Just m -> ppModule m
        Nothing -> toHtml s
      )

    shortDescr = maybe noHtml (origDocToHtml pkg qual) short
    htmlPkg = maybe noHtml (thespan ! [theclass "package"] <<) srcPkg

    subtree =
      if null ts then noHtml else
      collapseDetails p DetailsOpen (
        thesummary ! [ theclass "hide-when-js-enabled" ] << "Submodules" +++
        mkNodeList pkg qual (s:ss) p ts
      )

--------------------------------------------------------------------------------
-- * Generate the index
--------------------------------------------------------------------------------

ppJsonIndex :: FilePath
           -> SourceURLs                   -- ^ The source URL (--source)
           -> WikiURLs                     -- ^ The wiki URL (--wiki)
           -> Bool
           -> Maybe Package
           -> QualOption
           -> [Interface]
           -> IO ()
ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces = do
  createDirectoryIfMissing True odir
  IO.withBinaryFile (joinPath [odir, indexJsonFile]) IO.WriteMode $ \h -> do
    Builder.hPutBuilder h (encodeToBuilder modules)
  where
    modules :: Value
    modules = Array (concatMap goInterface ifaces)

    goInterface :: Interface -> [Value]
    goInterface iface =
        concatMap (goExport mdl qual) (ifaceRnExportItems iface)
      where
        aliases = ifaceModuleAliases iface
        qual    = makeModuleQual qual_opt aliases mdl
        mdl     = ifaceMod iface

    goExport :: Module -> Qualification -> ExportItem DocNameI -> [Value]
    goExport mdl qual item
      | Just item_html <- processExport True links_info unicode pkg qual item
      = [ Object
            [ "display_html" .= String (showHtmlFragment item_html)
            , "name"         .= String (intercalate " " (map nameString names))
            , "module"       .= String (moduleString mdl)
            , "link"         .= String (fromMaybe "" (listToMaybe (map (nameLink mdl) names)))
            ]
        ]
      | otherwise = []
      where
        names = exportName item ++ exportSubs item

    exportSubs :: ExportItem name -> [IdP name]
    exportSubs ExportDecl { expItemSubDocs } = map fst expItemSubDocs
    exportSubs _ = []

    exportName :: ExportItem name -> [IdP name]
    exportName ExportDecl { expItemDecl } = getMainDeclBinder (unLoc expItemDecl)
    exportName ExportNoDecl { expItemName } = [expItemName]
    exportName _ = []

    nameString :: NamedThing name => name -> String
    nameString = occNameString . nameOccName . getName

    nameLink :: NamedThing name => Module -> name -> String
    nameLink mdl = moduleNameUrl' (moduleName mdl) . nameOccName . getName

    links_info = (maybe_source_url, maybe_wiki_url)

ppHtmlIndex :: FilePath
            -> String
            -> Maybe String
            -> Themes
            -> Maybe String
            -> Maybe String
            -> SourceURLs
            -> WikiURLs
            -> [InstalledInterface]
            -> Bool
            -> IO ()
ppHtmlIndex odir doctitle _maybe_package themes
  maybe_mathjax_url maybe_contents_url maybe_source_url maybe_wiki_url ifaces debug = do
  let html = indexPage split_indices Nothing
              (if split_indices then [] else index)

  createDirectoryIfMissing True odir

  when split_indices $ do
    mapM_ (do_sub_index index) initialChars
    -- Let's add a single large index as well for those who don't know exactly what they're looking for:
    let mergedhtml = indexPage False Nothing index
    writeFile (joinPath [odir, subIndexHtmlFile merged_name]) (renderToString debug mergedhtml)

  writeFile (joinPath [odir, indexHtmlFile]) (renderToString debug html)

  where
    indexPage showLetters ch items =
      headHtml (doctitle ++ " (" ++ indexName ch ++ ")") themes maybe_mathjax_url +++
      bodyHtml doctitle Nothing
        maybe_source_url maybe_wiki_url
        maybe_contents_url Nothing << [
          if showLetters then indexInitialLetterLinks else noHtml,
          if null items then noHtml else
            divIndex << [sectionName << indexName ch, buildIndex items]
          ]

    indexName ch = "Index" ++ maybe "" (\c -> " - " ++ [c]) ch
    merged_name = "All"

    buildIndex items = table << aboves (map indexElt items)

    -- an arbitrary heuristic:
    -- too large, and a single-page will be slow to load
    -- too small, and we'll have lots of letter-indexes with only one
    --   or two members in them, which seems inefficient or
    --   unnecessarily hard to use.
    split_indices = length index > 150

    indexInitialLetterLinks =
      divAlphabet <<
         unordList (map (\str -> anchor ! [href (subIndexHtmlFile str)] << str) $
                        [ [c] | c <- initialChars
                              , any ((==c) . toUpper . head . fst) index ] ++
                        [merged_name])

    -- todo: what about names/operators that start with Unicode
    -- characters?
    -- Exports beginning with '_' can be listed near the end,
    -- presumably they're not as important... but would be listed
    -- with non-split index!
    initialChars = [ 'A'..'Z' ] ++ ":!#$%&*+./<=>?@\\^|-~" ++ "_"

    do_sub_index this_ix c
      = unless (null index_part) $
          writeFile (joinPath [odir, subIndexHtmlFile [c]]) (renderToString debug html)
      where
        html = indexPage True (Just c) index_part
        index_part = [(n,stuff) | (n,stuff) <- this_ix, toUpper (head n) == c]

    index :: [(String, Map GHC.Name [(Module,Bool)])]
    index = sortBy cmp (Map.toAscList full_index)
      where cmp (n1,_) (n2,_) = comparing (map toUpper) n1 n2

    -- for each name (a plain string), we have a number of original HsNames that
    -- it can refer to, and for each of those we have a list of modules
    -- that export that entity.  Each of the modules exports the entity
    -- in a visible or invisible way (hence the Bool).
    full_index :: Map String (Map GHC.Name [(Module,Bool)])
    full_index = Map.fromListWith (flip (Map.unionWith (++)))
                 (concatMap getIfaceIndex ifaces)

    getIfaceIndex iface =
      [ (getOccString name
         , Map.fromList [(name, [(mdl, name `Set.member` visible)])])
         | name <- instExports iface ]
      where
        mdl = instMod iface
        visible = Set.fromList (instVisibleExports iface)

    indexElt :: (String, Map GHC.Name [(Module,Bool)]) -> HtmlTable
    indexElt (str, entities) =
       case Map.toAscList entities of
          [(nm,entries)] ->
              td ! [ theclass "src" ] << toHtml str <->
                          indexLinks nm entries
          many_entities ->
              td ! [ theclass "src" ] << toHtml str <-> td << spaceHtml </>
                  aboves (zipWith (curry doAnnotatedEntity) [1..] many_entities)

    doAnnotatedEntity :: (Integer, (Name, [(Module, Bool)])) -> HtmlTable
    doAnnotatedEntity (j,(nm,entries))
          = td ! [ theclass "alt" ] <<
                  toHtml (show j) <+> parens (ppAnnot (nameOccName nm)) <->
                   indexLinks nm entries

    ppAnnot n | not (isValOcc n) = toHtml "Type/Class"
              | isDataOcc n      = toHtml "Data Constructor"
              | otherwise        = toHtml "Function"

    indexLinks nm entries =
       td ! [ theclass "module" ] <<
          hsep (punctuate comma
          [ if visible then
               linkId mdl (Just nm) << toHtml (moduleString mdl)
            else
               toHtml (moduleString mdl)
          | (mdl, visible) <- entries ])

--------------------------------------------------------------------------------
-- * Generate the HTML page for a module
--------------------------------------------------------------------------------

ppHtmlModule
        :: FilePath -> String -> Themes
        -> Maybe String -> SourceURLs -> WikiURLs
        -> Maybe String -> Maybe String -> Bool -> Maybe Package -> QualOption
        -> Bool -> Interface -> IO ()
ppHtmlModule odir doctitle themes
  maybe_mathjax_url maybe_source_url maybe_wiki_url
  maybe_contents_url maybe_index_url unicode pkg qual debug iface = do
  let
      mdl = ifaceMod iface
      aliases = ifaceModuleAliases iface
      mdl_str = moduleString mdl
      mdl_str_annot = mdl_str ++ if ifaceIsSig iface
                                    then " (signature)"
                                    else ""
      mdl_str_linked
        | ifaceIsSig iface
        = mdl_str +++ " (signature" +++
                       sup << ("[" +++ anchor ! [href signatureDocURL] << "?" +++ "]" ) +++
                       ")"
        | otherwise
        = toHtml mdl_str
      real_qual = makeModuleQual qual aliases mdl
      html =
        headHtml mdl_str_annot themes maybe_mathjax_url +++
        bodyHtml doctitle (Just iface)
          maybe_source_url maybe_wiki_url
          maybe_contents_url maybe_index_url << [
            divModuleHeader << (moduleInfo iface +++ (sectionName << mdl_str_linked)),
            ifaceToHtml maybe_source_url maybe_wiki_url iface unicode pkg real_qual
          ]

  createDirectoryIfMissing True odir
  writeFile (joinPath [odir, moduleHtmlFile mdl]) (renderToString debug html)

signatureDocURL :: String
signatureDocURL = "https://wiki.haskell.org/Module_signature"

ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> Bool -> Maybe Package -> Qualification -> Html
ifaceToHtml maybe_source_url maybe_wiki_url iface unicode pkg qual
  = ppModuleContents pkg qual exports (not . null $ ifaceRnOrphanInstances iface) +++
    description +++
    synopsis +++
    divInterface (maybe_doc_hdr +++ bdy +++ orphans)
  where
    exports = numberSectionHeadings (ifaceRnExportItems iface)

    -- todo: if something has only sub-docs, or fn-args-docs, should
    -- it be measured here and thus prevent omitting the synopsis?
    has_doc ExportDecl { expItemMbDoc = (Documentation mDoc mWarning, _) } = isJust mDoc || isJust mWarning
    has_doc (ExportNoDecl _ _) = False
    has_doc (ExportModule _) = False
    has_doc _ = True

    no_doc_at_all = not (any has_doc exports)

    description | isNoHtml doc = doc
                | otherwise    = divDescription $ sectionName << "Description" +++ doc
                where doc = docSection Nothing pkg qual (ifaceRnDoc iface)

        -- omit the synopsis if there are no documentation annotations at all
    synopsis
      | no_doc_at_all = noHtml
      | otherwise
      = divSynopsis $
            collapseDetails "syn" DetailsClosed (
              thesummary << "Synopsis" +++
              shortDeclList (
                  mapMaybe (processExport True linksInfo unicode pkg qual) exports
              ) ! collapseToggle "syn" ""
            )

        -- if the documentation doesn't begin with a section header, then
        -- add one ("Documentation").
    maybe_doc_hdr
      = case exports of
          [] -> noHtml
          ExportGroup {} : _ -> noHtml
          _ -> h1 << "Documentation"

    bdy =
      foldr (+++) noHtml $
        mapMaybe (processExport False linksInfo unicode pkg qual) exports

    orphans =
      ppOrphanInstances linksInfo (ifaceRnOrphanInstances iface) False unicode pkg qual

    linksInfo = (maybe_source_url, maybe_wiki_url)

ppModuleContents :: Maybe Package -- ^ This package
                 -> Qualification
                 -> [ExportItem DocNameI]
                 -> Bool          -- ^ Orphans sections
                 -> Html
ppModuleContents pkg qual exports orphan
  | null sections && not orphan  = noHtml
  | otherwise                    = contentsDiv
 where
  contentsDiv = divTableOfContents << (
    sectionName << "Contents" +++
    unordList (sections ++ orphanSection))

  (sections, _leftovers{-should be []-}) = process 0 exports
  orphanSection
    | orphan =  [ linkedAnchor "section.orphans" << "Orphan instances" ]
    | otherwise = []

  process :: Int -> [ExportItem DocNameI] -> ([Html],[ExportItem DocNameI])
  process _ [] = ([], [])
  process n items@(ExportGroup lev id0 doc : rest)
    | lev <= n  = ( [], items )
    | otherwise = ( html:secs, rest2 )
    where
      html = linkedAnchor (groupId id0)
             << docToHtmlNoAnchors (Just id0) pkg qual (mkMeta doc) +++ mk_subsections ssecs
      (ssecs, rest1) = process lev rest
      (secs,  rest2) = process n   rest1
  process n (_ : rest) = process n rest

  mk_subsections [] = noHtml
  mk_subsections ss = unordList ss

-- we need to assign a unique id to each section heading so we can hyperlink
-- them from the contents:
numberSectionHeadings :: [ExportItem DocNameI] -> [ExportItem DocNameI]
numberSectionHeadings = go 1
  where go :: Int -> [ExportItem DocNameI] -> [ExportItem DocNameI]
        go _ [] = []
        go n (ExportGroup lev _ doc : es)
          = ExportGroup lev (show n) doc : go (n+1) es
        go n (other:es)
          = other : go n es

processExport :: Bool -> LinksInfo -> Bool -> Maybe Package -> Qualification
              -> ExportItem DocNameI -> Maybe Html
processExport _ _ _ _ _ ExportDecl { expItemDecl = L _ (InstD _) } = Nothing -- Hide empty instances
processExport summary _ _ pkg qual (ExportGroup lev id0 doc)
  = nothingIf summary $ groupHeading lev id0 << docToHtml (Just id0) pkg qual (mkMeta doc)
processExport summary links unicode pkg qual (ExportDecl decl pats doc subdocs insts fixities splice)
  = processDecl summary $ ppDecl summary links decl pats doc insts fixities subdocs splice unicode pkg qual
processExport summary _ _ _ qual (ExportNoDecl y [])
  = processDeclOneLiner summary $ ppDocName qual Prefix True y
processExport summary _ _ _ qual (ExportNoDecl y subs)
  = processDeclOneLiner summary $
      ppDocName qual Prefix True y
      +++ parenList (map (ppDocName qual Prefix True) subs)
processExport summary _ _ pkg qual (ExportDoc doc)
  = nothingIf summary $ docSection_ Nothing pkg qual doc
processExport summary _ _ _ _ (ExportModule mdl)
  = processDeclOneLiner summary $ toHtml "module" <+> ppModule mdl

nothingIf :: Bool -> a -> Maybe a
nothingIf True _ = Nothing
nothingIf False a = Just a

processDecl :: Bool -> Html -> Maybe Html
processDecl True = Just
processDecl False = Just . divTopDecl

trim :: String -> String
trim = f . f
  where f = reverse . dropWhile isSpace

processDeclOneLiner :: Bool -> Html -> Maybe Html
processDeclOneLiner True = Just
processDeclOneLiner False = Just . divTopDecl . declElem

groupHeading :: Int -> String -> Html -> Html
groupHeading lev id0 = linkedAnchor grpId . groupTag lev ! [identifier grpId]
  where grpId = groupId id0

groupTag :: Int -> Html -> Html
groupTag lev
  | lev == 1  = h1
  | lev == 2  = h2
  | lev == 3  = h3
  | otherwise = h4


{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeApplications #-}

module Haddock.Backends.Hyperlinker.Ast (enrich) where

import qualified Haddock.Syb as Syb
import Haddock.Backends.Hyperlinker.Types

import qualified GHC
import qualified SrcLoc

import Control.Applicative
import Control.Monad (guard)
import Data.Data
import qualified Data.Map.Strict as Map
import Data.Maybe

import Prelude hiding (span)

everythingInRenamedSource :: (Alternative f, Data x)
  => (forall a. Data a => a -> f r) -> x -> f r
everythingInRenamedSource f = Syb.everythingButType @GHC.Name (<|>) f

-- | Add more detailed information to token stream using GHC API.
enrich :: GHC.RenamedSource -> [Token] -> [RichToken]
enrich src =
    map $ \token -> RichToken
        { rtkToken = token
        , rtkDetails = enrichToken token detailsMap
        }
  where
    detailsMap =
      mkDetailsMap (concatMap ($ src)
                     [ variables
                     , types
                     , decls
                     , binds
                     , imports
                     ])

type LTokenDetails = [(GHC.SrcSpan, TokenDetails)]

-- | A map containing association between source locations and "details" of
-- this location.
--
type DetailsMap = Map.Map Position (Span, TokenDetails)

mkDetailsMap :: [(GHC.SrcSpan, TokenDetails)] -> DetailsMap
mkDetailsMap xs =
  Map.fromListWith select_details [ (start, (span, token_details))
                                  | (ghc_span, token_details) <- xs
                                  , GHC.RealSrcSpan span <- [ghc_span]
                                  , let start = SrcLoc.realSrcSpanStart span
                                  ]
  where
    -- favour token details which appear earlier in the list
    select_details _new old = old

lookupBySpan :: Span -> DetailsMap -> Maybe TokenDetails
lookupBySpan span details = do
  let pos = SrcLoc.realSrcSpanStart span
  (_, (tok_span, tok_details)) <- Map.lookupLE pos details
  guard (tok_span `SrcLoc.containsSpan` span)
  return tok_details

enrichToken :: Token -> DetailsMap -> Maybe TokenDetails
enrichToken (Token typ _ spn) dm
    | typ `elem` [TkIdentifier, TkOperator] = lookupBySpan spn dm
enrichToken _ _ = Nothing

-- | Obtain details map for variables ("normally" used identifiers).
variables :: GHC.RenamedSource -> LTokenDetails
variables =
    everythingInRenamedSource (var `Syb.combine` rec)
  where
    var term = case cast term of
        (Just ((GHC.L sspan (GHC.HsVar name)) :: GHC.LHsExpr GHC.GhcRn)) ->
            pure (sspan, RtkVar (GHC.unLoc name))
        (Just (GHC.L _ (GHC.RecordCon (GHC.L sspan name) _ _ _))) ->
            pure (sspan, RtkVar name)
        _ -> empty
    rec term = case cast term of
        Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LHsExpr GHC.GhcRn) _) ->
            pure (sspan, RtkVar name)
        _ -> empty

-- | Obtain details map for types.
types :: GHC.RenamedSource -> LTokenDetails
types = everythingInRenamedSource ty
  where
    ty :: forall a. Data a => a -> [(GHC.SrcSpan, TokenDetails)]
    ty term = case cast term of
        (Just ((GHC.L sspan (GHC.HsTyVar _ name)) :: GHC.LHsType GHC.GhcRn)) ->
            pure (sspan, RtkType (GHC.unLoc name))
        (Just ((GHC.L sspan (GHC.HsOpTy l name r)) :: GHC.LHsType GHC.GhcRn)) ->
            (sspan, RtkType (GHC.unLoc name)):(ty l ++ ty r)
        _ -> empty

-- | Obtain details map for identifier bindings.
--
-- That includes both identifiers bound by pattern matching or declared using
-- ordinary assignment (in top-level declarations, let-expressions and where
-- clauses).

binds :: GHC.RenamedSource -> LTokenDetails
binds = everythingInRenamedSource
      (fun `Syb.combine` pat `Syb.combine` tvar)
  where
    fun term = case cast term of
        (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.GhcRn)) ->
            pure (sspan, RtkBind name)
        (Just (GHC.PatSynBind (GHC.PSB (GHC.L sspan name) _ args _ _))) ->
            pure (sspan, RtkBind name) ++ everythingInRenamedSource patsyn_binds args
        _ -> empty
    patsyn_binds term = case cast term of
        (Just (GHC.L sspan (name :: GHC.Name))) -> pure (sspan, RtkVar name)
        _ -> empty
    pat term = case cast term of
        (Just ((GHC.L sspan (GHC.VarPat name)) :: GHC.LPat GHC.GhcRn)) ->
            pure (sspan, RtkBind (GHC.unLoc name))
        (Just (GHC.L _ (GHC.ConPatIn (GHC.L sspan name) recs))) ->
            [(sspan, RtkVar name)] ++ everythingInRenamedSource rec recs
        (Just (GHC.L _ (GHC.AsPat (GHC.L sspan name) _))) ->
            pure (sspan, RtkBind name)
        _ -> empty
    rec term = case cast term of
        (Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LPat GHC.GhcRn) _)) ->
            pure (sspan, RtkVar name)
        _ -> empty
    tvar term = case cast term of
        (Just ((GHC.L sspan (GHC.UserTyVar name)) :: GHC.LHsTyVarBndr GHC.GhcRn)) ->
            pure (sspan, RtkBind (GHC.unLoc name))
        (Just (GHC.L _ (GHC.KindedTyVar (GHC.L sspan name) _))) ->
            pure (sspan, RtkBind name)
        _ -> empty

-- | Obtain details map for top-level declarations.
decls :: GHC.RenamedSource -> LTokenDetails
decls (group, _, _, _) = concatMap ($ group)
    [ concat . map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds
    , everythingInRenamedSource fun . GHC.hs_valds
    , everythingInRenamedSource fix . GHC.hs_fixds
    , everythingInRenamedSource (con `Syb.combine` ins)
    ]
  where
    typ (GHC.L _ t) = case t of
        GHC.DataDecl { tcdLName = name } -> pure . decl $ name
        GHC.SynDecl name _ _ _ _ -> pure . decl $ name
        GHC.FamDecl fam -> pure . decl $ GHC.fdLName fam
        GHC.ClassDecl{..} ->
          [decl tcdLName]
            ++ concatMap sig tcdSigs
            ++ concatMap tyfam tcdATs
    fun term = case cast term of
        (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.GhcRn))
            | GHC.isExternalName name -> pure (sspan, RtkDecl name)
        (Just (GHC.PatSynBind (GHC.PSB (GHC.L sspan name) _ _ _ _)))
            | GHC.isExternalName name -> pure (sspan, RtkDecl name)
        _ -> empty
    con term = case cast term of
        (Just (cdcl :: GHC.ConDecl GHC.GhcRn)) ->
            map decl (GHC.getConNames cdcl)
              ++ everythingInRenamedSource fld cdcl
        Nothing -> empty
    ins term = case cast term of
        (Just ((GHC.DataFamInstD (GHC.DataFamInstDecl eqn))
                :: GHC.InstDecl GHC.GhcRn))
          -> pure . tyref $ GHC.feqn_tycon $ GHC.hsib_body eqn
        (Just (GHC.TyFamInstD (GHC.TyFamInstDecl eqn))) ->
            pure . tyref $ GHC.feqn_tycon $ GHC.hsib_body eqn
        _ -> empty
    fld term = case cast term of
        Just (field :: GHC.ConDeclField GHC.GhcRn)
          -> map (decl . fmap GHC.selectorFieldOcc) $ GHC.cd_fld_names field
        Nothing -> empty
    fix term = case cast term of
        Just ((GHC.FixitySig names _) :: GHC.FixitySig GHC.GhcRn)
          -> map (\(GHC.L sspan x) -> (sspan, RtkVar x)) names
        Nothing -> empty
    tyfam (GHC.L _ (GHC.FamilyDecl{..})) = [decl fdLName]
    sig (GHC.L _ (GHC.TypeSig names _)) = map decl names
    sig (GHC.L _ (GHC.PatSynSig names _)) = map decl names
    sig (GHC.L _ (GHC.ClassOpSig _ names _)) = map decl names
    sig _ = []
    decl (GHC.L sspan name) = (sspan, RtkDecl name)
    tyref (GHC.L sspan name) = (sspan, RtkType name)

-- | Obtain details map for import declarations.
--
-- This map also includes type and variable details for items in export and
-- import lists.
imports :: GHC.RenamedSource -> LTokenDetails
imports src@(_, imps, _, _) =
    everythingInRenamedSource ie src ++ mapMaybe (imp . GHC.unLoc) imps
  where
    ie term = case cast term of
        (Just ((GHC.IEVar v) :: GHC.IE GHC.GhcRn)) -> pure $ var $ GHC.ieLWrappedName v
        (Just (GHC.IEThingAbs t)) -> pure $ typ $ GHC.ieLWrappedName t
        (Just (GHC.IEThingAll t)) -> pure $ typ $ GHC.ieLWrappedName t
        (Just (GHC.IEThingWith t _ vs _fls)) ->
          [typ $ GHC.ieLWrappedName t] ++ map (var . GHC.ieLWrappedName) vs
        (Just (GHC.IEModuleContents m)) -> pure $ modu m
        _ -> empty
    typ (GHC.L sspan name) = (sspan, RtkType name)
    var (GHC.L sspan name) = (sspan, RtkVar name)
    modu (GHC.L sspan name) = (sspan, RtkModule name)
    imp idecl
      | not . GHC.ideclImplicit $ idecl = Just (modu (GHC.ideclName idecl))
      | otherwise = Nothing


module Haddock.Backends.Hyperlinker.Parser (parse) where

import Data.Either         ( isRight, isLeft )
import Data.List           ( foldl', isPrefixOf, isSuffixOf )
import Data.Maybe          ( maybeToList )
import Data.Char           ( isSpace )
import qualified Text.Read as R

import GHC                 ( DynFlags, addSourceToTokens )
import SrcLoc
import FastString          ( mkFastString )
import StringBuffer        ( stringToStringBuffer )
import Lexer               ( Token(..) )
import qualified Lexer as L

import Haddock.Backends.Hyperlinker.Types as T

-- | Turn source code string into a stream of more descriptive tokens.
--
-- Result should retain original file layout (including comments, whitespace,
-- etc.), i.e. the following "law" should hold:
--
-- prop> concat . map tkValue . parse = id
--
-- (In reality, this only holds for input not containing '\r', '\t', '\f', '\v',
-- characters, since GHC transforms those into ' ' and '\n')
parse :: DynFlags -> FilePath -> String -> [T.Token]
parse dflags fp = ghcToks . processCPP dflags fp . filterCRLF
  where
    -- Remove CRLFs from source
    filterCRLF :: String -> String
    filterCRLF ('\r':'\n':cs) = '\n' : filterCRLF cs
    filterCRLF (c:cs) = c : filterCRLF cs
    filterCRLF [] = []

-- | Parse the source into tokens using the GHC lexer.
--
--   * CPP lines are removed and reinserted as line-comments
--   * top-level file pragmas are parsed as block comments (see the
--     'ITblockComment' case of 'classify' for more details)
--
processCPP :: DynFlags    -- ^ GHC's flags
           -> FilePath    -- ^ source file name (for position information)
           -> String      -- ^ source file contents
           -> [(Located L.Token, String)]
processCPP dflags fpath s = addSrc . go start . splitCPP $ s
  where
    start = mkRealSrcLoc (mkFastString fpath) 1 1
    addSrc = addSourceToTokens start (stringToStringBuffer s)

    -- Transform a list of Haskell/CPP lines into a list of tokens
    go :: RealSrcLoc -> [Either String String] -> [Located L.Token]
    go _   [] = []
    go pos ls =
      let (hLinesRight,  ls')  = span isRight ls
          (cppLinesLeft, rest) = span isLeft ls'

          hSrc   = concat [ hLine   | Right hLine  <- hLinesRight  ]
          cppSrc = concat [ cppLine | Left cppLine <- cppLinesLeft ]

      in case L.lexTokenStream (stringToStringBuffer hSrc) pos dflags of

           -- Stuff that fails to lex gets turned into comments
           L.PFailed _ _ss _msg ->
             let (src_pos, failed) = mkToken ITunknown pos hSrc
                 (new_pos, cpp)    = mkToken ITlineComment src_pos cppSrc
             in failed : cpp : go new_pos rest

           -- Successfully lexed
           L.POk ss toks ->
             let (new_pos, cpp) = mkToken ITlineComment (L.loc ss) cppSrc
             in toks ++ [cpp] ++ go new_pos rest

    -- Manually make a token from a 'String', advancing the cursor position
    mkToken tok start' str =
      let end = foldl' advanceSrcLoc start' str
      in (end, L (RealSrcSpan $ mkRealSrcSpan start' end) (tok str))

-- | Split apart the initial file into Haskell source lines ('Left' entries) and
-- CPP lines ('Right' entries).
--
-- All characters in the input are present in the output:
--
-- prop> concat . map (either id id) . splitCPP = id
splitCPP :: String -> [Either String String]
splitCPP "" = []
splitCPP s | isCPPline s = Left l : splitCPP rest
           | otherwise =  Right l : splitCPP rest
  where
    ~(l, rest) = spanToNewline 0 s

-- | Heuristic to decide if a line is going to be a CPP line. This should be a
-- cheap operation since it is going to be run on every line being processed.
--
-- Right now it just checks if the first non-whitespace character in the first
-- five characters of the line is a '#':
--
-- >>> isCPPline "#define FOO 1"
-- True
--
-- >>> isCPPline "\t\t  #ifdef GHC"
-- True
--
-- >>> isCPPline "       #endif"
-- False
--
isCPPline :: String -> Bool
isCPPline = isPrefixOf "#" . dropWhile (`elem` " \t") . take 5

-- | Split a "line" off the front of a string, hopefully without cutting tokens
-- in half. I say "hopefully" because knowing what a token is requires lexing,
-- yet lexing depends on this function.
--
-- All characters in the input are present in the output:
--
-- prop> curry (++) . spanToNewLine 0 = id
spanToNewline :: Int                 -- ^ open '{-'
              -> String              -- ^ input
              -> (String, String)

-- Base case and space characters
spanToNewline _ "" = ("", "")
spanToNewline n ('\n':str) | n <= 0 = ("\n", str)
spanToNewline n ('\n':str) | n <= 0 = ("\n", str)
spanToNewline n ('\\':'\n':str) =
    let (str', rest) = spanToNewline n str
    in ('\\':'\n':str', rest)

-- Block comments
spanToNewline n ('{':'-':str) =
    let (str', rest) = spanToNewline (n+1) str
    in ('{':'-':str', rest)
spanToNewline n ('-':'}':str) =
    let (str', rest) = spanToNewline (n-1) str
    in ('-':'}':str', rest)

-- When not in a block comment, try to lex a Haskell token
spanToNewline 0 str@(c:_) | ((lexed, str') : _) <- R.lex str, not (isSpace c) =
    if all (== '-') lexed && length lexed >= 2
      -- A Haskell line comment
      then case span (/= '\n') str' of
             (str'', '\n':rest) -> (lexed ++ str'' ++ "\n", rest)
             (_, _) -> (str, "")

      -- An actual Haskell token
      else let (str'', rest) = spanToNewline 0 str'
           in (lexed ++ str'', rest)

-- In all other cases, advance one character at a time
spanToNewline n (c:str) =
    let (str', rest) = spanToNewline n str
    in (c:str', rest)

-- | Turn a list of GHC's 'L.Token' (and their source 'String') into a list of
-- Haddock's 'T.Token'.
ghcToks :: [(Located L.Token, String)] -> [T.Token]
ghcToks = reverse . (\(_,ts,_) -> ts) . foldl' go (start, [], False)
  where
    start = mkRealSrcLoc (mkFastString "lexing") 1 1

    go :: (RealSrcLoc, [T.Token], Bool)
       -- ^ current position, tokens accumulated, currently in pragma (or not)

       -> (Located L.Token, String)
       -- ^ next token, its content

       -> (RealSrcLoc, [T.Token], Bool)
       -- ^ new position, new tokens accumulated, currently in pragma (or not)

    go (pos, toks, in_prag) (L l tok, raw) =
        ( next_pos
        , classifiedTok ++ maybeToList white ++ toks
        , inPragma in_prag tok
        )
       where
         (next_pos, white) = mkWhitespace pos l

         classifiedTok = [ Token (classify' tok) raw rss
                         | RealSrcSpan rss <- [l]
                         , not (null raw)
                         ]

         classify' | in_prag = const TkPragma
                   | otherwise = classify

-- | Find the correct amount of whitespace between tokens.
mkWhitespace :: RealSrcLoc -> SrcSpan -> (RealSrcLoc, Maybe T.Token)
mkWhitespace prev spn =
  case spn of
    UnhelpfulSpan _ -> (prev,Nothing)
    RealSrcSpan s | null wsstring -> (end, Nothing)
                  | otherwise -> (end, Just (Token TkSpace wsstring wsspan))
      where
        start = realSrcSpanStart s
        end = realSrcSpanEnd s
        wsspan = mkRealSrcSpan prev start
        nls = srcLocLine start - srcLocLine prev
        spaces = if nls == 0 then srcLocCol start - srcLocCol prev
                             else srcLocCol start - 1
        wsstring = replicate nls '\n' ++ replicate spaces ' '

-- | Classify given tokens as appropriate Haskell token type.
classify :: L.Token -> TokenType
classify tok =
  case tok of
    ITas                   -> TkKeyword
    ITcase                 -> TkKeyword
    ITclass                -> TkKeyword
    ITdata                 -> TkKeyword
    ITdefault              -> TkKeyword
    ITderiving             -> TkKeyword
    ITdo                   -> TkKeyword
    ITelse                 -> TkKeyword
    IThiding               -> TkKeyword
    ITforeign              -> TkKeyword
    ITif                   -> TkKeyword
    ITimport               -> TkKeyword
    ITin                   -> TkKeyword
    ITinfix                -> TkKeyword
    ITinfixl               -> TkKeyword
    ITinfixr               -> TkKeyword
    ITinstance             -> TkKeyword
    ITlet                  -> TkKeyword
    ITmodule               -> TkKeyword
    ITnewtype              -> TkKeyword
    ITof                   -> TkKeyword
    ITqualified            -> TkKeyword
    ITthen                 -> TkKeyword
    ITtype                 -> TkKeyword
    ITwhere                -> TkKeyword

    ITforall            {} -> TkKeyword
    ITexport               -> TkKeyword
    ITlabel                -> TkKeyword
    ITdynamic              -> TkKeyword
    ITsafe                 -> TkKeyword
    ITinterruptible        -> TkKeyword
    ITunsafe               -> TkKeyword
    ITstdcallconv          -> TkKeyword
    ITccallconv            -> TkKeyword
    ITcapiconv             -> TkKeyword
    ITprimcallconv         -> TkKeyword
    ITjavascriptcallconv   -> TkKeyword
    ITmdo                  -> TkKeyword
    ITfamily               -> TkKeyword
    ITrole                 -> TkKeyword
    ITgroup                -> TkKeyword
    ITby                   -> TkKeyword
    ITusing                -> TkKeyword
    ITpattern              -> TkKeyword
    ITstatic               -> TkKeyword
    ITstock                -> TkKeyword
    ITanyclass             -> TkKeyword

    ITunit                 -> TkKeyword
    ITsignature            -> TkKeyword
    ITdependency           -> TkKeyword
    ITrequires             -> TkKeyword

    ITinline_prag       {} -> TkPragma
    ITspec_prag         {} -> TkPragma
    ITspec_inline_prag  {} -> TkPragma
    ITsource_prag       {} -> TkPragma
    ITrules_prag        {} -> TkPragma
    ITwarning_prag      {} -> TkPragma
    ITdeprecated_prag   {} -> TkPragma
    ITline_prag         {} -> TkPragma
    ITcolumn_prag       {} -> TkPragma
    ITscc_prag          {} -> TkPragma
    ITgenerated_prag    {} -> TkPragma
    ITcore_prag         {} -> TkPragma
    ITunpack_prag       {} -> TkPragma
    ITnounpack_prag     {} -> TkPragma
    ITann_prag          {} -> TkPragma
    ITcomplete_prag     {} -> TkPragma
    ITclose_prag           -> TkPragma
    IToptions_prag      {} -> TkPragma
    ITinclude_prag      {} -> TkPragma
    ITlanguage_prag        -> TkPragma
    ITvect_prag         {} -> TkPragma
    ITvect_scalar_prag  {} -> TkPragma
    ITnovect_prag       {} -> TkPragma
    ITminimal_prag      {} -> TkPragma
    IToverlappable_prag {} -> TkPragma
    IToverlapping_prag  {} -> TkPragma
    IToverlaps_prag     {} -> TkPragma
    ITincoherent_prag   {} -> TkPragma
    ITctype             {} -> TkPragma

    ITdotdot               -> TkGlyph
    ITcolon                -> TkGlyph
    ITdcolon            {} -> TkGlyph
    ITequal                -> TkGlyph
    ITlam                  -> TkGlyph
    ITlcase                -> TkGlyph
    ITvbar                 -> TkGlyph
    ITlarrow            {} -> TkGlyph
    ITrarrow            {} -> TkGlyph
    ITat                   -> TkGlyph
    ITtilde                -> TkGlyph
    ITtildehsh             -> TkGlyph
    ITdarrow            {} -> TkGlyph
    ITminus                -> TkGlyph
    ITbang                 -> TkGlyph
    ITdot                  -> TkOperator
    ITtypeApp              -> TkGlyph

    ITbiglam               -> TkGlyph

    ITocurly               -> TkSpecial
    ITccurly               -> TkSpecial
    ITvocurly              -> TkSpecial
    ITvccurly              -> TkSpecial
    ITobrack               -> TkSpecial
    ITopabrack             -> TkSpecial
    ITcpabrack             -> TkSpecial
    ITcbrack               -> TkSpecial
    IToparen               -> TkSpecial
    ITcparen               -> TkSpecial
    IToubxparen            -> TkSpecial
    ITcubxparen            -> TkSpecial
    ITsemi                 -> TkSpecial
    ITcomma                -> TkSpecial
    ITunderscore           -> TkIdentifier
    ITbackquote            -> TkSpecial
    ITsimpleQuote          -> TkSpecial

    ITvarid             {} -> TkIdentifier
    ITconid             {} -> TkIdentifier
    ITvarsym            {} -> TkOperator
    ITconsym            {} -> TkOperator
    ITqvarid            {} -> TkIdentifier
    ITqconid            {} -> TkIdentifier
    ITqvarsym           {} -> TkOperator
    ITqconsym           {} -> TkOperator

    ITdupipvarid        {} -> TkUnknown
    ITlabelvarid        {} -> TkUnknown

    ITchar              {} -> TkChar
    ITstring            {} -> TkString
    ITinteger           {} -> TkNumber
    ITrational          {} -> TkNumber

    ITprimchar          {} -> TkChar
    ITprimstring        {} -> TkString
    ITprimint           {} -> TkNumber
    ITprimword          {} -> TkNumber
    ITprimfloat         {} -> TkNumber
    ITprimdouble        {} -> TkNumber

    ITopenExpQuote      {} -> TkSpecial
    ITopenPatQuote         -> TkSpecial
    ITopenDecQuote         -> TkSpecial
    ITopenTypQuote         -> TkSpecial
    ITcloseQuote        {} -> TkSpecial
    ITopenTExpQuote     {} -> TkSpecial
    ITcloseTExpQuote       -> TkSpecial
    ITidEscape          {} -> TkUnknown
    ITparenEscape          -> TkSpecial
    ITidTyEscape        {} -> TkUnknown
    ITparenTyEscape        -> TkSpecial
    ITtyQuote              -> TkSpecial
    ITquasiQuote        {} -> TkUnknown
    ITqQuasiQuote       {} -> TkUnknown

    ITproc                 -> TkKeyword
    ITrec                  -> TkKeyword
    IToparenbar         {} -> TkGlyph
    ITcparenbar         {} -> TkGlyph
    ITlarrowtail        {} -> TkGlyph
    ITrarrowtail        {} -> TkGlyph
    ITLarrowtail        {} -> TkGlyph
    ITRarrowtail        {} -> TkGlyph

    ITunknown           {} -> TkUnknown
    ITeof                  -> TkUnknown

    -- Line comments are only supposed to start with '--'. Starting with '#'
    -- means that this was probably a CPP.
    ITlineComment s
      | isCPPline s        -> TkCpp
      | otherwise          -> TkComment

    ITdocCommentNext    {} -> TkComment
    ITdocCommentPrev    {} -> TkComment
    ITdocCommentNamed   {} -> TkComment
    ITdocSection        {} -> TkComment
    ITdocOptions        {} -> TkComment

    -- The lexer considers top-level pragmas as comments (see `pragState` in
    -- the GHC lexer for more), so we have to manually reverse this. The
    -- following is a hammer: it smashes _all_ pragma-like block comments into
    -- pragmas.
    ITblockComment c
      | isPrefixOf "{-#" c
      , isSuffixOf "#-}" c -> TkPragma
      | otherwise          -> TkComment

-- | Classify given tokens as beginning pragmas (or not).
inPragma :: Bool     -- ^ currently in pragma
         -> L.Token  -- ^ current token
         -> Bool     -- ^ new information about whether we are in a pragma
inPragma _ ITclose_prag = False
inPragma True _ = True
inPragma False tok =
  case tok of
    ITinline_prag       {} -> True
    ITspec_prag         {} -> True
    ITspec_inline_prag  {} -> True
    ITsource_prag       {} -> True
    ITrules_prag        {} -> True
    ITwarning_prag      {} -> True
    ITdeprecated_prag   {} -> True
    ITline_prag         {} -> True
    ITcolumn_prag       {} -> True
    ITscc_prag          {} -> True
    ITgenerated_prag    {} -> True
    ITcore_prag         {} -> True
    ITunpack_prag       {} -> True
    ITnounpack_prag     {} -> True
    ITann_prag          {} -> True
    ITcomplete_prag     {} -> True
    IToptions_prag      {} -> True
    ITinclude_prag      {} -> True
    ITlanguage_prag        -> True
    ITvect_prag         {} -> True
    ITvect_scalar_prag  {} -> True
    ITnovect_prag       {} -> True
    ITminimal_prag      {} -> True
    IToverlappable_prag {} -> True
    IToverlapping_prag  {} -> True
    IToverlaps_prag     {} -> True
    ITincoherent_prag   {} -> True
    ITctype             {} -> True

    _                      -> False