De-flatten the namespace

1 files changed, 1508 insertions, 0 deletions

diff --git a/src/Haddock/Html.hs b/src/Haddock/Html.hs
new file mode 100644
index 00000000..6bd80687
--- /dev/null
+++ b/src/Haddock/Html.hs
@@ -0,0 +1,1508 @@
+--
+-- Haddock - A Haskell Documentation Tool
+--
+-- (c) Simon Marlow 2003
+--
+
+module Haddock.Html ( 
+	ppHtml, copyHtmlBits, 
+	ppHtmlIndex, ppHtmlContents,
+	ppHtmlHelpFiles
+  ) where
+
+import Prelude hiding (div)
+
+import Haddock.DevHelp
+import Haddock.HH
+import Haddock.HH2
+import Haddock.ModuleTree
+import Haddock.Types
+import Haddock.Utils
+import Haddock.Version
+import Haddock.Utils.Html
+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 Debug.Trace           ( trace )
+import Data.Map              ( Map )
+import qualified Data.Map as Map hiding ( Map )
+
+import GHC 
+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
+	-> [HaddockModule]
+	-> 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 hmods odir prologue maybe_html_help_format
+	maybe_source_url maybe_wiki_url
+	maybe_contents_url maybe_index_url =  do
+  let
+	visible_hmods = filter visible hmods
+	visible i = OptHide `notElem` hmod_options 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
+	visible_hmods
+	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 visible_hmods
+    
+  when (not (isJust maybe_contents_url && isJust maybe_index_url)) $ 
+	ppHtmlHelpFiles doctitle maybe_package hmods odir maybe_html_help_format []
+
+  mapM_ (ppHtmlModule odir doctitle
+	   maybe_source_url maybe_wiki_url
+	   maybe_contents_url maybe_index_url) visible_hmods
+
+ppHtmlHelpFiles	
+    :: String                   -- doctitle
+    -> Maybe String				-- package
+	-> [HaddockModule]
+	-> FilePath                 -- destination directory
+	-> Maybe String             -- the Html Help format (--html-help)
+	-> [FilePath]               -- external packages paths
+	-> IO ()
+ppHtmlHelpFiles doctitle maybe_package hmods odir maybe_html_help_format pkg_paths =  do
+  let
+	visible_hmods = filter visible hmods
+	visible i = OptHide `notElem` hmod_options 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_hmods pkg_paths
+    Just "mshelp2" -> do
+		ppHH2Files      odir maybe_package visible_hmods pkg_paths
+		ppHH2Collection odir doctitle maybe_package
+    Just "devhelp" -> ppDevHelpFile odir doctitle maybe_package visible_hmods
+    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 HaddockModule -> HtmlTable
+srcButton (Just src_base_url, _, _) Nothing =
+  topButBox (anchor ! [href src_base_url] << toHtml "Source code")
+
+srcButton (_, Just src_module_url, _) (Just hmod) =
+  let url = spliceURL (Just $ hmod_orig_filename hmod)
+                      (Just $ hmod_mod hmod) Nothing src_module_url
+   in topButBox (anchor ! [href url] << toHtml "Source code")
+
+srcButton _ _ =
+  Html.emptyTable
+ 
+spliceURL :: Maybe FilePath -> Maybe Module -> Maybe GHC.Name -> String -> String
+spliceURL maybe_file maybe_mod maybe_name 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")
+
+  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 ('%':'{':'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 (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 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 -> HaddockModule -> String
+    -> SourceURLs -> WikiURLs
+    -> Maybe String -> Maybe String -> HtmlTable
+pageHeader mdl hmod 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 hmod) <->
+	wikiButton maybe_wiki_url (Just $ hmod_mod hmod) <->
+	contentsButton maybe_contents_url <->
+	indexButton maybe_index_url
+    )
+   ) </>
+   tda [theclass "modulebar"] <<
+	(vanillaTable << (
+	  (td << font ! [size "6"] << toHtml mdl) <->
+	  moduleInfo hmod
+	)
+    )
+
+moduleInfo :: HaddockModule -> HtmlTable
+moduleInfo hmod = 
+   let
+      info = hmod_info hmod
+
+      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
+   -> [HaddockModule] -> 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 modules showPkgs prologue = do
+  let tree = mkModuleTree showPkgs
+         [(hmod_mod mod, toDescription mod) | mod <- modules]
+      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, HaddockModule)
+
+
+-- ---------------------------------------------------------------------------
+-- Generate the index
+
+ppHtmlIndex :: FilePath
+            -> String 
+            -> Maybe String
+            -> Maybe String
+            -> Maybe String
+            -> SourceURLs
+            -> WikiURLs
+            -> [HaddockModule] 
+            -> IO ()
+ppHtmlIndex odir doctitle maybe_package maybe_html_help_format
+  maybe_contents_url maybe_source_url maybe_wiki_url modules = do
+  let html = 
+	header (documentCharacterEncoding +++
+		thetitle (toHtml (doctitle ++ " (Index)")) +++
+		styleSheet) +++
+        body << vanillaTable << (
+	    simpleHeader doctitle maybe_contents_url Nothing
+                         maybe_source_url maybe_wiki_url </>
+	    index_html
+	   )
+
+  when split_indices $
+    mapM_ (do_sub_index index) initialChars
+
+  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 modules
+    Just "mshelp2" -> ppHH2Index odir maybe_package modules
+    Just "devhelp" -> return ()
+    Just format    -> fail ("The "++format++" format is not implemented")
+ where
+  split_indices = length index > 50
+
+  index_html
+    | split_indices = 
+	tda [theclass "section1"] << 
+	      	toHtml ("Index") </>
+	indexInitialLetterLinks
+   | otherwise =
+	td << table ! [cellpadding 0, cellspacing 5] <<
+	  aboves (map indexElt index) 
+ 	
+  indexInitialLetterLinks = 
+	td << table ! [cellpadding 0, cellspacing 5] <<
+	    besides [ td << anchor ! [href (subIndexHtmlFile c)] <<
+			 toHtml [c]
+		    | c <- initialChars
+                    , any ((==c) . toUpper . head . fst) index ]
+
+  do_sub_index this_ix c
+    = unless (null index_part) $
+        writeFile (pathJoin [odir, subIndexHtmlFile c]) (renderHtml html)
+    where 
+      html = header (documentCharacterEncoding +++
+		thetitle (toHtml (doctitle ++ " (Index)")) +++
+		styleSheet) +++
+             body << vanillaTable << (
+	        simpleHeader doctitle maybe_contents_url Nothing
+                             maybe_source_url maybe_wiki_url </>
+		indexInitialLetterLinks </>
+	        tda [theclass "section1"] << 
+	      	toHtml ("Index (" ++ c:")") </>
+	        td << table ! [cellpadding 0, cellspacing 5] <<
+	      	  aboves (map indexElt 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,_) = n1 `compare` 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 getHModIndex modules))
+
+  getHModIndex hmod = 
+    [ (getOccString name, 
+	Map.fromList [(name, [(mdl, name `elem` hmod_visible_exports hmod)])])
+    | name <- hmod_exports hmod ]
+    where mdl = hmod_mod hmod
+
+  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 ])
+
+  initialChars = [ 'A'..'Z' ] ++ ":!#$%&*+./<=>?@\\^|-~"
+
+-- ---------------------------------------------------------------------------
+-- Generate the HTML page for a module
+
+ppHtmlModule
+	:: FilePath -> String
+	-> SourceURLs -> WikiURLs
+	-> Maybe String -> Maybe String
+	-> HaddockModule -> IO ()
+ppHtmlModule odir doctitle
+  maybe_source_url maybe_wiki_url
+  maybe_contents_url maybe_index_url hmod = do
+  let 
+      mod = hmod_mod hmod
+      mdl = moduleString mod
+      html = 
+	header (documentCharacterEncoding +++
+		thetitle (toHtml mdl) +++
+		styleSheet +++
+		(script ! [src jsFile, thetype "text/javascript"] $ noHtml)) +++
+        body << vanillaTable << (
+	    pageHeader mdl hmod doctitle
+		maybe_source_url maybe_wiki_url
+		maybe_contents_url maybe_index_url </> s15 </>
+	    hmodToHtml maybe_source_url maybe_wiki_url hmod </> s15 </>
+	    footer
+         )
+  writeFile (pathJoin [odir, moduleHtmlFile mod]) (renderHtml html)
+
+hmodToHtml :: SourceURLs -> WikiURLs -> HaddockModule -> HtmlTable
+hmodToHtml maybe_source_url maybe_wiki_url hmod
+  = abovesSep s15 (contents: description: synopsis: maybe_doc_hdr: bdy)
+  where
+        docMap = hmod_rn_doc_map hmod
+ 
+	exports = numberSectionHeadings (hmod_rn_export_items hmod)
+
+	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 = td << vanillaTable << ppModuleContents exports
+
+	description
+          = case hmod_rn_doc hmod 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, hmod)
+
+ppModuleContents :: [ExportItem DocName] -> HtmlTable
+ppModuleContents exports
+  | length sections == 0 = Html.emptyTable
+  | otherwise            = 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 s) = ppSig summary links loc mbDoc s
+    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
+
+ppSig :: Bool -> LinksInfo -> SrcSpan -> Maybe (HsDoc DocName) -> Sig DocName -> HtmlTable
+ppSig summary links loc mbDoc (TypeSig lname ltype) 
+  | summary || noArgDocs t = 
+    declWithDoc summary links loc n mbDoc (ppTypeSig summary n t)
+  | otherwise = topDeclBox links loc n (ppBinder False n) </>
+    (tda [theclass "body"] << vanillaTable <<  (
+      do_args dcolon t </>
+        (case mbDoc of 
+          Just doc -> ndocBox (docToHtml doc)
+          Nothing -> Html.emptyTable)
+	))
+
+  where 
+  t = unLoc ltype
+  NoLink n = unLoc lname
+
+  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 = map ppName (tyvarNames tvs)
+
+tyvarNames = map f 
+  where f x = let NoLink n = hsTyVarName (unLoc x) in n
+  
+ppFor summary links loc mbDoc (ForeignImport lname ltype _)
+  = ppSig summary links loc mbDoc (TypeSig lname ltype)
+ppFor _ _ _ _ _ = error "ppFor"
+
+-- we skip type patterns for now
+ppTySyn summary links loc mbDoc (TySynonym lname ltyvars _ ltype) 
+  = declWithDoc summary links loc n mbDoc (
+    hsep ([keyword "type", ppBinder summary n]
+    ++ ppTyVars ltyvars) <+> equals <+> ppLType ltype)
+  where NoLink n = unLoc lname
+
+ppLType (L _ t) = ppType t
+
+ppTypeSig :: Bool -> Name -> (HsType DocName) -> Html
+ppTypeSig summary nm ty = ppBinder summary nm <+> dcolon <+> ppType ty
+
+--------------------------------------------------------------------------------
+-- 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) = ppDocName n <+> hsep (map ppLType ts)
+-- TODO: find out what happened to the Dupable/Linear distinction
+ppPred (HsIParam (IPName n) t) 
+  = toHtml "?" +++ ppDocName n <+> dcolon <+> ppLType t
+
+-- -----------------------------------------------------------------------------
+-- Class declarations
+
+ppClassHdr summ (L _ []) n tvs fds = 
+  keyword "class"
+	<+> ppBinder summ n <+> hsep (ppTyVars tvs)
+	<+> ppFds fds
+ppClassHdr summ lctxt n tvs fds = 
+  keyword "class" <+> ppLContext lctxt
+	<+> ppBinder summ n <+> hsep (ppTyVars 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 ] ++
+	        [ ppSig summary links loc mbDoc sig  
+		      | L _ sig@(TypeSig (L _ (NoLink n)) ty) <- sigs, let mbDoc = Map.lookup n docMap ])
+          )
+  where
+    hdr = ppClassHdr summary lctxt nm tvs fds
+    NoLink nm = 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")
+
+    NoLink nm = unLoc lname
+    ctxt = unLoc lctxt
+
+    hdr = ppClassHdr summary lctxt nm 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 [ ppSig summary links loc mbDoc sig
+                         | L _ sig@(TypeSig n _) <- lsigs, 
+                         let mbDoc = Map.lookup (orig 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) = ppAsst n ts 
+ppInstHead (ctxt, n, ts) = ppContextNoLocs ctxt <+> ppAsst n ts 
+
+ppAsst n ts = ppDocName n <+> hsep (map ppParendType ts)
+
+-- -----------------------------------------------------------------------------
+-- Data & newtype declarations
+
+orig (L _ (NoLink name)) = name
+orig _ = error "orig"
+
+-- 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      = orig (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 = dataHeader </> 
+    tda [theclass "body"] << vanillaTable << (
+      datadoc </> 
+      constrBit </>
+      instancesBit
+    )
+  
+  where
+    name      = orig (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)
+            )
+          )
+
+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 name : map ppLType args)
+    RecCon fields -> header +++ ppBinder summary name <+>
+      braces (vanillaTable << aboves (map (ppShortField summary) fields))
+    InfixCon arg1 arg2 -> header +++ 
+      hsep [ppLType arg1, ppBinder summary name, 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 name <+> dcolon <+> hsep [
+                             ppForAll forall ltvs lcontext,
+                             ppLType (foldr mkFunTy resTy args) ]
+
+    header   = ppConstrHdr forall tyVars context
+    name     = orig (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 ppContext 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 name) : map ppLType args)) 
+      <-> maybeRDocBox mbLDoc  
+
+    RecCon fields -> 
+      argBox (header +++ ppBinder False name) <->
+      maybeRDocBox mbLDoc </>
+      (tda [theclass "body"] << spacedTable1 <<
+      aboves (map ppSideBySideField fields))
+
+    InfixCon arg1 arg2 -> 
+      argBox (hsep [header+++ppLType arg1, ppBinder False name, 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 name <+> dcolon <+> hsep [
+                               ppForAll forall ltvs (con_cxt con),
+                               ppLType (foldr mkFunTy resTy args) ]
+                            ) <-> maybeRDocBox mbLDoc
+
+
+    header  = ppConstrHdr forall tyVars context
+    name    = orig (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 :: HsRecField DocName (LHsType DocName) -> HtmlTable
+ppSideBySideField (HsRecField lname ltype mbLDoc) =
+  argBox (ppBinder False (orig lname)
+    <+> 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 -> HsRecField DocName (LHsType DocName)-> HtmlTable
+ppShortField summary (HsRecField lname ltype mbLDoc) 
+  = tda [theclass "recfield"] << (
+      ppBinder summary (orig lname)
+      <+> 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  
+    (if isConSym name 
+      then ppName (tyvars!!0) <+> ppBinder summary name <+> ppName (tyvars!!1)
+      else ppBinder summary name <+> hsep (map ppName tyvars))
+  where 
+    tyvars = tyvarNames $ tcdTyVars decl
+    name = orig $ tcdLName 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
+
+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 <+> ppLDocName op <+> ppr_mono_lty pREC_OP ty2
+
+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 name = toHtml $ occNameString name
+
+ppRdrName :: RdrName -> Html
+ppRdrName = ppOccName . rdrNameOcc
+
+ppLDocName (L _ d) = ppDocName d
+
+ppDocName :: DocName -> Html
+ppDocName (Link name) = linkId (nameModule name) (Just name) << ppName name
+ppDocName (NoLink name) = toHtml (getOccString name)
+
+linkTarget :: Name -> Html
+linkTarget name = namedAnchor (anchorNameStr name) << toHtml "" 
+
+ppName :: Name -> Html
+ppName name = toHtml (getOccString name)
+
+ppBinder :: Bool -> Name -> 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 nm = linkedAnchor (anchorNameStr nm) << ppBinder' nm
+ppBinder False nm = linkTarget nm +++ bold << ppBinder' nm
+
+ppBinder' :: Name -> Html
+ppBinder' name 
+  | isVarSym name = parens $ toHtml (getOccString name)
+  | otherwise = toHtml (getOccString name)             
+
+linkId :: Module -> Maybe Name -> Html -> Html
+linkId 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
+
+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), hmod)
+           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 mod)
+                                               (Just name) url
+                           in anchor ! [href url'] << toHtml "Source"
+        wikiLink =
+          case maybe_wiki_url of
+            Nothing  -> Html.emptyTable
+            Just url -> tda [theclass "declbut"] <<
+                          let url' = spliceURL (Just fname) (Just mod)
+                                               (Just name) url
+                           in anchor ! [href url'] << toHtml "Comments"
+  
+        mod = hmod_mod hmod
+        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"]