src/Haddock/Backends/LaTeX.hs

+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Haddock.Backends.LaTeX
+-- Copyright   :  (c) Simon Marlow 2010
+-- License     :  BSD-like
+--
+-- Maintainer  :  haddock@projects.haskell.org
+-- Stability   :  experimental
+-- Portability :  portable
+-----------------------------------------------------------------------------
+module Haddock.Backends.LaTeX (
+  ppLaTeX
+) where
+
+
+import Haddock.Types
+import Haddock.Utils
+import Haddock.GhcUtils
+import Pretty hiding (Doc, quote)
+import qualified Pretty
+
+import GHC
+import OccName
+import Name                 ( nameOccName )
+import RdrName              ( rdrNameOcc )
+import FastString           ( unpackFS, unpackLitString )
+
+import qualified Data.Map as Map
+import System.Directory
+import System.FilePath
+import Data.Char
+import Control.Monad
+import Data.Maybe
+import Data.List
+-- import Debug.Trace
+
+{- SAMPLE OUTPUT
+
+\haddockmoduleheading{\texttt{Data.List}}
+\hrulefill
+{\haddockverb\begin{verbatim}
+module Data.List (
+    (++),  head,  last,  tail,  init,  null,  length,  map,  reverse,
+  ) where\end{verbatim}}
+\hrulefill
+
+\section{Basic functions}
+\begin{haddockdesc}
+\item[\begin{tabular}{@{}l}
+head\ ::\ {\char 91}a{\char 93}\ ->\ a
+\end{tabular}]\haddockbegindoc
+Extract the first element of a list, which must be non-empty.
+\par
+
+\end{haddockdesc}
+\begin{haddockdesc}
+\item[\begin{tabular}{@{}l}
+last\ ::\ {\char 91}a{\char 93}\ ->\ a
+\end{tabular}]\haddockbegindoc
+Extract the last element of a list, which must be finite and non-empty.
+\par
+
+\end{haddockdesc}
+-}
+
+
+{- TODO
+ * don't forget fixity!!
+-}
+
+ppLaTeX :: String                       -- Title
+        -> Maybe String                 -- Package name
+        -> [Interface]
+        -> FilePath                     -- destination directory
+        -> Maybe (Doc GHC.RdrName)      -- prologue text, maybe
+        -> Maybe String                 -- style file
+        -> FilePath
+        -> IO ()
+
+ppLaTeX title packageStr visible_ifaces odir prologue maybe_style libdir
+ = do
+   createDirectoryIfMissing True odir
+   when (isNothing maybe_style) $
+     copyFile (libdir </> "latex" </> haddockSty) (odir </> haddockSty)
+   ppLaTeXTop title packageStr odir prologue maybe_style visible_ifaces
+   mapM_ (ppLaTeXModule title odir) visible_ifaces
+
+
+haddockSty :: 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 (render tex)
+
+
+ppLaTeXModule :: String -> FilePath -> Interface -> IO ()
+ppLaTeXModule _title odir iface = do
+  createDirectoryIfMissing True odir
+  let
+      mdl = ifaceMod iface
+      mdl_str = moduleString mdl
+
+      exports = ifaceRnExportItems iface
+
+      tex = vcat [
+        text "\\haddockmoduleheading" <> braces (text mdl_str),
+        text "\\label{module:" <> text mdl_str <> char '}',
+        text "\\haddockbeginheader",
+        verb $ vcat [
+           text "module" <+> text mdl_str <+> lparen,
+           text "    " <> fsep (punctuate (text ", ") $
+                               map exportListItem $
+                               filter forSummary exports),
+           text "  ) where"
+         ],
+        text "\\haddockendheader" $$ text "",
+        description,
+        body
+       ]
+
+      description
+          = case ifaceRnDoc iface of
+              Nothing -> empty
+              Just doc -> docToLaTeX doc
+
+      body = processExports exports
+  --
+  writeFile (odir </> moduleLaTeXFile mdl) (fullRender PageMode 80 1 string_txt "" tex)
+
+
+string_txt :: TextDetails -> String -> String
+string_txt (Chr c)   s  = c:s
+string_txt (Str s1)  s2 = s1 ++ s2
+string_txt (PStr s1) s2 = unpackFS s1 ++ s2
+string_txt (LStr s1 _) s2 = unpackLitString s1 ++ s2
+
+
+exportListItem :: ExportItem DocName -> LaTeX
+exportListItem (ExportDecl decl _doc subdocs _insts)
+  = 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 DocName] -> 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 DocName -> Maybe ([DocName], HsType DocName)
+isSimpleSig (ExportDecl (L _ (SigD (TypeSig lnames (L _ t))))
+                        (Nothing, argDocs) _ _)
+  | Map.null argDocs = Just (map unLoc lnames, t)
+isSimpleSig _ = Nothing
+
+
+isExportModule :: ExportItem DocName -> Maybe Module
+isExportModule (ExportModule m) = Just m
+isExportModule _ = Nothing
+
+
+processExport :: ExportItem DocName -> LaTeX
+processExport (ExportGroup lev _id0 doc)
+  = ppDocGroup lev (docToLaTeX doc)
+processExport (ExportDecl decl doc subdocs insts)
+  = ppDecl decl doc insts subdocs
+processExport (ExportNoDecl y [])
+  = ppDocName y
+processExport (ExportNoDecl y subs)
+  = ppDocName y <> parens (sep (punctuate comma (map ppDocName subs)))
+processExport (ExportModule mdl)
+  = declWithDoc (text "module" <+> text (moduleString mdl)) Nothing
+processExport (ExportDoc doc)
+  = docToLaTeX doc
+
+
+ppDocGroup :: Int -> LaTeX -> LaTeX
+ppDocGroup lev doc = sec lev <> braces doc
+  where sec 1 = text "\\section"
+        sec 2 = text "\\subsection"
+        sec 3 = text "\\subsubsection"
+        sec _ = text "\\paragraph"
+
+
+declNames :: LHsDecl DocName -> [DocName]
+declNames (L _ decl) = case decl of
+  TyClD d  -> [unLoc $ tcdLName d]
+  SigD (TypeSig lnames _) -> map unLoc lnames
+  _ -> error "declaration not supported by declNames"
+
+
+forSummary :: (ExportItem DocName) -> Bool
+forSummary (ExportGroup _ _ _) = False
+forSummary (ExportDoc _)       = False
+forSummary _                    = True
+
+
+moduleLaTeXFile :: Module -> FilePath
+moduleLaTeXFile mdl = moduleBasename mdl ++ ".tex"
+
+
+moduleBasename :: Module -> FilePath
+moduleBasename mdl = map (\c -> if c == '.' then '-' else c)
+                         (moduleNameString (moduleName mdl))
+
+
+-------------------------------------------------------------------------------
+-- * Decls
+-------------------------------------------------------------------------------
+
+
+ppDecl :: LHsDecl DocName
+       -> DocForDecl DocName
+       -> [DocInstance DocName]
+       -> [(DocName, DocForDecl DocName)]
+       -> LaTeX
+
+ppDecl (L loc decl) (mbDoc, fnArgsDoc) instances subdocs = case decl of
+  TyClD d@(TyFamily {})          -> ppTyFam False loc mbDoc d unicode
+  TyClD d@(TyDecl{ tcdTyDefn = defn })   
+      | isHsDataDefn defn        -> ppDataDecl instances subdocs loc mbDoc d unicode
+      | otherwise                -> ppTySyn loc (mbDoc, fnArgsDoc) d unicode
+--    | Just _  <- tcdTyPats d     -> ppDataInst loc mbDoc d
+-- Family instances happen via FamInst now
+--  TyClD d@(TySynonym {})         
+--    | Just _  <- tcdTyPats d    -> ppTyInst False loc mbDoc d unicode
+-- Family instances happen via FamInst now
+  TyClD d@(ClassDecl {})         -> ppClassDecl instances loc mbDoc subdocs d unicode
+  SigD (TypeSig lnames (L _ t))  -> ppFunSig loc (mbDoc, fnArgsDoc) (map unLoc lnames) t unicode
+  ForD d                         -> ppFor loc (mbDoc, fnArgsDoc) d unicode
+  InstD _                        -> empty
+  _                              -> error "declaration not supported by ppDecl"
+  where
+    unicode = False
+
+
+ppTyFam :: Bool -> SrcSpan -> Maybe (Doc DocName) ->
+              TyClDecl DocName -> Bool -> LaTeX
+ppTyFam _ _ _ _ _ =
+  error "type family declarations are currently not supported by --latex"
+
+
+ppFor :: SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> Bool -> LaTeX
+ppFor _ _ _ _ =
+  error "foreign declarations are currently not supported by --latex"
+
+
+-------------------------------------------------------------------------------
+-- * Type Synonyms
+-------------------------------------------------------------------------------
+
+
+-- we skip type patterns for now
+ppTySyn :: SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool -> LaTeX
+
+ppTySyn loc doc (TyDecl { tcdLName = L _ name, tcdTyVars = ltyvars
+                        , tcdTyDefn = TySynonym { td_synRhs = ltype } }) unicode
+  = ppTypeOrFunSig loc [name] (unLoc ltype) doc (full, hdr, char '=') unicode
+  where
+    hdr  = hsep (keyword "type" : ppDocBinder name : ppTyVars ltyvars)
+    full = hdr <+> char '=' <+> ppLType unicode ltype
+
+ppTySyn _ _ _ _ = error "declaration not supported by ppTySyn"
+
+
+-------------------------------------------------------------------------------
+-- * Function signatures
+-------------------------------------------------------------------------------
+
+
+ppFunSig :: SrcSpan -> DocForDecl DocName -> [DocName] -> HsType DocName
+         -> Bool -> LaTeX
+ppFunSig loc doc docnames 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
+
+
+ppTypeOrFunSig :: SrcSpan -> [DocName] -> HsType DocName
+               -> DocForDecl DocName -> (LaTeX, LaTeX, LaTeX)
+               -> Bool -> LaTeX
+ppTypeOrFunSig _ _ typ (doc, argDocs) (pref1, pref2, sep0)
+               unicode
+  | Map.null argDocs =
+      declWithDoc pref1 (fmap docToLaTeX doc)
+  | otherwise        =
+      declWithDoc pref2 $ Just $
+        text "\\haddockbeginargs" $$
+        do_args 0 sep0 typ $$
+        text "\\end{tabulary}\\par" $$
+        maybe empty docToLaTeX doc
+  where
+     do_largs n leader (L _ t) = do_args n leader t
+
+     arg_doc n = rDoc (Map.lookup n argDocs)
+
+     do_args :: Int -> LaTeX -> (HsType DocName) -> LaTeX
+     do_args n leader (HsForAllTy Explicit tvs lctxt ltype)
+       = decltt leader <->
+             decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]) <+>
+                ppLContextNoArrow lctxt unicode) <+> nl $$
+         do_largs n (darrow unicode) ltype
+
+     do_args n leader (HsForAllTy Implicit _ lctxt ltype)
+       | not (null (unLoc lctxt))
+       = decltt leader <-> decltt (ppLContextNoArrow lctxt unicode) <+> nl $$
+         do_largs n (darrow unicode) ltype
+         -- if we're not showing any 'forall' or class constraints or
+         -- anything, skip having an empty line for the context.
+       | otherwise
+       = do_largs n leader ltype
+     do_args n leader (HsFunTy lt r)
+       = decltt leader <-> decltt (ppLFunLhType unicode lt) <-> arg_doc n <+> nl $$
+         do_largs (n+1) (arrow unicode) r
+     do_args n leader t
+       = decltt leader <-> decltt (ppType unicode t) <-> arg_doc n <+> nl
+
+
+ppTypeSig :: [Name] -> HsType DocName  -> Bool -> LaTeX
+ppTypeSig nms ty unicode =
+  hsep (punctuate comma $ map ppSymName nms)
+    <+> dcolon unicode
+    <+> ppType unicode ty
+
+
+ppTyVars :: LHsTyVarBndrs DocName -> [LaTeX]
+ppTyVars tvs = map ppSymName (tyvarNames tvs)
+
+
+tyvarNames :: LHsTyVarBndrs DocName -> [Name]
+tyvarNames = map getName . hsLTyVarNames
+
+
+declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX
+declWithDoc decl doc =
+   text "\\begin{haddockdesc}" $$
+   text "\\item[\\begin{tabular}{@{}l}" $$
+   text (latexMonoFilter (render decl)) $$
+   text "\\end{tabular}]" <>
+       (if isNothing doc then empty else text "\\haddockbegindoc") $$
+   maybe empty id doc $$
+   text "\\end{haddockdesc}"
+
+
+-- in a group of decls, we don't put them all in the same tabular,
+-- because that would prevent the group being broken over a page
+-- boundary (breaks Foreign.C.Error for example).
+multiDecl :: [LaTeX] -> LaTeX
+multiDecl decls =
+   text "\\begin{haddockdesc}" $$
+   vcat [
+      text "\\item[" $$
+      text (latexMonoFilter (render decl)) $$
+      text "]"
+      | decl <- decls ] $$
+   text "\\end{haddockdesc}"
+
+
+-------------------------------------------------------------------------------
+-- * Rendering Doc
+-------------------------------------------------------------------------------
+
+
+maybeDoc :: Maybe (Doc DocName) -> LaTeX
+maybeDoc = maybe empty docToLaTeX
+
+
+-- for table cells, we strip paragraphs out to avoid extra vertical space
+-- and don't add a quote environment.
+rDoc  :: Maybe (Doc DocName) -> LaTeX
+rDoc = maybeDoc . fmap latexStripTrailingWhitespace
+
+
+-------------------------------------------------------------------------------
+-- * Class declarations
+-------------------------------------------------------------------------------
+
+
+ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName
+           -> LHsTyVarBndrs DocName -> [Located ([DocName], [DocName])]
+           -> Bool -> LaTeX
+ppClassHdr summ lctxt n tvs fds unicode =
+  keyword "class"
+  <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode else empty)
+  <+> ppAppDocNameNames summ n (tyvarNames $ tvs)
+  <+> ppFds fds unicode
+
+
+ppFds :: [Located ([DocName], [DocName])] -> Bool -> LaTeX
+ppFds fds unicode =
+  if null fds then empty else
+    char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds))
+  where
+    fundep (vars1,vars2) = hsep (map ppDocName vars1) <+> arrow unicode <+>
+                           hsep (map ppDocName vars2)
+
+
+ppClassDecl :: [DocInstance DocName] -> SrcSpan
+            -> Maybe (Doc DocName) -> [(DocName, DocForDecl DocName)]
+            -> TyClDecl DocName -> Bool -> LaTeX
+ppClassDecl instances loc mbDoc subdocs
+  (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 [fmap docToLaTeX mbDoc, 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 names typ unicode
+            | L _ (TypeSig lnames (L _ typ)) <- lsigs
+            , let doc = lookupAnySubdoc (head names) subdocs
+                  names = map unLoc lnames ]
+              -- FIXME: is taking just the first name ok? Is it possible that
+              -- there are different subdocs for different names in a single
+              -- type signature?
+
+    instancesBit = ppDocInstances unicode instances
+
+ppClassDecl _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
+
+ppDocInstances :: Bool -> [DocInstance DocName] -> 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 DocName -> LaTeX
+ppDocInstance unicode (instHead, mbDoc) =
+  declWithDoc (ppInstDecl unicode instHead) (fmap docToLaTeX mbDoc)
+
+
+ppInstDecl :: Bool -> InstHead DocName -> LaTeX
+ppInstDecl unicode instHead = keyword "instance" <+> ppInstHead unicode instHead
+
+
+ppInstHead :: Bool -> InstHead DocName -> LaTeX
+ppInstHead unicode ([],   n, ts) = ppAppNameTypes n ts unicode
+ppInstHead unicode (ctxt, n, ts) = ppContextNoLocs ctxt unicode <+> ppAppNameTypes n ts unicode
+
+
+lookupAnySubdoc :: (Eq name1) =>
+                   name1 -> [(name1, DocForDecl name2)] -> DocForDecl name2
+lookupAnySubdoc n subdocs = case lookup n subdocs of
+  Nothing -> noDocForDecl
+  Just docs -> docs
+
+
+-------------------------------------------------------------------------------
+-- * Data & newtype declarations
+-------------------------------------------------------------------------------
+
+
+ppDataDecl :: [DocInstance DocName] ->
+              [(DocName, DocForDecl DocName)] ->
+              SrcSpan -> Maybe (Doc DocName) -> TyClDecl DocName -> Bool ->
+              LaTeX
+ppDataDecl instances subdocs _loc mbDoc dataDecl unicode
+
+   =  declWithDoc (ppDataHeader dataDecl unicode <+> whereBit)
+                  (if null body then Nothing else Just (vcat body))
+   $$ instancesBit
+
+  where
+    cons      = td_cons (tcdTyDefn dataDecl)
+    resTy     = (con_res . unLoc . head) cons
+
+    body = catMaybes [constrBit, fmap docToLaTeX mbDoc]
+
+    (whereBit, leaders)
+      | null cons = (empty,[])
+      | otherwise = case resTy of
+        ResTyGADT _ -> (decltt (keyword "where"), repeat empty)
+        _           -> (empty, (decltt (text "=") : repeat (decltt (text "|"))))
+
+    constrBit
+      | null cons = Nothing
+      | otherwise = Just $
+          text "\\haddockbeginconstrs" $$
+          vcat (zipWith (ppSideBySideConstr subdocs unicode) leaders cons) $$
+          text "\\end{tabulary}\\par"
+
+    instancesBit = ppDocInstances unicode instances
+
+
+-- ppConstrHdr is for (non-GADT) existentials constructors' syntax
+ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> 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
+      Explicit -> forallSymbol unicode <+> hsep (map ppName tvs) <+> text ". "
+      Implicit -> empty
+
+
+ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LaTeX
+                   -> LConDecl DocName -> LaTeX
+ppSideBySideConstr subdocs unicode leader (L _ con) =
+  leader <->
+  case con_res con of
+  ResTyH98 -> case con_details con of
+
+    PrefixCon args ->
+      decltt (hsep ((header_ unicode <+> ppBinder occ) :
+                 map (ppLParendType unicode) args))
+      <-> rDoc mbDoc <+> nl
+
+    RecCon fields ->
+      (decltt (header_ unicode <+> ppBinder occ)
+        <-> rDoc mbDoc <+> nl)
+      $$
+      doRecordFields fields
+
+    InfixCon arg1 arg2 ->
+      decltt (hsep [ header_ unicode <+> ppLParendType unicode arg1,
+                 ppBinder occ,
+                 ppLParendType unicode arg2 ])
+      <-> rDoc mbDoc <+> nl
+
+  ResTyGADT resTy -> case con_details con of
+    -- prefix & infix could also use hsConDeclArgTys if it seemed to
+    -- simplify the code.
+    PrefixCon args -> doGADTCon args resTy
+    cd@(RecCon fields) -> doGADTCon (hsConDeclArgTys cd) resTy <+> nl $$
+                                     doRecordFields fields
+    InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy
+
+ where
+    doRecordFields fields =
+        vcat (map (ppSideBySideField subdocs unicode) fields)
+
+    doGADTCon args resTy = decltt (ppBinder occ <+> dcolon unicode <+> hsep [
+                               ppForAll forall ltvs (con_cxt con) unicode,
+                               ppLType unicode (foldr mkFunTy resTy args) ]
+                            ) <-> rDoc mbDoc
+
+
+    header_ = ppConstrHdr forall tyVars context
+    occ     = nameOccName . getName . unLoc . con_name $ con
+    ltvs    = con_qvars con
+    tyVars  = tyvarNames (con_qvars con)
+    context = unLoc (con_cxt con)
+    forall  = con_explicit con
+    -- don't use "con_doc con", in case it's reconstructed from a .hi file,
+    -- or also because we want Haddock to do the doc-parsing, not GHC.
+    -- 'join' is in Maybe.
+    mbDoc = join $ fmap fst $ lookup (unLoc $ con_name con) subdocs
+    mkFunTy a b = noLoc (HsFunTy a b)
+
+
+ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName ->  LaTeX
+ppSideBySideField subdocs unicode (ConDeclField (L _ name) ltype _) =
+  decltt (ppBinder (nameOccName . getName $ name)
+    <+> dcolon unicode <+> ppLType unicode ltype) <-> rDoc mbDoc
+  where
+    -- don't use cd_fld_doc for same reason we don't use con_doc above
+    mbDoc = join $ fmap fst $ lookup name subdocs
+
+-- {-
+-- ppHsFullConstr :: HsConDecl -> LaTeX
+-- ppHsFullConstr (HsConDecl _ nm tvs ctxt typeList doc) = 
+--      declWithDoc False doc (
+-- 	hsep ((ppHsConstrHdr tvs ctxt +++ 
+-- 		ppHsBinder False nm) : map ppHsBangType typeList)
+--       )
+-- ppHsFullConstr (HsRecDecl _ nm tvs ctxt fields doc) =
+--    td << vanillaTable << (
+--      case doc of
+--        Nothing -> aboves [hdr, fields_html]
+--        Just _  -> aboves [hdr, constr_doc, fields_html]
+--    )
+-- 
+--   where hdr = declBox (ppHsConstrHdr tvs ctxt +++ ppHsBinder False nm)
+-- 
+-- 	constr_doc	
+-- 	  | isJust doc = docBox (docToLaTeX (fromJust doc))
+-- 	  | otherwise  = LaTeX.emptyTable
+-- 
+-- 	fields_html = 
+-- 	   td << 
+-- 	      table ! [width "100%", cellpadding 0, cellspacing 8] << (
+-- 		   aboves (map ppFullField (concat (map expandField fields)))
+-- 		)
+-- -}
+-- 
+-- ppShortField :: Bool -> Bool -> ConDeclField DocName -> LaTeX
+-- ppShortField summary unicode (ConDeclField (L _ name) ltype _)
+--   = tda [theclass "recfield"] << (
+--       ppBinder summary (docNameOcc name)
+--       <+> dcolon unicode <+> ppLType unicode ltype
+--     )
+-- 
+-- {-
+-- ppFullField :: HsFieldDecl -> LaTeX
+-- ppFullField (HsFieldDecl [n] ty doc) 
+--   = declWithDoc False doc (
+-- 	ppHsBinder False n <+> dcolon <+> ppHsBangType ty
+--     )
+-- ppFullField _ = error "ppFullField"
+-- 
+-- expandField :: HsFieldDecl -> [HsFieldDecl]
+-- expandField (HsFieldDecl ns ty doc) = [ HsFieldDecl [n] ty doc | n <- ns ]
+-- -}
+
+
+-- | Print the LHS of a data\/newtype declaration.
+-- Currently doesn't handle 'data instance' decls or kind signatures
+ppDataHeader :: TyClDecl DocName -> Bool -> LaTeX
+ppDataHeader (TyDecl { tcdLName = L _ name, tcdTyVars = tyvars
+                     , tcdTyDefn = TyData { td_ND = nd, td_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 and a list of HsTypes
+ppAppNameTypes :: DocName -> [HsType DocName] -> Bool -> LaTeX
+ppAppNameTypes n ts unicode = ppTypeApp n ts ppDocName (ppParendType unicode)
+
+
+-- | Print an application of a DocName and a list of Names 
+ppAppDocNameNames :: Bool -> DocName -> [Name] -> LaTeX
+ppAppDocNameNames _summ n ns =
+  ppTypeApp n ns (ppBinder . 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 DocName) -> Bool -> LaTeX
+ppLContext        = ppContext        . unLoc
+ppLContextNoArrow = ppContextNoArrow . unLoc
+
+
+ppContextNoArrow :: HsContext DocName -> Bool -> LaTeX
+ppContextNoArrow []  _ = empty
+ppContextNoArrow cxt unicode = pp_hs_context (map unLoc cxt) unicode
+
+
+ppContextNoLocs :: [HsType DocName] -> Bool -> LaTeX
+ppContextNoLocs []  _ = empty
+ppContextNoLocs cxt unicode = pp_hs_context cxt unicode <+> darrow unicode
+
+
+ppContext :: HsContext DocName -> Bool -> LaTeX
+ppContext cxt unicode = ppContextNoLocs (map unLoc cxt) unicode
+
+
+pp_hs_context :: [HsType DocName] -> 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 :: HsBang -> LaTeX
+ppBang HsNoBang = empty
+ppBang _        = char '!' -- Unpacked args is an implementation detail,
+
+
+tupleParens :: HsTupleSort -> [LaTeX] -> LaTeX
+tupleParens HsUnboxedTuple = ubxParenList
+tupleParens _              = parenList
+
+
+-------------------------------------------------------------------------------
+-- * Rendering of HsType
+--
+-- Stolen from Html and tweaked for LaTeX generation
+-------------------------------------------------------------------------------
+
+
+pREC_TOP, pREC_FUN, pREC_OP, pREC_CON :: Int
+
+pREC_TOP = (0 :: Int)   -- type in ParseIface.y in GHC
+pREC_FUN = (1 :: Int)   -- btype in ParseIface.y in GHC
+                        -- Used for LH arg of (->)
+pREC_OP  = (2 :: Int)   -- Used for arg of any infix operator
+                        -- (we don't keep their fixities around)
+pREC_CON = (3 :: Int)   -- Used for arg of type applicn:
+                        -- always parenthesise unless atomic
+
+maybeParen :: Int           -- Precedence of context
+           -> Int           -- Precedence of top-level operator
+           -> LaTeX -> LaTeX  -- Wrap in parens if (ctxt >= op)
+maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p
+                               | otherwise            = p
+
+
+ppLType, ppLParendType, ppLFunLhType :: Bool -> Located (HsType DocName) -> LaTeX
+ppLType       unicode y = ppType unicode (unLoc y)
+ppLParendType unicode y = ppParendType unicode (unLoc y)
+ppLFunLhType  unicode y = ppFunLhType unicode (unLoc y)
+
+
+ppType, ppParendType, ppFunLhType :: Bool -> HsType DocName -> LaTeX
+ppType       unicode ty = ppr_mono_ty pREC_TOP ty unicode
+ppParendType unicode ty = ppr_mono_ty pREC_CON ty unicode
+ppFunLhType  unicode ty = ppr_mono_ty pREC_FUN ty unicode
+
+ppLKind :: Bool -> LHsKind DocName -> LaTeX
+ppLKind unicode y = ppKind unicode (unLoc y)
+
+ppKind :: Bool -> HsKind DocName -> 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
+
+ppForAll :: HsExplicitFlag -> LHsTyVarBndrs DocName
+         -> Located (HsContext DocName) -> Bool -> LaTeX
+ppForAll expl tvs cxt unicode
+  | show_forall = forall_part <+> ppLContext cxt unicode
+  | otherwise   = ppLContext cxt unicode
+  where
+    show_forall = not (null (hsQTvBndrs tvs)) && is_explicit
+    is_explicit = case expl of {Explicit -> True; Implicit -> False}
+    forall_part = hsep (forallSymbol unicode : ppTyVars tvs) <> dot
+
+
+ppr_mono_lty :: Int -> LHsType DocName -> Bool -> LaTeX
+ppr_mono_lty ctxt_prec ty unicode = ppr_mono_ty ctxt_prec (unLoc ty) unicode
+
+
+ppr_mono_ty :: Int -> HsType DocName -> Bool -> LaTeX
+ppr_mono_ty ctxt_prec (HsForAllTy expl tvs ctxt ty) unicode
+  = maybeParen ctxt_prec pREC_FUN $
+    hsep [ppForAll expl tvs ctxt unicode, ppr_mono_lty pREC_TOP ty unicode]
+
+ppr_mono_ty _         (HsBangTy b ty)     u = ppBang b <> ppLParendType u ty
+ppr_mono_ty _         (HsTyVar name)      _ = ppDocName name
+ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2)   u = ppr_fun_ty ctxt_prec ty1 ty2 u
+ppr_mono_ty _         (HsTupleTy con tys) u = tupleParens con (map (ppLType u) tys)
+ppr_mono_ty _         (HsKindSig ty kind) u = parens (ppr_mono_lty pREC_TOP ty u <+> dcolon u <+> 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 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 _         (HsQuasiQuoteTy {}) _ = error "ppr_mono_ty HsQuasiQuoteTy"
+ppr_mono_ty _         (HsRecTy {})        _ = error "ppr_mono_ty HsRecTy"
+ppr_mono_ty _         (HsCoreTy {})       _ = error "ppr_mono_ty HsCoreTy"
+ppr_mono_ty _         (HsExplicitListTy _ tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys
+ppr_mono_ty _         (HsExplicitTupleTy _ tys) u = Pretty.quote $ parenList $ map (ppLType u) tys
+ppr_mono_ty _         (HsWrapTy {})       _ = error "ppr_mono_ty HsWrapTy"
+
+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 _ (HsTyLit t) u = ppr_tylit t u
+
+
+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 DocName -> LHsType DocName -> Bool -> LaTeX
+ppr_fun_ty ctxt_prec ty1 ty2 unicode
+  = let p1 = ppr_mono_lty pREC_FUN ty1 unicode
+        p2 = ppr_mono_lty pREC_TOP ty2 unicode
+    in
+    maybeParen ctxt_prec pREC_FUN $
+    sep [p1, arrow unicode <+> p2]
+
+
+-------------------------------------------------------------------------------
+-- * Names
+-------------------------------------------------------------------------------
+
+
+ppBinder :: OccName -> LaTeX
+ppBinder n
+  | isVarSym n = parens $ ppOccName n
+  | otherwise  = ppOccName n
+
+
+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),
+  markupEmphasis             = \p v -> emph (p v),
+  markupMonospaced           = \p _ -> tt (p Mono),
+  markupUnorderedList        = \p v -> itemizedList (map ($v) p) $$ text "",
+  markupPic                  = \path _ -> parens (text "image: " <> text path),
+  markupOrderedList          = \p v -> enumeratedList (map ($v) p) $$ text "",
+  markupDefList              = \l v -> descriptionList (map (\(a,b) -> (a v, b v)) l),
+  markupCodeBlock            = \p _ -> quote (verb (p Verb)) $$ text "",
+  markupURL                  = \u _ -> text "\\url" <> braces (text u),
+  markupAName                = \_ _ -> empty,
+  markupExample              = \e _ -> quote $ verb $ text $ unlines $ map exampleToString e
+  }
+  where
+    fixString Plain s = latexFilter s
+    fixString Verb  s = s
+    fixString Mono  s = latexMonoFilter s
+
+    markupId 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
+
+
+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
+
+
+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

src/Haddock/Backends/Xhtml.hs

+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Haddock.Backends.Html
+-- Copyright   :  (c) Simon Marlow   2003-2006,
+--                    David Waern    2006-2009,
+--                    Mark Lentczner 2010
+-- License     :  BSD-like
+--
+-- Maintainer  :  haddock@projects.haskell.org
+-- Stability   :  experimental
+-- Portability :  portable
+-----------------------------------------------------------------------------
+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 Text.XHtml hiding ( name, title, p, quote )
+import Haddock.GhcUtils
+
+import Control.Monad         ( when, unless )
+import Control.Monad.Instances ( ) -- for Functor Either a
+import Data.Char             ( toUpper )
+import Data.List             ( sortBy, groupBy, intercalate )
+import Data.Maybe
+import System.FilePath hiding ( (</>) )
+import System.Directory
+import Data.Map              ( Map )
+import qualified Data.Map as Map hiding ( Map )
+import qualified Data.Set as Set hiding ( Set )
+import Data.Function
+import Data.Ord              ( comparing )
+
+import GHC hiding ( NoLink, moduleInfo )
+import Name
+import Module
+
+
+--------------------------------------------------------------------------------
+-- * Generating HTML documentation
+--------------------------------------------------------------------------------
+
+
+ppHtml :: String
+       -> Maybe String                 -- ^ Package
+       -> [Interface]
+       -> FilePath                     -- ^ Destination directory
+       -> Maybe (Doc GHC.RdrName)      -- ^ Prologue text, maybe
+       -> Themes                       -- ^ Themes
+       -> 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)
+       -> Qualification                -- ^ How to qualify names
+       -> Bool                         -- ^ Output pretty html (newlines and indenting)
+       -> IO ()
+
+ppHtml doctitle maybe_package ifaces odir prologue
+        themes maybe_source_url maybe_wiki_url
+        maybe_contents_url maybe_index_url unicode
+        qual debug =  do
+  let
+    visible_ifaces = filter visible ifaces
+    visible i = OptHide `notElem` ifaceOptions i
+
+  when (isNothing maybe_contents_url) $
+    ppHtmlContents odir doctitle maybe_package
+        themes maybe_index_url maybe_source_url maybe_wiki_url
+        (map toInstalledIface visible_ifaces)
+        False -- we don't want to display the packages in a single-package contents
+        prologue debug qual
+
+  when (isNothing maybe_index_url) $
+    ppHtmlIndex odir doctitle maybe_package
+      themes maybe_contents_url maybe_source_url maybe_wiki_url
+      (map toInstalledIface visible_ifaces) debug
+
+  mapM_ (ppHtmlModule odir doctitle themes
+           maybe_source_url maybe_wiki_url
+           maybe_contents_url maybe_index_url unicode qual debug) visible_ifaces
+
+
+copyHtmlBits :: FilePath -> FilePath -> Themes -> IO ()
+copyHtmlBits odir libdir themes = 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)
+  mapM_ copyLibFile [ jsFile, framesFile ]
+
+
+headHtml :: String -> Maybe String -> Themes -> Html
+headHtml docTitle miniPage themes =
+  header << [
+    meta ! [httpequiv "Content-Type", content "text/html; charset=UTF-8"],
+    thetitle << docTitle,
+    styleSheet themes,
+    script ! [src jsFile, thetype "text/javascript"] << noHtml,
+    script ! [thetype "text/javascript"]
+        -- NB: Within XHTML, the content of script tags needs to be
+        -- a <![CDATA[ section. Will break if the miniPage name could
+        -- have "]]>" in it!
+      << primHtml (
+          "//<![CDATA[\nwindow.onload = function () {pageLoad();"
+          ++ setSynopsis ++ "};\n//]]>\n")
+    ]
+  where
+    setSynopsis = maybe "" (\p -> "setSynopsis(\"" ++ p ++ "\");") miniPage
+
+
+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 `fmap` iface),
+        contentsButton maybe_contents_url,
+        indexButton maybe_index_url])
+            ! [theclass "links", identifier "page-menu"],
+      nonEmpty sectionName << 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 = mapMaybe doOneEntry [
+         ("Portability",hmi_portability),
+         ("Stability",hmi_stability),
+         ("Maintainer",hmi_maintainer),
+         ("Safe Haskell",hmi_safety)
+         ]
+   in
+      case entries of
+         [] -> noHtml
+         _ -> table ! [theclass "info"] << aboves entries
+
+
+--------------------------------------------------------------------------------
+-- * Generate the module contents
+--------------------------------------------------------------------------------
+
+
+ppHtmlContents
+   :: FilePath
+   -> String
+   -> Maybe String
+   -> Themes
+   -> Maybe String
+   -> SourceURLs
+   -> WikiURLs
+   -> [InstalledInterface] -> Bool -> Maybe (Doc GHC.RdrName)
+   -> Bool
+   -> Qualification  -- ^ How to qualify names
+   -> IO ()
+ppHtmlContents odir doctitle _maybe_package
+  themes maybe_index_url
+  maybe_source_url maybe_wiki_url ifaces showPkgs prologue debug qual = do
+  let tree = mkModuleTree showPkgs
+         [(instMod iface, toInstalledDescription iface) | iface <- ifaces]
+      html =
+        headHtml doctitle Nothing themes +++
+        bodyHtml doctitle Nothing
+          maybe_source_url maybe_wiki_url
+          Nothing maybe_index_url << [
+            ppPrologue qual doctitle prologue,
+            ppModuleTree qual tree
+          ]
+  createDirectoryIfMissing True odir
+  writeFile (joinPath [odir, contentsHtmlFile]) (renderToString debug html)
+
+  -- XXX: think of a better place for this?
+  ppHtmlContentsFrame odir doctitle themes ifaces debug
+
+
+ppPrologue :: Qualification -> String -> Maybe (Doc GHC.RdrName) -> Html
+ppPrologue _ _ Nothing = noHtml
+ppPrologue qual title (Just doc) =
+  divDescription << (h1 << title +++ docElement thediv (rdrDocToHtml qual doc))
+
+
+ppModuleTree :: Qualification -> [ModuleTree] -> Html
+ppModuleTree qual ts =
+  divModuleList << (sectionName << "Modules" +++ mkNodeList qual [] "n" ts)
+
+
+mkNodeList :: Qualification -> [String] -> String -> [ModuleTree] -> Html
+mkNodeList qual ss p ts = case ts of
+  [] -> noHtml
+  _ -> unordList (zipWith (mkNode qual ss) ps ts)
+  where
+    ps = [ p ++ '.' : show i | i <- [(1::Int)..]]
+
+
+mkNode :: Qualification -> [String] -> String -> ModuleTree -> Html
+mkNode qual ss p (Node s leaf pkg short ts) =
+  htmlModule +++ shortDescr +++ htmlPkg +++ subtree
+  where
+    modAttrs = case (ts, leaf) of
+      (_:_, False) -> collapseControl p True "module"
+      (_,   _    ) -> [theclass "module"]
+
+    cBtn = case (ts, leaf) of
+      (_:_, True) -> thespan ! collapseControl p True "" << 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 +++
+      if leaf
+        then ppModule (mkModule (stringToPackageId (fromMaybe "" pkg))
+                                       (mkModuleName mdl))
+        else toHtml s
+      )
+
+    mdl = intercalate "." (reverse (s:ss))
+
+    shortDescr = maybe noHtml (origDocToHtml qual) short
+    htmlPkg = maybe noHtml (thespan ! [theclass "package"] <<) pkg
+
+    subtree = mkNodeList qual (s:ss) p ts ! collapseSection p True ""
+
+
+-- | Turn a module tree into a flat list of full module names.  E.g.,
+-- @
+--  A
+--  +-B
+--  +-C
+-- @
+-- becomes
+-- @["A", "A.B", "A.B.C"]@
+flatModuleTree :: [InstalledInterface] -> [Html]
+flatModuleTree ifaces =
+    map (uncurry ppModule' . head)
+            . groupBy ((==) `on` fst)
+            . sortBy (comparing fst)
+            $ mods
+  where
+    mods = [ (moduleString mdl, mdl) | mdl <- map instMod ifaces ]
+    ppModule' txt mdl =
+      anchor ! [href (moduleHtmlFile mdl), target mainFrameName]
+        << toHtml txt
+
+
+ppHtmlContentsFrame :: FilePath -> String -> Themes
+  -> [InstalledInterface] -> Bool -> IO ()
+ppHtmlContentsFrame odir doctitle themes ifaces debug = do
+  let mods = flatModuleTree ifaces
+      html =
+        headHtml doctitle Nothing themes +++
+        miniBody << divModuleList <<
+          (sectionName << "Modules" +++
+           ulist << [ li ! [theclass "module"] << m | m <- mods ])
+  createDirectoryIfMissing True odir
+  writeFile (joinPath [odir, frameIndexHtmlFile]) (renderToString debug html)
+
+
+--------------------------------------------------------------------------------
+-- * Generate the index
+--------------------------------------------------------------------------------
+
+
+ppHtmlIndex :: FilePath
+            -> String
+            -> Maybe String
+            -> Themes
+            -> Maybe String
+            -> SourceURLs
+            -> WikiURLs
+            -> [InstalledInterface]
+            -> Bool
+            -> IO ()
+ppHtmlIndex odir doctitle _maybe_package themes
+  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 ++ ")") Nothing themes +++
+      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 (map doAnnotatedEntity (zip [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
+        -> SourceURLs -> WikiURLs
+        -> Maybe String -> Maybe String -> Bool -> Qualification
+        -> Bool -> Interface -> IO ()
+ppHtmlModule odir doctitle themes
+  maybe_source_url maybe_wiki_url
+  maybe_contents_url maybe_index_url unicode qual debug iface = do
+  let
+      mdl = ifaceMod iface
+      mdl_str = moduleString mdl
+      real_qual = case qual of
+          LocalQual Nothing    -> LocalQual (Just mdl)
+          RelativeQual Nothing -> RelativeQual (Just mdl)
+          _                     -> qual
+      html =
+        headHtml mdl_str (Just $ "mini_" ++ moduleHtmlFile mdl) themes +++
+        bodyHtml doctitle (Just iface)
+          maybe_source_url maybe_wiki_url
+          maybe_contents_url maybe_index_url << [
+            divModuleHeader << (moduleInfo iface +++ (sectionName << mdl_str)),
+            ifaceToHtml maybe_source_url maybe_wiki_url iface unicode real_qual
+          ]
+
+  createDirectoryIfMissing True odir
+  writeFile (joinPath [odir, moduleHtmlFile mdl]) (renderToString debug html)
+  ppHtmlModuleMiniSynopsis odir doctitle themes iface unicode qual debug
+
+
+ppHtmlModuleMiniSynopsis :: FilePath -> String -> Themes
+  -> Interface -> Bool -> Qualification -> Bool -> IO ()
+ppHtmlModuleMiniSynopsis odir _doctitle themes iface unicode qual debug = do
+  let mdl = ifaceMod iface
+      html =
+        headHtml (moduleString mdl) Nothing themes +++
+        miniBody <<
+          (divModuleHeader << sectionName << moduleString mdl +++
+           miniSynopsis mdl iface unicode qual)
+  createDirectoryIfMissing True odir
+  writeFile (joinPath [odir, "mini_" ++ moduleHtmlFile mdl]) (renderToString debug html)
+
+
+ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> Bool -> Qualification -> Html
+ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual
+  = ppModuleContents qual exports +++
+    description +++
+    synopsis +++
+    divInterface (maybe_doc_hdr +++ bdy)
+  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 _ doc _ _) = isJust (fst doc)
+    has_doc (ExportNoDecl _ _) = False
+    has_doc (ExportModule _) = False
+    has_doc _ = True
+
+    no_doc_at_all = not (any has_doc exports)
+
+    description
+          = case ifaceRnDoc iface of
+              Nothing -> noHtml
+              Just doc -> divDescription $
+                            sectionName << "Description" +++ docSection qual doc
+
+        -- omit the synopsis if there are no documentation annotations at all
+    synopsis
+      | no_doc_at_all = noHtml
+      | otherwise
+      = divSynposis $
+            paragraph ! collapseControl "syn" False "caption" << "Synopsis" +++ 
+            shortDeclList (
+                mapMaybe (processExport True linksInfo unicode qual) exports
+            ) ! (collapseSection "syn" False "" ++ 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 qual) exports
+
+    linksInfo = (maybe_source_url, maybe_wiki_url)
+
+
+miniSynopsis :: Module -> Interface -> Bool -> Qualification -> Html
+miniSynopsis mdl iface unicode qual =
+    divInterface << concatMap (processForMiniSynopsis mdl unicode qual) exports
+  where
+    exports = numberSectionHeadings (ifaceRnExportItems iface)
+
+
+processForMiniSynopsis :: Module -> Bool -> Qualification -> ExportItem DocName
+                       -> [Html]
+processForMiniSynopsis mdl unicode qual (ExportDecl (L _loc decl0) _doc _ _insts) =
+  ((divTopDecl <<).(declElem <<)) `fmap` case decl0 of
+    TyClD d -> let b = ppTyClBinderWithVarsMini mdl d in case d of
+        (TyFamily{}) -> [ppTyFamHeader True False d unicode qual]
+        (TyDecl{ tcdTyDefn = TyData {} }) -> [keyword "data" <+> b]
+        (TyDecl{ tcdTyDefn = TySynonym {} }) -> [keyword "type" <+> b]
+        (ClassDecl {})    -> [keyword "class" <+> b]
+        _ -> []
+    SigD (TypeSig lnames (L _ _)) ->
+      map (ppNameMini mdl . nameOccName . getName . unLoc) lnames
+    _ -> []
+processForMiniSynopsis _ _ qual (ExportGroup lvl _id txt) =
+  [groupTag lvl << docToHtml qual txt]
+processForMiniSynopsis _ _ _ _ = []
+
+
+ppNameMini :: Module -> OccName -> Html
+ppNameMini mdl nm =
+    anchor ! [ href (moduleNameUrl mdl nm)
+             , target mainFrameName ]
+      << ppBinder' nm
+
+
+ppTyClBinderWithVarsMini :: Module -> TyClDecl DocName -> Html
+ppTyClBinderWithVarsMini mdl decl =
+  let n = unLoc $ tcdLName decl
+      ns = tyvarNames $ tcdTyVars decl
+  in ppTypeApp n ns (ppNameMini mdl . nameOccName . getName) ppTyName
+
+
+ppModuleContents :: Qualification -> [ExportItem DocName] -> Html
+ppModuleContents qual exports
+  | null sections = noHtml
+  | otherwise     = contentsDiv
+ where
+  contentsDiv = divTableOfContents << (
+    sectionName << "Contents" +++
+    unordList sections)
+
+  (sections, _leftovers{-should be []-}) = process 0 exports
+
+  process :: Int -> [ExportItem DocName] -> ([Html],[ExportItem DocName])
+  process _ [] = ([], [])
+  process n items@(ExportGroup lev id0 doc : rest)
+    | lev <= n  = ( [], items )
+    | otherwise = ( html:secs, rest2 )
+    where
+        html = linkedAnchor (groupId id0) << docToHtml qual 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 DocName] -> [ExportItem DocName]
+numberSectionHeadings exports = go 1 exports
+  where go :: Int -> [ExportItem DocName] -> [ExportItem DocName]
+        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 -> Qualification
+              -> ExportItem DocName -> Maybe Html
+processExport summary _ _ qual (ExportGroup lev id0 doc)
+  = nothingIf summary $ groupHeading lev id0 << docToHtml qual doc
+processExport summary links unicode qual (ExportDecl decl doc subdocs insts)
+  = processDecl summary $ ppDecl summary links decl doc insts subdocs unicode qual
+processExport summary _ _ qual (ExportNoDecl y [])
+  = processDeclOneLiner summary $ ppDocName qual y
+processExport summary _ _ qual (ExportNoDecl y subs)
+  = processDeclOneLiner summary $
+      ppDocName qual y +++ parenList (map (ppDocName qual) subs)
+processExport summary _ _ qual (ExportDoc doc)
+  = nothingIf summary $ docSection 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
+
+
+processDeclOneLiner :: Bool -> Html -> Maybe Html
+processDeclOneLiner True = Just
+processDeclOneLiner False = Just . divTopDecl . declElem
+
+groupHeading :: Int -> String -> Html -> Html
+groupHeading lev id0 = groupTag lev ! [identifier (groupId id0)]
+
+groupTag :: Int -> Html -> Html
+groupTag lev
+  | lev == 1  = h1
+  | lev == 2  = h2
+  | lev == 3  = h3
+  | otherwise = h4
+
+

src/Haddock/Backends/Xhtml/Decl.hs

+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Haddock.Backends.Html.Decl
+-- Copyright   :  (c) Simon Marlow   2003-2006,
+--                    David Waern    2006-2009,
+--                    Mark Lentczner 2010
+-- License     :  BSD-like
+--
+-- Maintainer  :  haddock@projects.haskell.org
+-- Stability   :  experimental
+-- Portability :  portable
+-----------------------------------------------------------------------------
+module Haddock.Backends.Xhtml.Decl (
+  ppDecl,
+
+  ppTyName, ppTyFamHeader, ppTypeApp,
+  tyvarNames
+) where
+
+
+import Haddock.Backends.Xhtml.DocMarkup
+import Haddock.Backends.Xhtml.Layout
+import Haddock.Backends.Xhtml.Names
+import Haddock.Backends.Xhtml.Types
+import Haddock.Backends.Xhtml.Utils
+import Haddock.GhcUtils
+import Haddock.Types
+
+import           Control.Monad         ( join )
+import           Data.List             ( intersperse )
+import qualified Data.Map as Map
+import           Text.XHtml hiding     ( name, title, p, quote )
+
+import GHC
+import Name
+
+
+-- TODO: use DeclInfo DocName or something
+ppDecl :: Bool -> LinksInfo -> LHsDecl DocName ->
+          DocForDecl DocName -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] ->
+          Bool -> Qualification -> Html
+ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances subdocs unicode qual = case decl of
+  TyClD d@(TyFamily {})          -> ppTyFam summ False links loc mbDoc d unicode qual
+  TyClD d@(TyDecl{ tcdTyDefn = defn })   
+      | isHsDataDefn defn        -> ppDataDecl summ links instances subdocs loc mbDoc d unicode qual
+      | otherwise                -> ppTySyn summ links loc (mbDoc, fnArgsDoc) d unicode qual
+  TyClD d@(ClassDecl {})         -> ppClassDecl summ links instances loc mbDoc subdocs d unicode qual
+  SigD (TypeSig lnames (L _ t))  -> ppFunSig summ links loc (mbDoc, fnArgsDoc) (map unLoc lnames) t unicode qual
+  ForD d                         -> ppFor summ links loc (mbDoc, fnArgsDoc) d unicode qual
+  InstD _                        -> noHtml
+  _                              -> error "declaration not supported by ppDecl"
+
+
+ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
+            [DocName] -> HsType DocName -> Bool -> Qualification -> Html
+ppFunSig summary links loc doc docnames typ unicode qual =
+  ppTypeOrFunSig summary links loc docnames typ doc
+    ( ppTypeSig summary occnames typ unicode qual
+    , concatHtml . punctuate comma $ map (ppBinder False) occnames
+    , dcolon unicode
+    )
+    unicode qual
+  where
+    occnames = map (nameOccName . getName) docnames
+
+
+ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsType DocName
+               -> DocForDecl DocName -> (Html, Html, Html) -> Bool -> Qualification -> Html
+ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) unicode qual
+  | summary = pref1
+  | Map.null argDocs = topDeclElem links loc docnames pref1 +++ maybeDocSection qual doc
+  | otherwise = topDeclElem links loc docnames pref2 +++
+      subArguments qual (do_args 0 sep typ) +++ maybeDocSection qual doc
+  where
+    argDoc n = Map.lookup n argDocs
+
+    do_largs n leader (L _ t) = do_args n leader t
+    do_args :: Int -> Html -> (HsType DocName) -> [SubDecl]
+    do_args n leader (HsForAllTy Explicit tvs lctxt ltype)
+      = (leader <+>
+          hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]) <+>
+          ppLContextNoArrow lctxt unicode qual,
+          Nothing, [])
+        : do_largs n (darrow unicode) ltype
+    do_args n leader (HsForAllTy Implicit _ lctxt ltype)
+      | not (null (unLoc lctxt))
+      = (leader <+> ppLContextNoArrow lctxt unicode qual,
+          Nothing, [])
+        : do_largs n (darrow unicode) ltype
+      -- if we're not showing any 'forall' or class constraints or
+      -- anything, skip having an empty line for the context.
+      | otherwise
+      = do_largs n leader ltype
+    do_args n leader (HsFunTy lt r)
+      = (leader <+> ppLFunLhType unicode qual lt, argDoc n, [])
+        : do_largs (n+1) (arrow unicode) r
+    do_args n leader t
+      = (leader <+> ppType unicode qual t, argDoc n, []) : []
+
+
+ppTyVars :: LHsTyVarBndrs DocName -> [Html]
+ppTyVars tvs = map ppTyName (tyvarNames tvs)
+
+
+tyvarNames :: LHsTyVarBndrs DocName -> [Name]
+tyvarNames = map getName . hsLTyVarNames
+
+
+ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName
+      -> ForeignDecl DocName -> Bool -> Qualification -> Html
+ppFor summary links loc doc (ForeignImport (L _ name) (L _ typ) _ _) unicode qual
+  = ppFunSig summary links loc doc [name] typ unicode qual
+ppFor _ _ _ _ _ _ _ = error "ppFor"
+
+
+-- we skip type patterns for now
+ppTySyn :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool
+        -> Qualification -> Html
+ppTySyn summary links loc doc (TyDecl { tcdLName = L _ name, tcdTyVars = ltyvars
+                                      , tcdTyDefn = TySynonym { td_synRhs = ltype } }) 
+        unicode qual
+  = ppTypeOrFunSig summary links loc [name] (unLoc ltype) doc
+                   (full, hdr, spaceHtml +++ equals) unicode qual
+  where
+    hdr  = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars ltyvars)
+    full = hdr <+> equals <+> ppLType unicode qual ltype
+    occ  = nameOccName . getName $ name
+ppTySyn _ _ _ _ _ _ _ = error "declaration not supported by ppTySyn"
+
+
+ppTypeSig :: Bool -> [OccName] -> HsType DocName  -> Bool -> Qualification -> Html
+ppTypeSig summary nms ty unicode qual =
+  concatHtml htmlNames <+> dcolon unicode <+> ppType unicode qual ty
+  where
+    htmlNames = intersperse (stringToHtml ", ") $ map (ppBinder summary) nms
+
+
+ppTyName :: Name -> Html
+ppTyName name
+  | isNameSym name = parens (ppName name)
+  | otherwise = ppName name
+
+
+--------------------------------------------------------------------------------
+-- * Type families
+--------------------------------------------------------------------------------
+
+
+ppTyFamHeader :: Bool -> Bool -> TyClDecl DocName -> Bool -> Qualification -> Html
+ppTyFamHeader summary associated decl unicode qual =
+
+  (case tcdFlavour decl of
+     TypeFamily
+       | associated -> keyword "type"
+       | otherwise  -> keyword "type family"
+     DataFamily
+       | associated -> keyword "data"
+       | otherwise  -> keyword "data family"
+  ) <+>
+
+  ppTyClBinderWithVars summary decl <+>
+
+  case tcdKindSig decl of
+    Just kind -> dcolon unicode  <+> ppLKind unicode qual kind
+    Nothing   -> noHtml
+
+
+ppTyFam :: Bool -> Bool -> LinksInfo -> SrcSpan -> Maybe (Doc DocName) ->
+              TyClDecl DocName -> Bool -> Qualification -> Html
+ppTyFam summary associated links loc mbDoc decl unicode qual
+
+  | summary   = ppTyFamHeader True associated decl unicode qual
+  | otherwise = header_ +++ maybeDocSection qual mbDoc +++ instancesBit
+
+  where
+    docname = tcdName decl
+
+    header_ = topDeclElem links loc [docname] (ppTyFamHeader summary associated decl unicode qual)
+
+    instancesBit = ppInstances instances docname unicode qual
+
+    -- TODO: get the instances
+    instances = []
+
+
+--------------------------------------------------------------------------------
+-- * Associated Types
+--------------------------------------------------------------------------------
+
+
+ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LTyClDecl DocName -> Bool
+            -> Qualification -> Html
+ppAssocType summ links doc (L loc decl) unicode qual =
+  case decl of
+    TyFamily  {} -> ppTyFam summ True links loc (fst doc) decl unicode qual
+    _            -> error "declaration type not supported by ppAssocType"
+
+
+--------------------------------------------------------------------------------
+-- * TyClDecl helpers
+--------------------------------------------------------------------------------
+
+
+-- | Print a type family / newtype / data / class binder and its variables 
+ppTyClBinderWithVars :: Bool -> TyClDecl DocName -> Html
+ppTyClBinderWithVars summ decl =
+  ppAppDocNameNames summ (unLoc $ tcdLName decl) (tyvarNames $ tcdTyVars decl)
+
+
+--------------------------------------------------------------------------------
+-- * Type applications
+--------------------------------------------------------------------------------
+
+
+-- | Print an application of a DocName and a list of HsTypes
+ppAppNameTypes :: DocName -> [HsType DocName] -> Bool -> Qualification -> Html
+ppAppNameTypes n ts unicode qual =
+    ppTypeApp n ts (ppDocName qual) (ppParendType unicode qual)
+
+
+-- | Print an application of a DocName and a list of Names 
+ppAppDocNameNames :: Bool -> DocName -> [Name] -> Html
+ppAppDocNameNames summ n ns =
+  ppTypeApp n ns (ppBinder summ . nameOccName . getName) ppTyName
+
+
+-- | General printing of type applications
+ppTypeApp :: DocName -> [a] -> (DocName -> Html) -> (a -> Html) -> Html
+ppTypeApp n (t1:t2:rest) ppDN ppT
+  | operator, not . null $ rest = parens opApp <+> hsep (map ppT rest)
+  | operator                    = opApp
+  where
+    operator = isNameSym . getName $ n
+    opApp = ppT t1 <+> ppDN n <+> ppT t2
+
+ppTypeApp n ts ppDN ppT = ppDN n <+> hsep (map ppT ts)
+
+
+-------------------------------------------------------------------------------
+-- * Contexts
+-------------------------------------------------------------------------------
+
+
+ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Bool
+                              -> Qualification -> Html
+ppLContext        = ppContext        . unLoc
+ppLContextNoArrow = ppContextNoArrow . unLoc
+
+
+ppContextNoArrow :: HsContext DocName -> Bool -> Qualification -> Html
+ppContextNoArrow []  _       _     = noHtml
+ppContextNoArrow cxt unicode qual = pp_hs_context (map unLoc cxt) unicode qual
+
+
+ppContextNoLocs :: [HsType DocName] -> Bool -> Qualification -> Html
+ppContextNoLocs []  _       _     = noHtml
+ppContextNoLocs cxt unicode qual = pp_hs_context cxt unicode qual 
+    <+> darrow unicode
+
+
+ppContext :: HsContext DocName -> Bool -> Qualification -> Html
+ppContext cxt unicode qual = ppContextNoLocs (map unLoc cxt) unicode qual
+
+
+pp_hs_context :: [HsType DocName] -> Bool -> Qualification-> Html
+pp_hs_context []  _       _     = noHtml
+pp_hs_context [p] unicode qual = ppType unicode qual p
+pp_hs_context cxt unicode qual = parenList (map (ppType unicode qual) cxt)
+
+
+-------------------------------------------------------------------------------
+-- * Class declarations
+-------------------------------------------------------------------------------
+
+
+ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName
+           -> LHsTyVarBndrs DocName -> [Located ([DocName], [DocName])]
+           -> Bool -> Qualification -> Html
+ppClassHdr summ lctxt n tvs fds unicode qual =
+  keyword "class"
+  <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode qual else noHtml)
+  <+> ppAppDocNameNames summ n (tyvarNames $ tvs)
+        <+> ppFds fds unicode qual
+
+
+ppFds :: [Located ([DocName], [DocName])] -> Bool -> Qualification -> Html
+ppFds fds unicode qual =
+  if null fds then noHtml else
+        char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds))
+  where
+        fundep (vars1,vars2) = hsep (map (ppDocName qual) vars1) <+> arrow unicode <+>
+                               hsep (map (ppDocName qual) vars2)
+
+
+ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan
+                 -> [(DocName, DocForDecl DocName)] -> Bool -> Qualification
+                 -> Html
+ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = tvs
+                                          , tcdFDs = fds, tcdSigs = sigs, tcdATs = ats }) loc
+    subdocs unicode qual = 
+  if null sigs && null ats
+    then (if summary then id else topDeclElem links loc [nm]) hdr
+    else (if summary then id else topDeclElem links loc [nm]) (hdr <+> keyword "where")
+      +++ shortSubDecls
+          (
+            [ ppAssocType summary links doc at unicode qual | at <- ats
+              , let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ]  ++
+
+                -- ToDo: add associated type defaults
+
+            [ ppFunSig summary links loc doc names typ unicode qual
+              | L _ (TypeSig lnames (L _ typ)) <- sigs
+              , let doc = lookupAnySubdoc (head names) subdocs
+                    names = map unLoc lnames ]
+              -- FIXME: is taking just the first name ok? Is it possible that
+              -- there are different subdocs for different names in a single
+              -- type signature?
+          )
+  where
+    hdr = ppClassHdr summary lctxt (unLoc lname) tvs fds unicode qual
+    nm  = unLoc lname
+ppShortClassDecl _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
+
+
+
+ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> SrcSpan
+            -> Maybe (Doc DocName) -> [(DocName, DocForDecl DocName)]
+            -> TyClDecl DocName -> Bool -> Qualification -> Html
+ppClassDecl summary links instances loc mbDoc subdocs
+        decl@(ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars
+                        , tcdFDs = lfds, tcdSigs = lsigs, tcdATs = ats }) unicode qual
+  | summary = ppShortClassDecl summary links decl loc subdocs unicode qual
+  | otherwise = classheader +++ maybeDocSection qual mbDoc
+                  +++ atBit +++ methodBit  +++ instancesBit
+  where
+    classheader
+      | null lsigs = topDeclElem links loc [nm] (hdr unicode qual)
+      | otherwise  = topDeclElem links loc [nm] (hdr unicode qual <+> keyword "where")
+
+    nm   = unLoc $ tcdLName decl
+
+    hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds
+
+    -- ToDo: add assocatied typ defaults
+    atBit = subAssociatedTypes [ ppAssocType summary links doc at unicode qual
+                      | at <- ats
+                      , let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ]
+
+    methodBit = subMethods [ ppFunSig summary links loc doc names typ unicode qual
+                           | L _ (TypeSig lnames (L _ typ)) <- lsigs
+                           , let doc = lookupAnySubdoc (head names) subdocs
+                                 names = map unLoc lnames ]
+                           -- FIXME: is taking just the first name ok? Is it possible that
+                           -- there are different subdocs for different names in a single
+                           -- type signature?
+
+    instancesBit = ppInstances instances nm unicode qual 
+
+ppClassDecl _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
+
+
+ppInstances :: [DocInstance DocName] -> DocName -> Bool -> Qualification -> Html
+ppInstances instances baseName unicode qual
+  = subInstances qual instName (map instDecl instances)
+  where
+    instName = getOccString $ getName baseName
+    instDecl :: DocInstance DocName -> SubDecl
+    instDecl (inst, maybeDoc) = (instHead inst, maybeDoc, [])
+    instHead ([],   n, ts) = ppAppNameTypes n ts unicode qual
+    instHead (ctxt, n, ts) = ppContextNoLocs ctxt unicode qual
+        <+> ppAppNameTypes n ts unicode qual
+
+
+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
+-------------------------------------------------------------------------------
+
+
+-- TODO: print contexts
+ppShortDataDecl :: Bool -> LinksInfo -> SrcSpan -> TyClDecl DocName -> Bool
+                -> Qualification -> Html
+ppShortDataDecl summary _links _loc dataDecl unicode qual
+
+  | [] <- cons = dataHeader 
+
+  | [lcon] <- cons, ResTyH98 <- resTy,
+    (cHead,cBody,cFoot) <- ppShortConstrParts summary (unLoc lcon) unicode qual
+       = (dataHeader <+> equals <+> cHead) +++ cBody +++ cFoot
+
+  | ResTyH98 <- resTy = dataHeader
+      +++ shortSubDecls (zipWith doConstr ('=':repeat '|') cons)
+
+  | otherwise = (dataHeader <+> keyword "where")
+      +++ shortSubDecls (map doGADTConstr cons)
+
+  where
+    dataHeader = ppDataHeader summary dataDecl unicode qual
+    doConstr c con = toHtml [c] <+> ppShortConstr summary (unLoc con) unicode qual
+    doGADTConstr con = ppShortConstr summary (unLoc con) unicode qual
+
+    cons      = td_cons (tcdTyDefn dataDecl)
+    resTy     = (con_res . unLoc . head) cons
+
+
+ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] ->
+              [(DocName, DocForDecl DocName)] ->
+              SrcSpan -> Maybe (Doc DocName) -> TyClDecl DocName -> Bool ->
+              Qualification -> Html
+ppDataDecl summary links instances subdocs loc mbDoc dataDecl unicode qual
+
+  | summary   = ppShortDataDecl summary links loc dataDecl unicode qual
+  | otherwise = header_ +++ maybeDocSection qual mbDoc +++ constrBit +++ instancesBit
+
+  where
+    docname   = unLoc . tcdLName $ dataDecl
+    cons      = td_cons (tcdTyDefn dataDecl)
+    resTy     = (con_res . unLoc . head) cons
+
+    header_ = topDeclElem links loc [docname] (ppDataHeader summary dataDecl unicode qual
+             <+> whereBit)
+
+    whereBit
+      | null cons = noHtml
+      | otherwise = case resTy of
+        ResTyGADT _ -> keyword "where"
+        _ -> noHtml
+
+    constrBit = subConstructors qual
+      (map (ppSideBySideConstr subdocs unicode qual) cons)
+
+    instancesBit = ppInstances instances docname unicode qual
+
+
+
+ppShortConstr :: Bool -> ConDecl DocName -> Bool -> Qualification -> Html
+ppShortConstr summary con unicode qual = cHead <+> cBody <+> cFoot
+  where
+    (cHead,cBody,cFoot) = ppShortConstrParts summary con unicode qual
+
+
+-- returns three pieces: header, body, footer so that header & footer can be
+-- incorporated into the declaration
+ppShortConstrParts :: Bool -> ConDecl DocName -> Bool -> Qualification -> (Html, Html, Html)
+ppShortConstrParts summary con unicode qual = case con_res con of
+  ResTyH98 -> case con_details con of
+    PrefixCon args ->
+      (header_ unicode qual +++ hsep (ppBinder summary occ
+            : map (ppLParendType unicode qual) args), noHtml, noHtml)
+    RecCon fields ->
+      (header_ unicode qual +++ ppBinder summary occ <+> char '{',
+       doRecordFields fields,
+       char '}')
+    InfixCon arg1 arg2 ->
+      (header_ unicode qual +++ hsep [ppLParendType unicode qual arg1,
+            ppBinder summary occ, ppLParendType unicode qual arg2],
+       noHtml, noHtml)
+
+  ResTyGADT resTy -> case con_details con of
+    -- prefix & infix could use hsConDeclArgTys if it seemed to
+    -- simplify the code.
+    PrefixCon args -> (doGADTCon args resTy, noHtml, noHtml)
+    -- display GADT records with the new syntax,
+    -- Constr :: (Context) => { field :: a, field2 :: b } -> Ty (a, b)
+    -- (except each field gets its own line in docs, to match
+    -- non-GADT records)
+    RecCon fields -> (ppBinder summary occ <+> dcolon unicode <+>
+                            ppForAll forall ltvs lcontext unicode qual <+> char '{',
+                            doRecordFields fields,
+                            char '}' <+> arrow unicode <+> ppLType unicode qual resTy)
+    InfixCon arg1 arg2 -> (doGADTCon [arg1, arg2] resTy, noHtml, noHtml)
+
+  where
+    doRecordFields fields = shortSubDecls (map (ppShortField summary unicode qual) fields)
+    doGADTCon args resTy = ppBinder summary occ <+> dcolon unicode <+> hsep [
+                             ppForAll forall ltvs lcontext unicode qual,
+                             ppLType unicode qual (foldr mkFunTy resTy args) ]
+
+    header_  = ppConstrHdr forall tyVars context
+    occ      = nameOccName . getName . unLoc . con_name $ con
+    ltvs     = con_qvars con
+    tyVars   = tyvarNames ltvs
+    lcontext = con_cxt con
+    context  = unLoc (con_cxt con)
+    forall   = con_explicit con
+    mkFunTy a b = noLoc (HsFunTy a b)
+
+
+-- ppConstrHdr is for (non-GADT) existentials constructors' syntax
+ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Bool
+            -> Qualification -> Html
+ppConstrHdr forall tvs ctxt unicode qual
+ = (if null tvs then noHtml else ppForall)
+   +++
+   (if null ctxt then noHtml else ppContextNoArrow ctxt unicode qual
+        <+> darrow unicode +++ toHtml " ")
+  where
+    ppForall = case forall of
+      Explicit -> forallSymbol unicode <+> hsep (map ppName tvs) <+> toHtml ". "
+      Implicit -> noHtml
+
+
+ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> Qualification
+                   -> LConDecl DocName -> SubDecl
+ppSideBySideConstr subdocs unicode qual (L _ con) = (decl, mbDoc, fieldPart)
+ where
+    decl = case con_res con of
+      ResTyH98 -> case con_details con of
+        PrefixCon args ->
+          hsep ((header_ unicode qual +++ ppBinder False occ)
+            : map (ppLParendType unicode qual) args)
+
+        RecCon _ -> header_ unicode qual +++ ppBinder False occ
+
+        InfixCon arg1 arg2 ->
+          hsep [header_ unicode qual +++ ppLParendType unicode qual arg1,
+            ppBinder False occ,
+            ppLParendType unicode qual arg2]
+
+      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 _) -> doGADTCon (hsConDeclArgTys cd) resTy
+        InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy
+
+    fieldPart = case con_details con of
+        RecCon fields -> [doRecordFields fields]
+        _ -> []
+
+    doRecordFields fields = subFields qual
+      (map (ppSideBySideField subdocs unicode qual) fields)
+    doGADTCon :: [LHsType DocName] -> Located (HsType DocName) -> Html
+    doGADTCon args resTy =
+      ppBinder False occ <+> dcolon unicode
+        <+> hsep [ppForAll forall ltvs (con_cxt con) unicode qual,
+                  ppLType unicode qual (foldr mkFunTy resTy args) ]
+
+    header_ = ppConstrHdr forall tyVars context
+    occ     = nameOccName . getName . unLoc . con_name $ con
+    ltvs    = con_qvars con
+    tyVars  = tyvarNames (con_qvars con)
+    context = unLoc (con_cxt con)
+    forall  = con_explicit con
+    -- don't use "con_doc con", in case it's reconstructed from a .hi file,
+    -- or also because we want Haddock to do the doc-parsing, not GHC.
+    -- 'join' is in Maybe.
+    mbDoc = join $ fmap fst $ lookup (unLoc $ con_name con) subdocs
+    mkFunTy a b = noLoc (HsFunTy a b)
+
+
+ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> Qualification
+                  -> ConDeclField DocName ->  SubDecl
+ppSideBySideField subdocs unicode qual (ConDeclField (L _ name) ltype _) =
+  (ppBinder False (nameOccName . getName $ name) <+> dcolon unicode <+> ppLType unicode qual ltype,
+    mbDoc,
+    [])
+  where
+    -- don't use cd_fld_doc for same reason we don't use con_doc above
+    mbDoc = join $ fmap fst $ lookup name subdocs
+
+
+ppShortField :: Bool -> Bool -> Qualification -> ConDeclField DocName -> Html
+ppShortField summary unicode qual (ConDeclField (L _ name) ltype _)
+  = ppBinder summary (nameOccName . getName $ name)
+    <+> dcolon unicode <+> ppLType unicode qual ltype
+
+
+-- | Print the LHS of a data\/newtype declaration.
+-- Currently doesn't handle 'data instance' decls or kind signatures
+ppDataHeader :: Bool -> TyClDecl DocName -> Bool -> Qualification -> Html
+ppDataHeader summary decl@(TyDecl { tcdTyDefn = TyData { td_ND = nd, td_ctxt = ctxt } }) 
+             unicode qual
+  = -- newtype or data
+    (case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }) <+>
+    -- context
+    ppLContext ctxt unicode qual <+>
+    -- T a b c ..., or a :+: b
+    ppTyClBinderWithVars summary decl
+ppDataHeader _ _ _ _ = error "ppDataHeader: illegal argument"
+
+
+--------------------------------------------------------------------------------
+-- * Types and contexts
+--------------------------------------------------------------------------------
+
+
+ppBang :: HsBang -> Html
+ppBang HsNoBang = noHtml
+ppBang _        = toHtml "!" -- Unpacked args is an implementation detail,
+                             -- so we just show the strictness annotation
+
+
+tupleParens :: HsTupleSort -> [Html] -> Html
+tupleParens HsUnboxedTuple = ubxParenList
+tupleParens _              = parenList
+
+
+--------------------------------------------------------------------------------
+-- * Rendering of HsType
+--------------------------------------------------------------------------------
+
+
+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
+           -> Html -> Html  -- Wrap in parens if (ctxt >= op)
+maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p
+                               | otherwise            = p
+
+
+ppLType, ppLParendType, ppLFunLhType :: Bool -> Qualification
+                                     -> Located (HsType DocName) -> Html
+ppLType       unicode qual y = ppType unicode qual (unLoc y)
+ppLParendType unicode qual y = ppParendType unicode qual (unLoc y)
+ppLFunLhType  unicode qual y = ppFunLhType unicode qual (unLoc y)
+
+
+ppType, ppParendType, ppFunLhType :: Bool -> Qualification-> HsType DocName -> Html
+ppType       unicode qual ty = ppr_mono_ty pREC_TOP ty unicode qual
+ppParendType unicode qual ty = ppr_mono_ty pREC_CON ty unicode qual
+ppFunLhType  unicode qual ty = ppr_mono_ty pREC_FUN ty unicode qual
+
+ppLKind :: Bool -> Qualification-> LHsKind DocName -> Html
+ppLKind unicode qual y = ppKind unicode qual (unLoc y)
+
+ppKind :: Bool -> Qualification-> HsKind DocName -> Html
+ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual
+
+-- Drop top-level for-all type variables in user style
+-- since they are implicit in Haskell
+
+ppForAll :: HsExplicitFlag -> LHsTyVarBndrs DocName
+         -> Located (HsContext DocName) -> Bool -> Qualification -> Html
+ppForAll expl tvs cxt unicode qual
+  | show_forall = forall_part <+> ppLContext cxt unicode qual
+  | otherwise   = ppLContext cxt unicode qual
+  where
+    show_forall = not (null (hsQTvBndrs tvs)) && is_explicit
+    is_explicit = case expl of {Explicit -> True; Implicit -> False}
+    forall_part = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot
+
+
+ppr_mono_lty :: Int -> LHsType DocName -> Bool -> Qualification -> Html
+ppr_mono_lty ctxt_prec ty unicode qual = ppr_mono_ty ctxt_prec (unLoc ty) unicode qual
+
+
+ppr_mono_ty :: Int -> HsType DocName -> Bool -> Qualification -> Html
+ppr_mono_ty ctxt_prec (HsForAllTy expl tvs ctxt ty) unicode qual
+  = maybeParen ctxt_prec pREC_FUN $
+    hsep [ppForAll expl tvs ctxt unicode qual, ppr_mono_lty pREC_TOP ty unicode qual]
+
+ppr_mono_ty _         (HsBangTy b ty)     u q = ppBang b +++ ppLParendType u q ty
+ppr_mono_ty _         (HsTyVar name)      _ q = ppDocName q name
+ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2)   u q = ppr_fun_ty ctxt_prec ty1 ty2 u q
+ppr_mono_ty _         (HsTupleTy con tys) u q = tupleParens con (map (ppLType u q) tys)
+ppr_mono_ty _         (HsKindSig ty kind) u q =
+    parens (ppr_mono_lty pREC_TOP ty u q <+> dcolon u <+> ppLKind u q kind)
+ppr_mono_ty _         (HsListTy ty)       u q = brackets (ppr_mono_lty pREC_TOP ty u q)
+ppr_mono_ty _         (HsPArrTy ty)       u q = pabrackets (ppr_mono_lty pREC_TOP ty u q)
+ppr_mono_ty _         (HsIParamTy n ty)   u q = brackets (ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q)
+ppr_mono_ty _         (HsSpliceTy {})     _ _ = error "ppr_mono_ty HsSpliceTy"
+#if __GLASGOW_HASKELL__ == 612
+ppr_mono_ty _         (HsSpliceTyOut {})  _ _ = error "ppr_mono_ty HsQuasiQuoteTy"
+#else
+ppr_mono_ty _         (HsQuasiQuoteTy {}) _ _ = error "ppr_mono_ty HsQuasiQuoteTy"
+#endif
+ppr_mono_ty _         (HsRecTy {})        _ _ = error "ppr_mono_ty HsRecTy"
+ppr_mono_ty _         (HsCoreTy {})       _ _ = error "ppr_mono_ty HsCoreTy"
+ppr_mono_ty _         (HsExplicitListTy _ tys) u q = quote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys
+ppr_mono_ty _         (HsExplicitTupleTy _ tys) u q = quote $ parenList $ map (ppLType u q) tys
+ppr_mono_ty _         (HsWrapTy {})       _ _ = error "ppr_mono_ty HsWrapTy"
+
+ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode qual
+  = maybeParen ctxt_prec pREC_OP $
+    ppr_mono_lty pREC_OP ty1 unicode qual <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode qual
+
+ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode qual
+  = maybeParen ctxt_prec pREC_CON $
+    hsep [ppr_mono_lty pREC_FUN fun_ty unicode qual, ppr_mono_lty pREC_CON arg_ty unicode qual]
+
+ppr_mono_ty ctxt_prec (HsOpTy ty1 (_, op) ty2) unicode qual
+  = maybeParen ctxt_prec pREC_FUN $
+    ppr_mono_lty pREC_OP ty1 unicode qual <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual
+  where
+    ppr_op = if not (isSymOcc occ) then quote (ppLDocName qual op) else ppLDocName qual op
+    occ = nameOccName . getName . unLoc $ op
+
+ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual
+--  = parens (ppr_mono_lty pREC_TOP ty)
+  = ppr_mono_lty ctxt_prec ty unicode qual
+
+ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual
+  = ppr_mono_lty ctxt_prec ty unicode qual
+
+ppr_mono_ty _ (HsTyLit n) _ _ = ppr_tylit n
+
+ppr_tylit :: HsTyLit -> Html
+ppr_tylit (HsNumTy n) = toHtml (show n)
+ppr_tylit (HsStrTy s) = toHtml (show s)
+
+
+ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Bool -> Qualification -> Html
+ppr_fun_ty ctxt_prec ty1 ty2 unicode qual
+  = let p1 = ppr_mono_lty pREC_FUN ty1 unicode qual
+        p2 = ppr_mono_lty pREC_TOP ty2 unicode qual
+    in
+    maybeParen ctxt_prec pREC_FUN $
+    hsep [p1, arrow unicode <+> p2]
+
+

src/Haddock/Backends/Xhtml/DocMarkup.hs

+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Haddock.Backends.Html.DocMarkup
+-- Copyright   :  (c) Simon Marlow   2003-2006,
+--                    David Waern    2006-2009,
+--                    Mark Lentczner 2010
+-- License     :  BSD-like
+--
+-- Maintainer  :  haddock@projects.haskell.org
+-- Stability   :  experimental
+-- Portability :  portable
+-----------------------------------------------------------------------------
+module Haddock.Backends.Xhtml.DocMarkup (
+  docToHtml,
+  rdrDocToHtml,
+  origDocToHtml,
+
+  docElement, docSection, maybeDocSection,
+) where
+
+
+import Haddock.Backends.Xhtml.Names
+import Haddock.Backends.Xhtml.Utils
+import Haddock.Types
+import Haddock.Utils
+
+import Text.XHtml hiding ( name, title, p, quote )
+
+import GHC
+
+
+parHtmlMarkup :: Qualification -> (a -> Html) -> DocMarkup a Html
+parHtmlMarkup qual ppId = Markup {
+  markupEmpty                = noHtml,
+  markupString               = toHtml,
+  markupParagraph            = paragraph,
+  markupAppend               = (+++),
+  markupIdentifier           = thecode . ppId,
+  markupIdentifierUnchecked  = thecode . ppUncheckedLink qual,
+  markupModule               = \m -> let (mdl,ref) = break (=='#') m
+                                     in ppModuleRef (mkModuleName mdl) ref,
+  markupEmphasis             = emphasize,
+  markupMonospaced           = thecode,
+  markupUnorderedList        = unordList,
+  markupOrderedList          = ordList,
+  markupDefList              = defList,
+  markupCodeBlock            = pre,
+  markupURL                  = \url -> anchor ! [href url] << url,
+  markupAName                = \aname -> namedAnchor aname << "",
+  markupPic                  = \path -> image ! [src path],
+  markupExample              = examplesToHtml
+  }
+  where
+    examplesToHtml l = pre (concatHtml $ map exampleToHtml l) ! [theclass "screen"]
+
+    exampleToHtml (Example expression result) = htmlExample
+      where
+        htmlExample = htmlPrompt +++ htmlExpression +++ toHtml (unlines result)
+        htmlPrompt = (thecode . toHtml $ ">>> ") ! [theclass "prompt"]
+        htmlExpression = (strong . thecode . toHtml $ expression ++ "\n") ! [theclass "userinput"]
+
+
+-- If the doc is a single paragraph, don't surround it with <P> (this causes
+-- ugly extra whitespace with some browsers).  FIXME: Does this still apply?
+docToHtml :: Qualification -> Doc DocName -> Html
+docToHtml qual = markup fmt . cleanup
+  where fmt = parHtmlMarkup qual (ppDocName qual)
+
+
+origDocToHtml :: Qualification -> Doc Name -> Html
+origDocToHtml qual = markup fmt . cleanup
+  where fmt = parHtmlMarkup qual ppName
+
+
+rdrDocToHtml :: Qualification -> Doc RdrName -> Html
+rdrDocToHtml qual = markup fmt . cleanup
+  where fmt = parHtmlMarkup qual ppRdrName
+
+
+docElement :: (Html -> Html) -> Html -> Html
+docElement el content_ =
+  if isNoHtml content_
+    then el ! [theclass "doc empty"] << spaceHtml
+    else el ! [theclass "doc"] << content_
+
+
+docSection :: Qualification -> Doc DocName -> Html
+docSection qual = (docElement thediv <<) . docToHtml qual
+
+
+maybeDocSection :: Qualification -> Maybe (Doc DocName) -> Html
+maybeDocSection qual = maybe noHtml (docSection qual)
+
+
+cleanup :: Doc a -> Doc a
+cleanup = markup fmtUnParagraphLists
+  where
+    -- If there is a single paragraph, then surrounding it with <P>..</P>
+    -- can add too much whitespace in some browsers (eg. IE).  However if
+    -- we have multiple paragraphs, then we want the extra whitespace to
+    -- separate them.  So we catch the single paragraph case and transform it
+    -- here. We don't do this in code blocks as it eliminates line breaks.
+    unParagraph :: Doc a -> Doc a
+    unParagraph (DocParagraph d) = d
+    unParagraph doc              = doc
+
+    fmtUnParagraphLists :: DocMarkup a (Doc a)
+    fmtUnParagraphLists = idMarkup {
+      markupUnorderedList = DocUnorderedList . map unParagraph,
+      markupOrderedList   = DocOrderedList   . map unParagraph
+      }

src/Haddock/Backends/Xhtml/Layout.hs

+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Haddock.Backends.Html.Layout
+-- Copyright   :  (c) Simon Marlow   2003-2006,
+--                    David Waern    2006-2009,
+--                    Mark Lentczner 2010
+-- License     :  BSD-like
+--
+-- Maintainer  :  haddock@projects.haskell.org
+-- Stability   :  experimental
+-- Portability :  portable
+-----------------------------------------------------------------------------
+module Haddock.Backends.Xhtml.Layout (
+  miniBody,
+
+  divPackageHeader, divContent, divModuleHeader, divFooter,
+  divTableOfContents, divDescription, divSynposis, divInterface,
+  divIndex, divAlphabet, divModuleList,
+
+  sectionName,
+
+  shortDeclList,
+  shortSubDecls,
+
+  divTopDecl,
+
+  SubDecl,
+  subArguments,
+  subAssociatedTypes,
+  subConstructors,
+  subFields,
+  subInstances,
+  subMethods,
+
+  topDeclElem, declElem,
+) where
+
+
+import Haddock.Backends.Xhtml.DocMarkup
+import Haddock.Backends.Xhtml.Types
+import Haddock.Backends.Xhtml.Utils
+import Haddock.Types
+import Haddock.Utils (makeAnchorId)
+
+import qualified Data.Map as Map
+import Text.XHtml hiding ( name, title, p, quote )
+
+import FastString            ( unpackFS )
+import GHC
+
+
+--------------------------------------------------------------------------------
+-- * Sections of the document
+--------------------------------------------------------------------------------
+
+
+miniBody :: Html -> Html
+miniBody = body ! [identifier "mini"]
+
+
+sectionDiv :: String -> Html -> Html
+sectionDiv i = thediv ! [identifier i]
+
+
+sectionName :: Html -> Html
+sectionName = paragraph ! [theclass "caption"]
+
+
+divPackageHeader, divContent, divModuleHeader, divFooter,
+  divTableOfContents, divDescription, divSynposis, divInterface,
+  divIndex, divAlphabet, divModuleList
+    :: Html -> Html
+
+divPackageHeader    = sectionDiv "package-header"
+divContent          = sectionDiv "content"
+divModuleHeader     = sectionDiv "module-header"
+divFooter           = sectionDiv "footer"
+divTableOfContents  = sectionDiv "table-of-contents"
+divDescription      = sectionDiv "description"
+divSynposis         = sectionDiv "synopsis"
+divInterface        = sectionDiv "interface"
+divIndex            = sectionDiv "index"
+divAlphabet         = sectionDiv "alphabet"
+divModuleList       = sectionDiv "module-list"
+
+
+--------------------------------------------------------------------------------
+-- * Declaration containers
+--------------------------------------------------------------------------------
+
+
+shortDeclList :: [Html] -> Html
+shortDeclList items = ulist << map (li ! [theclass "src short"] <<) items
+
+
+shortSubDecls :: [Html] -> Html
+shortSubDecls items = ulist ! [theclass "subs"] << map (li <<) items
+
+
+divTopDecl :: Html -> Html
+divTopDecl = thediv ! [theclass "top"]
+
+
+type SubDecl = (Html, Maybe (Doc DocName), [Html])
+
+
+divSubDecls :: (HTML a) => String -> a -> Maybe Html -> Html
+divSubDecls cssClass captionName = maybe noHtml wrap
+  where
+    wrap = (subSection <<) . (subCaption +++)
+    subSection = thediv ! [theclass $ unwords ["subs", cssClass]]
+    subCaption = paragraph ! [theclass "caption"] << captionName
+
+
+subDlist :: Qualification -> [SubDecl] -> Maybe Html
+subDlist _ [] = Nothing
+subDlist qual decls = Just $ dlist << map subEntry decls +++ clearDiv
+  where
+    subEntry (decl, mdoc, subs) =
+      dterm ! [theclass "src"] << decl
+      +++
+      docElement ddef << (fmap (docToHtml qual) mdoc +++ subs)
+
+    clearDiv = thediv ! [ theclass "clear" ] << noHtml
+
+
+subTable :: Qualification -> [SubDecl] -> Maybe Html
+subTable _ [] = Nothing
+subTable qual decls = Just $ table << aboves (concatMap subRow decls)
+  where
+    subRow (decl, mdoc, subs) =
+      (td ! [theclass "src"] << decl
+       <->
+       docElement td << fmap (docToHtml qual) mdoc)
+      : map (cell . (td <<)) subs
+
+
+subBlock :: [Html] -> Maybe Html
+subBlock [] = Nothing
+subBlock hs = Just $ toHtml hs
+
+
+subArguments :: Qualification -> [SubDecl] -> Html
+subArguments qual = divSubDecls "arguments" "Arguments" . subTable qual
+
+
+subAssociatedTypes :: [Html] -> Html
+subAssociatedTypes = divSubDecls "associated-types" "Associated Types" . subBlock
+
+
+subConstructors :: Qualification -> [SubDecl] -> Html
+subConstructors qual = divSubDecls "constructors" "Constructors" . subTable qual
+
+
+subFields :: Qualification -> [SubDecl] -> Html
+subFields qual = divSubDecls "fields" "Fields" . subDlist qual
+
+
+subInstances :: Qualification -> String -> [SubDecl] -> Html
+subInstances qual nm = maybe noHtml wrap . instTable
+  where
+    wrap = (subSection <<) . (subCaption +++)
+    instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTable qual
+    subSection = thediv ! [theclass "subs instances"]
+    subCaption = paragraph ! collapseControl id_ True "caption" << "Instances"
+    id_ = makeAnchorId $ "i:" ++ nm
+
+subMethods :: [Html] -> Html
+subMethods = divSubDecls "methods" "Methods" . subBlock
+
+
+-- a box for displaying code
+declElem :: Html -> Html
+declElem = paragraph ! [theclass "src"]
+
+
+-- a box for top level documented names
+-- it adds a source and wiki link at the right hand side of the box
+topDeclElem :: LinksInfo -> SrcSpan -> [DocName] -> Html -> Html
+topDeclElem ((_,_,sourceMap), (_,_,maybe_wiki_url)) loc names html =
+    declElem << (html +++ srcLink +++ wikiLink)
+  where srcLink =
+          case Map.lookup origPkg sourceMap of
+            Nothing  -> noHtml
+            Just url -> let url' = spliceURL (Just fname) (Just origMod)
+                                               (Just n) (Just loc) url
+                          in anchor ! [href url', theclass "link"] << "Source"
+
+        wikiLink =
+          case maybe_wiki_url of
+            Nothing  -> noHtml
+            Just url -> let url' = spliceURL (Just fname) (Just mdl)
+                                               (Just n) (Just loc) url
+                          in anchor ! [href url', theclass "link"] << "Comments"
+
+        -- For source links, we want to point to the original module,
+        -- because only that will have the source.
+        -- TODO: do something about type instances. They will point to
+        -- the module defining the type family, which is wrong.
+        origMod = nameModule n
+        origPkg = modulePackageId origMod
+
+        -- Name must be documented, otherwise we wouldn't get here
+        Documented n mdl = head names
+        -- FIXME: is it ok to simply take the first name?
+
+        fname = case loc of
+                RealSrcSpan l -> unpackFS (srcSpanFile l)
+                UnhelpfulSpan _ -> error "topDeclElem UnhelpfulSpan"
+

src/Haddock/Backends/Xhtml/Names.hs

+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Haddock.Backends.Html.Names
+-- Copyright   :  (c) Simon Marlow   2003-2006,
+--                    David Waern    2006-2009,
+--                    Mark Lentczner 2010
+-- License     :  BSD-like
+--
+-- Maintainer  :  haddock@projects.haskell.org
+-- Stability   :  experimental
+-- Portability :  portable
+-----------------------------------------------------------------------------
+module Haddock.Backends.Xhtml.Names (
+  ppName, ppDocName, ppLDocName, ppRdrName, ppUncheckedLink,
+  ppBinder, ppBinder',
+  ppModule, ppModuleRef,
+  ppIPName,
+  linkId
+) where
+
+
+import Haddock.Backends.Xhtml.Utils
+import Haddock.GhcUtils
+import Haddock.Types
+import Haddock.Utils
+
+import Text.XHtml hiding ( name, title, p, quote )
+import qualified Data.List as List
+
+import GHC
+import Name
+import RdrName
+import FastString (unpackFS)
+
+
+ppOccName :: OccName -> Html
+ppOccName = toHtml . occNameString
+
+
+ppRdrName :: RdrName -> Html
+ppRdrName = ppOccName . rdrNameOcc
+
+ppIPName :: HsIPName -> Html
+ppIPName = toHtml . unpackFS . hsIPNameFS
+
+
+ppUncheckedLink :: Qualification -> (ModuleName, OccName) -> Html
+ppUncheckedLink _ (mdl, occ) = linkIdOcc' mdl (Just occ) << ppOccName occ -- TODO: apply ppQualifyName
+
+
+ppLDocName :: Qualification -> Located DocName -> Html
+ppLDocName qual (L _ d) = ppDocName qual d
+
+
+ppDocName :: Qualification -> DocName -> Html
+ppDocName qual docName =
+  case docName of
+    Documented name mdl ->
+      linkIdOcc mdl (Just (nameOccName name)) << ppQualifyName qual name mdl
+    Undocumented name -> ppQualifyName qual name (nameModule name)
+
+
+-- | Render a name depending on the selected qualification mode
+ppQualifyName :: Qualification -> Name -> Module -> Html
+ppQualifyName qual name mdl =
+  case qual of
+    NoQual   -> ppName name
+    FullQual -> ppFullQualName mdl name
+    -- this is just in case, it should never happen
+    LocalQual Nothing -> ppQualifyName FullQual name mdl
+    LocalQual (Just localmdl)
+      | moduleString mdl == moduleString localmdl -> ppName name
+      | otherwise -> ppFullQualName mdl name
+    -- again, this never happens
+    RelativeQual Nothing -> ppQualifyName FullQual name mdl
+    RelativeQual (Just localmdl) ->
+      case List.stripPrefix (moduleString localmdl) (moduleString mdl) of
+        -- local, A.x -> x
+        Just []      -> ppQualifyName NoQual name mdl
+        -- sub-module, A.B.x -> B.x
+        Just ('.':m) -> toHtml $ m ++ '.' : getOccString name
+        -- some module with same prefix, ABC.x -> ABC.x
+        Just _       -> ppQualifyName FullQual name mdl
+        -- some other module, D.x -> D.x
+        Nothing      -> ppQualifyName FullQual name mdl
+
+
+ppFullQualName :: Module -> Name -> Html
+ppFullQualName mdl name = toHtml $ moduleString mdl ++ '.' : getOccString name
+
+
+ppName :: Name -> Html
+ppName name = toHtml (getOccString name)
+
+
+ppBinder :: Bool -> OccName -> Html
+-- The Bool indicates whether we are generating the summary, in which case
+-- the binder will be a link to the full definition.
+ppBinder True n = linkedAnchor (nameAnchorId n) << ppBinder' n
+ppBinder False n = namedAnchor (nameAnchorId n) ! [theclass "def"]
+                        << ppBinder' n
+
+
+ppBinder' :: OccName -> Html
+ppBinder' n
+  | isVarSym n = parens $ ppOccName n
+  | otherwise  = ppOccName n
+
+
+linkId :: Module -> Maybe Name -> Html -> Html
+linkId mdl mbName = linkIdOcc mdl (fmap nameOccName mbName)
+
+
+linkIdOcc :: Module -> Maybe OccName -> Html -> Html
+linkIdOcc mdl mbName = anchor ! [href url]
+  where
+    url = case mbName of
+      Nothing   -> moduleUrl mdl
+      Just name -> moduleNameUrl mdl name
+
+
+linkIdOcc' :: ModuleName -> Maybe OccName -> Html -> Html
+linkIdOcc' mdl mbName = anchor ! [href url]
+  where
+    url = case mbName of
+      Nothing   -> moduleHtmlFile' mdl
+      Just name -> moduleNameUrl' mdl name
+
+
+ppModule :: Module -> Html
+ppModule mdl = anchor ! [href (moduleUrl mdl)]
+               << toHtml (moduleString mdl)
+
+
+ppModuleRef :: ModuleName -> String -> Html
+ppModuleRef mdl ref = anchor ! [href (moduleHtmlFile' mdl ++ ref)]
+                      << toHtml (moduleNameString mdl)
+    -- NB: The ref parameter already includes the '#'.
+    -- This function is only called from markupModule expanding a
+    -- DocModule, which doesn't seem to be ever be used.

src/Haddock/Backends/Xhtml/Themes.hs

+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Haddock.Backends.Html.Themes
+-- Copyright   :  (c) Mark Lentczner 2010
+-- License     :  BSD-like
+--
+-- Maintainer  :  haddock@projects.haskell.org
+-- Stability   :  experimental
+-- Portability :  portable
+-----------------------------------------------------------------------------
+module Haddock.Backends.Xhtml.Themes (
+    Themes,
+    getThemes,
+
+    cssFiles, styleSheet
+    )
+    where
+
+import Haddock.Options
+
+import Control.Applicative
+import Control.Monad (liftM)
+import Data.Char (toLower)
+import Data.Either (lefts, rights)
+import Data.List (nub)
+import Data.Maybe (isJust, listToMaybe)
+
+import System.Directory
+import System.FilePath
+import Text.XHtml hiding ( name, title, p, quote, (</>) )
+import qualified Text.XHtml as XHtml
+
+
+--------------------------------------------------------------------------------
+-- * CSS Themes
+--------------------------------------------------------------------------------
+
+data Theme = Theme {
+  themeName :: String,
+  themeHref :: String,
+  themeFiles :: [FilePath]
+  }
+
+type Themes = [Theme]
+
+type PossibleTheme = Either String Theme
+type PossibleThemes = Either String Themes
+
+
+-- | Find a theme by name (case insensitive match)
+findTheme :: String -> Themes -> Maybe Theme
+findTheme s = listToMaybe . filter ((== ls).lower.themeName)
+  where lower = map toLower
+        ls = lower s
+
+
+-- | Standard theme used by default
+standardTheme :: FilePath -> IO PossibleThemes
+standardTheme libDir = liftM (liftEither (take 1)) (defaultThemes libDir)
+
+
+-- | Default themes that are part of Haddock; added with --default-themes
+-- The first theme in this list is considered the standard theme.
+-- Themes are "discovered" by scanning the html sub-dir of the libDir,
+-- and looking for directories with the extension .theme or .std-theme.
+-- The later is, obviously, the standard theme.
+defaultThemes :: FilePath -> IO PossibleThemes
+defaultThemes libDir = do
+  themeDirs <- getDirectoryItems (libDir </> "html")
+  themes <- mapM directoryTheme $ discoverThemes themeDirs
+  return $ sequenceEither themes
+  where
+    discoverThemes paths =
+      filterExt ".std-theme" paths ++ filterExt ".theme" paths
+    filterExt ext = filter ((== ext).takeExtension)
+
+
+-- | Build a theme from a single .css file
+singleFileTheme :: FilePath -> IO PossibleTheme
+singleFileTheme path =
+  if isCssFilePath path
+      then retRight $ Theme name file [path]
+      else errMessage "File extension isn't .css" path
+  where
+    name = takeBaseName path
+    file = takeFileName path
+
+
+-- | Build a theme from a directory
+directoryTheme :: FilePath -> IO PossibleTheme
+directoryTheme path = do
+  items <- getDirectoryItems path
+  case filter isCssFilePath items of
+    [cf] -> retRight $ Theme (takeBaseName path) (takeFileName cf) items
+    [] -> errMessage "No .css file in theme directory" path
+    _ -> errMessage "More than one .css file in theme directory" path
+
+
+-- | Check if we have a built in theme
+doesBuiltInExist :: IO PossibleThemes -> String -> IO Bool
+doesBuiltInExist pts s = fmap (either (const False) test) pts
+  where test = isJust . findTheme s
+
+
+-- | Find a built in theme
+builtInTheme :: IO PossibleThemes -> String -> IO PossibleTheme
+builtInTheme pts s = either Left fetch <$> pts
+  where fetch = maybe (Left ("Unknown theme: " ++ s)) Right . findTheme s
+
+
+--------------------------------------------------------------------------------
+-- * CSS Theme Arguments
+--------------------------------------------------------------------------------
+
+-- | Process input flags for CSS Theme arguments
+getThemes :: FilePath -> [Flag] -> IO PossibleThemes
+getThemes libDir flags =
+  liftM concatEither (mapM themeFlag flags) >>= someTheme
+  where
+    themeFlag :: Flag -> IO (Either String Themes)
+    themeFlag (Flag_CSS path) = (liftM . liftEither) (:[]) (theme path)
+    themeFlag (Flag_BuiltInThemes) = builtIns
+    themeFlag _ = retRight []
+
+    theme :: FilePath -> IO PossibleTheme
+    theme path = pick path
+      [(doesFileExist,              singleFileTheme),
+       (doesDirectoryExist,         directoryTheme),
+       (doesBuiltInExist builtIns,  builtInTheme builtIns)]
+      "Theme not found"
+
+    pick :: FilePath
+      -> [(FilePath -> IO Bool, FilePath -> IO PossibleTheme)] -> String
+      -> IO PossibleTheme
+    pick path [] msg = errMessage msg path
+    pick path ((test,build):opts) msg = do
+      pass <- test path
+      if pass then build path else pick path opts msg
+
+
+    someTheme :: Either String Themes -> IO (Either String Themes)
+    someTheme (Right []) = standardTheme libDir
+    someTheme est = return est
+
+    builtIns = defaultThemes libDir
+
+
+errMessage :: String -> FilePath -> IO (Either String a)
+errMessage msg path = return (Left msg')
+  where msg' = "Error: " ++ msg ++ ": \"" ++ path ++ "\"\n"
+
+
+retRight :: a -> IO (Either String a)
+retRight = return . Right
+
+
+--------------------------------------------------------------------------------
+-- * File Utilities
+--------------------------------------------------------------------------------
+
+
+getDirectoryItems :: FilePath -> IO [FilePath]
+getDirectoryItems path =
+  map (combine path) . filter notDot <$> getDirectoryContents path
+  where notDot s = s /= "." && s /= ".."
+
+
+isCssFilePath :: FilePath -> Bool
+isCssFilePath path = takeExtension path == ".css"
+
+
+--------------------------------------------------------------------------------
+-- * Style Sheet Utilities
+--------------------------------------------------------------------------------
+
+cssFiles :: Themes -> [String]
+cssFiles ts = nub $ concatMap themeFiles ts
+
+
+styleSheet :: Themes -> Html
+styleSheet ts = toHtml $ zipWith mkLink rels ts
+  where
+    rels = "stylesheet" : repeat "alternate stylesheet"
+    mkLink aRel t =
+      thelink
+        ! [ href (themeHref t),  rel aRel, thetype "text/css",
+            XHtml.title (themeName t)
+          ]
+        << noHtml
+
+--------------------------------------------------------------------------------
+-- * Either Utilities
+--------------------------------------------------------------------------------
+
+-- These three routines are here because Haddock does not have access to the
+-- Control.Monad.Error module which supplies the Functor and Monad instances
+-- for Either String.
+
+sequenceEither :: [Either a b] -> Either a [b]
+sequenceEither es = maybe (Right $ rights es) Left (listToMaybe (lefts es))
+
+
+liftEither :: (b -> c) -> Either a b -> Either a c
+liftEither f = either Left (Right . f)
+
+
+concatEither :: [Either a [b]] -> Either a [b]
+concatEither = liftEither concat . sequenceEither
+

src/Haddock/Backends/Xhtml/Types.hs

+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Haddock.Backends.Html.Types
+-- Copyright   :  (c) Simon Marlow   2003-2006,
+--                    David Waern    2006-2009,
+--                    Mark Lentczner 2010
+-- License     :  BSD-like
+--
+-- Maintainer  :  haddock@projects.haskell.org
+-- Stability   :  experimental
+-- Portability :  portable
+-----------------------------------------------------------------------------
+module Haddock.Backends.Xhtml.Types (
+  SourceURLs, WikiURLs,
+  LinksInfo
+) where
+
+
+import Data.Map
+import GHC
+
+
+-- the base, module and entity URLs for the source code and wiki links.
+type SourceURLs = (Maybe FilePath, Maybe FilePath, Map PackageId FilePath)
+type WikiURLs = (Maybe FilePath, Maybe FilePath, Maybe FilePath)
+
+
+-- The URL for source and wiki links
+type LinksInfo = (SourceURLs, WikiURLs)

src/Haddock/Backends/Xhtml/Utils.hs

+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Haddock.Backends.Html.Util
+-- Copyright   :  (c) Simon Marlow   2003-2006,
+--                    David Waern    2006-2009,
+--                    Mark Lentczner 2010
+-- License     :  BSD-like
+--
+-- Maintainer  :  haddock@projects.haskell.org
+-- Stability   :  experimental
+-- Portability :  portable
+-----------------------------------------------------------------------------
+module Haddock.Backends.Xhtml.Utils (
+  renderToString,
+
+  namedAnchor, linkedAnchor,
+  spliceURL,
+  groupId,
+
+  (<+>), char, nonEmpty,
+  keyword, punctuate,
+
+  braces, brackets, pabrackets, parens, parenList, ubxParenList,
+  arrow, comma, dcolon, dot, darrow, equals, forallSymbol, quote,
+
+  hsep,
+
+  collapseSection, collapseToggle, collapseControl,
+) where
+
+
+import Haddock.GhcUtils
+import Haddock.Utils
+
+import Data.Maybe
+
+import Text.XHtml hiding ( name, title, p, quote )
+import qualified Text.XHtml as XHtml
+
+import GHC      ( SrcSpan(..), srcSpanStartLine, Name )
+import Module   ( Module )
+import Name     ( getOccString, nameOccName, isValOcc )
+
+
+spliceURL :: Maybe FilePath -> Maybe Module -> Maybe GHC.Name ->
+             Maybe SrcSpan -> String -> String
+spliceURL maybe_file maybe_mod maybe_name maybe_loc url = run url
+ where
+  file = fromMaybe "" maybe_file
+  mdl = case maybe_mod of
+          Nothing           -> ""
+          Just m -> moduleString m
+
+  (name, kind) =
+    case maybe_name of
+      Nothing             -> ("","")
+      Just n | isValOcc (nameOccName n) -> (escapeStr (getOccString n), "v")
+             | otherwise -> (escapeStr (getOccString n), "t")
+
+  line = case maybe_loc of
+    Nothing -> ""
+    Just span_ ->
+      case span_ of
+      RealSrcSpan span__ ->
+        show $ srcSpanStartLine span__
+      UnhelpfulSpan _ ->
+        error "spliceURL UnhelpfulSpan"
+
+  run "" = ""
+  run ('%':'M':rest) = mdl  ++ run rest
+  run ('%':'F':rest) = file ++ run rest
+  run ('%':'N':rest) = name ++ run rest
+  run ('%':'K':rest) = kind ++ run rest
+  run ('%':'L':rest) = line ++ run rest
+  run ('%':'%':rest) = "%"  ++ run rest
+
+  run ('%':'{':'M':'O':'D':'U':'L':'E':'}':rest) = mdl  ++ run rest
+  run ('%':'{':'F':'I':'L':'E':'}':rest)         = file ++ run rest
+  run ('%':'{':'N':'A':'M':'E':'}':rest)         = name ++ run rest
+  run ('%':'{':'K':'I':'N':'D':'}':rest)         = kind ++ run rest
+
+  run ('%':'{':'M':'O':'D':'U':'L':'E':'/':'.':'/':c:'}':rest) =
+    map (\x -> if x == '.' then c else x) mdl ++ run rest
+
+  run ('%':'{':'F':'I':'L':'E':'/':'/':'/':c:'}':rest) =
+    map (\x -> if x == '/' then c else x) file ++ run rest
+
+  run ('%':'{':'L':'I':'N':'E':'}':rest)         = line ++ run rest
+
+  run (c:rest) = c : run rest
+
+
+renderToString :: Bool -> Html -> String
+renderToString debug html
+  | debug = renderHtml html
+  | otherwise = showHtml html
+
+
+hsep :: [Html] -> Html
+hsep [] = noHtml
+hsep htmls = foldr1 (\a b -> a+++" "+++b) htmls
+
+
+infixr 8 <+>
+(<+>) :: Html -> Html -> Html
+a <+> b = a +++ toHtml " " +++ b
+
+
+keyword :: String -> Html
+keyword s = thespan ! [theclass "keyword"] << toHtml s
+
+
+equals, comma :: Html
+equals = char '='
+comma  = char ','
+
+
+char :: Char -> Html
+char c = toHtml [c]
+
+
+-- | Make an element that always has at least something (a non-breaking space)
+-- If it would have otherwise been empty, then give it the class ".empty"
+nonEmpty :: (Html -> Html) -> Html -> Html
+nonEmpty el content_ =
+  if isNoHtml content_
+    then el ! [theclass "empty"] << spaceHtml
+    else el << content_
+
+
+quote :: Html -> Html
+quote h = char '`' +++ h +++ '`'
+
+
+parens, brackets, pabrackets, braces :: Html -> Html
+parens h        = char '(' +++ h +++ char ')'
+brackets h      = char '[' +++ h +++ char ']'
+pabrackets h    = toHtml "[:" +++ h +++ toHtml ":]"
+braces h        = char '{' +++ h +++ char '}'
+
+
+punctuate :: Html -> [Html] -> [Html]
+punctuate _ []     = []
+punctuate h (d0:ds) = go d0 ds
+                   where
+                     go d [] = [d]
+                     go d (e:es) = (d +++ h) : go e es
+
+
+parenList :: [Html] -> Html
+parenList = parens . hsep . punctuate comma
+
+
+ubxParenList :: [Html] -> Html
+ubxParenList = ubxparens . hsep . punctuate comma
+
+
+ubxparens :: Html -> Html
+ubxparens h = toHtml "(#" +++ h +++ toHtml "#)"
+
+
+dcolon, arrow, darrow, forallSymbol :: Bool -> Html
+dcolon unicode = toHtml (if unicode then "∷" else "::")
+arrow  unicode = toHtml (if unicode then "→" else "->")
+darrow unicode = toHtml (if unicode then "⇒" else "=>")
+forallSymbol unicode = if unicode then toHtml "∀" else keyword "forall"
+
+
+dot :: Html
+dot = toHtml "."
+
+
+-- | Generate a named anchor
+namedAnchor :: String -> Html -> Html
+namedAnchor n = anchor ! [XHtml.name n]
+
+
+linkedAnchor :: String -> Html -> Html
+linkedAnchor n = anchor ! [href ('#':n)]
+
+
+-- | generate an anchor identifier for a group
+groupId :: String -> String
+groupId g = makeAnchorId ("g:" ++ g)
+
+--
+-- A section of HTML which is collapsible.
+--
+
+-- | Attributes for an area that can be collapsed
+collapseSection :: String -> Bool -> String -> [HtmlAttr]
+collapseSection id_ state classes = [ identifier sid, theclass cs ]
+  where cs = unwords (words classes ++ [pick state "show" "hide"])
+        sid = "section." ++ id_
+
+-- | Attributes for an area that toggles a collapsed area
+collapseToggle :: String -> [HtmlAttr]
+collapseToggle id_ = [ strAttr "onclick" js ]
+  where js = "toggleSection('" ++ id_ ++ "')";
+  
+-- | Attributes for an area that toggles a collapsed area,
+-- and displays a control.
+collapseControl :: String -> Bool -> String -> [HtmlAttr]
+collapseControl id_ state classes =
+  [ identifier cid, theclass cs ] ++ collapseToggle id_
+  where cs = unwords (words classes ++ [pick state "collapser" "expander"])
+        cid = "control." ++ id_
+
+
+pick :: Bool -> a -> a -> a
+pick True  t _ = t
+pick False _ f = f

src/Haddock/Convert.hs

+{-# LANGUAGE PatternGuards #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Haddock.Convert
+-- Copyright   :  (c) Isaac Dupree 2009,
+-- License     :  BSD-like
+--
+-- Maintainer  :  haddock@projects.haskell.org
+-- Stability   :  experimental
+-- Portability :  portable
+--
+-- Conversion between TyThing and HsDecl. This functionality may be moved into
+-- GHC at some point.
+-----------------------------------------------------------------------------
+module Haddock.Convert where
+-- Some other functions turned out to be useful for converting
+-- instance heads, which aren't TyThings, so just export everything.
+
+
+import HsSyn
+import TcType ( tcSplitTyConApp_maybe, tcSplitSigmaTy )
+import TypeRep
+import Type(isStrLitTy)
+import Kind ( splitKindFunTys, synTyConResKind )
+import Name
+import Var
+import Class
+import TyCon
+import DataCon
+import BasicTypes ( TupleSort(..) )
+import TysPrim ( alphaTyVars )
+import TysWiredIn ( listTyConName, eqTyCon )
+import PrelNames (ipClassName)
+import Bag ( emptyBag )
+import SrcLoc ( Located, noLoc, unLoc )
+import Data.List( partition )
+
+
+-- the main function here! yay!
+tyThingToLHsDecl :: TyThing -> LHsDecl Name
+tyThingToLHsDecl t = noLoc $ case t of
+  -- ids (functions and zero-argument a.k.a. CAFs) get a type signature.
+  -- Including built-in functions like seq.
+  -- foreign-imported functions could be represented with ForD
+  -- instead of SigD if we wanted...
+  --
+  -- in a future code version we could turn idVarDetails = foreign-call
+  -- into a ForD instead of a SigD if we wanted.  Haddock doesn't
+  -- need to care.
+  AnId i -> SigD (synifyIdSig ImplicitizeForAll i)
+
+  -- type-constructors (e.g. Maybe) are complicated, put the definition
+  -- later in the file (also it's used for class associated-types too.)
+  ATyCon tc
+    | Just cl <- tyConClass_maybe tc -- classes are just a little tedious
+    -> TyClD $ ClassDecl
+         { tcdCtxt = synifyCtx (classSCTheta cl)
+         , tcdLName = synifyName cl
+         , tcdTyVars = synifyTyVars (classTyVars cl)
+         , tcdFDs = map (\ (l,r) -> noLoc
+                        (map getName l, map getName r) ) $
+                         snd $ classTvsFds cl
+         , tcdSigs = map (noLoc . synifyIdSig DeleteTopLevelQuantification)
+                         (classMethods cl)
+         , tcdMeths = emptyBag --ignore default method definitions, they don't affect signature
+         -- class associated-types are a subset of TyCon:
+         , tcdATs = [noLoc (synifyTyCon at_tc) | (at_tc, _) <- classATItems cl]
+         , tcdATDefs = [] --ignore associated type defaults
+         , tcdDocs = [] --we don't have any docs at this point
+         , tcdFVs = placeHolderNames }
+    | otherwise
+    -> TyClD (synifyTyCon tc)
+
+  -- type-constructors (e.g. Maybe) are complicated, put the definition
+  -- later in the file (also it's used for class associated-types too.)
+  ACoAxiom ax -> InstD (FamInstD { lid_inst = synifyAxiom ax })
+
+  -- a data-constructor alone just gets rendered as a function:
+  ADataCon dc -> SigD (TypeSig [synifyName dc]
+    (synifyType ImplicitizeForAll (dataConUserType dc)))
+
+synifyATDefault :: TyCon -> LFamInstDecl Name
+synifyATDefault tc = noLoc (synifyAxiom ax)
+  where Just ax = tyConFamilyCoercion_maybe tc
+
+synifyAxiom :: CoAxiom -> FamInstDecl Name
+synifyAxiom (CoAxiom { co_ax_tvs = tvs, co_ax_lhs = lhs, co_ax_rhs = rhs })
+  | Just (tc, args) <- tcSplitTyConApp_maybe lhs
+  = let name      = synifyName tc
+        typats    = map (synifyType WithinType) args
+        hs_rhs_ty = synifyType WithinType rhs
+    in FamInstDecl { fid_tycon = name 
+                   , fid_pats = HsWB { hswb_cts = typats, hswb_kvs = [], hswb_tvs = map tyVarName tvs }
+                   , fid_defn = TySynonym hs_rhs_ty, fid_fvs = placeHolderNames }
+  | otherwise
+  = error "synifyAxiom" 
+
+synifyTyCon :: TyCon -> TyClDecl Name
+synifyTyCon tc
+  | isFunTyCon tc || isPrimTyCon tc 
+  = TyDecl { tcdLName = synifyName tc
+           , tcdTyVars =       -- tyConTyVars doesn't work on fun/prim, but we can make them up:
+                         let mk_hs_tv realKind fakeTyVar 
+                                = noLoc $ KindedTyVar (getName fakeTyVar) 
+                                                      (synifyKindSig realKind)
+                         in HsQTvs { hsq_kvs = []   -- No kind polymorhism
+                                   , hsq_tvs = zipWith mk_hs_tv (fst (splitKindFunTys (tyConKind tc)))
+                                                                alphaTyVars --a, b, c... which are unfortunately all kind *
+                                   }
+                            
+           , tcdTyDefn = TyData { td_ND = DataType  -- arbitrary lie, they are neither 
+                                                    -- algebraic data nor newtype:
+                                , td_ctxt = noLoc []
+                                , td_cType = Nothing
+                                , td_kindSig = Just (synifyKindSig (tyConKind tc))
+                                               -- we have their kind accurately:
+                                , td_cons = []  -- No constructors
+                                , td_derivs = Nothing }
+           , tcdFVs = placeHolderNames }
+  | isSynFamilyTyCon tc 
+  = case synTyConRhs tc of
+        SynFamilyTyCon ->
+          TyFamily TypeFamily (synifyName tc) (synifyTyVars (tyConTyVars tc))
+               (Just (synifyKindSig (synTyConResKind tc)))
+        _ -> error "synifyTyCon: impossible open type synonym?"
+  | isDataFamilyTyCon tc 
+  = --(why no "isOpenAlgTyCon"?)
+    case algTyConRhs tc of
+        DataFamilyTyCon ->
+          TyFamily DataFamily (synifyName tc) (synifyTyVars (tyConTyVars tc))
+               Nothing --always kind '*'
+               -- placeHolderKind
+        _ -> error "synifyTyCon: impossible open data type?"
+  | otherwise =
+  -- (closed) type, newtype, and data
+  let
+  -- alg_ only applies to newtype/data
+  -- syn_ only applies to type
+  -- others apply to both
+  alg_nd = if isNewTyCon tc then NewType else DataType
+  alg_ctx = synifyCtx (tyConStupidTheta tc)
+  name = synifyName tc
+  tyvars = synifyTyVars (tyConTyVars tc)
+  alg_kindSig = Just (tyConKind tc)
+  -- The data constructors.
+  --
+  -- Any data-constructors not exported from the module that *defines* the
+  -- type will not (cannot) be included.
+  --
+  -- Very simple constructors, Haskell98 with no existentials or anything,
+  -- probably look nicer in non-GADT syntax.  In source code, all constructors
+  -- must be declared with the same (GADT vs. not) syntax, and it probably
+  -- is less confusing to follow that principle for the documentation as well.
+  --
+  -- There is no sensible infix-representation for GADT-syntax constructor
+  -- declarations.  They cannot be made in source code, but we could end up
+  -- with some here in the case where some constructors use existentials.
+  -- That seems like an acceptable compromise (they'll just be documented
+  -- in prefix position), since, otherwise, the logic (at best) gets much more
+  -- complicated. (would use dataConIsInfix.)
+  alg_use_gadt_syntax = any (not . isVanillaDataCon) (tyConDataCons tc)
+  alg_cons = map (synifyDataCon alg_use_gadt_syntax) (tyConDataCons tc)
+  -- "deriving" doesn't affect the signature, no need to specify any.
+  alg_deriv = Nothing
+  syn_type = synifyType WithinType (synTyConType tc)
+  defn | isSynTyCon tc = TySynonym syn_type
+       | otherwise = TyData { td_ND = alg_nd, td_ctxt = alg_ctx
+                            , td_cType = Nothing
+                            , td_kindSig = fmap synifyKindSig alg_kindSig
+                            , td_cons    = alg_cons 
+                            , td_derivs  = alg_deriv }
+ in TyDecl { tcdLName = name, tcdTyVars = tyvars, tcdTyDefn = defn
+           , tcdFVs = placeHolderNames }
+
+-- User beware: it is your responsibility to pass True (use_gadt_syntax)
+-- for any constructor that would be misrepresented by omitting its
+-- result-type.
+-- But you might want pass False in simple enough cases,
+-- if you think it looks better.
+synifyDataCon :: Bool -> DataCon -> LConDecl Name
+synifyDataCon use_gadt_syntax dc = noLoc $
+ let
+  -- dataConIsInfix allegedly tells us whether it was declared with
+  -- infix *syntax*.
+  use_infix_syntax = dataConIsInfix dc
+  use_named_field_syntax = not (null field_tys)
+  name = synifyName dc
+  -- con_qvars means a different thing depending on gadt-syntax
+  (univ_tvs, ex_tvs, _eq_spec, theta, arg_tys, res_ty) = dataConFullSig dc
+
+  qvars = if use_gadt_syntax
+          then synifyTyVars (univ_tvs ++ ex_tvs)
+          else synifyTyVars ex_tvs
+
+  -- skip any EqTheta, use 'orig'inal syntax
+  ctx = synifyCtx theta
+
+  linear_tys = zipWith (\ty bang ->
+            let tySyn = synifyType WithinType ty
+            in case bang of
+                 HsUnpackFailed -> noLoc $ HsBangTy HsStrict tySyn
+                 HsNoBang       -> tySyn
+                      -- HsNoBang never appears, it's implied instead.
+                 _              -> noLoc $ HsBangTy bang tySyn
+          )
+          arg_tys (dataConStrictMarks dc)
+  field_tys = zipWith (\field synTy -> ConDeclField
+                                           (synifyName field) synTy Nothing)
+                (dataConFieldLabels dc) linear_tys
+  hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of
+          (True,True) -> error "synifyDataCon: contradiction!"
+          (True,False) -> RecCon field_tys
+          (False,False) -> PrefixCon linear_tys
+          (False,True) -> case linear_tys of
+                           [a,b] -> InfixCon a b
+                           _ -> error "synifyDataCon: infix with non-2 args?"
+  hs_res_ty = if use_gadt_syntax
+              then ResTyGADT (synifyType WithinType res_ty)
+              else ResTyH98
+ -- finally we get synifyDataCon's result!
+ in ConDecl name Implicit{-we don't know nor care-}
+      qvars ctx hs_arg_tys hs_res_ty Nothing
+      False --we don't want any "deprecated GADT syntax" warnings!
+
+
+synifyName :: NamedThing n => n -> Located Name
+synifyName = noLoc . getName
+
+
+synifyIdSig :: SynifyTypeState -> Id -> Sig Name
+synifyIdSig s i = TypeSig [synifyName i] (synifyType s (varType i))
+
+
+synifyCtx :: [PredType] -> LHsContext Name
+synifyCtx = noLoc . map (synifyType WithinType)
+
+
+synifyTyVars :: [TyVar] -> LHsTyVarBndrs Name
+synifyTyVars ktvs = HsQTvs { hsq_kvs = map tyVarName kvs
+                           , hsq_tvs = map synifyTyVar tvs }
+  where
+    (kvs, tvs) = partition isKindVar ktvs
+    synifyTyVar tv 
+      | isLiftedTypeKind kind = noLoc (UserTyVar name)
+      | otherwise             = noLoc (KindedTyVar name (synifyKindSig kind))
+      where
+        kind = tyVarKind tv
+        name = getName tv
+
+--states of what to do with foralls:
+data SynifyTypeState
+  = WithinType
+  -- ^ normal situation.  This is the safe one to use if you don't
+  -- quite understand what's going on.
+  | ImplicitizeForAll
+  -- ^ beginning of a function definition, in which, to make it look
+  --   less ugly, those rank-1 foralls are made implicit.
+  | DeleteTopLevelQuantification
+  -- ^ because in class methods the context is added to the type
+  --   (e.g. adding @forall a. Num a =>@ to @(+) :: a -> a -> a@)
+  --   which is rather sensible,
+  --   but we want to restore things to the source-syntax situation where
+  --   the defining class gets to quantify all its functions for free!
+
+
+synifyType :: SynifyTypeState -> Type -> LHsType Name
+synifyType _ (TyVarTy tv) = noLoc $ HsTyVar (getName tv)
+synifyType _ (TyConApp tc tys)
+  -- Use non-prefix tuple syntax where possible, because it looks nicer.
+  | isTupleTyCon tc, tyConArity tc == length tys =
+     noLoc $ HsTupleTy (case tupleTyConSort tc of
+                          BoxedTuple      -> HsBoxedTuple
+                          ConstraintTuple -> HsConstraintTuple
+                          UnboxedTuple    -> HsUnboxedTuple)
+                       (map (synifyType WithinType) tys)
+  -- ditto for lists
+  | getName tc == listTyConName, [ty] <- tys =
+     noLoc $ HsListTy (synifyType WithinType ty)
+  -- ditto for implicit parameter tycons
+  | tyConName tc == ipClassName
+  , [name, ty] <- tys
+  , Just x <- isStrLitTy name
+  = noLoc $ HsIParamTy (HsIPName x) (synifyType WithinType ty)
+  -- and equalities
+  | tc == eqTyCon
+  , [ty1, ty2] <- tys
+  = noLoc $ HsEqTy (synifyType WithinType ty1) (synifyType WithinType ty2)
+  -- Most TyCons:
+  | otherwise =
+    foldl (\t1 t2 -> noLoc (HsAppTy t1 t2))
+      (noLoc $ HsTyVar (getName tc))
+      (map (synifyType WithinType) tys)
+synifyType _ (AppTy t1 t2) = let
+  s1 = synifyType WithinType t1
+  s2 = synifyType WithinType t2
+  in noLoc $ HsAppTy s1 s2
+synifyType _ (FunTy t1 t2) = let
+  s1 = synifyType WithinType t1
+  s2 = synifyType WithinType t2
+  in noLoc $ HsFunTy s1 s2
+synifyType s forallty@(ForAllTy _tv _ty) =
+  let (tvs, ctx, tau) = tcSplitSigmaTy forallty
+  in case s of
+    DeleteTopLevelQuantification -> synifyType ImplicitizeForAll tau
+    _ -> let
+      forallPlicitness = case s of
+              WithinType -> Explicit
+              ImplicitizeForAll -> Implicit
+              _ -> error "synifyType: impossible case!!!"
+      sTvs = synifyTyVars tvs
+      sCtx = synifyCtx ctx
+      sTau = synifyType WithinType tau
+     in noLoc $
+           HsForAllTy forallPlicitness sTvs sCtx sTau
+synifyType _ (LitTy t) = noLoc $ HsTyLit $ synifyTyLit t
+
+synifyTyLit :: TyLit -> HsTyLit
+synifyTyLit (NumTyLit n) = HsNumTy n
+synifyTyLit (StrTyLit s) = HsStrTy s
+
+synifyKindSig :: Kind -> LHsKind Name
+synifyKindSig k = synifyType (error "synifyKind") k
+
+synifyInstHead :: ([TyVar], [PredType], Class, [Type]) ->
+                  ([HsType Name], Name, [HsType Name])
+synifyInstHead (_, preds, cls, ts) =
+  ( map (unLoc . synifyType WithinType) preds
+  , getName cls
+  , map (unLoc . synifyType WithinType) ts
+  )

src/Haddock/DevHelp.hs

-module Haddock.DevHelp(ppDevHelpFile) where
-
-import Haddock.ModuleTree
-import Haddock.Types
-import Haddock.Utils
-
-import Module        ( moduleName, moduleNameString, Module, mkModule, mkModuleName )
-import PackageConfig ( stringToPackageId )
-import Name          ( Name, nameModule, getOccString )
-
-import Data.Maybe    ( fromMaybe )
-import qualified Data.Map as Map
-import Text.PrettyPrint
-
-ppDevHelpFile :: FilePath -> String -> Maybe String -> [HaddockModule] -> IO ()
-ppDevHelpFile odir doctitle maybe_package modules = do
-  let devHelpFile = package++".devhelp"
-      tree = mkModuleTree True [ (hmod_mod mod, toDescription mod) | mod <- modules ]
-      doc =
-        text "<?xml version=\"1.0\" encoding=\"utf-8\" standalone=\"no\"?>" $$
-        (text "<book xmlns=\"http://www.devhelp.net/book\" title=\""<>text doctitle<>
-            text "\" link=\""<>text contentsHtmlFile<>text"\" author=\"\" name=\""<>text package<>text "\">") $$
-        text "<chapters>" $$
-        nest 4 (ppModuleTree [] tree) $+$
-        text "</chapters>" $$
-        text "<functions>" $$
-        nest 4 (ppList index) $+$
-        text "</functions>" $$
-        text "</book>"
-  writeFile (pathJoin [odir, devHelpFile]) (render doc)
-  where    
-    package = fromMaybe "pkg" maybe_package
-
-    ppModuleTree :: [String] -> [ModuleTree] -> Doc
-    ppModuleTree ss [x]    = ppNode ss x
-    ppModuleTree ss (x:xs) = ppNode ss x $$ ppModuleTree ss xs
-    ppModuleTree _  []     = error "HaddockHH.ppHHContents.fn: no module trees given"
-
-    ppNode :: [String] -> ModuleTree -> Doc
-    ppNode ss (Node s leaf _ _short ts) =
-        case ts of
-          [] -> text "<sub"<+>ppAttribs<>text "/>"
-          ts -> 
-            text "<sub"<+>ppAttribs<>text ">" $$
-            nest 4 (ppModuleTree (s:ss) ts) $+$
-            text "</sub>"
-        where
-          ppLink | leaf      = text (moduleHtmlFile (mkModule (stringToPackageId "") 
-                                                              (mkModuleName mdl)))
-                 | otherwise = empty
-
-          ppAttribs = text "name="<>doubleQuotes (text s)<+>text "link="<>doubleQuotes ppLink
-
-          mdl = foldr (++) "" (s' : map ('.':) ss')
-          (s':ss') = reverse (s:ss)
-		-- reconstruct the module name
-
-    index :: [(Name, [Module])]
-    index = Map.toAscList (foldr getModuleIndex Map.empty modules)
-
-    getModuleIndex hmod fm =
-	Map.unionWith (++) (Map.fromListWith (flip (++)) [(name, [mod]) | name <- hmod_exports hmod, nameModule name == mod]) fm
-	where mod = hmod_mod hmod
-
-    ppList :: [(Name, [Module])] -> Doc
-    ppList [] = empty
-    ppList ((name,refs):mdls)  =
-      ppReference name refs $$
-      ppList mdls
-
-    ppReference :: Name -> [Module] -> Doc
-    ppReference name [] = empty
-    ppReference name (mod:refs) =  
-      text "<function name=\""<>text (escapeStr (getOccString name))<>text"\" link=\""<>text (nameHtmlRef mod name)<>text"\"/>" $$
-      ppReference name refs

src/Haddock/Doc.hs

+module Haddock.Doc (
+  docAppend,
+  docParagraph
+  ) where
+
+
+import Haddock.Types
+import Data.Char (isSpace)
+
+
+-- used to make parsing easier; we group the list items later
+docAppend :: Doc id -> Doc id -> Doc id
+docAppend (DocUnorderedList ds1) (DocUnorderedList ds2)
+  = DocUnorderedList (ds1++ds2)
+docAppend (DocUnorderedList ds1) (DocAppend (DocUnorderedList ds2) d)
+  = DocAppend (DocUnorderedList (ds1++ds2)) d
+docAppend (DocOrderedList ds1) (DocOrderedList ds2)
+  = DocOrderedList (ds1++ds2)
+docAppend (DocOrderedList ds1) (DocAppend (DocOrderedList ds2) d)
+  = DocAppend (DocOrderedList (ds1++ds2)) d
+docAppend (DocDefList ds1) (DocDefList ds2)
+  = DocDefList (ds1++ds2)
+docAppend (DocDefList ds1) (DocAppend (DocDefList ds2) d)
+  = DocAppend (DocDefList (ds1++ds2)) d
+docAppend DocEmpty d = d
+docAppend d DocEmpty = d
+docAppend d1 d2
+  = DocAppend d1 d2
+
+
+-- again to make parsing easier - we spot a paragraph whose only item
+-- is a DocMonospaced and make it into a DocCodeBlock
+docParagraph :: Doc id -> Doc id
+docParagraph (DocMonospaced p)
+  = DocCodeBlock (docCodeBlock p)
+docParagraph (DocAppend (DocString s1) (DocMonospaced p))
+  | all isSpace s1
+  = DocCodeBlock (docCodeBlock p)
+docParagraph (DocAppend (DocString s1)
+    (DocAppend (DocMonospaced p) (DocString s2)))
+  | all isSpace s1 && all isSpace s2
+  = DocCodeBlock (docCodeBlock p)
+docParagraph (DocAppend (DocMonospaced p) (DocString s2))
+  | all isSpace s2
+  = DocCodeBlock (docCodeBlock p)
+docParagraph p
+  = DocParagraph p
+
+
+-- Drop trailing whitespace from @..@ code blocks.  Otherwise this:
+--
+--    -- @
+--    -- foo
+--    -- @
+--
+-- turns into (DocCodeBlock "\nfoo\n ") which when rendered in HTML
+-- gives an extra vertical space after the code block.  The single space
+-- on the final line seems to trigger the extra vertical space.
+--
+docCodeBlock :: Doc id -> Doc id
+docCodeBlock (DocString s)
+  = DocString (reverse $ dropWhile (`elem` " \t") $ reverse s)
+docCodeBlock (DocAppend l r)
+  = DocAppend l (docCodeBlock r)
+docCodeBlock d = d

src/Haddock/Exception.hs

-module Haddock.Exception (
-  HaddockException,
-  throwE
-)where
-
-import Data.Typeable
-import Control.Exception
-
-data HaddockException = HaddockException String deriving Typeable
-throwE str = throwDyn (HaddockException str)
-
-instance Show HaddockException where
-  show (HaddockException str) = str
-  

src/Haddock/GhcUtils.hs

+{-# LANGUAGE FlexibleInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# OPTIONS_HADDOCK hide #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Haddock.GhcUtils
+-- Copyright   :  (c) David Waern 2006-2009
+-- License     :  BSD-like
+--
+-- Maintainer  :  haddock@projects.haskell.org
+-- Stability   :  experimental
+-- Portability :  portable
+--
+-- Utils for dealing with types from the GHC API
+-----------------------------------------------------------------------------
+module Haddock.GhcUtils where
+
+
+import Data.Version
+import Control.Applicative  ( (<$>) )
+import Control.Arrow
+import Data.Foldable hiding (concatMap)
+import Data.Function
+import Data.Traversable
+import Distribution.Compat.ReadP
+import Distribution.Text
+
+import Exception
+import Outputable
+import Name
+import Packages
+import Module
+import RdrName (GlobalRdrEnv)
+import GhcMonad (withSession)
+import HscTypes
+import UniqFM
+import GHC
+
+
+moduleString :: Module -> String
+moduleString = moduleNameString . moduleName
+
+
+-- return the (name,version) of the package
+modulePackageInfo :: Module -> (String, [Char])
+modulePackageInfo modu = case unpackPackageId pkg of
+                          Nothing -> (packageIdString pkg, "")
+                          Just x -> (display $ pkgName x, showVersion (pkgVersion x))
+  where pkg = modulePackageId modu
+
+
+-- This was removed from GHC 6.11
+-- XXX we shouldn't be using it, probably
+
+-- | Try and interpret a GHC 'PackageId' as a cabal 'PackageIdentifer'. Returns @Nothing@ if
+-- we could not parse it as such an object.
+unpackPackageId :: PackageId -> Maybe PackageIdentifier
+unpackPackageId p
+  = case [ pid | (pid,"") <- readP_to_S parse str ] of
+        []      -> Nothing
+        (pid:_) -> Just pid
+  where str = packageIdString p
+
+
+lookupLoadedHomeModuleGRE  :: GhcMonad m => ModuleName -> m (Maybe GlobalRdrEnv)
+lookupLoadedHomeModuleGRE mod_name = withSession $ \hsc_env ->
+  case lookupUFM (hsc_HPT hsc_env) mod_name of
+    Just mod_info      -> return (mi_globals (hm_iface mod_info))
+    _not_a_home_module -> return Nothing
+
+
+isNameSym :: Name -> Bool
+isNameSym = isSymOcc . nameOccName
+
+
+isVarSym :: OccName -> Bool
+isVarSym = isLexVarSym . occNameFS
+
+
+getMainDeclBinder :: HsDecl name -> [name]
+getMainDeclBinder (TyClD d) = [tcdName d]
+getMainDeclBinder (ValD d) =
+  case collectHsBindBinders d of
+    []       -> []
+    (name:_) -> [name]
+getMainDeclBinder (SigD d) = sigNameNoLoc d
+getMainDeclBinder (ForD (ForeignImport name _ _ _)) = [unLoc name]
+getMainDeclBinder (ForD (ForeignExport _ _ _ _)) = []
+getMainDeclBinder _ = []
+
+
+-- Useful when there is a signature with multiple names, e.g.
+--   foo, bar :: Types..
+-- but only one of the names is exported and we have to change the
+-- type signature to only include the exported names.
+filterLSigNames :: (name -> Bool) -> LSig name -> Maybe (LSig name)
+filterLSigNames p (L loc sig) = L loc <$> (filterSigNames p sig)
+
+filterSigNames :: (name -> Bool) -> Sig name -> Maybe (Sig name)
+filterSigNames p orig@(SpecSig n _ _)          = ifTrueJust (p $ unLoc n) orig
+filterSigNames p orig@(InlineSig n _)          = ifTrueJust (p $ unLoc n) orig
+filterSigNames p orig@(FixSig (FixitySig n _)) = ifTrueJust (p $ unLoc n) orig
+filterSigNames p (TypeSig ns ty)               =
+  case filter (p . unLoc) ns of
+    []       -> Nothing
+    filtered -> Just (TypeSig filtered ty)
+filterSigNames _ _                           = Nothing
+
+ifTrueJust :: Bool -> name -> Maybe name
+ifTrueJust True  = Just
+ifTrueJust False = const Nothing
+
+sigName :: LSig name -> [name]
+sigName (L _ sig) = sigNameNoLoc sig
+
+sigNameNoLoc :: Sig name -> [name]
+sigNameNoLoc (TypeSig   ns _)         = map unLoc ns
+sigNameNoLoc (SpecSig   n _ _)        = [unLoc n]
+sigNameNoLoc (InlineSig n _)          = [unLoc n]
+sigNameNoLoc (FixSig (FixitySig n _)) = [unLoc n]
+sigNameNoLoc _                        = []
+
+
+isTyClD :: HsDecl a -> Bool
+isTyClD (TyClD _) = True
+isTyClD _ = False
+
+
+isClassD :: HsDecl a -> Bool
+isClassD (TyClD d) = isClassDecl d
+isClassD _ = False
+
+
+isDocD :: HsDecl a -> Bool
+isDocD (DocD _) = True
+isDocD _ = False
+
+
+isInstD :: HsDecl a -> Bool
+isInstD (InstD _) = True
+isInstD _ = False
+
+
+isValD :: HsDecl a -> Bool
+isValD (ValD _) = True
+isValD _ = False
+
+
+declATs :: HsDecl a -> [a]
+declATs (TyClD d) | isClassDecl d = map (tcdName . unL) $ tcdATs d
+declATs _ = []
+
+
+pretty :: Outputable a => a -> String
+pretty x = showSDoc (ppr x)
+
+
+trace_ppr :: Outputable a => a -> b -> b
+trace_ppr x y = trace (pretty x) y
+
+
+-------------------------------------------------------------------------------
+-- * Located
+-------------------------------------------------------------------------------
+
+
+unL :: Located a -> a
+unL (L _ x) = x
+
+
+reL :: a -> Located a
+reL = L undefined
+
+
+before :: Located a -> Located a -> Bool
+before = (<) `on` getLoc
+
+
+instance Foldable (GenLocated l) where
+  foldMap f (L _ x) = f x
+
+
+instance Traversable (GenLocated l) where
+  mapM f (L l x) = (return . L l) =<< f x
+
+
+-------------------------------------------------------------------------------
+-- * NamedThing instances
+-------------------------------------------------------------------------------
+
+
+instance NamedThing (TyClDecl Name) where
+  getName = tcdName
+
+
+instance NamedThing (ConDecl Name) where
+  getName = unL . con_name
+
+
+-------------------------------------------------------------------------------
+-- * Subordinates
+-------------------------------------------------------------------------------
+
+
+class Parent a where
+  children :: a -> [Name]
+
+
+instance Parent (ConDecl Name) where
+  children con =
+    case con_details con of
+      RecCon fields -> map (unL . cd_fld_name) fields
+      _             -> []
+
+
+instance Parent (TyClDecl Name) where
+  children d
+    | isDataDecl  d = map (unL . con_name . unL) . td_cons . tcdTyDefn $ d
+    | isClassDecl d =
+        map (tcdName . unL) (tcdATs d) ++
+        [ unL n | L _ (TypeSig ns _) <- tcdSigs d, n <- ns ]
+    | otherwise = []
+
+
+-- | A parent and its children
+family :: (NamedThing a, Parent a) => a -> (Name, [Name])
+family = getName &&& children
+
+
+-- | A mapping from the parent (main-binder) to its children and from each
+-- child to its grand-children, recursively.
+families :: TyClDecl Name -> [(Name, [Name])]
+families d
+  | isDataDecl  d = family d : map (family . unL) (td_cons (tcdTyDefn d))
+  | isClassDecl d = family d : concatMap (families . unL) (tcdATs d)
+  | otherwise     = []
+
+
+-- | A mapping from child to parent
+parentMap :: TyClDecl Name -> [(Name, Name)]
+parentMap d = [ (c, p) | (p, cs) <- families d, c <- cs ]
+
+
+-- | The parents of a subordinate in a declaration
+parents :: Name -> HsDecl Name -> [Name]
+parents n (TyClD d) = [ p | (c, p) <- parentMap d, c == n ]
+parents _ _ = []
+
+
+-------------------------------------------------------------------------------
+-- * Utils that work in monads defined by GHC
+-------------------------------------------------------------------------------
+
+
+modifySessionDynFlags :: (DynFlags -> DynFlags) -> Ghc ()
+modifySessionDynFlags f = do
+  dflags <- getSessionDynFlags
+  _ <- setSessionDynFlags (f dflags)
+  return ()
+
+
+-- | A variant of 'gbracket' where the return value from the first computation
+-- is not required.
+gbracket_ :: ExceptionMonad m => m a -> m b -> m c -> m c
+gbracket_ before_ after thing = gbracket before_ (const after) (const thing)
+
+
+-------------------------------------------------------------------------------
+-- * DynFlags
+-------------------------------------------------------------------------------
+
+
+setObjectDir, setHiDir, setStubDir, setOutputDir :: String -> DynFlags -> DynFlags
+setObjectDir  f d = d{ objectDir  = Just f}
+setHiDir      f d = d{ hiDir      = Just f}
+setStubDir    f d = d{ stubDir    = Just f, includePaths = f : includePaths d }
+  -- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file
+  -- \#included from the .hc file when compiling with -fvia-C.
+setOutputDir  f = setObjectDir f . setHiDir f . setStubDir f
+

src/Haddock/HH.hs

-module Haddock.HH(ppHHContents, ppHHIndex, ppHHProject) where
-
-ppHHContents = error "not yet"
-ppHHIndex = error "not yet"
-ppHHProject = error "not yet"
-
-{-
-import HaddockModuleTree
-import HaddockTypes
-import HaddockUtil
-import HsSyn2 hiding(Doc)
-import qualified Map
-
-import Data.Char ( toUpper )
-import Data.Maybe ( fromMaybe )
-import Text.PrettyPrint
-
-ppHHContents :: FilePath -> String -> Maybe String -> [ModuleTree] -> IO ()
-ppHHContents odir doctitle maybe_package tree = do
-  let contentsHHFile = package++".hhc"
-
-      html =
-      	text "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">" $$
-	text "<HTML>" $$
-	text "<HEAD>" $$
-	text "<META name=\"GENERATOR\" content=\"Haddock\">" $$
-	text "<!-- Sitemap 1.0 -->" $$
-	text "</HEAD><BODY>" $$
-	ppModuleTree tree $$
-	text "</BODY><HTML>"
-  writeFile (pathJoin [odir, contentsHHFile]) (render html)
-  where
-	package = fromMaybe "pkg" maybe_package
-	
-	ppModuleTree :: [ModuleTree] -> Doc
-	ppModuleTree ts =
-		text "<OBJECT type=\"text/site properties\">" $$
-		text "<PARAM name=\"FrameName\" value=\"main\">" $$
-		text "</OBJECT>" $$
-		text "<UL>" $+$
-		nest 4 (text "<LI>" <> nest 4
-		                (text "<OBJECT type=\"text/sitemap\">" $$
-		                 nest 4 (text "<PARAM name=\"Name\" value=\""<>text doctitle<>text "\">" $$
-		                         text "<PARAM name=\"Local\" value=\"index.html\">") $$
-		                 text "</OBJECT>") $+$
-		        text "</LI>" $$
-		        text "<UL>" $+$
-		        nest 4 (fn [] ts) $+$
-		        text "</UL>") $+$
-		text "</UL>"
-
-	fn :: [String] -> [ModuleTree] -> Doc
-	fn ss [x]    = ppNode ss x
-	fn ss (x:xs) = ppNode ss x $$ fn ss xs
-        fn _  []     = error "HaddockHH.ppHHContents.fn: no module trees given"
-
-	ppNode :: [String] -> ModuleTree -> Doc
-	ppNode ss (Node s leaf _pkg _ []) =
-	  ppLeaf s ss leaf
-	ppNode ss (Node s leaf _pkg _ ts) =
-	  ppLeaf s ss leaf $$
-	  text "<UL>" $+$
-	  nest 4 (fn (s:ss) ts) $+$
-	  text "</UL>"
-
-	ppLeaf s ss isleaf  =
-		text "<LI>" <> nest 4
-			(text "<OBJECT type=\"text/sitemap\">" $$
-			 text "<PARAM name=\"Name\" value=\"" <> text s <> text "\">" $$
-			 (if isleaf then text "<PARAM name=\"Local\" value=\"" <> text (moduleHtmlFile mdl) <> text "\">" else empty) $$
-			 text "</OBJECT>") $+$
-		text "</LI>"
-		where 
-			mdl = foldr (++) "" (s' : map ('.':) ss')
-			(s':ss') = reverse (s:ss)
-			-- reconstruct the module name
-		
--------------------------------
-ppHHIndex :: FilePath -> Maybe String -> [Interface] -> IO ()
-ppHHIndex odir maybe_package ifaces = do
-  let indexHHFile = package++".hhk"
-  
-      html = 
-      	text "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">" $$
-	text "<HTML>" $$
-	text "<HEAD>" $$
-	text "<META name=\"GENERATOR\" content=\"Haddock\">" $$
-	text "<!-- Sitemap 1.0 -->" $$
-	text "</HEAD><BODY>" $$
-	text "<UL>" $+$
-	nest 4 (ppList index) $+$
-	text "</UL>" $$
-	text "</BODY><HTML>"
-  writeFile (pathJoin [odir, indexHHFile]) (render html)
-  where
-	package = fromMaybe "pkg" maybe_package
-  	
-	index :: [(HsName, [Module])]
-	index = Map.toAscList (foldr getIfaceIndex Map.empty ifaces)
-
-	getIfaceIndex iface fm =
-		foldl (\m (k,e) -> Map.insertWith (++) k e m) fm [(name, [mdl]) | (name, Qual mdl' _) <- Map.toAscList (iface_env iface), mdl == mdl']
-		where mdl = iface_module iface
-	
-	ppList [] = empty
-	ppList ((name,refs):mdls)  =
-		text "<LI>" <> nest 4
-				(text "<OBJECT type=\"text/sitemap\">" $$
-				 text "<PARAM name=\"Name\" value=\"" <> text (show name) <> text "\">" $$
-				 ppReference name refs $$
-				 text "</OBJECT>") $+$
-		text "</LI>" $$
-		ppList mdls
-
-	ppReference name [] = empty
-	ppReference name (Module mdl:refs) =
-		text "<PARAM name=\"Local\" value=\"" <> text (nameHtmlRef mdl name) <> text "\">" $$
-		ppReference name refs
-
-
-ppHHProject :: FilePath -> String -> Maybe String -> [Interface] -> [FilePath] -> IO ()
-ppHHProject odir doctitle maybe_package ifaces pkg_paths = do
-  let projectHHFile = package++".hhp"
-      doc =
-        text "[OPTIONS]" $$
-        text "Compatibility=1.1 or later" $$
-        text "Compiled file=" <> text package <> text ".chm" $$
-        text "Contents file=" <> text package <> text ".hhc" $$
-        text "Default topic=" <> text contentsHtmlFile $$
-        text "Display compile progress=No" $$
-        text "Index file=" <> text package <> text ".hhk" $$
-        text "Title=" <> text doctitle $$
-	space $$
-        text "[FILES]" $$
-        ppMods ifaces $$
-        text contentsHtmlFile $$
-        text indexHtmlFile $$
-        ppIndexFiles chars $$
-        ppLibFiles ("":pkg_paths)
-  writeFile (pathJoin [odir, projectHHFile]) (render doc)
-  where
-    package = fromMaybe "pkg" maybe_package
-	
-    ppMods [] = empty
-    ppMods (iface:ifaces) =
-	let Module mdl = iface_module iface in
-        text (moduleHtmlFile mdl) $$
-        ppMods ifaces
-		
-    ppIndexFiles []     = empty
-    ppIndexFiles (c:cs) =
-        text (subIndexHtmlFile c) $$
-        ppIndexFiles cs
-        
-    ppLibFiles []           = empty
-    ppLibFiles (path:paths) =
-        ppLibFile cssFile   $$
-    	ppLibFile iconFile  $$
-    	ppLibFile jsFile    $$
-    	ppLibFile plusFile  $$
-        ppLibFile minusFile $$
-        ppLibFiles paths
-        where
-            toPath fname | null path = fname
-	                 | otherwise = pathJoin [path, fname]
-            ppLibFile fname = text (toPath fname)
-
-    chars :: [Char]
-    chars = map fst (Map.toAscList (foldr getIfaceIndex Map.empty ifaces))
-
-    getIfaceIndex iface fm =
-        Map.union (Map.fromList [(toUpper (head (show name)),()) | (name, Qual mdl' _) <- Map.toAscList (iface_env iface), mdl == mdl']) fm
-	where mdl = iface_module iface
--}

src/Haddock/HH2.hs

-module Haddock.HH2(ppHH2Contents, ppHH2Index, ppHH2Files, ppHH2Collection) where
-
-ppHH2Contents = error "not yet"
-ppHH2Index = error "not yet"
-ppHH2Files = error "not yet"
-ppHH2Collection = error "not yet"
-
-{-
-import HaddockModuleTree
-import HaddockTypes
-import HaddockUtil
-import HsSyn2 hiding(Doc)
-import qualified Map
-
-import Data.Char ( toUpper )
-import Data.Maybe ( fromMaybe )
-import Text.PrettyPrint
-
-ppHH2Contents :: FilePath -> String -> Maybe String -> [ModuleTree] -> IO ()
-ppHH2Contents odir doctitle maybe_package tree = do
-  let 	
-	contentsHH2File = package++".HxT"
-
-	doc  =
-		text "<?xml version=\"1.0\"?>" $$
-		text "<!DOCTYPE HelpTOC SYSTEM \"ms-help://hx/resources/HelpTOC.DTD\">" $$
-		text "<HelpTOC DTDVersion=\"1.0\">" $$
-		nest 4 (text "<HelpTOCNode Title=\""<>text doctitle<>text"\" Url=\"index.html\">" $$
-		        nest 4 (ppModuleTree [] tree) $+$
-		        text "</HelpTOCNode>") $$
-		text "</HelpTOC>"
-  writeFile (pathJoin [odir, contentsHH2File]) (render doc)
-  where
-	package = fromMaybe "pkg" maybe_package
-	
-	ppModuleTree :: [String] -> [ModuleTree] -> Doc
-	ppModuleTree ss [x]    = ppNode ss x
-	ppModuleTree ss (x:xs) = ppNode ss x $$ ppModuleTree ss xs
-	ppModuleTree _  []     = error "HaddockHH2.ppHH2Contents.ppModuleTree: no module trees given"
-
-	ppNode :: [String] -> ModuleTree -> Doc
-	ppNode ss (Node s leaf _pkg _short []) =
-	  text "<HelpTOCNode"  <+> ppAttributes leaf (s:ss) <> text "/>"
-	ppNode ss (Node s leaf _pkg _short ts) =
-	  text "<HelpTOCNode" <+> ppAttributes leaf (s:ss) <> text ">" $$
-	  nest 4 (ppModuleTree (s:ss) ts) $+$
-	  text "</HelpTOCNode>"
-			
-	ppAttributes :: Bool -> [String] -> Doc
-	ppAttributes isleaf ss = hsep [ppId,ppTitle,ppUrl]
-	  where
-	    mdl = foldr (++) "" (s' : map ('.':) ss')
-	    (s':ss') = reverse ss
-	                -- reconstruct the module name
-	    
-	    ppId = text "Id=" <> doubleQuotes (text mdl)
-	    
-	    ppTitle = text "Title=" <> doubleQuotes (text (head ss))
-	    
-	    ppUrl | isleaf    = text " Url=" <> doubleQuotes (text (moduleHtmlFile mdl))
-	          | otherwise = empty
-
------------------------------------------------------------------------------------
-
-ppHH2Index :: FilePath -> Maybe String -> [Interface] -> IO ()
-ppHH2Index odir maybe_package ifaces = do
-  let 
-	indexKHH2File     = package++"K.HxK"
-	indexNHH2File     = package++"N.HxK"
-	docK = 
-		text "<?xml version=\"1.0\"?>" $$
-		text "<!DOCTYPE HelpIndex SYSTEM \"ms-help://hx/resources/HelpIndex.DTD\">" $$
-		text "<HelpIndex DTDVersion=\"1.0\" Name=\"K\">" $$
-		nest 4 (ppList index) $+$
-		text "</HelpIndex>"  
-	docN = 
-		text "<?xml version=\"1.0\"?>" $$
-		text "<!DOCTYPE HelpIndex SYSTEM \"ms-help://hx/resources/HelpIndex.DTD\">" $$
-		text "<HelpIndex DTDVersion=\"1.0\" Name=\"NamedURLIndex\">" $$
-		text "<Keyword Term=\"HomePage\">" $$
-		nest 4 (text "<Jump Url=\""<>text contentsHtmlFile<>text "\"/>") $$
-		text "</Keyword>" $$
-		text "</HelpIndex>"
-  writeFile (pathJoin [odir, indexKHH2File]) (render docK)
-  writeFile (pathJoin [odir, indexNHH2File]) (render docN)
-  where
-	package = fromMaybe "pkg" maybe_package
-    
-	index :: [(HsName, [Module])]
-	index = Map.toAscList (foldr getIfaceIndex Map.empty ifaces)
-
-	getIfaceIndex iface fm =
-	    Map.unionWith (++) (Map.fromListWith (flip (++)) [(name, [mdl]) | (name, Qual mdl' _) <- Map.toAscList (iface_env iface), mdl == mdl']) fm
-	    where mdl = iface_module iface
-	
-	ppList [] = empty
-	ppList ((name,mdls):vs)  =
-		text "<Keyword Term=\"" <> text (escapeStr (show name)) <> text "\">" $$
-		nest 4 (vcat (map (ppJump name) mdls)) $$
-		text "</Keyword>" $$
-		ppList vs
-
-	ppJump name (Module mdl) = text "<Jump Url=\"" <> text (nameHtmlRef mdl name) <> text "\"/>"
-
-
------------------------------------------------------------------------------------
-
-ppHH2Files :: FilePath -> Maybe String -> [Interface] -> [FilePath] -> IO ()
-ppHH2Files odir maybe_package ifaces pkg_paths = do
-  let filesHH2File = package++".HxF"
-      doc =
-        text "<?xml version=\"1.0\"?>" $$
-        text "<!DOCTYPE HelpFileList SYSTEM \"ms-help://hx/resources/HelpFileList.DTD\">" $$
-        text "<HelpFileList DTDVersion=\"1.0\">" $$
-        nest 4 (ppMods ifaces $$
-                text "<File Url=\""<>text contentsHtmlFile<>text "\"/>" $$
-                text "<File Url=\""<>text indexHtmlFile<>text "\"/>" $$
-                ppIndexFiles chars $$
-                ppLibFiles ("":pkg_paths)) $$
-        text "</HelpFileList>"
-  writeFile (pathJoin [odir, filesHH2File]) (render doc)
-  where
-    package = fromMaybe "pkg" maybe_package
-	
-    ppMods [] = empty
-    ppMods (iface:ifaces) =
-		text "<File Url=\"" <> text (moduleHtmlFile mdl) <> text "\"/>" $$
-		ppMods ifaces
-		where Module mdl = iface_module iface
-		
-    ppIndexFiles []     = empty
-    ppIndexFiles (c:cs) =
-        text "<File Url=\""<>text (subIndexHtmlFile c)<>text "\"/>" $$
-        ppIndexFiles cs
-        
-    ppLibFiles []           = empty
-    ppLibFiles (path:paths) =        
-        ppLibFile cssFile   $$
-	ppLibFile iconFile  $$
-	ppLibFile jsFile    $$
-	ppLibFile plusFile  $$
-        ppLibFile minusFile $$
-        ppLibFiles paths
-        where
-            toPath fname | null path = fname
-                         | otherwise = pathJoin [path, fname]
-            ppLibFile fname = text "<File Url=\""<>text (toPath fname)<>text "\"/>"
-
-    chars :: [Char]
-    chars = map fst (Map.toAscList (foldr getIfaceIndex Map.empty ifaces))
-
-    getIfaceIndex iface fm =
-        Map.union (Map.fromList [(toUpper (head (show name)),()) | (name, Qual mdl' _) <- Map.toAscList (iface_env iface), mdl == mdl']) fm
-	where mdl = iface_module iface
-
------------------------------------------------------------------------------------
-
-ppHH2Collection :: FilePath -> String -> Maybe String -> IO ()
-ppHH2Collection odir doctitle maybe_package = do
-  let 
-	package = fromMaybe "pkg" maybe_package
-	collectionHH2File = package++".HxC"
-	
-	doc =
-		text "<?xml version=\"1.0\"?>" $$
-		text "<!DOCTYPE HelpCollection SYSTEM \"ms-help://hx/resources/HelpCollection.DTD\">" $$
-		text "<HelpCollection DTDVersion=\"1.0\" LangId=\"1033\" Title=\"" <> text doctitle <> text "\">" $$
-		nest 4 (text "<CompilerOptions CreateFullTextIndex=\"Yes\">" $$
-		        nest 4 (text "<IncludeFile File=\"" <> text package <> text ".HxF\"/>") $$
-		        text "</CompilerOptions>" $$
-		        text "<TOCDef File=\"" <> text package <> text ".HxT\"/>" $$
-		        text "<KeywordIndexDef File=\"" <> text package <> text "K.HxK\"/>" $$
-		        text "<KeywordIndexDef File=\"" <> text package <> text "N.HxK\"/>" $$
-		        text "<ItemMoniker Name=\"!DefaultToc\" ProgId=\"HxDs.HxHierarchy\" InitData=\"\"/>" $$
-		        text "<ItemMoniker Name=\"!DefaultFullTextSearch\" ProgId=\"HxDs.HxFullTextSearch\" InitData=\"\"/>" $$
-		        text "<ItemMoniker Name=\"!DefaultAssociativeIndex\" ProgId=\"HxDs.HxIndex\" InitData=\"A\"/>" $$
-		        text "<ItemMoniker Name=\"!DefaultKeywordIndex\" ProgId=\"HxDs.HxIndex\" InitData=\"K\"/>" $$
-		        text "<ItemMoniker Name=\"!DefaultNamedUrlIndex\" ProgId=\"HxDs.HxIndex\" InitData=\"NamedURLIndex\"/>" $$
-		        text "<ItemMoniker Name=\"!SampleInfo\" ProgId=\"HxDs.HxSampleCollection\" InitData=\"\"/>") $$
-		text "</HelpCollection>"
-  writeFile (pathJoin [odir, collectionHH2File]) (render doc)
--}

src/Haddock/Hoogle.hs

---
--- Haddock - A Haskell Documentation Tool
---
--- (c) Simon Marlow 2003
---
--- This file, (c) Neil Mitchell 2006
--- Write out Hoogle compatible documentation
--- http://www.haskell.org/hoogle/
-
-module Haddock.Hoogle ( 
-	ppHoogle
-  ) where
-
-ppHoogle = undefined
-
-{-
-import HaddockTypes
-import HaddockUtil
-import HsSyn2
-
-import Data.List ( intersperse )
-
-
-
-prefix = ["-- Hoogle documentation, generated by Haddock",
-          "-- See Hoogle, http://www.haskell.org/hoogle/"]
-
-ppHoogle :: Maybe String -> [Interface] -> FilePath -> IO ()
-ppHoogle maybe_package ifaces odir =
-    do
-        let
-            filename = case maybe_package of
-                        Just x -> x ++ ".txt"
-                        Nothing -> "hoogle.txt"
-
-            visible_ifaces = filter visible ifaces
-            visible i = OptHide `notElem` iface_options i
-
-            contents = prefix : map ppModule visible_ifaces
-
-        writeFile (pathJoin [odir, filename]) (unlines $ concat contents)
- 
-
-
--- ---------------------------------------------------------------------------
--- Generate the HTML page for a module
-
-
-ppDecl :: HsDecl -> [String]
-ppDecl (HsNewTypeDecl src context name args ctor unknown docs) =
-    ppData "newtype" context name args [ctor]
-
-ppDecl (HsDataDecl src context name args ctors unknown docs) =
-    ppData "data" context name args ctors
-
-ppDecl (HsTypeSig src names t doc) = map (`ppFunc` t) names
-
-ppDecl (HsForeignImport src _ _ _ name t doc) = ppDecl $ HsTypeSig src [name] t doc
-
-ppDecl (HsClassDecl src context name args fundeps members doc) =
-    ("class " ++ ppContext context ++ ppType typ) : concatMap f members
-    where
-        typ = foldl HsTyApp (HsTyCon $ UnQual name) (map HsTyVar args)
-        newcontext = (UnQual name, map HsTyVar args)
-        f (HsTypeSig src names t doc) = ppDecl (HsTypeSig src names (addContext newcontext t) doc)
-        f (HsFunBind{}) = []
-        f (HsPatBind{}) = []
-        f x = ["-- ERR " ++ show x]
-
-ppDecl (HsTypeDecl src name args t doc) =
-    ["type " ++ show name ++ concatMap (\x -> ' ':show x) args ++ " = " ++ ppType t]
-
-ppDecl x = ["-- ERR " ++ show x]
-
-
-
-addContext :: HsAsst -> HsType -> HsType
-addContext ctx (HsForAllType Nothing context t) = HsForAllType Nothing (HsAssump ctx : context) t
-addContext ctx x = HsForAllType Nothing [HsAssump ctx] x
-
-
-
-ppFunc :: HsName -> HsType -> String
-ppFunc name typ = show name ++ " :: " ++ ppType typ
-
-
-ppData :: String -> HsContext -> HsName -> [HsName] -> [HsConDecl] -> [String]
-ppData mode context name args ctors = (mode ++ " " ++ ppType typ) : concatMap (ppCtor typ) ctors
-    where
-        typ = foldl HsTyApp (HsTyCon $ UnQual name) (map HsTyVar args)
-        
-        
-deBang :: HsBangType -> HsType
-deBang (HsBangedTy   x) = x
-deBang (HsUnBangedTy x) = x
-
-
-ppCtor :: HsType -> HsConDecl -> [String]
-ppCtor result (HsConDecl src name types context typ doc) =
-    [show name ++ " :: " ++ ppContext context ++ ppTypesArr (map deBang typ ++ [result])]
-
-ppCtor result (HsRecDecl src name types context fields doc) =
-        ppCtor result (HsConDecl src name types context (map snd fields2) doc) ++
-        concatMap f fields2
-    where
-        fields2 = [(name, typ) | HsFieldDecl names typ _ <- fields, name <- names]
-        f (name, typ) = ppDecl $ HsTypeSig src [name] (HsTyFun result (deBang typ)) doc
-
-
-brack True  x = "(" ++ x ++ ")"
-brack False x = x
-
-ppContext :: HsContext -> String
-ppContext [] = ""
-ppContext xs = brack (length xs > 1) (concat $ intersperse ", " $ map ppContextItem xs) ++ " => "
-
-ppContextItem :: HsAsst -> String
-ppContextItem (name, types) = ppQName name ++ concatMap (\x -> ' ':ppType x) types
-
-ppContext2 :: HsIPContext -> String
-ppContext2 xs = ppContext [x | HsAssump x <- xs]
-
-
-ppType :: HsType -> String
-ppType x = f 0 x
-    where
-        f _ (HsTyTuple _ xs) = brack True $ concat $ intersperse ", " $ map (f 0) xs
-        f _ (HsTyCon x) = ppQName x
-        f _ (HsTyVar x) = show x
-
-        -- ignore ForAll types as Hoogle does not support them
-        f n (HsForAllType (Just items) context t) =
-            -- brack (n > 1) $
-            -- "forall" ++ concatMap (\x -> ' ':toStr x) items ++ " . " ++ f 0 t
-            f n t
-
-        f n (HsForAllType Nothing context t) = brack (n > 1) $
-            ppContext2 context ++ f 0 t
-
-        f n (HsTyFun a b) = brack g $ f (h 3) a ++ " -> " ++ f (h 2) b
-            where
-                g = n > 2
-                h x = if g then 0 else x
-        
-        f n (HsTyApp a b) | ppType a == "[]" = "[" ++ f 0 b ++ "]"
-        
-        f n (HsTyApp a b) = brack g $ f (h 3) a ++ " " ++ f (h 4) b
-            where
-                g = n > 3
-                h x = if g then 0 else x
-        
-        f n (HsTyDoc x _) = f n x
-
-        f n x = brack True $ show x
-
-
-ppQName :: HsQName -> String
-ppQName (Qual _ name) = show name
-ppQName (UnQual name) = show name
-
-
-
-ppTypesArr :: [HsType] -> String
-ppTypesArr xs = ppType $ foldr1 HsTyFun xs
-
-
-
-ppInst :: InstHead -> String
-ppInst (context, item) = "instance " ++ ppContext context ++ ppContextItem item
-
-
-
-ppModule :: Interface -> [String]
-ppModule iface = "" : ("module " ++ mdl) : concatMap ppExport (iface_exports iface)
-    where
-        Module mdl = iface_module iface
-
-
-ppExport :: ExportItem -> [String]
-ppExport (ExportDecl name decl insts) = ppDecl decl ++ map ppInst insts
-ppExport _ = []
-
-
--}

src/Haddock/Interface.hs

+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Haddock.Interface
+-- Copyright   :  (c) Simon Marlow 2003-2006,
+--                    David Waern  2006-2010
+-- License     :  BSD-like
+--
+-- Maintainer  :  haddock@projects.haskell.org
+-- Stability   :  experimental
+-- Portability :  portable
+--
+-- This module typechecks Haskell modules using the GHC API and processes
+-- the result to create 'Interface's. The typechecking and the 'Interface'
+-- creation is interleaved, so that when a module is processed, the
+-- 'Interface's of all previously processed modules are available. The
+-- creation of an 'Interface' from a typechecked module is delegated to
+-- "Haddock.Interface.Create".
+--
+-- When all modules have been typechecked and processed, information about
+-- instances are attached to each 'Interface'. This task is delegated to
+-- "Haddock.Interface.AttachInstances". Note that this is done as a separate
+-- step because GHC can't know about all instances until all modules have been
+-- typechecked.
+--
+-- As a last step a link environment is built which maps names to the \"best\"
+-- places to link to in the documentation, and all 'Interface's are \"renamed\"
+-- using this environment.
+-----------------------------------------------------------------------------
+module Haddock.Interface (
+  processModules
+) where
+
+
+import Haddock.GhcUtils
+import Haddock.InterfaceFile
+import Haddock.Interface.Create
+import Haddock.Interface.AttachInstances
+import Haddock.Interface.Rename
+import Haddock.Options hiding (verbosity)
+import Haddock.Types
+import Haddock.Utils
+
+import Control.Monad
+import Data.List
+import qualified Data.Map as Map
+import Distribution.Verbosity
+import System.Directory
+import System.FilePath
+import Text.Printf
+
+import Digraph
+import Exception
+import GHC hiding (verbosity, flags)
+import HscTypes
+
+
+-- | Create 'Interface's and a link environment by typechecking the list of
+-- modules using the GHC API and processing the resulting syntax trees.
+processModules
+  :: Verbosity                  -- ^ Verbosity of logging to 'stdout'
+  -> [String]                   -- ^ A list of file or module names sorted by
+                                -- module topology
+  -> [Flag]                     -- ^ Command-line flags
+  -> [InterfaceFile]            -- ^ Interface files of package dependencies
+  -> Ghc ([Interface], LinkEnv) -- ^ Resulting list of interfaces and renaming
+                                -- environment
+processModules verbosity modules flags extIfaces = do
+
+  out verbosity verbose "Creating interfaces..."
+  let instIfaceMap =  Map.fromList [ (instMod iface, iface) | ext <- extIfaces
+                                   , iface <- ifInstalledIfaces ext ]
+  interfaces <- createIfaces0 verbosity modules flags instIfaceMap
+
+  out verbosity verbose "Attaching instances..."
+  interfaces' <- attachInstances interfaces instIfaceMap
+
+  out verbosity verbose "Building cross-linking environment..."
+  -- Combine the link envs of the external packages into one
+  let extLinks  = Map.unions (map ifLinkEnv extIfaces)
+      homeLinks = buildHomeLinks interfaces -- Build the environment for the home
+                                            -- package
+      links     = homeLinks `Map.union` extLinks
+
+  out verbosity verbose "Renaming interfaces..."
+  let warnings = Flag_NoWarnings `notElem` flags
+  let (interfaces'', msgs) =
+         runWriter $ mapM (renameInterface links warnings) interfaces'
+  liftIO $ mapM_ putStrLn msgs
+
+  return (interfaces'', homeLinks)
+
+
+--------------------------------------------------------------------------------
+-- * Module typechecking and Interface creation
+--------------------------------------------------------------------------------
+
+
+createIfaces0 :: Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc [Interface]
+createIfaces0 verbosity modules flags instIfaceMap =
+  -- Output dir needs to be set before calling depanal since depanal uses it to
+  -- compute output file names that are stored in the DynFlags of the
+  -- resulting ModSummaries.
+  (if useTempDir then withTempOutputDir else id) $ do
+    modGraph <- depAnalysis
+    if needsTemplateHaskell modGraph then do
+      modGraph' <- enableCompilation modGraph
+      createIfaces verbosity flags instIfaceMap modGraph'
+    else
+      createIfaces verbosity flags instIfaceMap modGraph
+
+  where
+    useTempDir :: Bool
+    useTempDir = Flag_NoTmpCompDir `notElem` flags
+
+
+    withTempOutputDir :: Ghc a -> Ghc a
+    withTempOutputDir action = do
+      tmp <- liftIO getTemporaryDirectory
+      x   <- liftIO getProcessID
+      let dir = tmp </> ".haddock-" ++ show x
+      modifySessionDynFlags (setOutputDir dir)
+      withTempDir dir action
+
+
+    depAnalysis :: Ghc ModuleGraph
+    depAnalysis = do
+      targets <- mapM (\f -> guessTarget f Nothing) modules
+      setTargets targets
+      depanal [] False
+
+
+    enableCompilation :: ModuleGraph -> Ghc ModuleGraph
+    enableCompilation modGraph = do
+      let enableComp d = d { hscTarget = defaultObjectTarget }
+      modifySessionDynFlags enableComp
+      -- We need to update the DynFlags of the ModSummaries as well.
+      let upd m = m { ms_hspp_opts = enableComp (ms_hspp_opts m) }
+      let modGraph' = map upd modGraph
+      return modGraph'
+
+
+createIfaces :: Verbosity -> [Flag] -> InstIfaceMap -> ModuleGraph -> Ghc [Interface]
+createIfaces verbosity flags instIfaceMap mods = do
+  let sortedMods = flattenSCCs $ topSortModuleGraph False mods Nothing
+  out verbosity normal "Haddock coverage:"
+  (ifaces, _) <- foldM f ([], Map.empty) sortedMods
+  return (reverse ifaces)
+  where
+    f (ifaces, ifaceMap) modSummary = do
+      x <- processModule verbosity modSummary flags ifaceMap instIfaceMap
+      return $ case x of
+        Just iface -> (iface:ifaces, Map.insert (ifaceMod iface) iface ifaceMap)
+        Nothing    -> (ifaces, ifaceMap) -- Boot modules don't generate ifaces.
+
+
+processModule :: Verbosity -> ModSummary -> [Flag] -> IfaceMap -> InstIfaceMap -> Ghc (Maybe Interface)
+processModule verbosity modsum flags modMap instIfaceMap = do
+  out verbosity verbose $ "Checking module " ++ moduleString (ms_mod modsum) ++ "..."
+  tm <- loadModule =<< typecheckModule =<< parseModule modsum
+  if not $ isBootSummary modsum then do
+    out verbosity verbose "Creating interface..."
+    (interface, msg) <- runWriterGhc $ createInterface tm flags modMap instIfaceMap
+    liftIO $ mapM_ putStrLn msg
+    let (haddockable, haddocked) = ifaceHaddockCoverage interface
+        percentage = round (fromIntegral haddocked * 100 / fromIntegral haddockable :: Double) :: Int
+        modString = moduleString (ifaceMod interface)
+        coverageMsg = printf " %3d%% (%3d /%3d) in '%s'" percentage haddocked haddockable modString
+    out verbosity normal coverageMsg
+    interface' <- liftIO $ evaluate interface
+    return (Just interface')
+  else
+    return Nothing
+
+
+--------------------------------------------------------------------------------
+-- * Building of cross-linking environment  
+--------------------------------------------------------------------------------
+
+
+-- | Build a mapping which for each original name, points to the "best"
+-- place to link to in the documentation.  For the definition of
+-- "best", we use "the module nearest the bottom of the dependency
+-- graph which exports this name", not including hidden modules.  When
+-- there are multiple choices, we pick a random one.
+--
+-- The interfaces are passed in in topologically sorted order, but we start
+-- by reversing the list so we can do a foldl.
+buildHomeLinks :: [Interface] -> LinkEnv
+buildHomeLinks ifaces = foldl upd Map.empty (reverse ifaces)
+  where
+    upd old_env iface
+      | OptHide    `elem` ifaceOptions iface = old_env
+      | OptNotHome `elem` ifaceOptions iface =
+        foldl' keep_old old_env exported_names
+      | otherwise = foldl' keep_new old_env exported_names
+      where
+        exported_names = ifaceVisibleExports iface
+        mdl            = ifaceMod iface
+        keep_old env n = Map.insertWith (\_ old -> old) n mdl env
+        keep_new env n = Map.insert n mdl env
+
+
+--------------------------------------------------------------------------------
+-- * Utils
+--------------------------------------------------------------------------------
+
+
+withTempDir :: (ExceptionMonad m, MonadIO m) => FilePath -> m a -> m a
+withTempDir dir = gbracket_ (liftIO $ createDirectory dir)
+                            (liftIO $ removeDirectoryRecursive dir)
+

src/Haddock/Interface/AttachInstances.hs

+{-# LANGUAGE MagicHash #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Haddock.Interface.AttachInstances
+-- Copyright   :  (c) Simon Marlow 2006,
+--                    David Waern  2006-2009,
+--                    Isaac Dupree 2009
+-- License     :  BSD-like
+--
+-- Maintainer  :  haddock@projects.haskell.org
+-- Stability   :  experimental
+-- Portability :  portable
+-----------------------------------------------------------------------------
+module Haddock.Interface.AttachInstances (attachInstances) where
+
+
+import Haddock.Types
+import Haddock.Convert
+
+import Control.Arrow
+import Data.List
+import qualified Data.Map as Map
+
+import GHC
+import Name
+import InstEnv
+import Class
+import GhcMonad (withSession)
+import TysPrim( funTyCon )
+import MonadUtils (liftIO)
+import TcRnDriver (tcRnGetInfo)
+import TypeRep
+import Var hiding (varName)
+import TyCon
+import PrelNames
+import FastString
+#define FSLIT(x) (mkFastString# (x#))
+
+
+attachInstances :: [Interface] -> InstIfaceMap -> Ghc [Interface]
+attachInstances ifaces instIfaceMap = mapM attach ifaces
+  where
+    -- TODO: take an IfaceMap as input
+    ifaceMap = Map.fromList [ (ifaceMod i, i) | i <- ifaces ]
+
+    attach iface = do
+      newItems <- mapM (attachToExportItem iface ifaceMap instIfaceMap)
+                       (ifaceExportItems iface)
+      return $ iface { ifaceExportItems = newItems }
+
+
+attachToExportItem :: Interface -> IfaceMap -> InstIfaceMap -> ExportItem Name -> Ghc (ExportItem Name)
+attachToExportItem iface ifaceMap instIfaceMap export =
+  case export of
+    ExportDecl { expItemDecl = L _ (TyClD d) } -> do
+      mb_info <- getAllInfo (unLoc (tcdLName d))
+      let export' =
+            export {
+              expItemInstances =
+                case mb_info of
+                  Just (_, _, instances) ->
+                    let insts = map (first synifyInstHead) $ sortImage (first instHead)
+                                [ (instanceHead i, getName i) | i <- instances ]
+                    in [ (inst, lookupInstDoc name iface ifaceMap instIfaceMap)
+                       | (inst, name) <- insts ]
+                  Nothing -> []
+            }
+      return export'
+    _ -> return export
+
+
+lookupInstDoc :: Name -> Interface -> IfaceMap -> InstIfaceMap -> Maybe (Doc Name)
+-- TODO: capture this pattern in a function (when we have streamlined the
+-- handling of instances)
+lookupInstDoc name iface ifaceMap instIfaceMap =
+  case Map.lookup name (ifaceDocMap iface) of
+    Just doc -> Just doc
+    Nothing ->
+      case Map.lookup modName ifaceMap of
+        Just iface2 ->
+          case Map.lookup name (ifaceDocMap iface2) of
+            Just doc -> Just doc
+            Nothing -> Nothing
+        Nothing ->
+          case Map.lookup modName instIfaceMap of
+            Just instIface -> Map.lookup name (instDocMap instIface)
+            Nothing -> Nothing
+  where
+    modName = nameModule name
+
+
+-- | Like GHC's getInfo but doesn't cut things out depending on the
+-- interative context, which we don't set sufficiently anyway.
+getAllInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[ClsInst]))
+getAllInfo name = withSession $ \hsc_env -> do 
+   (_msgs, r) <- liftIO $ tcRnGetInfo hsc_env name
+   return r
+
+
+--------------------------------------------------------------------------------
+-- Collecting and sorting instances
+--------------------------------------------------------------------------------
+
+
+-- | Simplified type for sorting types, ignoring qualification (not visible
+-- in Haddock output) and unifying special tycons with normal ones.
+-- For the benefit of the user (looks nice and predictable) and the
+-- tests (which prefer output to be deterministic).
+data SimpleType = SimpleType Name [SimpleType]
+                | SimpleTyLit TyLit
+                  deriving (Eq,Ord)
+
+
+instHead :: ([TyVar], [PredType], Class, [Type]) -> ([Int], Name, [SimpleType])
+instHead (_, _, cls, args)
+  = (map argCount args, className cls, map simplify args)
+  where
+    argCount (AppTy t _) = argCount t + 1
+    argCount (TyConApp _ ts) = length ts
+    argCount (FunTy _ _ ) = 2
+    argCount (ForAllTy _ t) = argCount t
+    argCount _ = 0
+
+    simplify (ForAllTy _ t) = simplify t
+    simplify (FunTy t1 t2) = 
+      SimpleType funTyConName [simplify t1, simplify t2]
+    simplify (AppTy t1 t2) = SimpleType s (ts ++ [simplify t2])
+      where (SimpleType s ts) = simplify t1
+    simplify (TyVarTy v) = SimpleType (tyVarName v) []
+    simplify (TyConApp tc ts) = SimpleType (tyConName tc) (map simplify ts)
+    simplify (LitTy l) = SimpleTyLit l
+
+
+-- sortImage f = sortBy (\x y -> compare (f x) (f y))
+sortImage :: Ord b => (a -> b) -> [a] -> [a]
+sortImage f xs = map snd $ sortBy cmp_fst [(f x, x) | x <- xs]
+ where cmp_fst (x,_) (y,_) = compare x y
+
+
+funTyConName :: Name
+funTyConName = mkWiredInName gHC_PRIM
+                        (mkOccNameFS tcName FSLIT("(->)"))
+                        funTyConKey
+                        (ATyCon funTyCon)       -- Relevant TyCon
+                        BuiltInSyntax