From 11ebf08d5ef30375ba5585b6079f696d49402c3f Mon Sep 17 00:00:00 2001
From: "davve@dtek.chalmers.se" <David Waern>
Date: Sun, 25 Mar 2007 01:23:25 +0000
Subject: De-flatten the namespace

---
 src/Haddock/DevHelp.hs           |   75 ++
 src/Haddock/HH.hs                |  174 +++++
 src/Haddock/HH2.hs               |  182 +++++
 src/Haddock/HaddockDB.hs         |  165 +++++
 src/Haddock/Hoogle.hs            |  184 +++++
 src/Haddock/Html.hs              | 1508 ++++++++++++++++++++++++++++++++++++++
 src/Haddock/InterfaceFile.hs     |    2 +-
 src/Haddock/ModuleTree.hs        |   38 +
 src/Haddock/Rename.hs            |  320 ++++++++
 src/Haddock/Types.hs             |  123 ++++
 src/Haddock/Utils.hs             |  340 +++++++++
 src/Haddock/Utils/BlockTable.hs  |  180 +++++
 src/Haddock/Utils/FastMutInt2.hs |   63 ++
 src/Haddock/Utils/GHC.hs         |   26 +
 src/Haddock/Utils/Html.hs        | 1037 ++++++++++++++++++++++++++
 src/Haddock/Version.hs           |   18 +
 16 files changed, 4434 insertions(+), 1 deletion(-)
 create mode 100644 src/Haddock/DevHelp.hs
 create mode 100644 src/Haddock/HH.hs
 create mode 100644 src/Haddock/HH2.hs
 create mode 100644 src/Haddock/HaddockDB.hs
 create mode 100644 src/Haddock/Hoogle.hs
 create mode 100644 src/Haddock/Html.hs
 create mode 100644 src/Haddock/ModuleTree.hs
 create mode 100644 src/Haddock/Rename.hs
 create mode 100644 src/Haddock/Types.hs
 create mode 100644 src/Haddock/Utils.hs
 create mode 100644 src/Haddock/Utils/BlockTable.hs
 create mode 100644 src/Haddock/Utils/FastMutInt2.hs
 create mode 100644 src/Haddock/Utils/GHC.hs
 create mode 100644 src/Haddock/Utils/Html.hs
 create mode 100644 src/Haddock/Version.hs

(limited to 'src/Haddock')

diff --git a/src/Haddock/DevHelp.hs b/src/Haddock/DevHelp.hs
new file mode 100644
index 00000000..afcbd1c3
--- /dev/null
+++ b/src/Haddock/DevHelp.hs
@@ -0,0 +1,75 @@
+module Haddock.DevHelp(ppDevHelpFile) where
+
+import Haddock.ModuleTree
+import Haddock.Types
+import Haddock.Utils
+
+import Module        ( moduleName, moduleNameString, Module, mkModule, mkModuleName )
+import PackageConfig ( stringToPackageId )
+import Name          ( Name, nameModule, getOccString )
+
+import Data.Maybe    ( fromMaybe )
+import qualified Data.Map as Map
+import Text.PrettyPrint
+
+ppDevHelpFile :: FilePath -> String -> Maybe String -> [HaddockModule] -> IO ()
+ppDevHelpFile odir doctitle maybe_package modules = do
+  let devHelpFile = package++".devhelp"
+      tree = mkModuleTree True [ (hmod_mod mod, toDescription mod) | mod <- modules ]
+      doc =
+        text "<?xml version=\"1.0\" encoding=\"utf-8\" standalone=\"no\"?>" $$
+        (text "<book xmlns=\"http://www.devhelp.net/book\" title=\""<>text doctitle<>
+            text "\" link=\""<>text contentsHtmlFile<>text"\" author=\"\" name=\""<>text package<>text "\">") $$
+        text "<chapters>" $$
+        nest 4 (ppModuleTree [] tree) $+$
+        text "</chapters>" $$
+        text "<functions>" $$
+        nest 4 (ppList index) $+$
+        text "</functions>" $$
+        text "</book>"
+  writeFile (pathJoin [odir, devHelpFile]) (render doc)
+  where    
+    package = fromMaybe "pkg" maybe_package
+
+    ppModuleTree :: [String] -> [ModuleTree] -> Doc
+    ppModuleTree ss [x]    = ppNode ss x
+    ppModuleTree ss (x:xs) = ppNode ss x $$ ppModuleTree ss xs
+    ppModuleTree _  []     = error "HaddockHH.ppHHContents.fn: no module trees given"
+
+    ppNode :: [String] -> ModuleTree -> Doc
+    ppNode ss (Node s leaf _ _short ts) =
+        case ts of
+          [] -> text "<sub"<+>ppAttribs<>text "/>"
+          ts -> 
+            text "<sub"<+>ppAttribs<>text ">" $$
+            nest 4 (ppModuleTree (s:ss) ts) $+$
+            text "</sub>"
+        where
+          ppLink | leaf      = text (moduleHtmlFile (mkModule (stringToPackageId "") 
+                                                              (mkModuleName mdl)))
+                 | otherwise = empty
+
+          ppAttribs = text "name="<>doubleQuotes (text s)<+>text "link="<>doubleQuotes ppLink
+
+          mdl = foldr (++) "" (s' : map ('.':) ss')
+          (s':ss') = reverse (s:ss)
+		-- reconstruct the module name
+
+    index :: [(Name, [Module])]
+    index = Map.toAscList (foldr getModuleIndex Map.empty modules)
+
+    getModuleIndex hmod fm =
+	Map.unionWith (++) (Map.fromListWith (flip (++)) [(name, [mod]) | name <- hmod_exports hmod, nameModule name == mod]) fm
+	where mod = hmod_mod hmod
+
+    ppList :: [(Name, [Module])] -> Doc
+    ppList [] = empty
+    ppList ((name,refs):mdls)  =
+      ppReference name refs $$
+      ppList mdls
+
+    ppReference :: Name -> [Module] -> Doc
+    ppReference name [] = empty
+    ppReference name (mod:refs) =  
+      text "<function name=\""<>text (escapeStr (getOccString name))<>text"\" link=\""<>text (nameHtmlRef mod name)<>text"\"/>" $$
+      ppReference name refs
diff --git a/src/Haddock/HH.hs b/src/Haddock/HH.hs
new file mode 100644
index 00000000..a41d7297
--- /dev/null
+++ b/src/Haddock/HH.hs
@@ -0,0 +1,174 @@
+module Haddock.HH(ppHHContents, ppHHIndex, ppHHProject) where
+
+ppHHContents = error "not yet"
+ppHHIndex = error "not yet"
+ppHHProject = error "not yet"
+
+{-
+import HaddockModuleTree
+import HaddockTypes
+import HaddockUtil
+import HsSyn2 hiding(Doc)
+import qualified Map
+
+import Data.Char ( toUpper )
+import Data.Maybe ( fromMaybe )
+import Text.PrettyPrint
+
+ppHHContents :: FilePath -> String -> Maybe String -> [ModuleTree] -> IO ()
+ppHHContents odir doctitle maybe_package tree = do
+  let contentsHHFile = package++".hhc"
+
+      html =
+      	text "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">" $$
+	text "<HTML>" $$
+	text "<HEAD>" $$
+	text "<META name=\"GENERATOR\" content=\"Haddock\">" $$
+	text "<!-- Sitemap 1.0 -->" $$
+	text "</HEAD><BODY>" $$
+	ppModuleTree tree $$
+	text "</BODY><HTML>"
+  writeFile (pathJoin [odir, contentsHHFile]) (render html)
+  where
+	package = fromMaybe "pkg" maybe_package
+	
+	ppModuleTree :: [ModuleTree] -> Doc
+	ppModuleTree ts =
+		text "<OBJECT type=\"text/site properties\">" $$
+		text "<PARAM name=\"FrameName\" value=\"main\">" $$
+		text "</OBJECT>" $$
+		text "<UL>" $+$
+		nest 4 (text "<LI>" <> nest 4
+		                (text "<OBJECT type=\"text/sitemap\">" $$
+		                 nest 4 (text "<PARAM name=\"Name\" value=\""<>text doctitle<>text "\">" $$
+		                         text "<PARAM name=\"Local\" value=\"index.html\">") $$
+		                 text "</OBJECT>") $+$
+		        text "</LI>" $$
+		        text "<UL>" $+$
+		        nest 4 (fn [] ts) $+$
+		        text "</UL>") $+$
+		text "</UL>"
+
+	fn :: [String] -> [ModuleTree] -> Doc
+	fn ss [x]    = ppNode ss x
+	fn ss (x:xs) = ppNode ss x $$ fn ss xs
+        fn _  []     = error "HaddockHH.ppHHContents.fn: no module trees given"
+
+	ppNode :: [String] -> ModuleTree -> Doc
+	ppNode ss (Node s leaf _pkg _ []) =
+	  ppLeaf s ss leaf
+	ppNode ss (Node s leaf _pkg _ ts) =
+	  ppLeaf s ss leaf $$
+	  text "<UL>" $+$
+	  nest 4 (fn (s:ss) ts) $+$
+	  text "</UL>"
+
+	ppLeaf s ss isleaf  =
+		text "<LI>" <> nest 4
+			(text "<OBJECT type=\"text/sitemap\">" $$
+			 text "<PARAM name=\"Name\" value=\"" <> text s <> text "\">" $$
+			 (if isleaf then text "<PARAM name=\"Local\" value=\"" <> text (moduleHtmlFile mdl) <> text "\">" else empty) $$
+			 text "</OBJECT>") $+$
+		text "</LI>"
+		where 
+			mdl = foldr (++) "" (s' : map ('.':) ss')
+			(s':ss') = reverse (s:ss)
+			-- reconstruct the module name
+		
+-------------------------------
+ppHHIndex :: FilePath -> Maybe String -> [Interface] -> IO ()
+ppHHIndex odir maybe_package ifaces = do
+  let indexHHFile = package++".hhk"
+  
+      html = 
+      	text "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">" $$
+	text "<HTML>" $$
+	text "<HEAD>" $$
+	text "<META name=\"GENERATOR\" content=\"Haddock\">" $$
+	text "<!-- Sitemap 1.0 -->" $$
+	text "</HEAD><BODY>" $$
+	text "<UL>" $+$
+	nest 4 (ppList index) $+$
+	text "</UL>" $$
+	text "</BODY><HTML>"
+  writeFile (pathJoin [odir, indexHHFile]) (render html)
+  where
+	package = fromMaybe "pkg" maybe_package
+  	
+	index :: [(HsName, [Module])]
+	index = Map.toAscList (foldr getIfaceIndex Map.empty ifaces)
+
+	getIfaceIndex iface fm =
+		foldl (\m (k,e) -> Map.insertWith (++) k e m) fm [(name, [mdl]) | (name, Qual mdl' _) <- Map.toAscList (iface_env iface), mdl == mdl']
+		where mdl = iface_module iface
+	
+	ppList [] = empty
+	ppList ((name,refs):mdls)  =
+		text "<LI>" <> nest 4
+				(text "<OBJECT type=\"text/sitemap\">" $$
+				 text "<PARAM name=\"Name\" value=\"" <> text (show name) <> text "\">" $$
+				 ppReference name refs $$
+				 text "</OBJECT>") $+$
+		text "</LI>" $$
+		ppList mdls
+
+	ppReference name [] = empty
+	ppReference name (Module mdl:refs) =
+		text "<PARAM name=\"Local\" value=\"" <> text (nameHtmlRef mdl name) <> text "\">" $$
+		ppReference name refs
+
+
+ppHHProject :: FilePath -> String -> Maybe String -> [Interface] -> [FilePath] -> IO ()
+ppHHProject odir doctitle maybe_package ifaces pkg_paths = do
+  let projectHHFile = package++".hhp"
+      doc =
+        text "[OPTIONS]" $$
+        text "Compatibility=1.1 or later" $$
+        text "Compiled file=" <> text package <> text ".chm" $$
+        text "Contents file=" <> text package <> text ".hhc" $$
+        text "Default topic=" <> text contentsHtmlFile $$
+        text "Display compile progress=No" $$
+        text "Index file=" <> text package <> text ".hhk" $$
+        text "Title=" <> text doctitle $$
+	space $$
+        text "[FILES]" $$
+        ppMods ifaces $$
+        text contentsHtmlFile $$
+        text indexHtmlFile $$
+        ppIndexFiles chars $$
+        ppLibFiles ("":pkg_paths)
+  writeFile (pathJoin [odir, projectHHFile]) (render doc)
+  where
+    package = fromMaybe "pkg" maybe_package
+	
+    ppMods [] = empty
+    ppMods (iface:ifaces) =
+	let Module mdl = iface_module iface in
+        text (moduleHtmlFile mdl) $$
+        ppMods ifaces
+		
+    ppIndexFiles []     = empty
+    ppIndexFiles (c:cs) =
+        text (subIndexHtmlFile c) $$
+        ppIndexFiles cs
+        
+    ppLibFiles []           = empty
+    ppLibFiles (path:paths) =
+        ppLibFile cssFile   $$
+    	ppLibFile iconFile  $$
+    	ppLibFile jsFile    $$
+    	ppLibFile plusFile  $$
+        ppLibFile minusFile $$
+        ppLibFiles paths
+        where
+            toPath fname | null path = fname
+	                 | otherwise = pathJoin [path, fname]
+            ppLibFile fname = text (toPath fname)
+
+    chars :: [Char]
+    chars = map fst (Map.toAscList (foldr getIfaceIndex Map.empty ifaces))
+
+    getIfaceIndex iface fm =
+        Map.union (Map.fromList [(toUpper (head (show name)),()) | (name, Qual mdl' _) <- Map.toAscList (iface_env iface), mdl == mdl']) fm
+	where mdl = iface_module iface
+-}
diff --git a/src/Haddock/HH2.hs b/src/Haddock/HH2.hs
new file mode 100644
index 00000000..945734e6
--- /dev/null
+++ b/src/Haddock/HH2.hs
@@ -0,0 +1,182 @@
+module Haddock.HH2(ppHH2Contents, ppHH2Index, ppHH2Files, ppHH2Collection) where
+
+ppHH2Contents = error "not yet"
+ppHH2Index = error "not yet"
+ppHH2Files = error "not yet"
+ppHH2Collection = error "not yet"
+
+{-
+import HaddockModuleTree
+import HaddockTypes
+import HaddockUtil
+import HsSyn2 hiding(Doc)
+import qualified Map
+
+import Data.Char ( toUpper )
+import Data.Maybe ( fromMaybe )
+import Text.PrettyPrint
+
+ppHH2Contents :: FilePath -> String -> Maybe String -> [ModuleTree] -> IO ()
+ppHH2Contents odir doctitle maybe_package tree = do
+  let 	
+	contentsHH2File = package++".HxT"
+
+	doc  =
+		text "<?xml version=\"1.0\"?>" $$
+		text "<!DOCTYPE HelpTOC SYSTEM \"ms-help://hx/resources/HelpTOC.DTD\">" $$
+		text "<HelpTOC DTDVersion=\"1.0\">" $$
+		nest 4 (text "<HelpTOCNode Title=\""<>text doctitle<>text"\" Url=\"index.html\">" $$
+		        nest 4 (ppModuleTree [] tree) $+$
+		        text "</HelpTOCNode>") $$
+		text "</HelpTOC>"
+  writeFile (pathJoin [odir, contentsHH2File]) (render doc)
+  where
+	package = fromMaybe "pkg" maybe_package
+	
+	ppModuleTree :: [String] -> [ModuleTree] -> Doc
+	ppModuleTree ss [x]    = ppNode ss x
+	ppModuleTree ss (x:xs) = ppNode ss x $$ ppModuleTree ss xs
+	ppModuleTree _  []     = error "HaddockHH2.ppHH2Contents.ppModuleTree: no module trees given"
+
+	ppNode :: [String] -> ModuleTree -> Doc
+	ppNode ss (Node s leaf _pkg _short []) =
+	  text "<HelpTOCNode"  <+> ppAttributes leaf (s:ss) <> text "/>"
+	ppNode ss (Node s leaf _pkg _short ts) =
+	  text "<HelpTOCNode" <+> ppAttributes leaf (s:ss) <> text ">" $$
+	  nest 4 (ppModuleTree (s:ss) ts) $+$
+	  text "</HelpTOCNode>"
+			
+	ppAttributes :: Bool -> [String] -> Doc
+	ppAttributes isleaf ss = hsep [ppId,ppTitle,ppUrl]
+	  where
+	    mdl = foldr (++) "" (s' : map ('.':) ss')
+	    (s':ss') = reverse ss
+	                -- reconstruct the module name
+	    
+	    ppId = text "Id=" <> doubleQuotes (text mdl)
+	    
+	    ppTitle = text "Title=" <> doubleQuotes (text (head ss))
+	    
+	    ppUrl | isleaf    = text " Url=" <> doubleQuotes (text (moduleHtmlFile mdl))
+	          | otherwise = empty
+
+-----------------------------------------------------------------------------------
+
+ppHH2Index :: FilePath -> Maybe String -> [Interface] -> IO ()
+ppHH2Index odir maybe_package ifaces = do
+  let 
+	indexKHH2File     = package++"K.HxK"
+	indexNHH2File     = package++"N.HxK"
+	docK = 
+		text "<?xml version=\"1.0\"?>" $$
+		text "<!DOCTYPE HelpIndex SYSTEM \"ms-help://hx/resources/HelpIndex.DTD\">" $$
+		text "<HelpIndex DTDVersion=\"1.0\" Name=\"K\">" $$
+		nest 4 (ppList index) $+$
+		text "</HelpIndex>"  
+	docN = 
+		text "<?xml version=\"1.0\"?>" $$
+		text "<!DOCTYPE HelpIndex SYSTEM \"ms-help://hx/resources/HelpIndex.DTD\">" $$
+		text "<HelpIndex DTDVersion=\"1.0\" Name=\"NamedURLIndex\">" $$
+		text "<Keyword Term=\"HomePage\">" $$
+		nest 4 (text "<Jump Url=\""<>text contentsHtmlFile<>text "\"/>") $$
+		text "</Keyword>" $$
+		text "</HelpIndex>"
+  writeFile (pathJoin [odir, indexKHH2File]) (render docK)
+  writeFile (pathJoin [odir, indexNHH2File]) (render docN)
+  where
+	package = fromMaybe "pkg" maybe_package
+    
+	index :: [(HsName, [Module])]
+	index = Map.toAscList (foldr getIfaceIndex Map.empty ifaces)
+
+	getIfaceIndex iface fm =
+	    Map.unionWith (++) (Map.fromListWith (flip (++)) [(name, [mdl]) | (name, Qual mdl' _) <- Map.toAscList (iface_env iface), mdl == mdl']) fm
+	    where mdl = iface_module iface
+	
+	ppList [] = empty
+	ppList ((name,mdls):vs)  =
+		text "<Keyword Term=\"" <> text (escapeStr (show name)) <> text "\">" $$
+		nest 4 (vcat (map (ppJump name) mdls)) $$
+		text "</Keyword>" $$
+		ppList vs
+
+	ppJump name (Module mdl) = text "<Jump Url=\"" <> text (nameHtmlRef mdl name) <> text "\"/>"
+
+
+-----------------------------------------------------------------------------------
+
+ppHH2Files :: FilePath -> Maybe String -> [Interface] -> [FilePath] -> IO ()
+ppHH2Files odir maybe_package ifaces pkg_paths = do
+  let filesHH2File = package++".HxF"
+      doc =
+        text "<?xml version=\"1.0\"?>" $$
+        text "<!DOCTYPE HelpFileList SYSTEM \"ms-help://hx/resources/HelpFileList.DTD\">" $$
+        text "<HelpFileList DTDVersion=\"1.0\">" $$
+        nest 4 (ppMods ifaces $$
+                text "<File Url=\""<>text contentsHtmlFile<>text "\"/>" $$
+                text "<File Url=\""<>text indexHtmlFile<>text "\"/>" $$
+                ppIndexFiles chars $$
+                ppLibFiles ("":pkg_paths)) $$
+        text "</HelpFileList>"
+  writeFile (pathJoin [odir, filesHH2File]) (render doc)
+  where
+    package = fromMaybe "pkg" maybe_package
+	
+    ppMods [] = empty
+    ppMods (iface:ifaces) =
+		text "<File Url=\"" <> text (moduleHtmlFile mdl) <> text "\"/>" $$
+		ppMods ifaces
+		where Module mdl = iface_module iface
+		
+    ppIndexFiles []     = empty
+    ppIndexFiles (c:cs) =
+        text "<File Url=\""<>text (subIndexHtmlFile c)<>text "\"/>" $$
+        ppIndexFiles cs
+        
+    ppLibFiles []           = empty
+    ppLibFiles (path:paths) =        
+        ppLibFile cssFile   $$
+	ppLibFile iconFile  $$
+	ppLibFile jsFile    $$
+	ppLibFile plusFile  $$
+        ppLibFile minusFile $$
+        ppLibFiles paths
+        where
+            toPath fname | null path = fname
+                         | otherwise = pathJoin [path, fname]
+            ppLibFile fname = text "<File Url=\""<>text (toPath fname)<>text "\"/>"
+
+    chars :: [Char]
+    chars = map fst (Map.toAscList (foldr getIfaceIndex Map.empty ifaces))
+
+    getIfaceIndex iface fm =
+        Map.union (Map.fromList [(toUpper (head (show name)),()) | (name, Qual mdl' _) <- Map.toAscList (iface_env iface), mdl == mdl']) fm
+	where mdl = iface_module iface
+
+-----------------------------------------------------------------------------------
+
+ppHH2Collection :: FilePath -> String -> Maybe String -> IO ()
+ppHH2Collection odir doctitle maybe_package = do
+  let 
+	package = fromMaybe "pkg" maybe_package
+	collectionHH2File = package++".HxC"
+	
+	doc =
+		text "<?xml version=\"1.0\"?>" $$
+		text "<!DOCTYPE HelpCollection SYSTEM \"ms-help://hx/resources/HelpCollection.DTD\">" $$
+		text "<HelpCollection DTDVersion=\"1.0\" LangId=\"1033\" Title=\"" <> text doctitle <> text "\">" $$
+		nest 4 (text "<CompilerOptions CreateFullTextIndex=\"Yes\">" $$
+		        nest 4 (text "<IncludeFile File=\"" <> text package <> text ".HxF\"/>") $$
+		        text "</CompilerOptions>" $$
+		        text "<TOCDef File=\"" <> text package <> text ".HxT\"/>" $$
+		        text "<KeywordIndexDef File=\"" <> text package <> text "K.HxK\"/>" $$
+		        text "<KeywordIndexDef File=\"" <> text package <> text "N.HxK\"/>" $$
+		        text "<ItemMoniker Name=\"!DefaultToc\" ProgId=\"HxDs.HxHierarchy\" InitData=\"\"/>" $$
+		        text "<ItemMoniker Name=\"!DefaultFullTextSearch\" ProgId=\"HxDs.HxFullTextSearch\" InitData=\"\"/>" $$
+		        text "<ItemMoniker Name=\"!DefaultAssociativeIndex\" ProgId=\"HxDs.HxIndex\" InitData=\"A\"/>" $$
+		        text "<ItemMoniker Name=\"!DefaultKeywordIndex\" ProgId=\"HxDs.HxIndex\" InitData=\"K\"/>" $$
+		        text "<ItemMoniker Name=\"!DefaultNamedUrlIndex\" ProgId=\"HxDs.HxIndex\" InitData=\"NamedURLIndex\"/>" $$
+		        text "<ItemMoniker Name=\"!SampleInfo\" ProgId=\"HxDs.HxSampleCollection\" InitData=\"\"/>") $$
+		text "</HelpCollection>"
+  writeFile (pathJoin [odir, collectionHH2File]) (render doc)
+-}
diff --git a/src/Haddock/HaddockDB.hs b/src/Haddock/HaddockDB.hs
new file mode 100644
index 00000000..6341c6c4
--- /dev/null
+++ b/src/Haddock/HaddockDB.hs
@@ -0,0 +1,165 @@
+--
+-- Haddock - A Haskell Documentation Tool
+--
+-- (c) Simon Marlow 2003
+--
+
+module Haddock.HaddockDB (ppDocBook) where
+
+{-
+import HaddockTypes
+import HaddockUtil
+import HsSyn2
+
+import Text.PrettyPrint
+-}
+
+-----------------------------------------------------------------------------
+-- Printing the results in DocBook format
+
+ppDocBook = error "not working"
+{-
+ppDocBook :: FilePath -> [(Module, Interface)] -> String
+ppDocBook odir mods = render (ppIfaces mods)
+
+ppIfaces mods
+  =  text "<!DOCTYPE BOOK PUBLIC \"-//OASIS//DTD DocBook V3.1//EN\" ["
+  $$ text "]>"
+  $$ text "<book>"
+  $$ text "<bookinfo>"
+  $$ text "<author><othername>HaskellDoc version 0.0</othername></author>"
+  $$ text "</bookinfo>"
+  $$ text "<article>"
+  $$ vcat (map do_mod mods)
+  $$ text "</article></book>"
+  where
+     do_mod (Module mod, iface)
+        =  text "<sect1 id=\"sec-" <> text mod <> text "\">"
+        $$ text "<title><literal>" 
+	   <> text mod
+	   <> text "</literal></title>"
+	$$ text "<indexterm><primary><literal>"
+	   <> text mod
+	   <> text "</literal></primary></indexterm>"
+	$$ text "<variablelist>"
+	$$ vcat (map (do_export mod) (eltsFM (iface_decls iface)))
+	$$ text "</variablelist>"
+	$$ text "</sect1>"
+ 
+     do_export mod decl | (nm:_) <- declBinders decl
+	=  text "<varlistentry id=" <> ppLinkId mod nm <> char '>'
+	$$ text "<term><literal>" 
+		<> do_decl decl
+		<> text "</literal></term>"
+	$$ text "<listitem>"
+	$$ text "<para>"
+	$$ text "</para>"
+	$$ text "</listitem>"
+	$$ text "</varlistentry>"
+     do_export _ _ = empty
+
+     do_decl (HsTypeSig _ [nm] ty _) 
+	=  ppHsName nm <> text " :: " <> ppHsType ty
+     do_decl (HsTypeDecl _ nm args ty _)
+	=  hsep ([text "type", ppHsName nm ]
+		 ++ map ppHsName args 
+		 ++ [equals, ppHsType ty])
+     do_decl (HsNewTypeDecl loc ctx nm args con drv _)
+	= hsep ([text "data", ppHsName nm] -- data, not newtype
+		++ map ppHsName args
+		) <+> equals <+> ppHsConstr con -- ToDo: derivings
+     do_decl (HsDataDecl loc ctx nm args cons drv _)
+	= hsep ([text "data", {-ToDo: context-}ppHsName nm]
+	        ++ map ppHsName args)
+            <+> vcat (zipWith (<+>) (equals : repeat (char '|'))
+                                    (map ppHsConstr cons))
+     do_decl (HsClassDecl loc ty fds decl _)
+	= hsep [text "class", ppHsType ty]
+     do_decl decl
+	= empty
+
+ppHsConstr :: HsConDecl -> Doc
+ppHsConstr (HsRecDecl pos name tvs ctxt fieldList maybe_doc) =
+	 ppHsName name
+	 <> (braces . hsep . punctuate comma . map ppField $ fieldList)
+ppHsConstr (HsConDecl pos name tvs ctxt typeList maybe_doc) = 
+	 hsep (ppHsName name : map ppHsBangType typeList)
+
+ppField (HsFieldDecl ns ty doc)
+   = hsep (punctuate comma (map ppHsName ns) ++
+	 	[text "::", ppHsBangType ty])
+
+ppHsBangType :: HsBangType -> Doc
+ppHsBangType (HsBangedTy ty) = char '!' <> ppHsType ty
+ppHsBangType (HsUnBangedTy ty) = ppHsType ty
+
+ppHsContext :: HsContext -> Doc
+ppHsContext []      = empty
+ppHsContext context = parenList (map (\ (a,b) -> ppHsQName a <+> 
+					 hsep (map ppHsAType b)) context)
+
+ppHsType :: HsType -> Doc
+ppHsType (HsForAllType Nothing context htype) =
+     hsep [ ppHsContext context, text "=>", ppHsType htype]
+ppHsType (HsForAllType (Just tvs) [] htype) =
+     hsep (text "forall" : map ppHsName tvs ++ text "." : [ppHsType htype])
+ppHsType (HsForAllType (Just tvs) context htype) =
+     hsep (text "forall" : map ppHsName tvs ++ text "." : 
+	   ppHsContext context : text "=>" : [ppHsType htype])
+ppHsType (HsTyFun a b) = fsep [ppHsBType a, text "-&gt;", ppHsType b]
+ppHsType (HsTyIP n t)  = fsep [(char '?' <> ppHsName n), text "::", ppHsType t]
+ppHsType t = ppHsBType t
+
+ppHsBType (HsTyApp (HsTyCon (Qual (Module "Prelude") (HsTyClsName (HsSpecial "[]")))) b )
+  = brackets $ ppHsType b
+ppHsBType (HsTyApp a b) = fsep [ppHsBType a, ppHsAType b]
+ppHsBType t = ppHsAType t
+
+ppHsAType :: HsType -> Doc
+ppHsAType (HsTyTuple True l)  = parenList . map ppHsType $ l
+ppHsAType (HsTyTuple False l) = ubxParenList . map ppHsType $ l
+-- special case
+ppHsAType (HsTyApp (HsTyCon (Qual (Module "Prelude") (HsTyClsName (HsSpecial "[]")))) b )
+  = brackets $ ppHsType b
+ppHsAType (HsTyVar name) = ppHsName name
+ppHsAType (HsTyCon name) = ppHsQName name
+ppHsAType t = parens $ ppHsType t
+
+ppHsQName :: HsQName -> Doc
+ppHsQName (UnQual str)			= ppHsName str
+ppHsQName n@(Qual (Module mod) str)
+	 | n == unit_con_name		= ppHsName str
+	 | isSpecial str 		= ppHsName str
+	 | otherwise 
+		=  text "<link linkend=" <> ppLinkId mod str <> char '>'
+		<> ppHsName str
+		<> text "</link>"
+
+isSpecial (HsTyClsName id) | HsSpecial _ <- id = True
+isSpecial (HsVarName id) | HsSpecial _ <- id = True
+isSpecial _ = False
+
+ppHsName :: HsName -> Doc
+ppHsName (HsTyClsName id) = ppHsIdentifier id
+ppHsName (HsVarName id) = ppHsIdentifier id
+
+ppHsIdentifier :: HsIdentifier -> Doc
+ppHsIdentifier (HsIdent str)	= text str
+ppHsIdentifier (HsSymbol str) = text str
+ppHsIdentifier (HsSpecial str) = text str
+
+ppLinkId :: String -> HsName -> Doc
+ppLinkId mod str
+  = hcat [char '\"', text mod, char '.', ppHsName str, char '\"']
+
+-- -----------------------------------------------------------------------------
+-- * Misc
+
+parenList :: [Doc] -> Doc
+parenList = parens . fsep . punctuate comma
+
+ubxParenList :: [Doc] -> Doc
+ubxParenList = ubxparens . fsep . punctuate comma
+
+ubxparens p = text "(#" <> p <> text "#)"
+-}
diff --git a/src/Haddock/Hoogle.hs b/src/Haddock/Hoogle.hs
new file mode 100644
index 00000000..618d6eb3
--- /dev/null
+++ b/src/Haddock/Hoogle.hs
@@ -0,0 +1,184 @@
+--
+-- Haddock - A Haskell Documentation Tool
+--
+-- (c) Simon Marlow 2003
+--
+-- This file, (c) Neil Mitchell 2006
+-- Write out Hoogle compatible documentation
+-- http://www.haskell.org/hoogle/
+
+module Haddock.Hoogle ( 
+	ppHoogle
+  ) where
+
+ppHoogle = undefined
+
+{-
+import HaddockTypes
+import HaddockUtil
+import HsSyn2
+
+import Data.List ( intersperse )
+
+
+
+prefix = ["-- Hoogle documentation, generated by Haddock",
+          "-- See Hoogle, http://www.haskell.org/hoogle/"]
+
+ppHoogle :: Maybe String -> [Interface] -> FilePath -> IO ()
+ppHoogle maybe_package ifaces odir =
+    do
+        let
+            filename = case maybe_package of
+                        Just x -> x ++ ".txt"
+                        Nothing -> "hoogle.txt"
+
+            visible_ifaces = filter visible ifaces
+            visible i = OptHide `notElem` iface_options i
+
+            contents = prefix : map ppModule visible_ifaces
+
+        writeFile (pathJoin [odir, filename]) (unlines $ concat contents)
+ 
+
+
+-- ---------------------------------------------------------------------------
+-- Generate the HTML page for a module
+
+
+ppDecl :: HsDecl -> [String]
+ppDecl (HsNewTypeDecl src context name args ctor unknown docs) =
+    ppData "newtype" context name args [ctor]
+
+ppDecl (HsDataDecl src context name args ctors unknown docs) =
+    ppData "data" context name args ctors
+
+ppDecl (HsTypeSig src names t doc) = map (`ppFunc` t) names
+
+ppDecl (HsForeignImport src _ _ _ name t doc) = ppDecl $ HsTypeSig src [name] t doc
+
+ppDecl (HsClassDecl src context name args fundeps members doc) =
+    ("class " ++ ppContext context ++ ppType typ) : concatMap f members
+    where
+        typ = foldl HsTyApp (HsTyCon $ UnQual name) (map HsTyVar args)
+        newcontext = (UnQual name, map HsTyVar args)
+        f (HsTypeSig src names t doc) = ppDecl (HsTypeSig src names (addContext newcontext t) doc)
+        f (HsFunBind{}) = []
+        f (HsPatBind{}) = []
+        f x = ["-- ERR " ++ show x]
+
+ppDecl (HsTypeDecl src name args t doc) =
+    ["type " ++ show name ++ concatMap (\x -> ' ':show x) args ++ " = " ++ ppType t]
+
+ppDecl x = ["-- ERR " ++ show x]
+
+
+
+addContext :: HsAsst -> HsType -> HsType
+addContext ctx (HsForAllType Nothing context t) = HsForAllType Nothing (HsAssump ctx : context) t
+addContext ctx x = HsForAllType Nothing [HsAssump ctx] x
+
+
+
+ppFunc :: HsName -> HsType -> String
+ppFunc name typ = show name ++ " :: " ++ ppType typ
+
+
+ppData :: String -> HsContext -> HsName -> [HsName] -> [HsConDecl] -> [String]
+ppData mode context name args ctors = (mode ++ " " ++ ppType typ) : concatMap (ppCtor typ) ctors
+    where
+        typ = foldl HsTyApp (HsTyCon $ UnQual name) (map HsTyVar args)
+        
+        
+deBang :: HsBangType -> HsType
+deBang (HsBangedTy   x) = x
+deBang (HsUnBangedTy x) = x
+
+
+ppCtor :: HsType -> HsConDecl -> [String]
+ppCtor result (HsConDecl src name types context typ doc) =
+    [show name ++ " :: " ++ ppContext context ++ ppTypesArr (map deBang typ ++ [result])]
+
+ppCtor result (HsRecDecl src name types context fields doc) =
+        ppCtor result (HsConDecl src name types context (map snd fields2) doc) ++
+        concatMap f fields2
+    where
+        fields2 = [(name, typ) | HsFieldDecl names typ _ <- fields, name <- names]
+        f (name, typ) = ppDecl $ HsTypeSig src [name] (HsTyFun result (deBang typ)) doc
+
+
+brack True  x = "(" ++ x ++ ")"
+brack False x = x
+
+ppContext :: HsContext -> String
+ppContext [] = ""
+ppContext xs = brack (length xs > 1) (concat $ intersperse ", " $ map ppContextItem xs) ++ " => "
+
+ppContextItem :: HsAsst -> String
+ppContextItem (name, types) = ppQName name ++ concatMap (\x -> ' ':ppType x) types
+
+ppContext2 :: HsIPContext -> String
+ppContext2 xs = ppContext [x | HsAssump x <- xs]
+
+
+ppType :: HsType -> String
+ppType x = f 0 x
+    where
+        f _ (HsTyTuple _ xs) = brack True $ concat $ intersperse ", " $ map (f 0) xs
+        f _ (HsTyCon x) = ppQName x
+        f _ (HsTyVar x) = show x
+
+        -- ignore ForAll types as Hoogle does not support them
+        f n (HsForAllType (Just items) context t) =
+            -- brack (n > 1) $
+            -- "forall" ++ concatMap (\x -> ' ':toStr x) items ++ " . " ++ f 0 t
+            f n t
+
+        f n (HsForAllType Nothing context t) = brack (n > 1) $
+            ppContext2 context ++ f 0 t
+
+        f n (HsTyFun a b) = brack g $ f (h 3) a ++ " -> " ++ f (h 2) b
+            where
+                g = n > 2
+                h x = if g then 0 else x
+        
+        f n (HsTyApp a b) | ppType a == "[]" = "[" ++ f 0 b ++ "]"
+        
+        f n (HsTyApp a b) = brack g $ f (h 3) a ++ " " ++ f (h 4) b
+            where
+                g = n > 3
+                h x = if g then 0 else x
+        
+        f n (HsTyDoc x _) = f n x
+
+        f n x = brack True $ show x
+
+
+ppQName :: HsQName -> String
+ppQName (Qual _ name) = show name
+ppQName (UnQual name) = show name
+
+
+
+ppTypesArr :: [HsType] -> String
+ppTypesArr xs = ppType $ foldr1 HsTyFun xs
+
+
+
+ppInst :: InstHead -> String
+ppInst (context, item) = "instance " ++ ppContext context ++ ppContextItem item
+
+
+
+ppModule :: Interface -> [String]
+ppModule iface = "" : ("module " ++ mdl) : concatMap ppExport (iface_exports iface)
+    where
+        Module mdl = iface_module iface
+
+
+ppExport :: ExportItem -> [String]
+ppExport (ExportDecl name decl insts) = ppDecl decl ++ map ppInst insts
+ppExport _ = []
+
+
+-}
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"]
diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs
index becd40df..7964a3a5 100644
--- a/src/Haddock/InterfaceFile.hs
+++ b/src/Haddock/InterfaceFile.hs
@@ -4,7 +4,7 @@ module Haddock.InterfaceFile (
   readInterfaceFile
 ) where
 
-import HaddockTypes
+import Haddock.Types
 import Haddock.Exception
 
 import Binary
diff --git a/src/Haddock/ModuleTree.hs b/src/Haddock/ModuleTree.hs
new file mode 100644
index 00000000..e4c72880
--- /dev/null
+++ b/src/Haddock/ModuleTree.hs
@@ -0,0 +1,38 @@
+module Haddock.ModuleTree ( ModuleTree(..), mkModuleTree ) where
+
+import Haddock.Types ( DocName )
+import GHC           ( HsDoc, Name )
+import Module        ( Module, moduleNameString, moduleName, modulePackageId )
+import PackageConfig ( packageIdString )
+
+data ModuleTree = Node String Bool (Maybe String) (Maybe (HsDoc Name)) [ModuleTree]
+
+mkModuleTree :: Bool -> [(Module, Maybe (HsDoc Name))] -> [ModuleTree]
+mkModuleTree showPkgs mods = 
+  foldr fn [] [ (splitModule mod, modPkg mod, short) | (mod, short) <- mods ]
+  where
+    modPkg mod | showPkgs = Just (packageIdString (modulePackageId mod))
+               | otherwise = Nothing
+    fn (mod,pkg,short) trees = addToTrees mod pkg short trees
+
+addToTrees :: [String] -> Maybe String -> Maybe (HsDoc Name) -> [ModuleTree] -> [ModuleTree]
+addToTrees [] pkg short ts = ts
+addToTrees ss pkg short [] = mkSubTree ss pkg short
+addToTrees (s1:ss) pkg short (t@(Node s2 leaf node_pkg node_short subs) : ts)
+  | s1 >  s2  = t : addToTrees (s1:ss) pkg short ts
+  | s1 == s2  = Node s2 (leaf || null ss) this_pkg this_short (addToTrees ss pkg short subs) : ts
+  | otherwise = mkSubTree (s1:ss) pkg short ++ t : ts
+ where
+  this_pkg = if null ss then pkg else node_pkg
+  this_short = if null ss then short else node_short
+
+mkSubTree :: [String] -> Maybe String -> Maybe (HsDoc Name) -> [ModuleTree]
+mkSubTree []     pkg short = []
+mkSubTree [s]    pkg short = [Node s True pkg short []]
+mkSubTree (s:ss) pkg short = [Node s (null ss) Nothing Nothing (mkSubTree ss pkg short)]
+
+splitModule :: Module -> [String]
+splitModule mod = split (moduleNameString (moduleName mod))
+  where split mod0 = case break (== '.') mod0 of
+     			(s1, '.':s2) -> s1 : split s2
+     			(s1, _)      -> [s1]
diff --git a/src/Haddock/Rename.hs b/src/Haddock/Rename.hs
new file mode 100644
index 00000000..7e12a412
--- /dev/null
+++ b/src/Haddock/Rename.hs
@@ -0,0 +1,320 @@
+--
+-- Haddock - A Haskell Documentation Tool
+--
+-- (c) Simon Marlow 2003
+--
+
+module Haddock.Rename (
+  runRnFM, -- the monad (instance of Monad)
+  renameDoc, renameMaybeDoc, renameExportItems,
+) where
+
+import Haddock.Types
+
+import GHC
+import BasicTypes
+import SrcLoc 
+import Bag ( emptyBag )
+
+import Data.Map ( Map )
+import qualified Data.Map as Map hiding ( Map )
+import Prelude hiding ( mapM )
+import Data.Traversable ( mapM )
+
+-- -----------------------------------------------------------------------------
+-- Monad for renaming
+
+-- The monad does two things for us: it passes around the environment for
+-- renaming, and it returns a list of names which couldn't be found in 
+-- the environment.
+
+newtype GenRnM n a = 
+  RnM { unRn :: (n -> (Bool, DocName))	-- name lookup function
+             -> (a,[n])
+      }
+
+type RnM a = GenRnM Name a
+
+instance Monad (GenRnM n) where
+  (>>=) = thenRn
+  return = returnRn   
+
+returnRn :: a -> GenRnM n a
+returnRn a   = RnM (\_ -> (a,[]))
+thenRn :: GenRnM n a -> (a -> GenRnM n b) -> GenRnM n b
+m `thenRn` k = RnM (\lkp -> case unRn m lkp of 
+				(a,out1) -> case unRn (k a) lkp of
+						(b,out2) -> (b,out1++out2))
+
+getLookupRn :: RnM (Name -> (Bool, DocName))
+getLookupRn = RnM (\lkp -> (lkp,[]))
+outRn :: Name -> RnM ()
+outRn name = RnM (\_ -> ((),[name]))
+
+lookupRn :: (DocName -> a) -> Name -> RnM a
+lookupRn and_then name = do
+  lkp <- getLookupRn
+  case lkp name of
+	(False,maps_to) -> do outRn name; return (and_then maps_to)
+	(True, maps_to) -> return (and_then maps_to)
+
+runRnFM :: Map Name Name -> RnM a -> (a,[Name])
+runRnFM env rn = unRn rn lkp 
+  where lkp n = case Map.lookup n env of
+		  Nothing -> (False, NoLink n) 
+		  Just q  -> (True,  Link q)
+
+runRn :: (n -> (Bool,DocName)) -> GenRnM n a -> (a,[n])
+runRn lkp rn = unRn rn lkp
+
+-- -----------------------------------------------------------------------------
+-- Renaming 
+
+keep n = NoLink n
+keepL (L loc n) = L loc (NoLink n)
+
+rename = lookupRn id 
+renameL (L loc name) = return . L loc =<< rename name
+
+renameExportItems :: [ExportItem Name] -> RnM [ExportItem DocName]
+renameExportItems items = mapM renameExportItem items
+
+renameMaybeDoc :: Maybe (HsDoc Name) -> RnM (Maybe (HsDoc DocName))
+renameMaybeDoc mbDoc = mapM renameDoc mbDoc
+
+renameLDoc (L loc doc) = return . L loc =<< renameDoc doc
+
+renameDoc :: HsDoc Name -> RnM (HsDoc DocName)
+renameDoc doc = case doc of
+  DocEmpty -> return DocEmpty
+  DocAppend a b -> do
+    a' <- renameDoc a
+    b' <- renameDoc b
+    return (DocAppend a' b')
+  DocString str -> return (DocString str)
+  DocParagraph doc -> do
+    doc' <- renameDoc doc
+    return (DocParagraph doc')
+  DocIdentifier ids -> do
+    lkp <- getLookupRn
+    case [ n | (True, n) <- map lkp ids ] of
+      ids'@(_:_) -> return (DocIdentifier ids')
+      [] -> return (DocIdentifier (map NoLink ids))
+  DocModule str -> return (DocModule str)
+  DocEmphasis doc -> do
+    doc' <- renameDoc doc
+    return (DocEmphasis doc')
+  DocMonospaced doc -> do
+    doc' <- renameDoc doc
+    return (DocMonospaced doc')
+  DocUnorderedList docs -> do
+    docs' <- mapM renameDoc docs
+    return (DocUnorderedList docs')
+  DocOrderedList docs -> do
+    docs' <- mapM renameDoc docs
+    return (DocOrderedList docs')
+  DocDefList docs -> do
+    docs' <- mapM (\(a,b) -> do
+      a' <- renameDoc a
+      b' <- renameDoc b
+      return (a',b')) docs
+    return (DocDefList docs')  
+  DocCodeBlock doc -> do
+    doc' <- renameDoc doc
+    return (DocCodeBlock doc')
+  DocURL str -> return (DocURL str) 
+  DocAName str -> return (DocAName str)
+
+renameLPred (L loc p) = return . L loc =<< renamePred p
+
+renamePred :: HsPred Name -> RnM (HsPred DocName)
+renamePred (HsClassP name types) = do
+  name' <- rename name 
+  types' <- mapM renameLType types
+  return (HsClassP name' types')
+renamePred (HsIParam (IPName name) t) = do
+  name' <- rename name
+  t' <- renameLType t
+  return (HsIParam (IPName name') t')
+
+renameLType (L loc t) = return . L loc =<< renameType t
+
+renameType t = case t of 
+  HsForAllTy expl tyvars lcontext ltype -> do
+    tyvars' <- mapM renameLTyVarBndr tyvars
+    lcontext' <- renameLContext lcontext 
+    ltype' <- renameLType ltype
+    return (HsForAllTy expl tyvars' lcontext' ltype')
+
+  HsTyVar n -> return . HsTyVar =<< rename n
+  HsBangTy b ltype -> return . HsBangTy b =<< renameLType ltype
+  
+  HsAppTy a b -> do
+    a' <- renameLType a
+    b' <- renameLType b
+    return (HsAppTy a' b')
+
+  HsFunTy a b -> do     
+    a' <- renameLType a
+    b' <- renameLType b
+    return (HsFunTy a' b')
+
+  HsListTy t -> return . HsListTy =<< renameLType t
+  HsPArrTy t -> return . HsPArrTy =<< renameLType t
+
+  HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts
+
+  HsOpTy a (L loc op) b -> do
+    op' <- rename op
+    a' <- renameLType a
+    b' <- renameLType b
+    return (HsOpTy a' (L loc op') b')
+
+  HsParTy t -> return . HsParTy =<< renameLType t
+
+  HsNumTy n -> return (HsNumTy n)
+
+  HsPredTy p -> return . HsPredTy =<< renamePred p
+
+  HsKindSig t k -> do
+    t' <- renameLType t
+    return (HsKindSig t' k)
+
+  HsDocTy t doc -> do
+    t' <- renameLType t
+    doc' <- renameLDoc doc
+    return (HsDocTy t' doc')
+
+  _ -> error "renameType"
+ 
+renameLTyVarBndr (L loc tv) = do
+  name' <- rename (hsTyVarName tv)
+  return $ L loc (replaceTyVarName tv name')
+    
+renameLContext (L loc context) = do
+  context' <- mapM renameLPred context
+  return (L loc context')
+
+renameInstHead :: InstHead Name -> RnM (InstHead DocName)
+renameInstHead (preds, className, types) = do
+  preds' <- mapM renamePred preds
+  className' <- rename className
+  types' <- mapM renameType types
+  return (preds', className', types')
+
+renameLDecl (L loc d) = return . L loc =<< renameDecl d
+
+renameDecl d = case d of
+  TyClD d -> do
+    d' <- renameTyClD d
+    return (TyClD d')
+  SigD s -> do
+    s' <- renameSig s
+    return (SigD s')
+  ForD d -> do
+    d' <- renameForD d
+    return (ForD d')
+  _ -> error "renameDecl"
+
+renameTyClD d = case d of
+  ForeignType _ _ _ -> error "renameTyClD" -- I'm guessing these can't be exported
+ -- ForeignType name a b -> do
+ --   name' <- renameL name
+ --   return (ForeignType name' a b)
+
+  TyData x lcontext lname ltyvars _ k cons _ -> do
+    lcontext' <- renameLContext lcontext
+    ltyvars' <- mapM renameLTyVarBndr ltyvars
+    cons' <- mapM renameLCon cons
+    -- I don't think we need the derivings, so we return Nothing
+    -- We skip the type patterns too. TODO: find out what they are :-)
+    return (TyData x lcontext' (keepL lname) ltyvars' Nothing k cons' Nothing) 
+ 
+  TySynonym lname ltyvars typat ltype -> do
+    ltyvars' <- mapM renameLTyVarBndr ltyvars
+    ltype' <- renameLType ltype
+    -- We skip type patterns here as well.
+    return (TySynonym (keepL lname) ltyvars' Nothing ltype')
+
+  ClassDecl lcontext lname ltyvars lfundeps lsigs _ _ _ -> do
+    lcontext' <- renameLContext lcontext
+    ltyvars' <- mapM renameLTyVarBndr ltyvars
+    lfundeps' <- mapM renameLFunDep lfundeps 
+    lsigs' <- mapM renameLSig lsigs
+    -- we don't need the default methods or the already collected doc entities
+    -- we skip the ATs for now.
+    return (ClassDecl lcontext' (keepL lname) ltyvars' lfundeps' lsigs' emptyBag [] [])
+ 
+  where
+    renameLCon (L loc con) = return . L loc =<< renameCon con
+    renameCon (ConDecl lname expl ltyvars lcontext details restype mbldoc) = do
+      ltyvars' <- mapM renameLTyVarBndr ltyvars
+      lcontext' <- renameLContext lcontext
+      details' <- renameDetails details
+      restype' <- renameResType restype
+      mbldoc' <- mapM renameLDoc mbldoc
+      return (ConDecl (keepL lname) expl ltyvars' lcontext' details' restype' mbldoc') 
+
+    renameDetails (RecCon fields) = return . RecCon =<< mapM renameField fields
+    renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps
+    renameDetails (InfixCon a b) = do
+      a' <- renameLType a
+      b' <- renameLType b
+      return (InfixCon a' b')
+  
+    renameField (HsRecField id arg doc) = do
+      arg' <- renameLType arg
+      doc' <- mapM renameLDoc doc 
+      return (HsRecField (keepL id) arg' doc')
+
+    renameResType (ResTyH98) = return ResTyH98
+    renameResType (ResTyGADT t) = return . ResTyGADT =<< renameLType t
+
+    renameLFunDep (L loc (xs, ys)) = return (L loc (map keep xs, map keep ys))
+   
+    renameLSig (L loc sig) = return . L loc =<< renameSig sig
+      
+renameSig sig = case sig of 
+  TypeSig (L loc name) ltype -> do 
+    ltype' <- renameLType ltype
+    return (TypeSig (L loc (keep name)) ltype')
+{-  SpecSig lname ltype x -> do
+    lname' <- renameL lname
+    ltype' <- renameLType ltype
+    return (SpecSig lname' ltype' x)
+  InlineSig lname x -> do
+    lname' <- renameL lname
+    return (InlineSig lname' x)   
+  SpecInstSig t -> return . SpecInstSig =<< renameLType t
+  FixSig fsig -> return . FixSig =<< renameFixitySig fsig
+  where
+    renameFixitySig (FixitySig lname x) = do
+      lname' <- renameL lname
+      return (FixitySig lname' x)
+-}
+
+renameForD (ForeignImport lname ltype x) = do
+  ltype' <- renameLType ltype
+  return (ForeignImport (keepL lname) ltype' x)
+renameForD (ForeignExport lname ltype x) = do
+  ltype' <- renameLType ltype
+  return (ForeignExport (keepL lname) ltype' x)
+
+renameExportItem :: ExportItem Name -> RnM (ExportItem DocName)
+renameExportItem item = case item of 
+  ExportModule mod -> return (ExportModule mod)
+  ExportGroup lev id doc -> do
+    doc' <- renameDoc doc
+    return (ExportGroup lev id doc')
+  ExportDecl x decl doc instances -> do
+    decl' <- renameLDecl decl
+    doc' <- mapM renameDoc doc
+    instances' <- mapM renameInstHead instances
+    return (ExportDecl x decl' doc' instances')
+  ExportNoDecl x y subs -> do
+    y' <- lookupRn id y
+    subs' <- mapM (lookupRn id) subs
+    return (ExportNoDecl x y' subs')
+  ExportDoc doc -> do
+    doc' <- renameDoc doc
+    return (ExportDoc doc')
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
new file mode 100644
index 00000000..4c4587ac
--- /dev/null
+++ b/src/Haddock/Types.hs
@@ -0,0 +1,123 @@
+--
+-- Haddock - A Haskell Documentation Tool
+--
+-- (c) Simon Marlow 2003
+--
+-- Ported to use the GHC API by David Waern 2006
+-- 
+
+module Haddock.Types where
+
+import GHC
+import Outputable
+
+import Data.Map
+
+data DocOption
+  = OptHide           -- ^ This module should not appear in the docs
+  | OptPrune
+  | OptIgnoreExports  -- ^ Pretend everything is exported
+  | OptNotHome        -- ^ Not the best place to get docs for things
+                      -- exported by this module.
+  deriving (Eq, Show)
+
+data ExportItem name
+  = ExportDecl
+      Name                 -- ^ The original name
+      (LHsDecl name)       -- ^ A declaration
+      (Maybe (HsDoc name)) -- ^ Maybe a doc comment
+      [InstHead name]	     -- ^ Instances relevant to this declaration
+
+  | ExportNoDecl           -- ^ An exported entity for which we have no 
+                           -- documentation (perhaps because it resides in
+                           -- another package)
+      Name                 -- ^ The original name
+      name                 -- ^ Where to link to
+      [name]               -- ^ Subordinate names
+
+  | ExportGroup            -- ^ A section heading
+      Int                  -- ^ section level (1, 2, 3, ... )
+      String               -- ^ Section "id" (for hyperlinks)
+      (HsDoc name)         -- ^ Section heading text
+
+  | ExportDoc              -- ^ Some documentation
+      (HsDoc name)
+
+  | ExportModule           -- ^ A cross-reference to another module
+      Module
+
+type InstHead name = ([HsPred name], name, [HsType name])
+type ModuleMap     = Map Module HaddockModule
+type DocMap        = Map Name (HsDoc DocName)
+type DocEnv        = Map Name Name
+
+data DocName = Link Name | NoLink Name
+
+instance Outputable DocName where
+  ppr (Link   n) = ppr n
+  ppr (NoLink n) = ppr n
+
+data HaddockModule = HM {
+
+  -- | A value to identify the module
+  hmod_mod                :: Module,
+
+  -- | The original filename for this module
+  hmod_orig_filename      :: FilePath,
+
+  -- | Textual information about the module 
+  hmod_info               :: HaddockModInfo Name,
+
+  -- | The documentation header for this module
+  hmod_doc                :: Maybe (HsDoc Name),
+
+  -- | The renamed documentation header for this module
+  hmod_rn_doc             :: Maybe (HsDoc DocName),
+
+  -- | The Haddock options for this module (prune, ignore-exports, etc)
+  hmod_options            :: [DocOption],
+
+  hmod_exported_decl_map  :: Map Name (LHsDecl Name),
+  hmod_doc_map            :: Map Name (HsDoc Name),  
+  hmod_rn_doc_map         :: Map Name (HsDoc DocName),
+
+  hmod_export_items       :: [ExportItem Name],
+  hmod_rn_export_items    :: [ExportItem DocName],
+
+  -- | All the names that are defined in this module
+  hmod_locals             :: [Name],
+
+  -- | All the names that are exported by this module
+  hmod_exports            :: [Name],
+
+  -- | All the visible names exported by this module
+  -- For a name to be visible, it has to:
+  -- - be exported normally, and not via a full module re-exportation.
+  -- - have a declaration in this module or any of it's imports, with the    
+  --   exception that it can't be from another package.
+  -- Basically, a visible name is a name that will show up in the documentation
+  -- for this module.
+  hmod_visible_exports    :: [Name],
+
+  hmod_sub_map            :: Map Name [Name],
+
+  -- | The instances exported by this module
+  hmod_instances          :: [Instance]
+}
+
+data DocMarkup id a = Markup {
+  markupEmpty         :: a,
+  markupString        :: String -> a,
+  markupParagraph     :: a -> a,
+  markupAppend        :: a -> a -> a,
+  markupIdentifier    :: [id] -> a,
+  markupModule        :: String -> a,
+  markupEmphasis      :: a -> a,
+  markupMonospaced    :: a -> a,
+  markupUnorderedList :: [a] -> a,
+  markupOrderedList   :: [a] -> a,
+  markupDefList       :: [(a,a)] -> a,
+  markupCodeBlock     :: a -> a,
+  markupURL           :: String -> a,
+  markupAName         :: String -> a
+}
diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs
new file mode 100644
index 00000000..27f60e4a
--- /dev/null
+++ b/src/Haddock/Utils.hs
@@ -0,0 +1,340 @@
+--
+-- Haddock - A Haskell Documentation Tool
+--
+-- (c) The University of Glasgow 2001-2002
+-- (c) Simon Marlow 2003
+--
+
+module Haddock.Utils (
+
+  -- * Misc utilities
+  restrictTo, 
+  toDescription,
+
+  -- * Filename utilities
+  basename, dirname, splitFilename3, 
+  moduleHtmlFile, nameHtmlRef,
+  contentsHtmlFile, indexHtmlFile, subIndexHtmlFile, pathJoin,
+  anchorNameStr,
+  cssFile, iconFile, jsFile, plusFile, minusFile,
+
+  -- * Miscellaneous utilities
+  getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr,
+  isConSym, isVarSym, nameOccString, moduleString, mkModuleNoPkg,
+
+  -- * HTML cross reference mapping
+  html_xrefs_ref,
+
+  -- * HsDoc markup 
+  markup, 
+  idMarkup,
+
+  -- * Binary extras
+--  FormatVersion, mkFormatVersion  
+ ) where
+
+import Haddock.Types
+
+import GHC
+import SrcLoc
+import Name
+import OccName
+import Binary
+import Module
+import PackageConfig ( stringToPackageId )
+
+import Control.Monad ( liftM, MonadPlus(..) )
+import Data.Map ( Map )
+import qualified Data.Map as Map hiding ( Map )
+import Data.Char
+import Data.IORef ( IORef, newIORef, readIORef )
+import Data.List ( intersect, isSuffixOf, intersperse )
+import Data.Maybe ( maybeToList, fromMaybe, isJust, fromJust )
+import Data.Word ( Word8 )
+import Data.Bits ( testBit )
+import Network.URI
+import System.Environment ( getProgName )
+import System.Exit ( exitWith, ExitCode(..) )
+import System.IO ( hPutStr, stderr )
+import System.IO.Unsafe	 ( unsafePerformIO )
+
+-- -----------------------------------------------------------------------------
+-- Some Utilities
+
+-- | extract a module's short description.
+toDescription :: HaddockModule -> Maybe (HsDoc Name)
+toDescription = hmi_description . hmod_info
+
+-- ---------------------------------------------------------------------------
+-- Making abstract declarations
+
+restrictTo :: [Name] -> (LHsDecl Name) -> (LHsDecl Name)
+restrictTo names (L loc decl) = L loc $ case decl of
+  TyClD d | isDataDecl d && tcdND d == DataType -> 
+    TyClD (d { tcdCons = restrictCons names (tcdCons d) }) 
+  TyClD d | isDataDecl d && tcdND d == NewType -> 
+    case restrictCons names (tcdCons d) of
+      []    -> TyClD (d { tcdND = DataType, tcdCons = [] }) 
+      [con] -> TyClD (d { tcdCons = [con] })
+  TyClD d | isClassDecl d -> 
+    TyClD (d { tcdSigs = restrictDecls names (tcdSigs d) })
+  _ -> decl
+   
+restrictCons :: [Name] -> [LConDecl Name] -> [LConDecl Name]
+restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]  
+  where 
+    keep d | unLoc (con_name d) `elem` names = 
+      case con_details d of
+        PrefixCon _ -> Just d
+        RecCon fields  
+          | all field_avail fields -> Just d
+          | otherwise -> Just (d { con_details = PrefixCon (field_types fields) })
+          -- if we have *all* the field names available, then
+          -- keep the record declaration.  Otherwise degrade to
+          -- a constructor declaration.  This isn't quite right, but
+          -- it's the best we can do.
+        InfixCon _ _ -> Just d
+      where
+        field_avail (HsRecField n _ _) = (unLoc n) `elem` names
+        field_types flds = [ ty | HsRecField n ty _ <- flds] 
+      
+    keep d | otherwise = Nothing
+
+restrictDecls :: [Name] -> [LSig Name] -> [LSig Name]
+restrictDecls names decls = filter keep decls
+  where keep d = fromJust (sigName d) `elem` names
+        -- has to have a name, since it's a class method type signature
+
+-- -----------------------------------------------------------------------------
+-- Filename mangling functions stolen from s main/DriverUtil.lhs.
+
+type Suffix = String
+
+splitFilename :: String -> (String,Suffix)
+splitFilename f = split_longest_prefix f (=='.')
+
+basename :: String -> String
+basename f = base where (_dir, base, _suff) = splitFilename3 f
+
+dirname :: String -> String
+dirname f = dir where (dir, _base, _suff) = splitFilename3 f
+
+-- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext")
+splitFilename3 :: String -> (String,String,Suffix)
+splitFilename3 str
+   = let (dir, rest) = split_longest_prefix str isPathSeparator
+	 (name, ext) = splitFilename rest
+	 real_dir | null dir  = "."
+		  | otherwise = dir
+     in  (real_dir, name, ext)
+
+split_longest_prefix :: String -> (Char -> Bool) -> (String,String)
+split_longest_prefix s pred0
+  = case pre0 of
+	[]      -> ([], reverse suf)
+	(_:pre) -> (reverse pre, reverse suf)
+  where (suf,pre0) = break pred0 (reverse s)
+
+pathSeparator :: Char
+#ifdef __WIN32__
+pathSeparator = '\\'
+#else
+pathSeparator = '/'
+#endif
+
+isPathSeparator :: Char -> Bool
+isPathSeparator ch =
+#ifdef mingw32_TARGET_OS
+  ch == '/' || ch == '\\'
+#else
+  ch == '/'
+#endif
+
+moduleHtmlFile :: Module -> FilePath
+moduleHtmlFile mdl =
+  case Map.lookup mdl html_xrefs of
+    Nothing  -> mdl' ++ ".html"
+    Just fp0 -> pathJoin [fp0, mdl' ++ ".html"]
+  where
+   mdl' = map (\c -> if c == '.' then '-' else c) 
+              (moduleNameString (moduleName mdl))
+
+nameHtmlRef :: Module -> Name -> String	
+nameHtmlRef mdl str = moduleHtmlFile mdl ++ '#':escapeStr (anchorNameStr str)
+
+contentsHtmlFile, indexHtmlFile :: String
+contentsHtmlFile = "index.html"
+indexHtmlFile = "doc-index.html"
+
+subIndexHtmlFile :: Char -> String
+subIndexHtmlFile a = "doc-index-" ++ b ++ ".html"
+   where b | isAlpha a = [a]
+           | otherwise = show (ord a)
+
+anchorNameStr :: Name -> String
+anchorNameStr name | isValOcc occName = "v:" ++ getOccString name 
+                   | otherwise        = "t:" ++ getOccString name
+  where occName = nameOccName name
+
+pathJoin :: [FilePath] -> FilePath
+pathJoin = foldr join []
+  where join :: FilePath -> FilePath -> FilePath
+        join path1 ""    = path1
+	join ""    path2 = path2
+	join path1 path2
+          | isPathSeparator (last path1) = path1++path2
+          | otherwise                    = path1++pathSeparator:path2
+
+-- -----------------------------------------------------------------------------
+-- Files we need to copy from our $libdir
+
+cssFile, iconFile, jsFile, plusFile,minusFile :: String
+cssFile   = "haddock.css"
+iconFile  = "haskell_icon.gif"
+jsFile    = "haddock.js"
+plusFile  = "plus.gif"
+minusFile = "minus.gif"
+
+-----------------------------------------------------------------------------
+-- misc.
+
+getProgramName :: IO String
+getProgramName = liftM (`withoutSuffix` ".bin") getProgName
+   where str `withoutSuffix` suff
+            | suff `isSuffixOf` str = take (length str - length suff) str
+            | otherwise             = str
+
+bye :: String -> IO a
+bye s = putStr s >> exitWith ExitSuccess
+
+die :: String -> IO a
+die s = hPutStr stderr s >> exitWith (ExitFailure 1)
+
+dieMsg :: String -> IO a
+dieMsg s = getProgramName >>= \prog -> die (prog ++ ": " ++ s)
+
+noDieMsg :: String -> IO ()
+noDieMsg s = getProgramName >>= \prog -> hPutStr stderr (prog ++ ": " ++ s)
+
+mapSnd :: (b -> c) -> [(a,b)] -> [(a,c)]
+mapSnd _ [] = []
+mapSnd f ((x,y):xs) = (x,f y) : mapSnd f xs
+
+mapMaybeM :: Monad m => (a -> m b) -> Maybe a -> m (Maybe b)
+mapMaybeM _ Nothing = return Nothing
+mapMaybeM f (Just a) = f a >>= return . Just
+
+escapeStr :: String -> String
+#if __GLASGOW_HASKELL__ < 603
+escapeStr = flip escapeString unreserved
+#else
+escapeStr = escapeURIString isUnreserved
+#endif
+
+-- there should be a better way to check this using the GHC API
+isConSym n = head (nameOccString n) == ':'
+isVarSym n = fstChar /= '_' && not (isConSym n) && (not . isLetter) fstChar
+  where fstChar = head (nameOccString n)
+
+nameOccString = occNameString . nameOccName 
+
+moduleString :: Module -> String
+moduleString = moduleNameString . moduleName 
+
+mkModuleNoPkg :: String -> Module
+mkModuleNoPkg str = mkModule (stringToPackageId "") (mkModuleName str)
+
+-----------------------------------------------------------------------------
+-- HTML cross references
+
+-- For each module, we need to know where its HTML documentation lives
+-- so that we can point hyperlinks to it.  It is extremely
+-- inconvenient to plumb this information to all the places that need
+-- it (basically every function in HaddockHtml), and furthermore the
+-- mapping is constant for any single run of Haddock.  So for the time
+-- being I'm going to use a write-once global variable.
+
+{-# NOINLINE html_xrefs_ref #-}
+html_xrefs_ref :: IORef (Map Module FilePath)
+html_xrefs_ref = unsafePerformIO (newIORef (error "module_map"))
+
+{-# NOINLINE html_xrefs #-}
+html_xrefs :: Map Module FilePath
+html_xrefs = unsafePerformIO (readIORef html_xrefs_ref)
+
+-----------------------------------------------------------------------------
+-- put here temporarily
+
+markup :: DocMarkup id a -> HsDoc id -> a
+markup m DocEmpty              = markupEmpty m
+markup m (DocAppend d1 d2)     = markupAppend m (markup m d1) (markup m d2)
+markup m (DocString s)         = markupString m s
+markup m (DocParagraph d)      = markupParagraph m (markup m d)
+markup m (DocIdentifier ids)   = markupIdentifier m ids
+markup m (DocModule mod0)      = markupModule m mod0
+markup m (DocEmphasis d)       = markupEmphasis m (markup m d)
+markup m (DocMonospaced d)     = markupMonospaced m (markup m d)
+markup m (DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds)
+markup m (DocOrderedList ds)   = markupOrderedList m (map (markup m) ds)
+markup m (DocDefList ds)       = markupDefList m (map (markupPair m) ds)
+markup m (DocCodeBlock d)      = markupCodeBlock m (markup m d)
+markup m (DocURL url)          = markupURL m url
+markup m (DocAName ref)        = markupAName m ref
+
+markupPair :: DocMarkup id a -> (HsDoc id, HsDoc id) -> (a, a)
+markupPair m (a,b) = (markup m a, markup m b)
+
+-- | The identity markup
+idMarkup :: DocMarkup a (HsDoc a)
+idMarkup = Markup {
+  markupEmpty         = DocEmpty,
+  markupString        = DocString,
+  markupParagraph     = DocParagraph,
+  markupAppend        = DocAppend,
+  markupIdentifier    = DocIdentifier,
+  markupModule        = DocModule,
+  markupEmphasis      = DocEmphasis,
+  markupMonospaced    = DocMonospaced,
+  markupUnorderedList = DocUnorderedList,
+  markupOrderedList   = DocOrderedList,
+  markupDefList       = DocDefList,
+  markupCodeBlock     = DocCodeBlock,
+  markupURL	      = DocURL,
+  markupAName	      = DocAName
+  }
+
+-- | Since marking up is just a matter of mapping 'Doc' into some
+-- other type, we can \'rename\' documentation by marking up 'Doc' into
+-- the same thing, modifying only the identifiers embedded in it.
+
+mapIdent f = idMarkup { markupIdentifier = f }
+
+-----------------------------------------------------------------------------
+-- put here temporarily
+
+newtype FormatVersion = FormatVersion Int deriving (Eq,Ord)
+
+nullFormatVersion :: FormatVersion
+nullFormatVersion = mkFormatVersion 0
+
+mkFormatVersion :: Int -> FormatVersion
+mkFormatVersion i = FormatVersion i
+
+instance Binary FormatVersion where
+   put_ bh (FormatVersion i) =
+      case compare i 0 of
+         EQ -> return ()
+         GT -> put_ bh (-i)
+         LT -> error (
+            "Binary.hs: negative FormatVersion " ++ show i 
+               ++ " is not allowed")
+   get bh =
+      do
+         (w8 :: Word8) <- get bh   
+         if testBit w8 7
+            then
+               do
+                  i <- get bh
+                  return (FormatVersion (-i))
+            else
+               return nullFormatVersion
diff --git a/src/Haddock/Utils/BlockTable.hs b/src/Haddock/Utils/BlockTable.hs
new file mode 100644
index 00000000..ed51654e
--- /dev/null
+++ b/src/Haddock/Utils/BlockTable.hs
@@ -0,0 +1,180 @@
+-----------------------------------------------------------------------------
+-- 
+-- Module      :  Text.Html.BlockTable
+-- Copyright   :  (c) Andy Gill, and the Oregon Graduate Institute of 
+--		  Science and Technology, 1999-2001
+-- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- 
+-- Maintainer  :  Andy Gill <andy@galconn.com>
+-- Stability   :  experimental
+-- Portability :  portable
+--
+-- $Id: BlockTable.hs,v 1.2 2002/07/24 09:42:18 simonmar Exp $
+--
+-- An Html combinator library
+--
+-----------------------------------------------------------------------------
+
+module Haddock.Utils.BlockTable (
+
+-- Datatypes:
+
+      BlockTable,             -- abstract
+
+-- Contruction Functions: 
+
+      single,
+      empty,
+      above,
+      beside,
+
+-- Investigation Functions: 
+
+      getMatrix,
+      showsTable,
+      showTable,
+
+      ) where
+
+import Prelude
+
+infixr 4 `beside`
+infixr 3 `above`
+
+-- These combinators can be used to build formated 2D tables.
+-- The specific target useage is for HTML table generation.
+
+{-
+   Examples of use:
+
+  	> table1 :: BlockTable String
+  	> table1 = single "Hello"	+-----+
+					|Hello|
+	  This is a 1x1 cell		+-----+
+	  Note: single has type
+	 
+		single :: a -> BlockTable a
+	
+	  So the cells can contain anything.
+	
+	> table2 :: BlockTable String
+	> table2 = single "World"	+-----+
+					|World|
+					+-----+
+
+
+	> table3 :: BlockTable String
+	> table3 = table1 %-% table2	+-----%-----+
+					|Hello%World|
+	 % is used to indicate		+-----%-----+
+	 the join edge between
+	 the two Tables.  
+
+	> table4 :: BlockTable String
+	> table4 = table3 %/% table2	+-----+-----+
+					|Hello|World|
+	  Notice the padding on the	%%%%%%%%%%%%%
+	  smaller (bottom) cell to	|World      |
+	  force the table to be a	+-----------+
+	  rectangle.
+
+	> table5 :: BlockTable String
+	> table5 = table1 %-% table4	+-----%-----+-----+
+					|Hello%Hello|World|
+	  Notice the padding on the	|     %-----+-----+
+	  leftmost cell, again to	|     %World      |
+	  force the table to be a	+-----%-----------+
+	  rectangle.
+ 
+   Now the table can be rendered with processTable, for example:
+	Main> processTable table5
+	[[("Hello",(1,2)),
+	  ("Hello",(1,1)),
+	  ("World",(1,1))],
+	 [("World",(2,1))]] :: [[([Char],(Int,Int))]]
+	Main> 
+-}
+
+-- ---------------------------------------------------------------------------
+-- Contruction Functions
+
+-- Perhaps one day I'll write the Show instance
+-- to show boxes aka the above ascii renditions.
+
+instance (Show a) => Show (BlockTable a) where
+      showsPrec _ = showsTable
+
+type TableI a = [[(a,(Int,Int))]] -> [[(a,(Int,Int))]]
+
+data BlockTable a = Table (Int -> Int -> TableI a) Int Int
+
+
+-- You can create a (1x1) table entry
+
+single :: a -> BlockTable a
+single a = Table (\ x y r -> [(a,(x+1,y+1))] : r) 1 1
+
+empty :: BlockTable a
+empty = Table (\ _ _ r -> r) 0 0
+
+
+-- You can compose tables, horizonally and vertically
+
+above  :: BlockTable a -> BlockTable a -> BlockTable a
+beside :: BlockTable a -> BlockTable a -> BlockTable a
+
+t1 `above` t2 = trans (combine (trans t1) (trans t2) (.))
+
+t1 `beside` t2 = combine t1 t2 (\ lst1 lst2 r ->
+    let
+      -- Note this depends on the fact that
+      -- that the result has the same number
+      -- of lines as the y dimention; one list
+      -- per line. This is not true in general
+      -- but is always true for these combinators.
+      -- I should assert this!
+      -- I should even prove this.
+      beside' (x:xs) (y:ys) = (x ++ y) : beside' xs ys
+      beside' (x:xs) []     = x        : xs ++ r
+      beside' []     (y:ys) = y        : ys ++ r
+      beside' []     []     =                  r
+    in
+      beside' (lst1 []) (lst2 []))
+
+-- trans flips (transposes) over the x and y axis of
+-- the table. It is only used internally, and typically
+-- in pairs, ie. (flip ... munge ... (un)flip).
+
+trans :: BlockTable a -> BlockTable a
+trans (Table f1 x1 y1) = Table (flip f1) y1 x1
+
+combine :: BlockTable a 
+      -> BlockTable b 
+      -> (TableI a -> TableI b -> TableI c) 
+      -> BlockTable c
+combine (Table f1 x1 y1) (Table f2 x2 y2) comb = Table new_fn (x1+x2) max_y
+    where
+      max_y = max y1 y2
+      new_fn x y =
+         case compare y1 y2 of
+          EQ -> comb (f1 0 y)             (f2 x y)
+          GT -> comb (f1 0 y)             (f2 x (y + y1 - y2))
+          LT -> comb (f1 0 (y + y2 - y1)) (f2 x y)
+
+-- ---------------------------------------------------------------------------
+-- Investigation Functions
+
+-- This is the other thing you can do with a Table;
+-- turn it into a 2D list, tagged with the (x,y)
+-- sizes of each cell in the table.
+
+getMatrix :: BlockTable a -> [[(a,(Int,Int))]]
+getMatrix (Table r _ _) = r 0 0 []
+
+-- You can also look at a table
+
+showsTable :: (Show a) => BlockTable a -> ShowS
+showsTable table = shows (getMatrix table)
+
+showTable :: (Show a) => BlockTable a -> String
+showTable table = showsTable table ""
diff --git a/src/Haddock/Utils/FastMutInt2.hs b/src/Haddock/Utils/FastMutInt2.hs
new file mode 100644
index 00000000..c47b514b
--- /dev/null
+++ b/src/Haddock/Utils/FastMutInt2.hs
@@ -0,0 +1,63 @@
+{-# OPTIONS_GHC -cpp -fglasgow-exts #-}
+--
+-- (c) The University of Glasgow 2002
+--
+-- Unboxed mutable Ints
+
+module Haddock.Utils.FastMutInt2(
+	FastMutInt, newFastMutInt,
+	readFastMutInt, writeFastMutInt,
+	incFastMutInt, incFastMutIntBy
+  ) where
+
+#include "MachDeps.h"
+
+#ifndef SIZEOF_HSINT
+#define SIZEOF_HSINT  INT_SIZE_IN_BYTES
+#endif
+
+
+#if __GLASGOW_HASKELL__ < 503
+import GlaExts
+import PrelIOBase
+#else
+import GHC.Base
+import GHC.IOBase
+#endif
+
+#if __GLASGOW_HASKELL__ < 411
+newByteArray# = newCharArray#
+#endif
+
+#ifdef __GLASGOW_HASKELL__
+data FastMutInt = FastMutInt (MutableByteArray# RealWorld)
+
+newFastMutInt :: IO FastMutInt
+newFastMutInt = IO $ \s0 ->
+  case newByteArray# size s0 of { (# s, arr #) ->
+  (# s, FastMutInt arr #) }
+  where I# size = SIZEOF_HSINT
+
+readFastMutInt :: FastMutInt -> IO Int
+readFastMutInt (FastMutInt arr) = IO $ \s0 ->
+  case readIntArray# arr 0# s0 of { (# s, i #) ->
+  (# s, I# i #) }
+
+writeFastMutInt :: FastMutInt -> Int -> IO ()
+writeFastMutInt (FastMutInt arr) (I# i) = IO $ \s0 ->
+  case writeIntArray# arr 0# i s0 of { s ->
+  (# s, () #) }
+
+incFastMutInt :: FastMutInt -> IO Int	-- Returns original value
+incFastMutInt (FastMutInt arr) = IO $ \s0 ->
+  case readIntArray# arr 0# s0 of { (# s1, i #) ->
+  case writeIntArray# arr 0# (i +# 1#) s1 of { s ->
+  (# s, I# i #) } }
+
+incFastMutIntBy :: FastMutInt -> Int -> IO Int	-- Returns original value
+incFastMutIntBy (FastMutInt arr) (I# n) = IO $ \s0 ->
+  case readIntArray# arr 0# s0 of { (# s1, i #) ->
+  case writeIntArray# arr 0# (i +# n) s1 of { s ->
+  (# s, I# i #) } }
+#endif
+
diff --git a/src/Haddock/Utils/GHC.hs b/src/Haddock/Utils/GHC.hs
new file mode 100644
index 00000000..b6fb54d4
--- /dev/null
+++ b/src/Haddock/Utils/GHC.hs
@@ -0,0 +1,26 @@
+module Haddock.Utils.GHC where
+
+import Debug.Trace
+
+import GHC
+import HsSyn
+import SrcLoc
+import HscTypes
+import Outputable
+
+getMainDeclBinder :: HsDecl name -> Maybe name
+getMainDeclBinder (TyClD d) = Just (tcdName d)
+getMainDeclBinder (ValD d)
+   = case collectAcc d [] of
+        []       -> Nothing 
+        (name:_) -> Just (unLoc name)
+getMainDeclBinder (SigD d) = sigNameNoLoc d
+getMainDeclBinder (ForD (ForeignImport name _ _)) = Just (unLoc name)
+getMainDeclBinder (ForD (ForeignExport name _ _)) = Nothing
+getMainDeclBinder _ = Nothing
+
+-- To keep if if minf_iface is re-introduced
+--modInfoName = moduleName . mi_module . minf_iface
+--modInfoMod  = mi_module . minf_iface 
+
+trace_ppr x y = trace (showSDoc (ppr x)) y
diff --git a/src/Haddock/Utils/Html.hs b/src/Haddock/Utils/Html.hs
new file mode 100644
index 00000000..dbef2112
--- /dev/null
+++ b/src/Haddock/Utils/Html.hs
@@ -0,0 +1,1037 @@
+-----------------------------------------------------------------------------
+-- 
+-- Module      :  Text.Html
+-- Copyright   :  (c) Andy Gill, and the Oregon Graduate Institute of 
+--		  Science and Technology, 1999-2001
+-- License     :  BSD-style (see the file libraries/core/LICENSE)
+-- 
+-- Maintainer  :  Andy Gill <andy@galconn.com>
+-- Stability   :  experimental
+-- Portability :  portable
+--
+-- An Html combinator library
+--
+-----------------------------------------------------------------------------
+
+module Haddock.Utils.Html (
+      module Haddock.Utils.Html,
+      ) where
+
+import qualified Haddock.Utils.BlockTable as BT
+
+import Data.Char (isAscii, ord)
+import Numeric (showHex)
+
+infixr 2 +++  -- combining Html
+infixr 7 <<   -- nesting Html
+infixl 8 !    -- adding optional arguments
+
+
+-- A important property of Html is that all strings inside the
+-- structure are already in Html friendly format.
+-- For example, use of &gt;,etc.
+
+data HtmlElement
+{-
+ -    ..just..plain..normal..text... but using &copy; and &amb;, etc.
+ -}
+      = HtmlString String
+{-
+ -    <thetag {..attrs..}> ..content.. </thetag>
+ -}
+      | HtmlTag {                   -- tag with internal markup
+              markupTag      :: String,
+              markupAttrs    :: [HtmlAttr],
+              markupContent  :: Html
+              }
+
+{- These are the index-value pairs.
+ - The empty string is a synonym for tags with no arguments.
+ - (not strictly HTML, but anyway).
+ -}
+
+
+data HtmlAttr = HtmlAttr String String
+
+
+newtype Html = Html { getHtmlElements :: [HtmlElement] }
+
+-- Read MARKUP as the class of things that can be validly rendered
+-- inside MARKUP tag brackets. So this can be one or more Html's,
+-- or a String, for example.
+
+class HTML a where
+      toHtml     :: a -> Html
+      toHtmlFromList :: [a] -> Html
+
+      toHtmlFromList xs = Html (concat [ x | (Html x) <- map toHtml xs])
+
+instance HTML Html where
+      toHtml a    = a
+
+instance HTML Char where
+      toHtml       a = toHtml [a]
+      toHtmlFromList []  = Html []
+      toHtmlFromList str = Html [HtmlString (stringToHtmlString str)]
+
+instance (HTML a) => HTML [a] where
+    toHtml xs = toHtmlFromList xs
+
+class ADDATTRS a where
+      (!) :: a -> [HtmlAttr] -> a
+
+instance (ADDATTRS b) => ADDATTRS (a -> b) where
+      (!) fn attr = \ arg -> fn arg ! attr
+
+instance ADDATTRS Html where
+      (!) (Html htmls) attr = Html (map addAttrs htmls)
+        where
+              addAttrs html =
+                  case html of
+                       HtmlTag { markupAttrs   = markupAttrs0
+                               , markupTag     = markupTag0
+                               , markupContent = markupContent0 } ->
+                               HtmlTag { markupAttrs   = markupAttrs0 ++ attr
+                                       , markupTag     = markupTag0
+                                       , markupContent = markupContent0 }
+                       _                                         -> html
+
+
+(<<)            :: (HTML a) => (Html -> b) -> a        -> b
+fn << arg = fn (toHtml arg)
+
+
+concatHtml :: (HTML a) => [a] -> Html
+concatHtml as = Html (concat (map (getHtmlElements.toHtml) as))
+
+(+++) :: (HTML a,HTML b) => a -> b -> Html
+a +++ b = Html (getHtmlElements (toHtml a) ++ getHtmlElements (toHtml b))
+
+noHtml :: Html
+noHtml = Html []
+
+
+isNoHtml :: Html -> Bool
+isNoHtml (Html xs) = null xs
+
+
+tag  :: String -> Html -> Html
+tag str htmls =
+    Html [ HtmlTag { markupTag = str,
+                     markupAttrs = [],
+                     markupContent = htmls }
+         ]
+
+itag :: String -> Html
+itag str = tag str noHtml
+
+emptyAttr :: String -> HtmlAttr
+emptyAttr s = HtmlAttr s ""
+
+intAttr :: String -> Int -> HtmlAttr
+intAttr s i = HtmlAttr s (show i)
+
+strAttr :: String -> String -> HtmlAttr
+strAttr s t = HtmlAttr s t
+
+
+{-
+foldHtml :: (String -> [HtmlAttr] -> [a] -> a) 
+      -> (String -> a)
+      -> Html
+      -> a
+foldHtml f g (HtmlTag str attr fmls) 
+      = f str attr (map (foldHtml f g) fmls) 
+foldHtml f g (HtmlString  str)           
+      = g str
+
+-}
+-- Processing Strings into Html friendly things.
+-- This converts a String to a Html String.
+stringToHtmlString :: String -> String
+stringToHtmlString = concatMap fixChar
+    where
+      fixChar '<' = "&lt;"
+      fixChar '>' = "&gt;"
+      fixChar '&' = "&amp;"
+      fixChar '"' = "&quot;"
+      fixChar c
+	| isAscii c = [c]
+	| otherwise = "&#x" ++ showHex (ord c) ";"
+
+-- ---------------------------------------------------------------------------
+-- Classes
+
+instance Show Html where
+      showsPrec _ html = showString (prettyHtml html)
+      showList htmls   = showString (concat (map show htmls))
+
+instance Show HtmlAttr where
+      showsPrec _ (HtmlAttr str val) = 
+              showString str .
+              showString "=" .
+              shows val
+
+
+-- ---------------------------------------------------------------------------
+-- Data types
+
+type URL = String
+
+-- ---------------------------------------------------------------------------
+-- Basic primitives
+
+-- This is not processed for special chars. 
+-- use stringToHtml or lineToHtml instead, for user strings, 
+-- because they  understand special chars, like '<'.
+
+primHtml      :: String                                -> Html
+primHtml x    = Html [HtmlString x]
+
+-- ---------------------------------------------------------------------------
+-- Basic Combinators
+
+stringToHtml          :: String                       -> Html
+stringToHtml = primHtml . stringToHtmlString 
+
+-- This converts a string, but keeps spaces as non-line-breakable
+
+lineToHtml            :: String                       -> Html
+lineToHtml = primHtml . concatMap htmlizeChar2 . stringToHtmlString 
+   where 
+      htmlizeChar2 ' ' = "&nbsp;"
+      htmlizeChar2 c   = [c]
+
+-- ---------------------------------------------------------------------------
+-- Html Constructors
+
+-- (automatically generated)
+
+address             :: Html -> Html
+anchor              :: Html -> Html
+applet              :: Html -> Html
+area                ::         Html
+basefont            ::         Html
+big                 :: Html -> Html
+blockquote          :: Html -> Html
+body                :: Html -> Html
+bold                :: Html -> Html
+br                  ::         Html
+button		    :: Html -> Html
+caption             :: Html -> Html
+center              :: Html -> Html
+cite                :: Html -> Html
+ddef                :: Html -> Html
+define              :: Html -> Html
+dlist               :: Html -> Html
+dterm               :: Html -> Html
+emphasize           :: Html -> Html
+fieldset            :: Html -> Html
+font                :: Html -> Html
+form                :: Html -> Html
+frame               :: Html -> Html
+frameset            :: Html -> Html
+h1                  :: Html -> Html
+h2                  :: Html -> Html
+h3                  :: Html -> Html
+h4                  :: Html -> Html
+h5                  :: Html -> Html
+h6                  :: Html -> Html
+header              :: Html -> Html
+hr                  ::         Html
+image               ::         Html
+input               ::         Html
+italics             :: Html -> Html
+keyboard            :: Html -> Html
+legend              :: Html -> Html
+li                  :: Html -> Html
+meta                ::         Html
+noframes            :: Html -> Html
+olist               :: Html -> Html
+option              :: Html -> Html
+paragraph           :: Html -> Html
+param               ::         Html
+pre                 :: Html -> Html
+sample              :: Html -> Html
+script		    :: Html -> Html
+select              :: Html -> Html
+small               :: Html -> Html
+strong              :: Html -> Html
+style               :: Html -> Html
+sub                 :: Html -> Html
+sup                 :: Html -> Html
+table               :: Html -> Html
+thetd               :: Html -> Html
+textarea            :: Html -> Html
+th                  :: Html -> Html
+thebase             ::         Html
+thecode             :: Html -> Html
+thediv              :: Html -> Html
+thehtml             :: Html -> Html
+thelink             ::         Html
+themap              :: Html -> Html
+thespan             :: Html -> Html
+thetitle            :: Html -> Html
+tr                  :: Html -> Html
+tt                  :: Html -> Html
+ulist               :: Html -> Html
+underline           :: Html -> Html
+variable            :: Html -> Html
+
+address             =  tag "ADDRESS"
+anchor              =  tag "A"
+applet              =  tag "APPLET"
+area                = itag "AREA"
+basefont            = itag "BASEFONT"
+big                 =  tag "BIG"
+blockquote          =  tag "BLOCKQUOTE"
+body                =  tag "BODY"
+bold                =  tag "B"
+br                  = itag "BR"
+button		    =  tag "BUTTON"
+caption             =  tag "CAPTION"
+center              =  tag "CENTER"
+cite                =  tag "CITE"
+ddef                =  tag "DD"
+define              =  tag "DFN"
+dlist               =  tag "DL"
+dterm               =  tag "DT"
+emphasize           =  tag "EM"
+fieldset            =  tag "FIELDSET"
+font                =  tag "FONT"
+form                =  tag "FORM"
+frame               =  tag "FRAME"
+frameset            =  tag "FRAMESET"
+h1                  =  tag "H1"
+h2                  =  tag "H2"
+h3                  =  tag "H3"
+h4                  =  tag "H4"
+h5                  =  tag "H5"
+h6                  =  tag "H6"
+header              =  tag "HEAD"
+hr                  = itag "HR"
+image               = itag "IMG"
+input               = itag "INPUT"
+italics             =  tag "I"
+keyboard            =  tag "KBD"
+legend              =  tag "LEGEND"
+li                  =  tag "LI"
+meta                = itag "META"
+noframes            =  tag "NOFRAMES"
+olist               =  tag "OL"
+option              =  tag "OPTION"
+paragraph           =  tag "P"
+param               = itag "PARAM"
+pre                 =  tag "PRE"
+sample              =  tag "SAMP"
+script		    =  tag "SCRIPT"
+select              =  tag "SELECT"
+small               =  tag "SMALL"
+strong              =  tag "STRONG"
+style               =  tag "STYLE"
+sub                 =  tag "SUB"
+sup                 =  tag "SUP"
+table               =  tag "TABLE"
+thetd               =  tag "TD"
+textarea            =  tag "TEXTAREA"
+th                  =  tag "TH"
+thebase             = itag "BASE"
+thecode             =  tag "CODE"
+thediv              =  tag "DIV"
+thehtml             =  tag "HTML"
+thelink             = itag "LINK"
+themap              =  tag "MAP"
+thespan             =  tag "SPAN"
+thetitle            =  tag "TITLE"
+tr                  =  tag "TR"
+tt                  =  tag "TT"
+ulist               =  tag "UL"
+underline           =  tag "U"
+variable            =  tag "VAR"
+
+-- ---------------------------------------------------------------------------
+-- Html Attributes
+
+-- (automatically generated)
+
+action              :: String -> HtmlAttr
+align               :: String -> HtmlAttr
+alink               :: String -> HtmlAttr
+alt                 :: String -> HtmlAttr
+altcode             :: String -> HtmlAttr
+archive             :: String -> HtmlAttr
+background          :: String -> HtmlAttr
+base                :: String -> HtmlAttr
+bgcolor             :: String -> HtmlAttr
+border              :: Int    -> HtmlAttr
+bordercolor         :: String -> HtmlAttr
+cellpadding         :: Int    -> HtmlAttr
+cellspacing         :: Int    -> HtmlAttr
+checked             ::           HtmlAttr
+clear               :: String -> HtmlAttr
+code                :: String -> HtmlAttr
+codebase            :: String -> HtmlAttr
+color               :: String -> HtmlAttr
+cols                :: String -> HtmlAttr
+colspan             :: Int    -> HtmlAttr
+compact             ::           HtmlAttr
+content             :: String -> HtmlAttr
+coords              :: String -> HtmlAttr
+enctype             :: String -> HtmlAttr
+face                :: String -> HtmlAttr
+frameborder         :: Int    -> HtmlAttr
+height              :: Int    -> HtmlAttr
+href                :: String -> HtmlAttr
+hspace              :: Int    -> HtmlAttr
+httpequiv           :: String -> HtmlAttr
+identifier          :: String -> HtmlAttr
+ismap               ::           HtmlAttr
+lang                :: String -> HtmlAttr
+link                :: String -> HtmlAttr
+marginheight        :: Int    -> HtmlAttr
+marginwidth         :: Int    -> HtmlAttr
+maxlength           :: Int    -> HtmlAttr
+method              :: String -> HtmlAttr
+multiple            ::           HtmlAttr
+name                :: String -> HtmlAttr
+nohref              ::           HtmlAttr
+noresize            ::           HtmlAttr
+noshade             ::           HtmlAttr
+nowrap              ::           HtmlAttr
+onclick		    :: String -> HtmlAttr
+rel                 :: String -> HtmlAttr
+rev                 :: String -> HtmlAttr
+rows                :: String -> HtmlAttr
+rowspan             :: Int    -> HtmlAttr
+rules               :: String -> HtmlAttr
+scrolling           :: String -> HtmlAttr
+selected            ::           HtmlAttr
+shape               :: String -> HtmlAttr
+size                :: String -> HtmlAttr
+src                 :: String -> HtmlAttr
+start               :: Int    -> HtmlAttr
+target              :: String -> HtmlAttr
+text                :: String -> HtmlAttr
+theclass            :: String -> HtmlAttr
+thestyle            :: String -> HtmlAttr
+thetype             :: String -> HtmlAttr
+title               :: String -> HtmlAttr
+usemap              :: String -> HtmlAttr
+valign              :: String -> HtmlAttr
+value               :: String -> HtmlAttr
+version             :: String -> HtmlAttr
+vlink               :: String -> HtmlAttr
+vspace              :: Int    -> HtmlAttr
+width               :: String -> HtmlAttr
+
+action              =   strAttr "ACTION"
+align               =   strAttr "ALIGN"
+alink               =   strAttr "ALINK"
+alt                 =   strAttr "ALT"
+altcode             =   strAttr "ALTCODE"
+archive             =   strAttr "ARCHIVE"
+background          =   strAttr "BACKGROUND"
+base                =   strAttr "BASE"
+bgcolor             =   strAttr "BGCOLOR"
+border              =   intAttr "BORDER"
+bordercolor         =   strAttr "BORDERCOLOR"
+cellpadding         =   intAttr "CELLPADDING"
+cellspacing         =   intAttr "CELLSPACING"
+checked             = emptyAttr "CHECKED"
+clear               =   strAttr "CLEAR"
+code                =   strAttr "CODE"
+codebase            =   strAttr "CODEBASE"
+color               =   strAttr "COLOR"
+cols                =   strAttr "COLS"
+colspan             =   intAttr "COLSPAN"
+compact             = emptyAttr "COMPACT"
+content             =   strAttr "CONTENT"
+coords              =   strAttr "COORDS"
+enctype             =   strAttr "ENCTYPE"
+face                =   strAttr "FACE"
+frameborder         =   intAttr "FRAMEBORDER"
+height              =   intAttr "HEIGHT"
+href                =   strAttr "HREF"
+hspace              =   intAttr "HSPACE"
+httpequiv           =   strAttr "HTTP-EQUIV"
+identifier          =   strAttr "ID"
+ismap               = emptyAttr "ISMAP"
+lang                =   strAttr "LANG"
+link                =   strAttr "LINK"
+marginheight        =   intAttr "MARGINHEIGHT"
+marginwidth         =   intAttr "MARGINWIDTH"
+maxlength           =   intAttr "MAXLENGTH"
+method              =   strAttr "METHOD"
+multiple            = emptyAttr "MULTIPLE"
+name                =   strAttr "NAME"
+nohref              = emptyAttr "NOHREF"
+noresize            = emptyAttr "NORESIZE"
+noshade             = emptyAttr "NOSHADE"
+nowrap              = emptyAttr "NOWRAP"
+onclick             =   strAttr "ONCLICK"
+rel                 =   strAttr "REL"
+rev                 =   strAttr "REV"
+rows                =   strAttr "ROWS"
+rowspan             =   intAttr "ROWSPAN"
+rules               =   strAttr "RULES"
+scrolling           =   strAttr "SCROLLING"
+selected            = emptyAttr "SELECTED"
+shape               =   strAttr "SHAPE"
+size                =   strAttr "SIZE"
+src                 =   strAttr "SRC"
+start               =   intAttr "START"
+target              =   strAttr "TARGET"
+text                =   strAttr "TEXT"
+theclass            =   strAttr "CLASS"
+thestyle            =   strAttr "STYLE"
+thetype             =   strAttr "TYPE"
+title               =   strAttr "TITLE"
+usemap              =   strAttr "USEMAP"
+valign              =   strAttr "VALIGN"
+value               =   strAttr "VALUE"
+version             =   strAttr "VERSION"
+vlink               =   strAttr "VLINK"
+vspace              =   intAttr "VSPACE"
+width               =   strAttr "WIDTH"
+
+-- ---------------------------------------------------------------------------
+-- Html Constructors
+
+-- (automatically generated)
+
+validHtmlTags :: [String]
+validHtmlTags = [
+      "ADDRESS",
+      "A",
+      "APPLET",
+      "BIG",
+      "BLOCKQUOTE",
+      "BODY",
+      "B",
+      "CAPTION",
+      "CENTER",
+      "CITE",
+      "DD",
+      "DFN",
+      "DL",
+      "DT",
+      "EM",
+      "FIELDSET",
+      "FONT",
+      "FORM",
+      "FRAME",
+      "FRAMESET",
+      "H1",
+      "H2",
+      "H3",
+      "H4",
+      "H5",
+      "H6",
+      "HEAD",
+      "I",
+      "KBD",
+      "LEGEND",
+      "LI",
+      "NOFRAMES",
+      "OL",
+      "OPTION",
+      "P",
+      "PRE",
+      "SAMP",
+      "SELECT",
+      "SMALL",
+      "STRONG",
+      "STYLE",
+      "SUB",
+      "SUP",
+      "TABLE",
+      "TD",
+      "TEXTAREA",
+      "TH",
+      "CODE",
+      "DIV",
+      "HTML",
+      "LINK",
+      "MAP",
+      "TITLE",
+      "TR",
+      "TT",
+      "UL",
+      "U",
+      "VAR"]
+
+validHtmlITags :: [String]
+validHtmlITags = [
+      "AREA",
+      "BASEFONT",
+      "BR",
+      "HR",
+      "IMG",
+      "INPUT",
+      "LINK",
+      "META",
+      "PARAM",
+      "BASE"]
+
+validHtmlAttrs :: [String]
+validHtmlAttrs = [
+      "ACTION",
+      "ALIGN",
+      "ALINK",
+      "ALT",
+      "ALTCODE",
+      "ARCHIVE",
+      "BACKGROUND",
+      "BASE",
+      "BGCOLOR",
+      "BORDER",
+      "BORDERCOLOR",
+      "CELLPADDING",
+      "CELLSPACING",
+      "CHECKED",
+      "CLEAR",
+      "CODE",
+      "CODEBASE",
+      "COLOR",
+      "COLS",
+      "COLSPAN",
+      "COMPACT",
+      "CONTENT",
+      "COORDS",
+      "ENCTYPE",
+      "FACE",
+      "FRAMEBORDER",
+      "HEIGHT",
+      "HREF",
+      "HSPACE",
+      "HTTP-EQUIV",
+      "ID",
+      "ISMAP",
+      "LANG",
+      "LINK",
+      "MARGINHEIGHT",
+      "MARGINWIDTH",
+      "MAXLENGTH",
+      "METHOD",
+      "MULTIPLE",
+      "NAME",
+      "NOHREF",
+      "NORESIZE",
+      "NOSHADE",
+      "NOWRAP",
+      "REL",
+      "REV",
+      "ROWS",
+      "ROWSPAN",
+      "RULES",
+      "SCROLLING",
+      "SELECTED",
+      "SHAPE",
+      "SIZE",
+      "SRC",
+      "START",
+      "TARGET",
+      "TEXT",
+      "CLASS",
+      "STYLE",
+      "TYPE",
+      "TITLE",
+      "USEMAP",
+      "VALIGN",
+      "VALUE",
+      "VERSION",
+      "VLINK",
+      "VSPACE",
+      "WIDTH"]
+
+-- ---------------------------------------------------------------------------
+-- Html colors
+
+aqua          :: String
+black         :: String
+blue          :: String
+fuchsia       :: String
+gray          :: String
+green         :: String
+lime          :: String
+maroon        :: String
+navy          :: String
+olive         :: String
+purple        :: String
+red           :: String
+silver        :: String
+teal          :: String
+yellow        :: String
+white         :: String
+
+aqua          = "aqua"
+black         = "black"
+blue          = "blue"
+fuchsia       = "fuchsia"
+gray          = "gray"
+green         = "green"
+lime          = "lime"
+maroon        = "maroon"
+navy          = "navy"
+olive         = "olive"
+purple        = "purple"
+red           = "red"
+silver        = "silver"
+teal          = "teal"
+yellow        = "yellow"
+white         = "white"
+
+-- ---------------------------------------------------------------------------
+-- Basic Combinators
+
+linesToHtml :: [String]       -> Html
+
+linesToHtml []     = noHtml
+linesToHtml (x:[]) = lineToHtml x
+linesToHtml (x:xs) = lineToHtml x +++ br +++ linesToHtml xs
+
+
+-- ---------------------------------------------------------------------------
+-- Html abbriviations
+
+primHtmlChar  :: String -> Html
+copyright     :: Html
+spaceHtml     :: Html
+bullet        :: Html
+p             :: Html -> Html
+
+primHtmlChar  = \ x -> primHtml ("&" ++ x ++ ";")
+copyright     = primHtmlChar "copy"
+spaceHtml     = primHtmlChar "nbsp"
+bullet        = primHtmlChar "#149"
+
+p             = paragraph
+
+-- ---------------------------------------------------------------------------
+-- Html tables
+
+cell :: Html -> HtmlTable
+cell h = let
+              cellFn x y = h ! (add x colspan $ add y rowspan $ [])
+              add 1 _  rest = rest
+              add n fn rest = fn n : rest
+              r = BT.single cellFn
+         in 
+              mkHtmlTable r
+
+-- We internally represent the Cell inside a Table with an
+-- object of the type
+-- \pre{
+-- 	   Int -> Int -> Html
+-- } 	
+-- When we render it later, we find out how many columns
+-- or rows this cell will span over, and can
+-- include the correct colspan/rowspan command.
+
+newtype HtmlTable 
+      = HtmlTable (BT.BlockTable (Int -> Int -> Html))
+
+td :: Html -> HtmlTable
+td = cell . thetd
+
+tda :: [HtmlAttr] -> Html -> HtmlTable
+tda as = cell . (thetd ! as)
+
+above, beside :: HtmlTable -> HtmlTable -> HtmlTable
+above  a b = combine BT.above a b
+beside a b = combine BT.beside a b
+
+infixr 3 </>  -- combining table cells 
+infixr 4 <->  -- combining table cells
+(</>), (<->) :: HtmlTable -> HtmlTable -> HtmlTable
+(</>) = above
+(<->) = beside
+
+emptyTable :: HtmlTable
+emptyTable = HtmlTable BT.empty
+
+aboves, besides :: [HtmlTable] -> HtmlTable
+aboves  = foldr above  emptyTable
+besides = foldr beside emptyTable
+
+mkHtmlTable :: BT.BlockTable (Int -> Int -> Html) -> HtmlTable
+mkHtmlTable r = HtmlTable r
+
+combine :: (BT.BlockTable (Int -> Int -> Html)
+	    -> BT.BlockTable (Int -> Int -> Html)
+	    -> BT.BlockTable (Int -> Int -> Html))
+	-> HtmlTable -> HtmlTable -> HtmlTable
+combine fn (HtmlTable a) (HtmlTable b) = mkHtmlTable (a `fn` b)
+
+-- renderTable takes the HtmlTable, and renders it back into
+-- and Html object.
+
+renderTable :: BT.BlockTable (Int -> Int -> Html) -> Html
+renderTable theTable
+      = concatHtml
+          [tr << [theCell x y | (theCell,(x,y)) <- theRow ]
+                      | theRow <- BT.getMatrix theTable]
+
+instance HTML HtmlTable where
+      toHtml (HtmlTable tab) = renderTable tab
+
+instance Show HtmlTable where
+      showsPrec _ (HtmlTable tab) = shows (renderTable tab)
+
+
+-- If you can't be bothered with the above, then you
+-- can build simple tables with simpleTable.
+-- Just provide the attributes for the whole table,
+-- attributes for the cells (same for every cell),
+-- and a list of lists of cell contents,
+-- and this function will build the table for you.
+-- It does presume that all the lists are non-empty,
+-- and there is at least one list.
+--  
+-- Different length lists means that the last cell
+-- gets padded. If you want more power, then
+-- use the system above, or build tables explicitly.
+
+simpleTable :: HTML a => [HtmlAttr] -> [HtmlAttr] -> [[a]] -> Html
+simpleTable attr cellAttr lst
+      = table ! attr 
+          <<  (aboves 
+              . map (besides . map (cell . (thetd ! cellAttr) . toHtml))
+              ) lst
+
+
+-- ---------------------------------------------------------------------------
+-- Tree Displaying Combinators
+ 
+-- The basic idea is you render your structure in the form
+-- of this tree, and then use treeHtml to turn it into a Html
+-- object with the structure explicit.
+
+data HtmlTree
+      = HtmlLeaf Html
+      | HtmlNode Html [HtmlTree] Html
+
+treeHtml :: [String] -> HtmlTree -> Html
+treeHtml colors h = table ! [
+                    border 0,
+                    cellpadding 0,
+                    cellspacing 2] << treeHtml' colors h
+     where
+      manycolors = scanr (:) []
+
+      treeHtmls :: [[String]] -> [HtmlTree] -> HtmlTable
+      treeHtmls c ts = aboves (zipWith treeHtml' c ts)
+
+      treeHtml' :: [String] -> HtmlTree -> HtmlTable
+      treeHtml' (_:_) (HtmlLeaf leaf) = cell
+                                         (thetd ! [width "100%"] 
+                                            << bold  
+                                               << leaf)
+      treeHtml' (c:cs@(c2:_)) (HtmlNode hopen ts hclose) =
+          if null ts && isNoHtml hclose
+          then
+              hd 
+          else if null ts
+          then
+              hd </> bar `beside` (cell . (thetd ! [bgcolor c2]) << spaceHtml)
+                 </> tl
+          else
+              hd </> (bar `beside` treeHtmls morecolors ts)
+                 </> tl
+        where
+              -- This stops a column of colors being the same
+              -- color as the immeduately outside nesting bar.
+              morecolors = filter ((/= c).head) (manycolors cs)
+              bar = cell (thetd ! [bgcolor c,width "10"] << spaceHtml)
+              hd = cell (thetd ! [bgcolor c] << hopen)
+              tl = cell (thetd ! [bgcolor c] << hclose)
+      treeHtml' _ _ = error "The imposible happens"
+
+instance HTML HtmlTree where
+      toHtml x = treeHtml treeColors x
+
+-- type "length treeColors" to see how many colors are here.
+treeColors :: [String]
+treeColors = ["#88ccff","#ffffaa","#ffaaff","#ccffff"] ++ treeColors
+
+
+-- ---------------------------------------------------------------------------
+-- Html Debugging Combinators
+ 
+-- This uses the above tree rendering function, and displays the
+-- Html as a tree structure, allowing debugging of what is
+-- actually getting produced.
+
+debugHtml :: (HTML a) => a -> Html
+debugHtml obj = table ! [border 0] << (
+                  cell (th ! [bgcolor "#008888"] 
+                     	<< underline
+                       	   << "Debugging Output")
+               </>  td << (toHtml (debug' (toHtml obj)))
+              )
+  where
+
+      debug' :: Html -> [HtmlTree]
+      debug' (Html markups) = map debug markups
+
+      debug :: HtmlElement -> HtmlTree
+      debug (HtmlString str) = HtmlLeaf (spaceHtml +++
+                                              linesToHtml (lines str))
+      debug (HtmlTag {
+              markupTag = markupTag0,
+              markupContent = markupContent0,
+              markupAttrs  = markupAttrs0
+              }) =
+              case markupContent0 of
+                Html [] -> HtmlNode hd [] noHtml
+                Html xs -> HtmlNode hd (map debug xs) tl
+        where
+              args = if null markupAttrs0
+                     then ""
+                     else "  " ++ unwords (map show markupAttrs0) 
+              hd = font ! [size "1"] << ("<" ++ markupTag0 ++ args ++ ">")
+              tl = font ! [size "1"] << ("</" ++ markupTag0 ++ ">")
+
+-- ---------------------------------------------------------------------------
+-- Hotlink datatype
+
+data HotLink = HotLink {
+      hotLinkURL        :: URL,
+      hotLinkContents   :: [Html],
+      hotLinkAttributes :: [HtmlAttr]
+      } deriving Show
+
+instance HTML HotLink where
+      toHtml hl = anchor ! (href (hotLinkURL hl) : hotLinkAttributes hl)
+                      << hotLinkContents hl
+
+hotlink :: URL -> [Html] -> HotLink
+hotlink url h = HotLink {
+      hotLinkURL = url,
+      hotLinkContents = h,
+      hotLinkAttributes = [] }
+
+
+-- ---------------------------------------------------------------------------
+-- More Combinators
+
+-- (Abridged from Erik Meijer's Original Html library)
+
+ordList   :: (HTML a) => [a] -> Html
+ordList items = olist << map (li <<) items
+
+unordList :: (HTML a) => [a] -> Html
+unordList items = ulist << map (li <<) items
+
+defList   :: (HTML a,HTML b) => [(a,b)] -> Html
+defList items
+ = dlist << [ [ dterm << bold << dt, ddef << dd ] | (dt,dd) <- items ]
+
+
+widget :: String -> String -> [HtmlAttr] -> Html
+widget w n markupAttrs0 = input ! ([thetype w,name n] ++ markupAttrs0)
+
+checkbox :: String -> String -> Html
+hidden   :: String -> String -> Html
+radio    :: String -> String -> Html
+reset    :: String -> String -> Html
+submit   :: String -> String -> Html
+password :: String           -> Html
+textfield :: String          -> Html
+afile    :: String           -> Html
+clickmap :: String           -> Html
+
+checkbox n v = widget "CHECKBOX" n [value v]
+hidden   n v = widget "HIDDEN"   n [value v]
+radio    n v = widget "RADIO"    n [value v]
+reset    n v = widget "RESET"    n [value v]
+submit   n v = widget "SUBMIT"   n [value v]
+password n   = widget "PASSWORD" n []
+textfield n  = widget "TEXT"     n []
+afile    n   = widget "FILE"     n []
+clickmap n   = widget "IMAGE"    n []
+
+menu :: String -> [Html] -> Html
+menu n choices
+   = select ! [name n] << [ option << p << choice | choice <- choices ]
+
+gui :: String -> Html -> Html
+gui act = form ! [action act,method "POST"]
+
+-- ---------------------------------------------------------------------------
+-- Html Rendering
+ 
+-- Uses the append trick to optimize appending.
+-- The output is quite messy, because space matters in
+-- HTML, so we must not generate needless spaces.
+
+renderHtml :: (HTML html) => html -> String
+renderHtml theHtml =
+      renderMessage ++ 
+         foldr (.) id (map unprettyHtml
+                           (getHtmlElements (tag "HTML" << theHtml))) "\n"
+
+renderMessage :: String
+renderMessage =
+      "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">\n" ++
+      "<!--Rendered using the Haskell Html Library v0.2-->\n"
+
+unprettyHtml :: HtmlElement -> ShowS
+unprettyHtml (HtmlString str) = (++) str
+unprettyHtml (HtmlTag
+              { markupTag = name0,
+                markupContent = html,
+                markupAttrs = markupAttrs0 })
+      = if isNoHtml html && elem name0 validHtmlITags
+        then renderTag True name0 markupAttrs0 0
+        else (renderTag True name0 markupAttrs0 0
+             . foldr (.) id (map unprettyHtml (getHtmlElements html))
+             . renderTag False name0 [] 0)
+
+-- Local Utilities
+prettyHtml :: (HTML html) => html -> String
+prettyHtml theHtml = 
+        unlines
+      $ concat
+      $ map prettyHtml'
+      $ getHtmlElements
+      $ toHtml theHtml
+
+prettyHtml' :: HtmlElement -> [String]
+prettyHtml' (HtmlString str) = [str]
+prettyHtml' (HtmlTag
+              { markupTag = name0,
+                markupContent = html,
+                markupAttrs = markupAttrs0 })
+      = if isNoHtml html && elem name0 validHtmlITags
+        then 
+         [rmNL (renderTag True name0 markupAttrs0 0 "")]
+        else
+         [rmNL (renderTag True name0 markupAttrs0 0 "")] ++ 
+          shift (concat (map prettyHtml' (getHtmlElements html))) ++
+         [rmNL (renderTag False name0 [] 0 "")]
+  where
+      shift = map (\x -> "   " ++ x)
+
+rmNL :: [Char] -> [Char]
+rmNL = filter (/= '\n')
+
+-- This prints the Tags The lack of spaces in intentunal, because Html is
+-- actually space dependant.
+
+renderTag :: Bool -> String -> [HtmlAttr] -> Int -> ShowS
+renderTag x name0 markupAttrs0 n r
+      = open ++ name0 ++ rest markupAttrs0 ++ ">" ++ r
+  where
+      open = if x then "<" else "</"
+      
+      nl = "\n" ++ replicate (n `div` 8) '\t' 
+                ++ replicate (n `mod` 8) ' '
+
+      rest []   = nl
+      rest attr = " " ++ unwords (map showPair attr) ++ nl
+
+      showPair :: HtmlAttr -> String
+      showPair (HtmlAttr tag0 val)
+              = tag0 ++ "=\"" ++ val  ++ "\""
+
diff --git a/src/Haddock/Version.hs b/src/Haddock/Version.hs
new file mode 100644
index 00000000..f4d02b7d
--- /dev/null
+++ b/src/Haddock/Version.hs
@@ -0,0 +1,18 @@
+--
+-- Haddock - A Haskell Documentation Tool
+--
+-- (c) Simon Marlow 2003
+--
+
+module Haddock.Version ( 
+	projectName, projectVersion, projectUrl
+   ) where
+
+import Paths_haddock_ghc ( version )
+import Data.Version      ( showVersion )
+
+projectName, projectUrl :: String
+projectName = "Haddock-GHC"
+projectUrl = "http://www.haskell.org/haddock/"
+
+projectVersion = showVersion version
-- 
cgit v1.2.3