path: root/src/Haddock/Backends/Html.hs

--
-- Haddock - A Haskell Documentation Tool
--
-- (c) Simon Marlow 2003
--


module Haddock.Backends.Html ( 
  ppHtml, copyHtmlBits, 
  ppHtmlIndex, ppHtmlContents,
  ppHtmlHelpFiles
) where


import Prelude hiding (div)

import Haddock.DocName
import Haddock.Backends.DevHelp
import Haddock.Backends.HH
import Haddock.Backends.HH2
import Haddock.ModuleTree
import Haddock.Types
import Haddock.Version
import Haddock.Utils
import Haddock.Utils.Html
import Haddock.GHC.Utils
import qualified Haddock.Utils.Html as Html

import Control.Exception     ( bracket )
import Control.Monad         ( when, unless )
import Data.Char             ( isUpper, toUpper )
import Data.List             ( sortBy )
import Data.Maybe            ( fromJust, isJust, mapMaybe, fromMaybe )
import Foreign.Marshal.Alloc ( allocaBytes )
import System.IO             ( IOMode(..), hClose, hGetBuf, hPutBuf, openFile )
import Data.Map              ( Map )
import qualified Data.Map as Map hiding ( Map )

import GHC hiding ( NoLink )
import Name
import Module
import PackageConfig         ( stringToPackageId )
import RdrName hiding ( Qual )
import SrcLoc   
import FastString            ( unpackFS )
import BasicTypes            ( IPName(..), Boxity(..) )
import Type                  ( Kind )
import Outputable            ( ppr, defaultUserStyle, showSDoc )

-- the base, module and entity URLs for the source code and wiki links.
type SourceURLs = (Maybe String, Maybe String, Maybe String)
type WikiURLs = (Maybe String, Maybe String, Maybe String)

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

ppHtml	:: String
	-> Maybe String				-- package
	-> [Interface]
	-> FilePath			-- destination directory
	-> Maybe (GHC.HsDoc GHC.RdrName)    -- prologue text, maybe
	-> Maybe String		        -- the Html Help format (--html-help)
	-> SourceURLs			-- the source URL (--source)
	-> WikiURLs			-- the wiki URL (--wiki)
	-> Maybe String			-- the contents URL (--use-contents)
	-> Maybe String			-- the index URL (--use-index)
	-> IO ()

ppHtml doctitle maybe_package ifaces odir prologue maybe_html_help_format
	maybe_source_url maybe_wiki_url
	maybe_contents_url maybe_index_url =  do
  let
	visible_ifaces = filter visible ifaces
	visible i = OptHide `notElem` ifaceOptions i

  when (not (isJust maybe_contents_url)) $ 
    ppHtmlContents odir doctitle maybe_package
        maybe_html_help_format 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

  when (not (isJust maybe_index_url)) $ 
    ppHtmlIndex odir doctitle maybe_package maybe_html_help_format
      maybe_contents_url maybe_source_url maybe_wiki_url 
      (map toInstalledIface visible_ifaces)
    
  when (not (isJust maybe_contents_url && isJust maybe_index_url)) $ 
	ppHtmlHelpFiles doctitle maybe_package ifaces odir maybe_html_help_format []

  mapM_ (ppHtmlModule odir doctitle
	   maybe_source_url maybe_wiki_url
	   maybe_contents_url maybe_index_url) visible_ifaces

ppHtmlHelpFiles	
    :: String                   -- doctitle
    -> Maybe String				-- package
	-> [Interface]
	-> FilePath                 -- destination directory
	-> Maybe String             -- the Html Help format (--html-help)
	-> [FilePath]               -- external packages paths
	-> IO ()
ppHtmlHelpFiles doctitle maybe_package ifaces odir maybe_html_help_format pkg_paths =  do
  let
	visible_ifaces = filter visible ifaces
	visible i = OptHide `notElem` ifaceOptions i

  -- Generate index and contents page for Html Help if requested
  case maybe_html_help_format of
    Nothing        -> return ()
    Just "mshelp"  -> ppHHProject odir doctitle maybe_package visible_ifaces pkg_paths
    Just "mshelp2" -> do
		ppHH2Files      odir maybe_package visible_ifaces pkg_paths
		ppHH2Collection odir doctitle maybe_package
    Just "devhelp" -> ppDevHelpFile odir doctitle maybe_package visible_ifaces
    Just format    -> fail ("The "++format++" format is not implemented")

copyFile :: FilePath -> FilePath -> IO ()
copyFile fromFPath toFPath =
	(bracket (openFile fromFPath ReadMode) hClose $ \hFrom ->
	 bracket (openFile toFPath WriteMode) hClose $ \hTo ->
	 allocaBytes bufferSize $ \buffer ->
		copyContents hFrom hTo buffer)
	where
		bufferSize = 1024
		
		copyContents hFrom hTo buffer = do
			count <- hGetBuf hFrom buffer bufferSize
			when (count > 0) $ do
				hPutBuf hTo buffer count
				copyContents hFrom hTo buffer


copyHtmlBits :: FilePath -> FilePath -> Maybe FilePath -> IO ()
copyHtmlBits odir libdir maybe_css = do
  let 
	libhtmldir = pathJoin [libdir, "html"]
	css_file = case maybe_css of
			Nothing -> pathJoin [libhtmldir, cssFile]
			Just f  -> f
	css_destination = pathJoin [odir, cssFile]
	copyLibFile f = do
	   copyFile (pathJoin [libhtmldir, f]) (pathJoin [odir, f])
  copyFile css_file css_destination
  mapM_ copyLibFile [ iconFile, plusFile, minusFile, jsFile ]

footer :: HtmlTable
footer = 
  tda [theclass "botbar"] << 
	( toHtml "Produced by" <+> 
	  (anchor ! [href projectUrl] << toHtml projectName) <+>
	  toHtml ("version " ++ projectVersion)
	)
   
srcButton :: SourceURLs -> Maybe Interface -> HtmlTable
srcButton (Just src_base_url, _, _) Nothing =
  topButBox (anchor ! [href src_base_url] << toHtml "Source code")

srcButton (_, Just src_module_url, _) (Just iface) =
  let url = spliceURL (Just $ ifaceOrigFilename iface)
                      (Just $ ifaceMod iface) Nothing Nothing src_module_url
   in topButBox (anchor ! [href url] << toHtml "Source code")

srcButton _ _ =
  Html.emptyTable
 
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
  mod = case maybe_mod of
          Nothing           -> ""
          Just mod -> moduleString mod 
  
  (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 -> show $ srcSpanStartLine span

  run "" = ""
  run ('%':'M':rest) = mod ++ 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) = mod ++ 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) mod ++ 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
  
wikiButton :: WikiURLs -> Maybe Module -> HtmlTable
wikiButton (Just wiki_base_url, _, _) Nothing =
  topButBox (anchor ! [href wiki_base_url] << toHtml "User Comments")

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

wikiButton _ _ =
  Html.emptyTable

contentsButton :: Maybe String -> HtmlTable
contentsButton maybe_contents_url 
  = topButBox (anchor ! [href url] << toHtml "Contents")
  where url = case maybe_contents_url of
			Nothing -> contentsHtmlFile
			Just url -> url

indexButton :: Maybe String -> HtmlTable
indexButton maybe_index_url 
  = topButBox (anchor ! [href url] << toHtml "Index")
  where url = case maybe_index_url of
			Nothing -> indexHtmlFile
			Just url -> url

simpleHeader :: String -> Maybe String -> Maybe String
             -> SourceURLs -> WikiURLs -> HtmlTable
simpleHeader doctitle maybe_contents_url maybe_index_url
  maybe_source_url maybe_wiki_url = 
  (tda [theclass "topbar"] << 
     vanillaTable << (
       (td << 
  	image ! [src "haskell_icon.gif", width "16", height 16, alt " " ]
       ) <->
       (tda [theclass "title"] << toHtml doctitle) <->
	srcButton maybe_source_url Nothing <->
        wikiButton maybe_wiki_url Nothing <->
	contentsButton maybe_contents_url <-> indexButton maybe_index_url
   ))

pageHeader :: String -> Interface -> String
    -> SourceURLs -> WikiURLs
    -> Maybe String -> Maybe String -> HtmlTable
pageHeader mdl iface doctitle
           maybe_source_url maybe_wiki_url
           maybe_contents_url maybe_index_url =
  (tda [theclass "topbar"] << 
    vanillaTable << (
       (td << 
  	image ! [src "haskell_icon.gif", width "16", height 16, alt " "]
       ) <->
       (tda [theclass "title"] << toHtml doctitle) <->
	srcButton maybe_source_url (Just iface) <->
	wikiButton maybe_wiki_url (Just $ ifaceMod iface) <->
	contentsButton maybe_contents_url <->
	indexButton maybe_index_url
    )
   ) </>
   tda [theclass "modulebar"] <<
	(vanillaTable << (
	  (td << font ! [size "6"] << toHtml mdl) <->
	  moduleInfo iface
	)
    )

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

      doOneEntry :: (String, (GHC.HaddockModInfo GHC.Name) -> Maybe String) -> Maybe HtmlTable
      doOneEntry (fieldName,field) = case field info of
         Nothing -> Nothing
         Just fieldValue -> 
            Just ((tda [theclass "infohead"] << toHtml fieldName)
               <-> (tda [theclass "infoval"]) << toHtml fieldValue)
     
      entries :: [HtmlTable]
      entries = mapMaybe doOneEntry [
         ("Portability",GHC.hmi_portability),
         ("Stability",GHC.hmi_stability),
         ("Maintainer",GHC.hmi_maintainer)
         ]
   in
      case entries of
         [] -> Html.emptyTable
         _ -> tda [align "right"] << narrowTable << (foldl1 (</>) entries)

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

ppHtmlContents
   :: FilePath
   -> String
   -> Maybe String
   -> Maybe String
   -> Maybe String
   -> SourceURLs
   -> WikiURLs
   -> [InstalledInterface] -> Bool -> Maybe (GHC.HsDoc GHC.RdrName)
   -> IO ()
ppHtmlContents odir doctitle
  maybe_package maybe_html_help_format maybe_index_url
  maybe_source_url maybe_wiki_url ifaces showPkgs prologue = do
  let tree = mkModuleTree showPkgs
         [(instMod mod, toInstalledDescription mod) | mod <- ifaces]
      html = 
	header 
		(documentCharacterEncoding +++
		 thetitle (toHtml doctitle) +++
		 styleSheet +++
		 (script ! [src jsFile, thetype "text/javascript"] $ noHtml)) +++
        body << vanillaTable << (
   	    simpleHeader doctitle Nothing maybe_index_url
                         maybe_source_url maybe_wiki_url </>
	    ppPrologue doctitle prologue </>
	    ppModuleTree doctitle tree </>
	    s15 </>
	    footer
	  )
  writeFile (pathJoin [odir, contentsHtmlFile]) (renderHtml html)
  
  -- Generate contents page for Html Help if requested
  case maybe_html_help_format of
    Nothing        -> return ()
    Just "mshelp"  -> ppHHContents  odir doctitle maybe_package tree
    Just "mshelp2" -> ppHH2Contents odir doctitle maybe_package tree
    Just "devhelp" -> return ()
    Just format    -> fail ("The "++format++" format is not implemented")

ppPrologue :: String -> Maybe (GHC.HsDoc GHC.RdrName) -> HtmlTable
ppPrologue title Nothing = Html.emptyTable
ppPrologue title (Just doc) = 
  (tda [theclass "section1"] << toHtml title) </>
  docBox (rdrDocToHtml doc)

ppModuleTree :: String -> [ModuleTree] -> HtmlTable
ppModuleTree _ ts = 
  tda [theclass "section1"] << toHtml "Modules" </>
  td << vanillaTable2 << htmlTable
  where
    genTable htmlTable id []     = (htmlTable,id)
    genTable htmlTable id (x:xs) = genTable (htmlTable </> u) id' xs      
      where
        (u,id') = mkNode [] x 0 id

    (htmlTable,_) = genTable emptyTable 0 ts

mkNode :: [String] -> ModuleTree -> Int -> Int -> (HtmlTable,Int)
mkNode ss (Node s leaf pkg short ts) depth id = htmlNode
  where
    htmlNode = case ts of
      [] -> (td_pad_w 1.25 depth << htmlModule  <-> shortDescr <-> htmlPkg,id)
      _  -> (td_w depth << (collapsebutton id_s +++ htmlModule) <-> shortDescr <-> htmlPkg </> 
                (td_subtree << sub_tree), id')

    mod_width = 50::Int {-em-}

    td_pad_w pad depth = 
	tda [thestyle ("padding-left: " ++ show pad ++ "em;" ++
		       "width: " ++ show (mod_width - depth*2) ++ "em")]

    td_w depth = 
	tda [thestyle ("width: " ++ show (mod_width - depth*2) ++ "em")]

    td_subtree =
	tda [thestyle ("padding: 0; padding-left: 2em")]

    shortDescr :: HtmlTable
    shortDescr = case short of
	Nothing -> td empty
	Just doc -> tda [theclass "rdoc"] (origDocToHtml doc)

    htmlModule 
      | leaf      = ppModule (mkModule (stringToPackageId pkgName) 
                                       (mkModuleName mdl)) ""
      | otherwise = toHtml s

    -- ehm.. TODO: change the ModuleTree type
    (htmlPkg, pkgName) = case pkg of
      Nothing -> (td << empty, "")
      Just p  -> (td << toHtml p, p)

    mdl = foldr (++) "" (s' : map ('.':) ss')
    (s':ss') = reverse (s:ss)
	 -- reconstruct the module name
    
    id_s = "n:" ++ show id
    
    (sub_tree,id') = genSubTree emptyTable (id+1) ts
    
    genSubTree :: HtmlTable -> Int -> [ModuleTree] -> (Html,Int)
    genSubTree htmlTable id [] = (sub_tree,id)
      where
        sub_tree = collapsed vanillaTable2 id_s htmlTable
    genSubTree htmlTable id (x:xs) = genSubTree (htmlTable </> u) id' xs      
      where
        (u,id') = mkNode (s:ss) x (depth+1) id

-- The URL for source and wiki links, and the current module
type LinksInfo = (SourceURLs, WikiURLs, Interface)


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

ppHtmlIndex :: FilePath
            -> String 
            -> Maybe String
            -> Maybe String
            -> Maybe String
            -> SourceURLs
            -> WikiURLs
            -> [InstalledInterface] 
            -> IO ()
ppHtmlIndex odir doctitle maybe_package maybe_html_help_format
  maybe_contents_url maybe_source_url maybe_wiki_url ifaces = do
  let html = 
        header (documentCharacterEncoding +++
                thetitle (toHtml (doctitle ++ " (Index)")) +++
        styleSheet +++
        (script ! [src jsFile, thetype "text/javascript"] $ noHtml)) +++
        body << vanillaTable << (
            simpleHeader doctitle maybe_contents_url Nothing
                         maybe_source_url maybe_wiki_url </>
        search_box </> index_html
           )

  writeFile (pathJoin [odir, indexHtmlFile]) (renderHtml html)
  
    -- Generate index and contents page for Html Help if requested
  case maybe_html_help_format of
    Nothing        -> return ()
    Just "mshelp"  -> ppHHIndex  odir maybe_package ifaces
    Just "mshelp2" -> ppHH2Index odir maybe_package ifaces
    Just "devhelp" -> return ()
    Just format    -> fail ("The "++format++" format is not implemented")
 where
  -- colspan 2, marginheight 5
  search_box :: HtmlTable
  search_box = tda [colspan 2, thestyle "padding-top:5px;"] << search
    where
      search :: Html
      search = form ! [strAttr "onsubmit" "full_search(); return false;", action ""] << (
                    "Search: "
                    +++ input ! [identifier "searchbox", strAttr "onkeyup" "quick_search()"]
                    +++ " " +++ input ! [value "Search", thetype "submit"]
                    +++ " " +++ thespan ! [identifier "searchmsg"] << " ")

  index_html = td << setTrClass (table ! [identifier "indexlist", cellpadding 0, cellspacing 5] <<
          aboves (map indexElt index))

  setTrClass :: Html -> Html
  setTrClass (Html xs) = Html $ map f xs
      where
          f (HtmlTag name attrs inner)
               | map toUpper name == "TR" = HtmlTag name (theclass "indexrow":attrs) inner
               | otherwise = HtmlTag name attrs (setTrClass inner)
          f x = x

  index :: [(String, Map GHC.Name [(Module,Bool)])]
  index = sortBy cmp (Map.toAscList full_index)
    where cmp (n1,_) (n2,_) = map toUpper n1 `compare` map toUpper 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 (++)))
               (concat (map getIfaceIndex ifaces))

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

  indexElt :: (String, Map GHC.Name [(Module,Bool)]) -> HtmlTable
  indexElt (str, entities) = 
     case Map.toAscList entities of
	[(nm,entries)] ->  
	    tda [ theclass "indexentry" ] << toHtml str <-> 
			indexLinks nm entries
	many_entities ->
	    tda [ theclass "indexentry" ] << toHtml str </> 
		aboves (map doAnnotatedEntity (zip [1..] many_entities))

  doAnnotatedEntity (j,(nm,entries))
	= tda [ theclass "indexannot" ] << 
		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 = 
     tda [ theclass "indexlinks" ] << 
	hsep (punctuate comma 
	[ if visible then
	     linkId mod (Just nm) << toHtml (moduleString mod)
	  else
	     toHtml (moduleString mod)
	| (mod, visible) <- entries ])

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

ppHtmlModule
	:: FilePath -> String
	-> SourceURLs -> WikiURLs
	-> Maybe String -> Maybe String
	-> Interface -> IO ()
ppHtmlModule odir doctitle
  maybe_source_url maybe_wiki_url
  maybe_contents_url maybe_index_url iface = do
  let 
      mod = ifaceMod iface
      mdl = moduleString mod
      html = 
	header (documentCharacterEncoding +++
		thetitle (toHtml mdl) +++
		styleSheet +++
		(script ! [src jsFile, thetype "text/javascript"] $ noHtml)) +++
        body << vanillaTable << (
	    pageHeader mdl iface doctitle
		maybe_source_url maybe_wiki_url
		maybe_contents_url maybe_index_url </> s15 </>
	    ifaceToHtml maybe_source_url maybe_wiki_url iface </> s15 </>
	    footer
         )
  writeFile (pathJoin [odir, moduleHtmlFile mod]) (renderHtml html)


ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> HtmlTable
ifaceToHtml maybe_source_url maybe_wiki_url iface
  = abovesSep s15 (contents ++ description: synopsis: maybe_doc_hdr: bdy)
  where
    docMap = ifaceRnDocMap iface
 
    exports = numberSectionHeadings (ifaceRnExportItems iface)

    has_doc (ExportDecl _ _ doc _) = isJust doc
    has_doc (ExportNoDecl _ _ _) = False
    has_doc (ExportModule _) = False
    has_doc _ = True

    no_doc_at_all = not (any has_doc exports)

    contents = case ppModuleContents exports of
                   Nothing -> []
                   Just x -> [td << vanillaTable << x]

    description
          = case ifaceRnDoc iface of
              Nothing -> Html.emptyTable
              Just doc -> (tda [theclass "section1"] << toHtml "Description") </>
                          docBox (docToHtml doc)

	-- omit the synopsis if there are no documentation annotations at all
    synopsis
      | no_doc_at_all = Html.emptyTable
      | otherwise
      = (tda [theclass "section1"] << toHtml "Synopsis") </>
        s15 </>
            (tda [theclass "body"] << vanillaTable <<
            abovesSep s8 (map (processExport True linksInfo docMap)
            (filter forSummary exports))
        )

	-- if the documentation doesn't begin with a section header, then
	-- add one ("Documentation").
    maybe_doc_hdr
      = case exports of		   
          [] -> Html.emptyTable
          ExportGroup _ _ _ : _ -> Html.emptyTable
          _ -> tda [ theclass "section1" ] << toHtml "Documentation"

    bdy  = map (processExport False linksInfo docMap) exports
    linksInfo = (maybe_source_url, maybe_wiki_url, iface)


ppModuleContents :: [ExportItem DocName] -> Maybe HtmlTable
ppModuleContents exports
  | length sections == 0 = Nothing
  | otherwise            = Just (tda [theclass "section4"] << bold << toHtml "Contents"
  		                 </> td << dlist << concatHtml sections)
 where
  (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 = (dterm << linkedAnchor id0 << docToHtml 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 = ddef << dlist << concatHtml 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 -> DocMap -> (ExportItem DocName) -> HtmlTable
processExport _ _ _ (ExportGroup lev id0 doc)
  = ppDocGroup lev (namedAnchor id0 << docToHtml doc)
processExport summary links docMap (ExportDecl x decl doc insts)
  = doDecl summary links x decl doc insts docMap
processExport summmary _ _ (ExportNoDecl _ y [])
  = declBox (ppDocName y)
processExport summmary _ _ (ExportNoDecl _ y subs)
  = declBox (ppDocName y <+> parenList (map ppDocName subs))
processExport _ _ _ (ExportDoc doc)
  = docBox (docToHtml doc)
processExport _ _ _ (ExportModule mod)
  = declBox (toHtml "module" <+> ppModule mod "")

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

ppDocGroup :: Int -> Html -> HtmlTable
ppDocGroup lev doc
  | lev == 1  = tda [ theclass "section1" ] << doc
  | lev == 2  = tda [ theclass "section2" ] << doc
  | lev == 3  = tda [ theclass "section3" ] << doc
  | otherwise = tda [ theclass "section4" ] << doc

declWithDoc :: Bool -> LinksInfo -> SrcSpan -> Name -> Maybe (HsDoc DocName) -> Html -> HtmlTable
declWithDoc True  _     _   _  _          html_decl = declBox html_decl
declWithDoc False links loc nm Nothing    html_decl = topDeclBox links loc nm html_decl
declWithDoc False links loc nm (Just doc) html_decl = 
		topDeclBox links loc nm html_decl </> docBox (docToHtml doc)

doDecl :: Bool -> LinksInfo -> Name -> LHsDecl DocName -> 
          Maybe (HsDoc DocName) -> [InstHead DocName] -> DocMap -> HtmlTable
doDecl summary links x (L loc d) mbDoc instances docMap = doDecl d
  where
    doDecl (TyClD d) = doTyClD d 
    doDecl (SigD (TypeSig (L _ n) (L _ t))) = 
      ppFunSig summary links loc mbDoc (docNameOrig n) t
    doDecl (ForD d) = ppFor summary links loc mbDoc d

    doTyClD d0@(TyData {}) = ppDataDecl summary links instances x loc mbDoc d0
    doTyClD d0@(TySynonym {}) = ppTySyn summary links loc mbDoc d0
    doTyClD d0@(ClassDecl {}) = ppClassDecl summary links instances x loc mbDoc docMap d0


ppFunSig :: Bool -> LinksInfo -> SrcSpan -> Maybe (HsDoc DocName) ->
            Name -> HsType DocName -> HtmlTable
ppFunSig summary links loc mbDoc name typ =
  ppTypeOrFunSig summary links loc name typ mbDoc 
    (ppTypeSig summary (nameOccName name) typ, 
     ppBinder False (nameOccName name), dcolon)


ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> Name -> HsType DocName ->
                  Maybe (HsDoc DocName) -> (Html, Html, Html) -> HtmlTable
ppTypeOrFunSig summary links loc name typ doc (pref1, pref2, sep)
  | summary || noArgDocs typ = declWithDoc summary links loc name doc pref1
  | otherwise = topDeclBox links loc name pref2 </>
    (tda [theclass "body"] << vanillaTable <<  (
      do_args sep typ </>
        (case doc of
          Just doc -> ndocBox (docToHtml doc)
          Nothing -> Html.emptyTable)
	))
  where 
    noLArgDocs (L _ t) = noArgDocs t
    noArgDocs (HsForAllTy _ _ _ t) = noLArgDocs t
    noArgDocs (HsFunTy (L _ (HsDocTy _ _)) _) = False 
    noArgDocs (HsFunTy _ r) = noLArgDocs r
    noArgDocs (HsDocTy _ _) = False
    noArgDocs _ = True

    do_largs leader (L _ t) = do_args leader t  
    do_args :: Html -> (HsType DocName) -> HtmlTable
    do_args leader (HsForAllTy Explicit tvs lctxt ltype)
      = (argBox (
          leader <+> 
          hsep (keyword "forall" : ppTyVars tvs ++ [dot]) <+>
          ppLContextNoArrow lctxt)
            <-> rdocBox noHtml) </> 
            do_largs darrow ltype
    do_args leader (HsForAllTy Implicit _ lctxt ltype)
      = (argBox (leader <+> ppLContextNoArrow lctxt)
          <-> rdocBox noHtml) </> 
          do_largs darrow ltype
    do_args leader (HsFunTy (L _ (HsDocTy lt ldoc)) r)
      = (argBox (leader <+> ppLType lt) <-> rdocBox (docToHtml (unLoc ldoc)))
          </> do_largs arrow r
    do_args leader (HsFunTy lt r)
      = (argBox (leader <+> ppLType lt) <-> rdocBox noHtml) </> do_largs arrow r
    do_args leader (HsDocTy lt ldoc)
      = (argBox (leader <+> ppLType lt) <-> rdocBox (docToHtml (unLoc ldoc)))
    do_args leader t
      = argBox (leader <+> ppType t) <-> rdocBox (noHtml)


ppTyVars tvs = ppTyNames (tyvarNames tvs)

tyvarNames = map f 
  where f x = docNameOrig . hsTyVarName . unLoc $ x
  
ppFor summary links loc mbDoc (ForeignImport (L _ name) (L _ typ) _)
  = ppFunSig summary links loc mbDoc (docNameOrig name) typ
ppFor _ _ _ _ _ = error "ppFor"

-- we skip type patterns for now
ppTySyn summary links loc mbDoc (TySynonym (L _ name) ltyvars _ ltype) 
  = ppTypeOrFunSig summary links loc n (unLoc ltype) mbDoc 
                   (full, hdr, spaceHtml +++ equals)
  where
    hdr  = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars ltyvars)
    full = hdr <+> equals <+> ppLType ltype
    n    = docNameOrig name
    occ  = docNameOcc name


ppTypeSig :: Bool -> OccName -> HsType DocName -> Html
ppTypeSig summary nm ty = ppBinder summary nm <+> dcolon <+> ppType ty


ppTyName name
  | isNameSym name = parens (ppName name)
  | otherwise = ppName name


ppTyNames = map ppTyName


--------------------------------------------------------------------------------
-- Type applications
--------------------------------------------------------------------------------


-- | Print an application of a DocName and a list of HsTypes
ppAppNameTypes :: DocName -> [HsType DocName] -> Html
ppAppNameTypes n ts = ppTypeApp n ts ppDocName ppParendType


-- | Print an application of a DocName and a list of Names 
ppDataClassHead :: Bool -> DocName -> [Name] -> Html
ppDataClassHead summ n ns = 
  ppTypeApp n ns (ppBinder summ . docNameOcc) ppTyName


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

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


--------------------------------------------------------------------------------
-- Contexts 
--------------------------------------------------------------------------------

ppLContext        = ppContext        . unLoc
ppLContextNoArrow = ppContextNoArrow . unLoc

ppContextNoArrow :: HsContext DocName -> Html
ppContextNoArrow []  = empty
ppContextNoArrow cxt = pp_hs_context (map unLoc cxt) 

ppContextNoLocs :: [HsPred DocName] -> Html
ppContextNoLocs []  = empty
ppContextNoLocs cxt = pp_hs_context cxt <+> darrow  

ppContext :: HsContext DocName -> Html
ppContext cxt = ppContextNoLocs (map unLoc cxt)

pp_hs_context []  = empty
pp_hs_context [p] = ppPred p
pp_hs_context cxt = parenList (map ppPred cxt) 

ppLPred = ppPred . unLoc


ppPred (HsClassP n ts) = ppAppNameTypes n (map unLoc ts)
-- TODO: find out what happened to the Dupable/Linear distinction
ppPred (HsEqualP t1 t2) = ppLType t1 <+> toHtml "~" <+> ppLType t2
ppPred (HsIParam (IPName n) t) 
  = toHtml "?" +++ ppDocName n <+> dcolon <+> ppLType t


-- -----------------------------------------------------------------------------
-- Class declarations

ppClassHdr summ lctxt n tvs fds = 
  keyword "class" 
  <+> (if not . null . unLoc $ lctxt then ppLContext lctxt else empty)
  <+> ppDataClassHead summ n (tyvarNames $ tvs)
	<+> ppFds fds

ppFds fds =
  if null fds then noHtml else 
	char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds))
  where
	fundep (vars1,vars2) = hsep (map ppDocName vars1) <+> toHtml "->" <+>
			       hsep (map ppDocName vars2)

ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan -> DocMap -> HtmlTable
ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _) loc docMap = 
  if null sigs && null ats
    then (if summary then declBox else topDeclBox links loc nm) hdr
    else (if summary then declBox else topDeclBox links loc nm) (hdr <+> keyword "where")
	    </> 
           (tda [theclass "body"] << 
	     vanillaTable << 
         aboves ([ ppAT summary at | L _ at <- ats ] ++
	        [ ppFunSig summary links loc mbDoc n typ
		          | L _ (TypeSig (L _ fname) (L _ typ)) <- sigs
              , let n = docNameOrig fname, let mbDoc = Map.lookup n docMap ])
          )
  where
    hdr = ppClassHdr summary lctxt (unLoc lname) tvs fds
    nm  = docNameOrig . unLoc $ lname
    
    ppAT summary at = case at of
      TyData {} -> topDeclBox links loc nm (ppDataHeader summary at)
      _ -> error "associated type synonyms or type families not supported yet"

-- we skip ATs for now
ppClassDecl :: Ord key => Bool -> LinksInfo -> [InstHead DocName] -> key -> SrcSpan ->
                          Maybe (HsDoc DocName) -> DocMap -> TyClDecl DocName -> 
                          HtmlTable
ppClassDecl summary links instances orig_c loc mbDoc docMap
	decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ _ _)
  | summary = ppShortClassDecl summary links decl loc docMap
  | otherwise
    = classheader </>
      tda [theclass "body"] << vanillaTable << (
        classdoc </> methodsBit </> instancesBit
      )
  where 
    classheader
      | null lsigs = topDeclBox links loc nm hdr
      | otherwise  = topDeclBox links loc nm (hdr <+> keyword "where")

    nm   = docNameOrig . unLoc $ lname
    ctxt = unLoc lctxt

    hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds
    
    classdoc = case mbDoc of
      Nothing -> Html.emptyTable
      Just d -> ndocBox (docToHtml d)

    methodsBit
      | null lsigs = Html.emptyTable
      | otherwise  = 
        s8 </> methHdr </>
        tda [theclass "body"] << vanillaTable << (
          abovesSep s8 [ ppFunSig summary links loc mbDoc (docNameOrig n) typ
                           | L _ (TypeSig (L _ n) (L _ typ)) <- lsigs
                           , let mbDoc = Map.lookup (docNameOrig n) docMap ]
        )

    instId = collapseId nm
    instancesBit
      | null instances = Html.emptyTable
      | otherwise 
        =  s8 </> instHdr instId </>
           tda [theclass "body"] << 
             collapsed thediv instId (
             spacedTable1 << (
               aboves (map (declBox . ppInstHead) instances)
             ))

ppInstHead :: InstHead DocName -> Html
ppInstHead ([],   n, ts) = ppAppNameTypes n ts 
ppInstHead (ctxt, n, ts) = ppContextNoLocs ctxt <+> ppAppNameTypes n ts 


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


-- TODO: print contexts
ppShortDataDecl :: Bool -> LinksInfo -> SrcSpan -> 
                   Maybe (HsDoc DocName) -> TyClDecl DocName -> Html
ppShortDataDecl summary links loc mbDoc dataDecl 

  | [lcon] <- cons, ResTyH98 <- resTy = 
    ppDataHeader summary dataDecl 
    <+> equals <+> ppShortConstr summary (unLoc lcon)

  | [] <- cons = ppDataHeader summary dataDecl

  | otherwise = vanillaTable << (
      case resTy of 
        ResTyH98 -> dataHeader </> 
          tda [theclass "body"] << vanillaTable << (
            aboves (zipWith doConstr ('=':repeat '|') cons)
          )
        ResTyGADT _ -> dataHeader </> 
          tda [theclass "body"] << vanillaTable << (
            aboves (map doGADTConstr cons)
          )
    )
  
  where
    dataHeader = 
      (if summary then declBox else topDeclBox links loc name)
      ((ppDataHeader summary dataDecl) <+> 
      case resTy of ResTyGADT _ -> keyword "where"; _ -> empty)

    doConstr c con = declBox (toHtml [c] <+> ppShortConstr summary (unLoc con))
    doGADTConstr con = declBox (ppShortConstr summary (unLoc con))

    name      = docNameOrig . unLoc . tcdLName $ dataDecl
    context   = unLoc (tcdCtxt dataDecl)
    newOrData = tcdND dataDecl
    tyVars    = tyvarNames (tcdTyVars dataDecl)
    mbKSig    = tcdKindSig dataDecl
    cons      = tcdCons dataDecl
    resTy     = (con_res . unLoc . head) cons 

ppDataDecl :: Ord key => Bool -> LinksInfo -> [InstHead DocName] -> key -> 
              SrcSpan -> Maybe (HsDoc DocName) -> TyClDecl DocName -> HtmlTable
ppDataDecl summary links instances x loc mbDoc dataDecl
  
  | summary = declWithDoc summary links loc name mbDoc 
              (ppShortDataDecl summary links loc mbDoc dataDecl)
  
  | otherwise
      = (if validTable then (</>) else const) dataHeader $
	      tda [theclass "body"] << vanillaTable << (
		      datadoc </> 
		      constrBit </>
		      instancesBit
        )


  where
    name      = docNameOrig . unLoc . tcdLName $ dataDecl
    context   = unLoc (tcdCtxt dataDecl)
    newOrData = tcdND dataDecl
    tyVars    = tyvarNames (tcdTyVars dataDecl)
    mbKSig    = tcdKindSig dataDecl
    cons      = tcdCons dataDecl
    resTy     = (con_res . unLoc . head) cons 
      
    dataHeader = 
      (if summary then declBox else topDeclBox links loc name)
      ((ppDataHeader summary dataDecl) <+> whereBit)

    whereBit 
      | null cons = empty 
      | otherwise = case resTy of 
        ResTyGADT _ -> keyword "where"
        _ -> empty                         

    constrTable
      | any isRecCon cons = spacedTable5
      | otherwise         = spacedTable1

    datadoc = case mbDoc of
      Just doc -> ndocBox (docToHtml doc)
      Nothing -> Html.emptyTable

    constrBit 
      | null cons = Html.emptyTable
      | otherwise = constrHdr </> ( 
          tda [theclass "body"] << constrTable << 
	  aboves (map ppSideBySideConstr cons)
        )

    instId = collapseId name

    instancesBit
      | null instances = Html.emptyTable
      | otherwise 
        = instHdr instId </>
	  tda [theclass "body"] << 
          collapsed thediv instId (
            spacedTable1 << (
              aboves (map (declBox . ppInstHead) instances)
            )
          )

    validTable = isJust mbDoc || not (null cons) || not (null instances)


isRecCon lcon = case con_details (unLoc lcon) of 
  RecCon _ -> True
  _ -> False

ppShortConstr :: Bool -> ConDecl DocName -> Html
ppShortConstr summary con = case con_res con of 

  ResTyH98 -> case con_details con of 
    PrefixCon args -> header +++ hsep (ppBinder summary occ : map ppLType args)
    RecCon fields -> header +++ ppBinder summary occ <+>
      braces (vanillaTable << aboves (map (ppShortField summary) fields))
    InfixCon arg1 arg2 -> header +++ 
      hsep [ppLType arg1, ppBinder summary occ, ppLType arg2]    

  ResTyGADT resTy -> case con_details con of 
    PrefixCon args -> doGADTCon args resTy
    RecCon _ -> error "GADT records not suported"
    InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy 
    
  where
    doGADTCon args resTy = ppBinder summary occ <+> dcolon <+> hsep [
                             ppForAll forall ltvs lcontext,
                             ppLType (foldr mkFunTy resTy args) ]

    header   = ppConstrHdr forall tyVars context
    occ      = docNameOcc . 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 :: HsExplicitForAll -> [Name] -> HsContext DocName -> Html
ppConstrHdr forall tvs ctxt
 = (if null tvs then noHtml else ppForall)
   +++
   (if null ctxt then noHtml else ppContextNoArrow ctxt <+> toHtml "=> ")
  where
    ppForall = case forall of 
      Explicit -> keyword "forall" <+> hsep (map ppName tvs) <+> toHtml ". "
      Implicit -> empty

ppSideBySideConstr :: LConDecl DocName -> HtmlTable
ppSideBySideConstr (L _ con) = case con_res con of 
 
  ResTyH98 -> case con_details con of 

    PrefixCon args -> 
      argBox (hsep ((header +++ ppBinder False occ) : map ppLType args)) 
      <-> maybeRDocBox mbLDoc  

    RecCon fields -> 
      argBox (header +++ ppBinder False occ) <->
      maybeRDocBox mbLDoc </>
      (tda [theclass "body"] << spacedTable1 <<
      aboves (map ppSideBySideField fields))

    InfixCon arg1 arg2 -> 
      argBox (hsep [header+++ppLType arg1, ppBinder False occ, ppLType arg2])
      <-> maybeRDocBox mbLDoc
 
  ResTyGADT resTy -> case con_details con of
    PrefixCon args -> doGADTCon args resTy
    RecCon _ -> error "GADT records not supported"
    InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy 

 where 
    doGADTCon args resTy = argBox (ppBinder False occ <+> dcolon <+> hsep [
                               ppForAll forall ltvs (con_cxt con),
                               ppLType (foldr mkFunTy resTy args) ]
                            ) <-> maybeRDocBox mbLDoc


    header  = ppConstrHdr forall tyVars context
    occ     = docNameOcc . unLoc . con_name $ con
    ltvs    = con_qvars con
    tyVars  = tyvarNames (con_qvars con)
    context = unLoc (con_cxt con)
    forall  = con_explicit con
    mbLDoc  = con_doc con
    mkFunTy a b = noLoc (HsFunTy a b)

ppSideBySideField :: ConDeclField DocName -> HtmlTable
ppSideBySideField (ConDeclField (L _ name) ltype mbLDoc) =
  argBox (ppBinder False (docNameOcc name)
    <+> dcolon <+> ppLType ltype) <->
  maybeRDocBox mbLDoc

{-
ppHsFullConstr :: HsConDecl -> Html
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 (docToHtml (fromJust doc))
	  | otherwise  = Html.emptyTable

	fields_html = 
	   td << 
	      table ! [width "100%", cellpadding 0, cellspacing 8] << (
		   aboves (map ppFullField (concat (map expandField fields)))
		)
-}

ppShortField :: Bool -> ConDeclField DocName -> HtmlTable
ppShortField summary (ConDeclField (L _ name) ltype _) 
  = tda [theclass "recfield"] << (
      ppBinder summary (docNameOcc name)
      <+> dcolon <+> ppLType ltype
    )

{-
ppFullField :: HsFieldDecl -> Html
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 :: Bool -> TyClDecl DocName -> Html
ppDataHeader summary decl 
  | not (isDataDecl decl) = error "ppDataHeader: illegal argument"
  | otherwise = 
    -- newtype or data
    (if tcdND decl == NewType then keyword "newtype" else keyword "data") <+> 
    -- context
    ppLContext (tcdCtxt decl) <+>
    -- T a b c ..., or a :+: b
    ppDataClassHead summary (unLoc $ tcdLName decl) (tyvarNames $ tcdTyVars decl)


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

ppKind k = toHtml $ showSDoc (ppr k)

{-
ppForAll Implicit _ lctxt = ppCtxtPart lctxt
ppForAll Explicit ltvs lctxt = 
  hsep (keyword "forall" : ppTyVars ltvs ++ [dot]) <+> ppCtxtPart lctxt 
-}

ppBang HsStrict = toHtml "!"
ppBang HsUnbox  = toHtml "!!"

tupleParens Boxed   = parenList
tupleParens Unboxed = ubxParenList 
{-
ppType :: HsType DocName -> Html
ppType t = case t of
  t@(HsForAllTy expl ltvs lcontext ltype) -> ppForAllTy t <+> ppLType ltype
  HsTyVar n -> ppDocName n
  HsBangTy HsStrict lt -> toHtml "!" <+> ppLType lt
  HsBangTy HsUnbox lt -> toHtml "!!" <+> ppLType lt
  HsAppTy a b -> ppLType a <+> ppLType b 
  HsFunTy a b -> hsep [ppLType a, toHtml "->", ppLType b]
  HsListTy t -> brackets $ ppLType t
  HsPArrTy t -> toHtml "[:" +++ ppLType t +++ toHtml ":]"
  HsTupleTy Boxed ts -> parenList $ map ppLType ts
  HsTupleTy Unboxed ts -> ubxParenList $ map ppLType ts
  HsOpTy a n b -> ppLType a <+> ppLDocName n <+> ppLType b
  HsParTy t -> parens $ ppLType t
  HsNumTy n -> toHtml (show n)
  HsPredTy p -> ppPred p
  HsKindSig t k -> hsep [ppLType t, dcolon, ppKind k]
  HsSpliceTy _ -> error "ppType"
  HsDocTy t _ -> ppLType t
-}
--------------------------------------------------------------------------------
-- Rendering of HsType 
--------------------------------------------------------------------------------

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


ppLTypes       = hsep . map ppLType
ppLParendTypes = hsep . map ppLParendType


ppParendTypes = hsep . map ppParendType


ppLType       = ppType . unLoc
ppLParendType = ppParendType . unLoc


ppType ty       = ppr_mono_ty pREC_TOP (prepare ty)
ppParendType ty = ppr_mono_ty pREC_CON ty


-- Before printing a type
-- (a) Remove outermost HsParTy parens
-- (b) Drop top-level for-all type variables in user style
--     since they are implicit in Haskell
prepare (HsParTy ty) = prepare (unLoc ty)
prepare ty           = ty

ppForAll exp tvs cxt 
  | show_forall = forall_part <+> ppLContext cxt
  | otherwise   = ppLContext cxt
  where
    show_forall = not (null tvs) && is_explicit
    is_explicit = case exp of {Explicit -> True; Implicit -> False}
    forall_part = hsep (keyword "forall" : ppTyVars tvs) +++ dot 

ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty)

ppr_mono_ty ctxt_prec (HsForAllTy exp tvs ctxt ty)
  = maybeParen ctxt_prec pREC_FUN $
    hsep [ppForAll exp tvs ctxt, ppr_mono_lty pREC_TOP ty]

-- gaw 2004
ppr_mono_ty ctxt_prec (HsBangTy b ty)     = ppBang b +++ ppLType ty
ppr_mono_ty ctxt_prec (HsTyVar name)      = ppDocName name
ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2)   = ppr_fun_ty ctxt_prec ty1 ty2
ppr_mono_ty ctxt_prec (HsTupleTy con tys) = tupleParens con (map ppLType tys)
ppr_mono_ty ctxt_prec (HsKindSig ty kind) = parens (ppr_mono_lty pREC_TOP ty <+> dcolon <+> ppKind kind)
ppr_mono_ty ctxt_prec (HsListTy ty)       = brackets (ppr_mono_lty pREC_TOP ty)
ppr_mono_ty ctxt_prec (HsPArrTy ty)       = pabrackets (ppr_mono_lty pREC_TOP ty)
ppr_mono_ty ctxt_prec (HsPredTy pred)     = parens (ppPred pred)
ppr_mono_ty ctxt_prec (HsNumTy n)         = toHtml (show n) -- generics only
ppr_mono_ty ctxt_prec (HsSpliceTy s)      = error "ppr_mono_ty-haddock"

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

ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2)
  = maybeParen ctxt_prec pREC_OP $
    ppr_mono_lty pREC_OP ty1 <+> ppr_op <+> ppr_mono_lty pREC_OP ty2
  where
    ppr_op = if not (isSymOcc occName) then quote (ppLDocName op) else ppLDocName op
    occName = docNameOcc . unLoc $ op

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

ppr_mono_ty ctxt_prec (HsDocTy ty doc)
  = ppLType ty

ppr_fun_ty ctxt_prec ty1 ty2
  = let p1 = ppr_mono_lty pREC_FUN ty1
        p2 = ppr_mono_lty pREC_TOP ty2
    in
    maybeParen ctxt_prec pREC_FUN $
    hsep [p1, arrow <+> p2]

-- ----------------------------------------------------------------------------
-- Names

ppOccName :: OccName -> Html
ppOccName = toHtml . occNameString

ppRdrName :: RdrName -> Html
ppRdrName = ppOccName . rdrNameOcc

ppLDocName (L _ d) = ppDocName d

ppDocName :: DocName -> Html
ppDocName (Documented name mod) = 
  linkIdOcc mod (Just occName) << ppOccName occName
    where occName = nameOccName name
ppDocName (Undocumented name) = toHtml (getOccString name)

linkTarget :: OccName -> Html
linkTarget n = namedAnchor (anchorNameStr n) << toHtml "" 

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 (anchorNameStr n) << ppBinder' n
ppBinder False n = linkTarget n +++ bold << ppBinder' n


ppBinder' :: OccName -> Html
ppBinder' n
  | isVarSym n = parens $ ppOccName n
  | otherwise  = ppOccName n


linkId mod mbName = linkIdOcc mod (fmap nameOccName mbName)


linkIdOcc :: Module -> Maybe OccName -> Html -> Html
linkIdOcc mod mbName = anchor ! [href hr]
  where 
    hr = case mbName of
      Nothing   -> moduleHtmlFile mod
      Just name -> nameHtmlRef mod name

ppModule :: Module -> String -> Html
ppModule mod ref = anchor ! [href ((moduleHtmlFile mod) ++ ref)] 
                   << toHtml (moduleString mod)

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

parHtmlMarkup :: (a -> Html) -> DocMarkup a Html
parHtmlMarkup ppId = Markup {
  markupParagraph     = paragraph,
  markupEmpty	      = toHtml "",
  markupString        = toHtml,
  markupAppend        = (+++),
  markupIdentifier    = tt . ppId . head,
  markupModule        = \m -> ppModule (mkModuleNoPkg m) "",
  markupEmphasis      = emphasize . toHtml,
  markupMonospaced    = tt . toHtml,
  markupUnorderedList = ulist . concatHtml . map (li <<),
  markupOrderedList   = olist . concatHtml . map (li <<),
  markupDefList       = dlist . concatHtml . map markupDef,
  markupCodeBlock     = pre,
  markupURL	      = \url -> anchor ! [href url] << toHtml url,
  markupAName	      = \aname -> namedAnchor aname << toHtml ""
  }

markupDef (a,b) = dterm << a +++ ddef << b

htmlMarkup = parHtmlMarkup ppDocName
htmlOrigMarkup = parHtmlMarkup ppName
htmlRdrMarkup = parHtmlMarkup ppRdrName

-- If the doc is a single paragraph, don't surround it with <P> (this causes
-- ugly extra whitespace with some browsers).
docToHtml :: GHC.HsDoc DocName -> Html
docToHtml doc = markup htmlMarkup (unParagraph (markup htmlCleanup doc))

origDocToHtml :: GHC.HsDoc GHC.Name -> Html
origDocToHtml doc = markup htmlOrigMarkup (unParagraph (markup htmlCleanup doc))

rdrDocToHtml doc = markup htmlRdrMarkup (unParagraph (markup htmlCleanup doc))

-- 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.
unParagraph (GHC.DocParagraph d) = d
--NO: This eliminates line breaks in the code block:  (SDM, 6/5/2003)
--unParagraph (DocCodeBlock d) = (DocMonospaced d)
unParagraph doc              = doc

htmlCleanup :: DocMarkup a (GHC.HsDoc a)
htmlCleanup = idMarkup { 
  markupUnorderedList = GHC.DocUnorderedList . map unParagraph,
  markupOrderedList   = GHC.DocOrderedList   . map unParagraph
  } 

-- -----------------------------------------------------------------------------
-- * Misc

hsep :: [Html] -> Html
hsep [] = noHtml
hsep htmls = foldr1 (\a b -> a+++" "+++b) htmls

infixr 8 <+>
(<+>) :: Html -> Html -> Html
a <+> b = Html (getHtmlElements (toHtml a) ++ HtmlString " ": getHtmlElements (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]

empty :: Html
empty  = noHtml


quote :: Html -> Html
quote h = char '`' +++ h +++ '`'


parens, brackets, 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

abovesSep :: HtmlTable -> [HtmlTable] -> HtmlTable
abovesSep _ []      = Html.emptyTable
abovesSep 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 "#)"

{-
text :: Html
text   = strAttr "TEXT"
-}

-- a box for displaying code
declBox :: Html -> HtmlTable
declBox html = tda [theclass "decl"] << html

-- a box for top level documented names
-- it adds a source and wiki link at the right hand side of the box
topDeclBox :: LinksInfo -> SrcSpan -> Name -> Html -> HtmlTable
topDeclBox ((_,_,Nothing), (_,_,Nothing), _) _ _ html = declBox html
topDeclBox ((_,_,maybe_source_url), (_,_,maybe_wiki_url), iface)
           loc name html =
  tda [theclass "topdecl"] <<
  (        table ! [theclass "declbar"] <<
	    ((tda [theclass "declname"] << html)
             <-> srcLink
             <-> wikiLink)
  )
  where srcLink =
          case maybe_source_url of
            Nothing  -> Html.emptyTable
            Just url -> tda [theclass "declbut"] <<
                          let url' = spliceURL (Just fname) (Just origMod)
                                               (Just name) (Just loc) url
                           in anchor ! [href url'] << toHtml "Source"

        -- for source links, we want to point to the original module,
        -- because only that will have the source.
        origMod = case Map.lookup (nameOccName name) (ifaceEnv iface) of
          Just n -> case nameModule_maybe n of
            Just m -> m
            Nothing -> mod
          _ -> error "This shouldn't happen (topDeclBox)"

        wikiLink =
          case maybe_wiki_url of
            Nothing  -> Html.emptyTable
            Just url -> tda [theclass "declbut"] <<
                          let url' = spliceURL (Just fname) (Just mod)
                                               (Just name) (Just loc) url
                           in anchor ! [href url'] << toHtml "Comments"
  
        mod = ifaceMod iface
        fname = unpackFS (srcSpanFile loc)


-- a box for displaying an 'argument' (some code which has text to the
-- right of it).  Wrapping is not allowed in these boxes, whereas it is
-- in a declBox.
argBox :: Html -> HtmlTable
argBox html = tda [theclass "arg"] << html

-- a box for displaying documentation, 
-- indented and with a little padding at the top
docBox :: Html -> HtmlTable
docBox html = tda [theclass "doc"] << html

-- a box for displaying documentation, not indented.
ndocBox :: Html -> HtmlTable
ndocBox html = tda [theclass "ndoc"] << html

-- a box for displaying documentation, padded on the left a little
rdocBox :: Html -> HtmlTable
rdocBox html = tda [theclass "rdoc"] << html

maybeRDocBox :: Maybe (GHC.LHsDoc DocName) -> HtmlTable
maybeRDocBox Nothing = rdocBox (noHtml)
maybeRDocBox (Just ldoc) = rdocBox (docToHtml (unLoc ldoc))

-- a box for the buttons at the top of the page
topButBox :: Html -> HtmlTable
topButBox html = tda [theclass "topbut"] << html

-- a vanilla table has width 100%, no border, no padding, no spacing
-- a narrow table is the same but without width 100%.
vanillaTable, narrowTable :: Html -> Html
vanillaTable = table ! [theclass "vanilla", cellspacing 0, cellpadding 0]
vanillaTable2 = table ! [theclass "vanilla2", cellspacing 0, cellpadding 0]
narrowTable  = table ! [theclass "narrow",  cellspacing 0, cellpadding 0]

spacedTable1, spacedTable5 :: Html -> Html
spacedTable1 = table ! [theclass "vanilla",  cellspacing 1, cellpadding 0]
spacedTable5 = table ! [theclass "vanilla",  cellspacing 5, cellpadding 0]

constrHdr, methHdr :: HtmlTable
constrHdr  = tda [ theclass "section4" ] << toHtml "Constructors"
methHdr    = tda [ theclass "section4" ] << toHtml "Methods"

instHdr :: String -> HtmlTable
instHdr id = 
  tda [ theclass "section4" ] << (collapsebutton id +++ toHtml " Instances")

dcolon, arrow, darrow :: Html
dcolon = toHtml "::"
arrow  = toHtml "->"
darrow = toHtml "=>"
dot    = toHtml "."

s8, s15 :: HtmlTable
s8  = tda [ theclass "s8" ]  << noHtml
s15 = tda [ theclass "s15" ] << noHtml

namedAnchor :: String -> Html -> Html
namedAnchor n = anchor ! [name (escapeStr n)]

--
-- A section of HTML which is collapsible via a +/- button.
--

-- TODO: Currently the initial state is non-collapsed. Change the 'minusFile'
-- below to a 'plusFile' and the 'display:block;' to a 'display:none;' when we
-- use cookies from JavaScript to have a more persistent state.

collapsebutton :: String -> Html
collapsebutton id = 
  image ! [ src minusFile, theclass "coll", onclick ("toggle(this,'" ++ id ++ "')"), alt "show/hide" ]

collapsed :: (HTML a) => (Html -> Html) -> String -> a -> Html
collapsed fn id html =
  fn ! [identifier id, thestyle "display:block;"] << html

-- A quote is a valid part of a Haskell identifier, but it would interfere with
-- the ECMA script string delimiter used in collapsebutton above.
collapseId :: Name -> String
collapseId nm = "i:" ++ escapeStr (getOccString nm)

linkedAnchor :: String -> Html -> Html
linkedAnchor frag = anchor ! [href hr]
   where hr | null frag = ""
            | otherwise = '#': escapeStr frag

documentCharacterEncoding :: Html
documentCharacterEncoding =
   meta ! [httpequiv "Content-Type", content "text/html; charset=UTF-8"]

styleSheet :: Html
styleSheet =
   thelink ! [href cssFile, rel "stylesheet", thetype "text/css"]