First, experimental XHTML rendering

    switch to using the xhtml package

    copied Html.hs to Xhtml.hs
        and split into sub-modules under Haddock/Backends/Xhtml
        and detabify

    moved footer into div, got ready for iface change
    headers converted to semantic markup
    contents in semantic markup
    summary as semantic markup
    description in semantic markup, info block in header fixed

    factored out rendering so during debug it can be readable
        (see renderToString)

8 files changed, 2161 insertions, 0 deletions

diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs
new file mode 100644
index 00000000..630a603e
--- /dev/null
+++ b/src/Haddock/Backends/Xhtml.hs
@@ -0,0 +1,758 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Haddock.Backends.Html
+-- Copyright   :  (c) Simon Marlow   2003-2006,
+--                    David Waern    2006-2009,
+--                    Mark Lentczner 2010
+-- License     :  BSD-like
+--
+-- Maintainer  :  haddock@projects.haskell.org
+-- Stability   :  experimental
+-- Portability :  portable
+-----------------------------------------------------------------------------
+
+module Haddock.Backends.Xhtml ( 
+  ppHtml, copyHtmlBits, 
+  ppHtmlIndex, ppHtmlContents,
+  ppHtmlHelpFiles
+) where
+
+
+import Prelude hiding (div)
+
+import Haddock.Backends.DevHelp
+import Haddock.Backends.HH
+import Haddock.Backends.HH2
+import Haddock.Backends.Xhtml.Decl
+import Haddock.Backends.Xhtml.DocMarkup
+import Haddock.Backends.Xhtml.Layout
+import Haddock.Backends.Xhtml.Names
+import Haddock.Backends.Xhtml.Types
+import Haddock.Backends.Xhtml.Util
+import Haddock.ModuleTree
+import Haddock.Types
+import Haddock.Version
+import Haddock.Utils
+import Text.XHtml hiding ( name, title, p, quote )
+import qualified Text.XHtml as Html
+import Haddock.GhcUtils
+
+import Control.Exception     ( bracket )
+import Control.Monad         ( when, unless )
+import Control.Monad.Instances ( ) -- for Functor Either a
+import Data.Char             ( toUpper )
+import Data.Either
+import Data.List             ( sortBy, groupBy )
+import Data.Maybe
+import Foreign.Marshal.Alloc ( allocaBytes )
+import System.IO             ( IOMode(..), hClose, hGetBuf, hPutBuf, openFile )
+import System.Directory hiding ( copyFile )
+import Data.Map              ( Map )
+import qualified Data.Map as Map hiding ( Map )
+import Data.Function
+import Data.Ord              ( comparing )
+
+import GHC hiding ( NoLink, moduleInfo )
+import Name
+import Module
+
+
+
+-- -----------------------------------------------------------------------------
+-- Generating HTML documentation
+
+ppHtml  :: String
+        -> Maybe String                         -- package
+        -> [Interface]
+        -> FilePath                     -- destination directory
+        -> Maybe (Doc GHC.RdrName)    -- prologue text, maybe
+        -> 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)
+        -> Bool                         -- whether to use unicode in output (--use-unicode)
+        -> IO ()
+
+ppHtml doctitle maybe_package ifaces odir prologue maybe_html_help_format
+        maybe_source_url maybe_wiki_url
+        maybe_contents_url maybe_index_url unicode =  do
+  let
+        visible_ifaces = filter visible ifaces
+        visible i = OptHide `notElem` ifaceOptions i
+  when (not (isJust maybe_contents_url)) $ 
+    ppHtmlContents odir doctitle maybe_package
+        maybe_html_help_format maybe_index_url maybe_source_url maybe_wiki_url
+        (map toInstalledIface visible_ifaces)
+        False -- we don't want to display the packages in a single-package contents
+        prologue
+
+  when (not (isJust maybe_index_url)) $ 
+    ppHtmlIndex odir doctitle maybe_package maybe_html_help_format
+      maybe_contents_url maybe_source_url maybe_wiki_url 
+      (map toInstalledIface visible_ifaces)
+    
+  when (not (isJust maybe_contents_url && isJust maybe_index_url)) $ 
+        ppHtmlHelpFiles doctitle maybe_package ifaces odir maybe_html_help_format []
+
+  mapM_ (ppHtmlModule odir doctitle
+           maybe_source_url maybe_wiki_url
+           maybe_contents_url maybe_index_url unicode) visible_ifaces
+
+ppHtmlHelpFiles 
+    :: String                   -- doctitle
+    -> Maybe String                             -- package
+        -> [Interface]
+        -> FilePath                 -- destination directory
+        -> Maybe String             -- the Html Help format (--html-help)
+        -> [FilePath]               -- external packages paths
+        -> IO ()
+ppHtmlHelpFiles doctitle maybe_package ifaces odir maybe_html_help_format pkg_paths =  do
+  let
+        visible_ifaces = filter visible ifaces
+        visible i = OptHide `notElem` ifaceOptions i
+
+  -- Generate index and contents page for Html Help if requested
+  case maybe_html_help_format of
+    Nothing        -> return ()
+    Just "mshelp"  -> ppHHProject odir doctitle maybe_package visible_ifaces pkg_paths
+    Just "mshelp2" -> do
+                ppHH2Files      odir maybe_package visible_ifaces pkg_paths
+                ppHH2Collection odir doctitle maybe_package
+    Just "devhelp" -> ppDevHelpFile odir doctitle maybe_package visible_ifaces
+    Just format    -> fail ("The "++format++" format is not implemented")
+
+copyFile :: FilePath -> FilePath -> IO ()
+copyFile fromFPath toFPath =
+        (bracket (openFile fromFPath ReadMode) hClose $ \hFrom ->
+         bracket (openFile toFPath WriteMode) hClose $ \hTo ->
+         allocaBytes bufferSize $ \buffer ->
+                copyContents hFrom hTo buffer)
+        where
+                bufferSize = 1024
+                
+                copyContents hFrom hTo buffer = do
+                        count <- hGetBuf hFrom buffer bufferSize
+                        when (count > 0) $ do
+                                hPutBuf hTo buffer count
+                                copyContents hFrom hTo buffer
+
+
+copyHtmlBits :: FilePath -> FilePath -> Maybe FilePath -> IO ()
+copyHtmlBits odir libdir maybe_css = do
+  let 
+        libhtmldir = pathJoin [libdir, "html"]
+        css_file = case maybe_css of
+                        Nothing -> pathJoin [libhtmldir, 'x':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, framesFile ]
+
+footer :: Html
+footer =
+  thediv ! [theclass "bottom"] << paragraph << (
+    "Produced by " +++ 
+    (anchor ! [href projectUrl] << toHtml projectName) +++
+    (" version " ++ projectVersion)
+    )
+   
+srcButton :: SourceURLs -> Maybe Interface -> Maybe Html
+srcButton (Just src_base_url, _, _) Nothing =
+  Just (anchor ! [href src_base_url] << "Source code")
+srcButton (_, Just src_module_url, _) (Just iface) =
+  let url = spliceURL (Just $ ifaceOrigFilename iface)
+                      (Just $ ifaceMod iface) Nothing Nothing src_module_url
+   in Just (anchor ! [href url] << "Source code")
+srcButton _ _ =
+  Nothing
+ 
+  
+wikiButton :: WikiURLs -> Maybe Module -> Maybe Html
+wikiButton (Just wiki_base_url, _, _) Nothing =
+  Just (anchor ! [href wiki_base_url] << "User Comments")
+
+wikiButton (_, Just wiki_module_url, _) (Just mdl) =
+  let url = spliceURL Nothing (Just mdl) Nothing Nothing wiki_module_url
+   in Just (anchor ! [href url] << "User Comments")
+
+wikiButton _ _ =
+  Nothing
+
+contentsButton :: Maybe String -> Maybe Html
+contentsButton maybe_contents_url 
+  = Just (anchor ! [href url] << "Contents")
+  where url = maybe contentsHtmlFile id maybe_contents_url
+
+indexButton :: Maybe String -> Maybe Html
+indexButton maybe_index_url 
+  = Just (anchor ! [href url] << "Index")
+  where url = maybe indexHtmlFile id maybe_index_url
+
+simpleHeader :: String -> Maybe String -> Maybe String
+             -> SourceURLs -> WikiURLs -> Html
+simpleHeader doctitle maybe_contents_url maybe_index_url
+  maybe_source_url maybe_wiki_url = 
+  thediv ! [theclass "package-header"] << (
+    paragraph ! [theclass "caption"] << doctitle +++
+    unordList (catMaybes [ 
+      srcButton maybe_source_url Nothing,
+      wikiButton maybe_wiki_url Nothing,
+      contentsButton maybe_contents_url,
+      indexButton maybe_index_url
+      ]) ! [theclass "links"]
+  )
+
+pageHeader :: String -> Interface -> String
+    -> SourceURLs -> WikiURLs
+    -> Maybe String -> Maybe String -> Html
+pageHeader mdl iface doctitle
+           maybe_source_url maybe_wiki_url
+           maybe_contents_url maybe_index_url =
+  thediv ! [theclass "package-header"] << (
+    paragraph ! [theclass "caption"] << (doctitle +++ spaceHtml) +++
+    unordList (catMaybes [ 
+        srcButton maybe_source_url (Just iface),
+        wikiButton maybe_wiki_url (Just $ ifaceMod iface),
+        contentsButton maybe_contents_url,
+        indexButton maybe_index_url
+        ]) ! [theclass "links"]
+   ) +++
+  thediv ! [theclass "module-header"] << (
+    paragraph ! [theclass "caption"] << mdl +++
+    moduleInfo iface
+  )
+
+moduleInfo :: Interface -> Html
+moduleInfo iface = 
+   let
+      info = ifaceInfo iface
+
+      doOneEntry :: (String, (HaddockModInfo GHC.Name) -> Maybe String) -> Maybe (String, String)
+      doOneEntry (fieldName, field) = field info >>= \a -> return (fieldName, a)
+
+      entries :: [(String, String)]
+      entries = mapMaybe doOneEntry [
+         ("Portability",hmi_portability),
+         ("Stability",hmi_stability),
+         ("Maintainer",hmi_maintainer)
+         ]
+   in
+      case entries of
+         [] -> noHtml
+         _ -> defList entries ! [theclass "info"]
+
+-- ---------------------------------------------------------------------------
+-- Generate the module contents
+
+ppHtmlContents
+   :: FilePath
+   -> String
+   -> Maybe String
+   -> Maybe String
+   -> Maybe String
+   -> SourceURLs
+   -> WikiURLs
+   -> [InstalledInterface] -> Bool -> Maybe (Doc GHC.RdrName)
+   -> IO ()
+ppHtmlContents odir doctitle
+  maybe_package maybe_html_help_format maybe_index_url
+  maybe_source_url maybe_wiki_url ifaces showPkgs prologue = do
+  let tree = mkModuleTree showPkgs
+         [(instMod iface, toInstalledDescription iface) | iface <- ifaces]
+      html = 
+        header 
+                (documentCharacterEncoding +++
+                 thetitle (toHtml doctitle) +++
+                 styleSheet +++
+                 (script ! [src jsFile, thetype "text/javascript"] $ noHtml)) +++
+        body << (
+            simpleHeader doctitle Nothing maybe_index_url
+                             maybe_source_url maybe_wiki_url +++
+            vanillaTable << (
+               ppPrologue doctitle prologue </>
+               ppModuleTree doctitle tree) +++
+            footer
+          )
+  createDirectoryIfMissing True odir
+  writeFile (pathJoin [odir, contentsHtmlFile]) (renderToString html)
+
+  -- XXX: think of a better place for this?
+  ppHtmlContentsFrame odir doctitle ifaces
+  
+  -- 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 (Doc GHC.RdrName) -> HtmlTable
+ppPrologue _ Nothing = 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 tbl id_ []     = (tbl, id_)
+    genTable tbl id_ (x:xs) = genTable (tbl </> 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 :: Double -> Int -> Html -> HtmlTable
+    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 -> cell $ 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__
+
+
+-- | Turn a module tree into a flat list of full module names.  E.g.,
+-- @
+--  A
+--  +-B
+--  +-C
+-- @
+-- becomes
+-- @["A", "A.B", "A.B.C"]@
+flatModuleTree :: [InstalledInterface] -> [Html]
+flatModuleTree ifaces =
+    map (uncurry ppModule' . head)
+            . groupBy ((==) `on` fst)
+            . sortBy (comparing fst)
+            $ mods
+  where
+    mods = [ (moduleString mdl, mdl) | mdl <- map instMod ifaces ]
+    ppModule' txt mdl =
+      anchor ! [href ((moduleHtmlFile mdl)), target mainFrameName]
+        << toHtml txt
+
+ppHtmlContentsFrame :: FilePath -> String -> [InstalledInterface] -> IO ()
+ppHtmlContentsFrame odir doctitle ifaces = do
+  let mods = flatModuleTree ifaces
+      html =
+        header
+            (documentCharacterEncoding +++
+             thetitle (toHtml doctitle) +++
+             styleSheet +++
+             (script ! [src jsFile, thetype "text/javascript"] $ noHtml)) +++
+        body << vanillaTable << Html.p << (
+            foldr (+++) noHtml (map (+++br) mods))
+  createDirectoryIfMissing True odir
+  writeFile (pathJoin [odir, frameIndexHtmlFile]) (renderToString html)
+
+-- ---------------------------------------------------------------------------
+-- Generate the index
+
+ppHtmlIndex :: FilePath
+            -> String 
+            -> Maybe String
+            -> Maybe String
+            -> Maybe String
+            -> SourceURLs
+            -> WikiURLs
+            -> [InstalledInterface] 
+            -> IO ()
+ppHtmlIndex odir doctitle maybe_package maybe_html_help_format
+  maybe_contents_url maybe_source_url maybe_wiki_url ifaces = do
+  let html = 
+        header (documentCharacterEncoding +++
+                thetitle (toHtml (doctitle ++ " (Index)")) +++
+        styleSheet +++
+        (script ! [src jsFile, thetype "text/javascript"] $ noHtml)) +++
+        body << (
+            simpleHeader doctitle maybe_contents_url Nothing
+                         maybe_source_url maybe_wiki_url +++
+            vanillaTable << index_html
+           )
+
+  createDirectoryIfMissing True odir
+
+  when split_indices $
+    mapM_ (do_sub_index index) initialChars
+
+  writeFile (pathJoin [odir, indexHtmlFile]) (renderToString html)
+  
+    -- Generate index and contents page for Html Help if requested
+  case maybe_html_help_format of
+    Nothing        -> return ()
+    Just "mshelp"  -> ppHHIndex  odir maybe_package ifaces
+    Just "mshelp2" -> ppHH2Index odir maybe_package ifaces
+    Just "devhelp" -> return ()
+    Just format    -> fail ("The "++format++" format is not implemented")
+ where
+
+  index_html
+    | split_indices = 
+        tda [theclass "section1"] << 
+                toHtml ("Index") </>
+        indexInitialLetterLinks
+    | otherwise =
+        cell $ td << setTrClass (table ! [identifier "indexlist", cellpadding 0, cellspacing 5] <<
+          aboves (map indexElt index))
+
+  -- an arbitrary heuristic:
+  -- too large, and a single-page will be slow to load
+  -- too small, and we'll have lots of letter-indexes with only one
+  --   or two members in them, which seems inefficient or
+  --   unnecessarily hard to use.
+  split_indices = length index > 150
+
+  setTrClass :: Html -> Html
+  setTrClass = id
+  -- XHtml is more strict about not allowing you to poke inside a structure
+  -- hence this approach won't work for now -- since the whole table is
+  -- going away soon, this is just disabled for now.
+{-
+  setTrClass (Html xs) = Html $ map f xs
+      where
+          f (HtmlTag name attrs inner)
+               | map toUpper name == "TR" = HtmlTag name (theclass "indexrow":attrs) inner
+               | otherwise = HtmlTag name attrs (setTrClass inner)
+          f x = x
+-}      
+  indexInitialLetterLinks = 
+        td << setTrClass (table ! [cellpadding 0, cellspacing 5] <<
+            besides [ td << anchor ! [href (subIndexHtmlFile c)] <<
+                         toHtml [c]
+                    | c <- initialChars
+                    , any ((==c) . toUpper . head . fst) index ])
+
+  -- todo: what about names/operators that start with Unicode
+  -- characters?
+  -- Exports beginning with '_' can be listed near the end,
+  -- presumably they're not as important... but would be listed
+  -- with non-split index!
+  initialChars = [ 'A'..'Z' ] ++ ":!#$%&*+./<=>?@\\^|-~" ++ "_"
+
+  do_sub_index this_ix c
+    = unless (null index_part) $
+        writeFile (pathJoin [odir, subIndexHtmlFile c]) (renderToString html)
+    where 
+      html = header (documentCharacterEncoding +++
+                thetitle (toHtml (doctitle ++ " (Index)")) +++
+                styleSheet) +++
+             body << (
+                simpleHeader doctitle maybe_contents_url Nothing
+                             maybe_source_url maybe_wiki_url +++
+                vanillaTable << (
+                          indexInitialLetterLinks </>
+                tda [theclass "section1"] << 
+                toHtml ("Index (" ++ c:")") </>
+                td << setTrClass (table ! [identifier "indexlist", 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,_) = map toUpper n1 `compare` map toUpper n2
+
+  -- for each name (a plain string), we have a number of original HsNames that
+  -- it can refer to, and for each of those we have a list of modules
+  -- that export that entity.  Each of the modules exports the entity
+  -- in a visible or invisible way (hence the Bool).
+  full_index :: Map String (Map GHC.Name [(Module,Bool)])
+  full_index = Map.fromListWith (flip (Map.unionWith (++)))
+               (concat (map getIfaceIndex ifaces))
+
+  getIfaceIndex iface = 
+    [ (getOccString name
+       , Map.fromList [(name, [(mdl, name `elem` instVisibleExports iface)])])
+       | name <- instExports iface ]
+    where mdl = instMod iface
+
+  indexElt :: (String, Map GHC.Name [(Module,Bool)]) -> HtmlTable
+  indexElt (str, entities) = 
+     case Map.toAscList entities of
+        [(nm,entries)] ->  
+            tda [ theclass "indexentry" ] << toHtml str <-> 
+                        indexLinks nm entries
+        many_entities ->
+            tda [ theclass "indexentry" ] << toHtml str </> 
+                aboves (map doAnnotatedEntity (zip [1..] many_entities))
+
+  doAnnotatedEntity :: (Integer, (Name, [(Module, Bool)])) -> HtmlTable
+  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 mdl (Just nm) << toHtml (moduleString mdl)
+          else
+             toHtml (moduleString mdl)
+        | (mdl, visible) <- entries ])
+
+-- ---------------------------------------------------------------------------
+-- Generate the HTML page for a module
+
+ppHtmlModule
+        :: FilePath -> String
+        -> SourceURLs -> WikiURLs
+        -> Maybe String -> Maybe String -> Bool
+        -> Interface -> IO ()
+ppHtmlModule odir doctitle
+  maybe_source_url maybe_wiki_url
+  maybe_contents_url maybe_index_url unicode iface = do
+  let 
+      mdl = ifaceMod iface
+      mdl_str = moduleString mdl
+      html = 
+        header (documentCharacterEncoding +++
+                thetitle (toHtml mdl_str) +++
+                styleSheet +++
+                (script ! [src jsFile, thetype "text/javascript"] $ noHtml) +++
+                (script ! [thetype "text/javascript"]
+                     -- XXX: quoting errors possible?
+                     << ("window.onload = function () {setSynopsis(\"mini_" 
+                                ++ moduleHtmlFile mdl ++ "\")};"))
+               ) +++
+        body << (
+          pageHeader mdl_str iface doctitle
+                maybe_source_url maybe_wiki_url
+                maybe_contents_url maybe_index_url +++
+          ifaceToHtml maybe_source_url maybe_wiki_url iface unicode +++
+          footer)
+         
+  createDirectoryIfMissing True odir
+  writeFile (pathJoin [odir, moduleHtmlFile mdl]) (renderToString html)
+  ppHtmlModuleMiniSynopsis odir doctitle iface unicode
+
+ppHtmlModuleMiniSynopsis :: FilePath -> String -> Interface -> Bool -> IO ()
+ppHtmlModuleMiniSynopsis odir _doctitle iface unicode = do
+  let mdl = ifaceMod iface
+      html =
+        header
+          (documentCharacterEncoding +++
+           thetitle (toHtml $ moduleString mdl) +++
+           styleSheet +++
+           (script ! [src jsFile, thetype "text/javascript"] $ noHtml)) +++
+        body << thediv ! [ theclass "outer" ] << (
+           (thediv ! [theclass "mini-topbar"]
+             << toHtml (moduleString mdl)) +++
+           miniSynopsis mdl iface unicode)
+  createDirectoryIfMissing True odir
+  writeFile (pathJoin [odir, "mini_" ++ moduleHtmlFile mdl]) (renderToString html)
+
+ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> Bool -> Html
+ifaceToHtml maybe_source_url maybe_wiki_url iface unicode
+  = ppModuleContents exports +++
+    description +++
+    synopsis +++
+    maybe_doc_hdr +++
+    bdy
+  where
+    exports = numberSectionHeadings (ifaceRnExportItems iface)
+
+    -- todo: if something has only sub-docs, or fn-args-docs, should
+    -- it be measured here and thus prevent omitting the synopsis?
+    has_doc (ExportDecl _ doc _ _) = isJust (fst doc)
+    has_doc (ExportNoDecl _ _) = False
+    has_doc (ExportModule _) = False
+    has_doc _ = True
+
+    no_doc_at_all = not (any has_doc exports)
+
+    description
+          = case ifaceRnDoc iface of
+              Nothing -> noHtml
+              Just doc -> h1 << toHtml "Description" +++ docToHtml doc
+
+        -- omit the synopsis if there are no documentation annotations at all
+    synopsis
+      | no_doc_at_all = noHtml
+      | otherwise
+      = h1 << "Synopsis" +++
+        unordList (
+            rights $
+            map (processExport True linksInfo unicode) exports
+        ) ! [theclass "synopsis"]
+
+        -- if the documentation doesn't begin with a section header, then
+        -- add one ("Documentation").
+    maybe_doc_hdr
+      = case exports of            
+          [] -> noHtml
+          ExportGroup _ _ _ : _ -> noHtml
+          _ -> h1 << "Documentation"
+
+    bdy =
+      foldr (+++) noHtml $
+        map (either id (paragraph ! [theclass "decl"] <<)) $
+          map (processExport False linksInfo unicode) exports
+          
+    linksInfo = (maybe_source_url, maybe_wiki_url)
+
+miniSynopsis :: Module -> Interface -> Bool -> Html
+miniSynopsis mdl iface unicode =
+    thediv ! [ theclass "mini-synopsis" ]
+      << hsep (map (processForMiniSynopsis mdl unicode) $ exports)
+  where
+    exports = numberSectionHeadings (ifaceRnExportItems iface)
+
+processForMiniSynopsis :: Module -> Bool -> ExportItem DocName ->  Html
+processForMiniSynopsis mdl unicode (ExportDecl (L _loc decl0) _doc _ _insts) =
+  thediv ! [theclass "decl" ] <<
+  case decl0 of
+    TyClD d@(TyFamily{}) -> ppTyFamHeader True False d unicode
+    TyClD d@(TyData{tcdTyPats = ps})
+      | Nothing <- ps    -> keyword "data" <++> ppTyClBinderWithVarsMini mdl d
+      | Just _ <- ps     -> keyword "data" <++> keyword "instance"
+                                           <++> ppTyClBinderWithVarsMini mdl d
+    TyClD d@(TySynonym{tcdTyPats = ps})
+      | Nothing <- ps    -> keyword "type" <++> ppTyClBinderWithVarsMini mdl d
+      | Just _ <- ps     -> keyword "type" <++> keyword "instance"
+                                           <++> ppTyClBinderWithVarsMini mdl d
+    TyClD d@(ClassDecl {}) ->
+                            keyword "class" <++> ppTyClBinderWithVarsMini mdl d
+    SigD (TypeSig (L _ n) (L _ _)) ->
+        let nm = docNameOcc n
+        in ppNameMini mdl nm
+    _ -> noHtml
+processForMiniSynopsis _ _ (ExportGroup lvl _id txt) =
+  let heading
+        | lvl == 1 = h1
+        | lvl == 2 = h2
+        | lvl >= 3 = h3
+        | otherwise = error "bad group level"
+  in heading << docToHtml txt
+processForMiniSynopsis _ _ _ = noHtml
+
+ppNameMini :: Module -> OccName -> Html
+ppNameMini mdl nm =
+    anchor ! [ href ( moduleHtmlFile mdl ++ "#"
+                      ++ (escapeStr (anchorNameStr nm)))
+             , target mainFrameName ]
+      << ppBinder' nm
+
+ppTyClBinderWithVarsMini :: Module -> TyClDecl DocName -> Html
+ppTyClBinderWithVarsMini mdl decl =
+  let n = unLoc $ tcdLName decl
+      ns = tyvarNames $ tcdTyVars decl
+  in ppTypeApp n ns (ppNameMini mdl . docNameOcc) ppTyName
+
+ppModuleContents :: [ExportItem DocName] -> Html
+ppModuleContents exports
+  | null sections = noHtml
+  | otherwise     = contentsDiv
+ where
+  contentsDiv = thediv ! [theclass "table-of-contents"] << (
+    paragraph ! [theclass "caption"] << "Contents" +++
+    unordList sections)
+    
+  (sections, _leftovers{-should be []-}) = process 0 exports
+
+  process :: Int -> [ExportItem DocName] -> ([Html],[ExportItem DocName])
+  process _ [] = ([], [])
+  process n items@(ExportGroup lev id0 doc : rest) 
+    | lev <= n  = ( [], items )
+    | otherwise = ( html:secs, rest2 )
+    where
+        html = linkedAnchor 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 = unordList ss
+
+-- we need to assign a unique id to each section heading so we can hyperlink
+-- them from the contents:
+numberSectionHeadings :: [ExportItem DocName] -> [ExportItem DocName]
+numberSectionHeadings exports = go 1 exports
+  where go :: Int -> [ExportItem DocName] -> [ExportItem DocName]
+        go _ [] = []
+        go n (ExportGroup lev _ doc : es) 
+          = ExportGroup lev (show n) doc : go (n+1) es
+        go n (other:es)
+          = other : go n es
+
+processExport :: Bool -> LinksInfo -> Bool -> (ExportItem DocName)
+  -> Either Html Html -- Right is a decl, Left is a "extra" (doc or group)
+processExport _ _ _ (ExportGroup lev id0 doc)
+  = Left $ groupTag lev << namedAnchor id0 << docToHtml doc
+processExport summary links unicode (ExportDecl decl doc subdocs insts)
+  = Right $ ppDecl' summary links decl doc insts subdocs unicode
+processExport _ _ _ (ExportNoDecl y [])
+  = Right $ ppDocName y
+processExport _ _ _ (ExportNoDecl y subs)
+  = Right $ ppDocName y +++ parenList (map ppDocName subs)
+processExport _ _ _ (ExportDoc doc)
+  = Left $ docToHtml doc
+processExport _ _ _ (ExportModule mdl)
+  = Right $ toHtml "module" +++ ppModule mdl ""
+
+groupTag :: Int -> Html -> Html
+groupTag lev
+  | lev == 1  = h1
+  | lev == 2  = h2
+  | lev == 3  = h3
+  | otherwise = h4
+
+
+
+
diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
new file mode 100644
index 00000000..db6d90a0
--- /dev/null
+++ b/src/Haddock/Backends/Xhtml/Decl.hs
@@ -0,0 +1,874 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Haddock.Backends.Html.Decl
+-- Copyright   :  (c) Simon Marlow   2003-2006,
+--                    David Waern    2006-2009,
+--                    Mark Lentczner 2010
+-- License     :  BSD-like
+--
+-- Maintainer  :  haddock@projects.haskell.org
+-- Stability   :  experimental
+-- Portability :  portable
+-----------------------------------------------------------------------------
+
+module Haddock.Backends.Xhtml.Decl where
+
+import Haddock.Backends.Xhtml.DocMarkup
+import Haddock.Backends.Xhtml.Layout
+import Haddock.Backends.Xhtml.Names
+import Haddock.Backends.Xhtml.Types
+import Haddock.Backends.Xhtml.Util
+import Haddock.GhcUtils
+import Haddock.Types
+
+import           Control.Monad         ( join )
+import qualified Data.Map as Map
+import           Data.Maybe
+import           Text.XHtml hiding     ( name, title, p, quote )
+
+import BasicTypes            ( IPName(..), Boxity(..) )
+import GHC
+import Name
+import Outputable            ( ppr, showSDoc, Outputable )
+
+
+-- TODO: use DeclInfo DocName or something
+ppDecl' :: Bool -> LinksInfo -> LHsDecl DocName -> 
+          DocForDecl DocName -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] -> Bool -> Html
+ppDecl' s k l m i d u = vanillaTable << ppDecl s k l m i d u
+
+ppDecl :: Bool -> LinksInfo -> LHsDecl DocName -> 
+          DocForDecl DocName -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] -> Bool -> HtmlTable
+ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances subdocs unicode = case decl of
+  TyClD d@(TyFamily {})          -> ppTyFam summ False links loc mbDoc d unicode
+  TyClD d@(TyData {})
+    | Nothing <- tcdTyPats d     -> ppDataDecl summ links instances subdocs loc mbDoc d unicode
+    | Just _  <- tcdTyPats d     -> ppDataInst summ links loc mbDoc d 
+  TyClD d@(TySynonym {})
+    | Nothing <- tcdTyPats d     -> ppTySyn summ links loc (mbDoc, fnArgsDoc) d unicode
+    | Just _  <- tcdTyPats d     -> ppTyInst summ False links loc mbDoc d unicode
+  TyClD d@(ClassDecl {})         -> ppClassDecl summ links instances loc mbDoc subdocs d unicode
+  SigD (TypeSig (L _ n) (L _ t)) -> ppFunSig summ links loc (mbDoc, fnArgsDoc) n t unicode
+  ForD d                         -> ppFor summ links loc (mbDoc, fnArgsDoc) d unicode
+  InstD _                        -> emptyTable
+  _                              -> error "declaration not supported by ppDecl"
+
+ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
+            DocName -> HsType DocName -> Bool -> HtmlTable
+ppFunSig summary links loc doc docname typ unicode =
+  ppTypeOrFunSig summary links loc docname typ doc
+    (ppTypeSig summary occname typ unicode, ppBinder False occname, dcolon unicode) unicode
+  where
+    occname = docNameOcc docname
+
+ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> DocName -> HsType DocName ->
+                  DocForDecl DocName -> (Html, Html, Html) -> Bool -> HtmlTable
+ppTypeOrFunSig summary links loc docname typ (doc, argDocs) (pref1, pref2, sep) unicode
+  | summary || Map.null argDocs = declWithDoc summary links loc docname doc pref1
+  | otherwise = topDeclBox links loc docname pref2 </>
+    (tda [theclass "body"] << vanillaTable <<  (
+      do_args 0 sep typ </>
+        (case doc of
+          Just d -> ndocBox (docToHtml d)
+          Nothing -> emptyTable)
+        ))
+  where 
+    argDocHtml n = case Map.lookup n argDocs of
+                    Just adoc -> docToHtml adoc
+                    Nothing -> noHtml
+
+    do_largs n leader (L _ t) = do_args n leader t  
+    do_args :: Int -> Html -> (HsType DocName) -> HtmlTable
+    do_args n leader (HsForAllTy Explicit tvs lctxt ltype)
+      = (argBox (
+          leader <+> 
+          hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]) <+>
+          ppLContextNoArrow lctxt unicode)
+            <-> rdocBox noHtml) </> 
+            do_largs n (darrow unicode) ltype
+    do_args n leader (HsForAllTy Implicit _ lctxt ltype)
+      | not (null (unLoc lctxt))
+      = (argBox (leader <+> ppLContextNoArrow lctxt unicode)
+          <-> rdocBox noHtml) </> 
+          do_largs n (darrow unicode) ltype
+      -- if we're not showing any 'forall' or class constraints or
+      -- anything, skip having an empty line for the context.
+      | otherwise
+      = do_largs n leader ltype
+    do_args n leader (HsFunTy lt r)
+      = (argBox (leader <+> ppLFunLhType unicode lt) <-> rdocBox (argDocHtml n))
+          </> do_largs (n+1) (arrow unicode) r
+    do_args n leader t
+      = argBox (leader <+> ppType unicode t) <-> rdocBox (argDocHtml n)
+
+
+ppTyVars :: [LHsTyVarBndr DocName] -> [Html]
+ppTyVars tvs = map ppTyName (tyvarNames tvs)
+
+
+tyvarNames :: [LHsTyVarBndr DocName] -> [Name]
+tyvarNames = map (getName . hsTyVarName . unLoc)
+  
+
+ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> Bool -> HtmlTable
+ppFor summary links loc doc (ForeignImport (L _ name) (L _ typ) _) unicode
+  = ppFunSig summary links loc doc name typ unicode
+ppFor _ _ _ _ _ _ = error "ppFor"
+
+
+-- we skip type patterns for now
+ppTySyn :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool -> HtmlTable
+ppTySyn summary links loc doc (TySynonym (L _ name) ltyvars _ ltype) unicode
+  = ppTypeOrFunSig summary links loc name (unLoc ltype) doc 
+                   (full, hdr, spaceHtml +++ equals) unicode
+  where
+    hdr  = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars ltyvars)
+    full = hdr <+> equals <+> ppLType unicode ltype
+    occ  = docNameOcc name
+ppTySyn _ _ _ _ _ _ = error "declaration not supported by ppTySyn"
+
+
+ppTypeSig :: Bool -> OccName -> HsType DocName  -> Bool -> Html
+ppTypeSig summary nm ty unicode = ppBinder summary nm <+> dcolon unicode <+> ppType unicode ty
+
+
+ppTyName :: Name -> Html
+ppTyName name
+  | isNameSym name = parens (ppName name)
+  | otherwise = ppName name
+
+
+--------------------------------------------------------------------------------
+-- Type families
+--------------------------------------------------------------------------------
+
+
+ppTyFamHeader :: Bool -> Bool -> TyClDecl DocName -> Bool -> Html
+ppTyFamHeader summary associated decl unicode =
+
+  (case tcdFlavour decl of
+     TypeFamily
+       | associated -> keyword "type"
+       | otherwise  -> keyword "type family"
+     DataFamily
+       | associated -> keyword "data"
+       | otherwise  -> keyword "data family"
+  ) <+>
+
+  ppTyClBinderWithVars summary decl <+>
+
+  case tcdKind decl of
+    Just kind -> dcolon unicode  <+> ppKind kind 
+    Nothing -> empty
+
+
+ppTyFam :: Bool -> Bool -> LinksInfo -> SrcSpan -> Maybe (Doc DocName) ->
+              TyClDecl DocName -> Bool -> HtmlTable
+ppTyFam summary associated links loc mbDoc decl unicode
+  
+  | summary = declWithDoc summary links loc docname mbDoc 
+              (ppTyFamHeader True associated decl unicode)
+  
+  | associated, isJust mbDoc         = header_ </> bodyBox << doc 
+  | associated                       = header_ 
+  | null instances, isJust mbDoc     = header_ </> bodyBox << doc
+  | null instances                   = header_
+  | isJust mbDoc                     = header_ </> bodyBox << (doc </> instancesBit)
+  | otherwise                        = header_ </> bodyBox << instancesBit
+
+  where
+    docname = tcdName decl
+
+    header_ = topDeclBox links loc docname (ppTyFamHeader summary associated decl unicode)
+
+    doc = ndocBox . docToHtml . fromJust $ mbDoc 
+
+    instId = collapseId (getName docname)
+
+    instancesBit = instHdr instId </>
+          tda [theclass "body"] << 
+            collapsed thediv instId (
+              spacedTable1 << (
+                aboves (map (ppDocInstance unicode) instances)
+              )
+            )
+
+    -- TODO: get the instances
+    instances = []
+
+
+--------------------------------------------------------------------------------
+-- Indexed data types
+--------------------------------------------------------------------------------
+
+
+ppDataInst :: a
+ppDataInst = undefined
+
+
+--------------------------------------------------------------------------------
+-- Indexed newtypes
+--------------------------------------------------------------------------------
+
+-- TODO
+-- ppNewTyInst = undefined
+
+
+--------------------------------------------------------------------------------
+-- Indexed types
+--------------------------------------------------------------------------------
+
+ 
+ppTyInst :: Bool -> Bool -> LinksInfo -> SrcSpan -> Maybe (Doc DocName) ->
+            TyClDecl DocName -> Bool -> HtmlTable
+ppTyInst summary associated links loc mbDoc decl unicode
+  
+  | summary = declWithDoc summary links loc docname mbDoc
+              (ppTyInstHeader True associated decl unicode)
+  
+  | isJust mbDoc = header_ </> bodyBox << doc 
+  | otherwise    = header_
+
+  where
+    docname = tcdName decl
+
+    header_ = topDeclBox links loc docname (ppTyInstHeader summary associated decl unicode)
+
+    doc = case mbDoc of
+      Just d -> ndocBox (docToHtml d)
+      Nothing -> emptyTable
+
+
+ppTyInstHeader :: Bool -> Bool -> TyClDecl DocName -> Bool -> Html
+ppTyInstHeader _ _ decl unicode =
+  keyword "type instance" <+>
+  ppAppNameTypes (tcdName decl) typeArgs unicode
+  where
+    typeArgs = map unLoc . fromJust . tcdTyPats $ decl
+
+
+--------------------------------------------------------------------------------
+-- Associated Types
+--------------------------------------------------------------------------------
+    
+
+ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LTyClDecl DocName -> Bool -> HtmlTable
+ppAssocType summ links doc (L loc decl) unicode = 
+  case decl of
+    TyFamily  {} -> ppTyFam summ True links loc (fst doc) decl unicode
+    TySynonym {} -> ppTySyn summ links loc doc decl unicode
+    _            -> error "declaration type not supported by ppAssocType" 
+
+
+--------------------------------------------------------------------------------
+-- TyClDecl helpers
+--------------------------------------------------------------------------------
+
+
+-- | Print a type family / newtype / data / class binder and its variables 
+ppTyClBinderWithVars :: Bool -> TyClDecl DocName -> Html
+ppTyClBinderWithVars summ decl = 
+  ppAppDocNameNames summ (unLoc $ tcdLName decl) (tyvarNames $ tcdTyVars decl)
+
+
+--------------------------------------------------------------------------------
+-- Type applications
+--------------------------------------------------------------------------------
+
+
+-- | Print an application of a DocName and a list of HsTypes
+ppAppNameTypes :: DocName -> [HsType DocName] -> Bool -> Html
+ppAppNameTypes n ts unicode = ppTypeApp n ts ppDocName (ppParendType unicode)
+
+
+-- | Print an application of a DocName and a list of Names 
+ppAppDocNameNames :: Bool -> DocName -> [Name] -> Html
+ppAppDocNameNames summ n ns = 
+  ppTypeApp n ns (ppBinder summ . docNameOcc) ppTyName
+
+
+-- | General printing of type applications
+ppTypeApp :: DocName -> [a] -> (DocName -> Html) -> (a -> Html) -> Html
+ppTypeApp n (t1:t2:rest) ppDN ppT
+  | operator, not . null $ rest = parens opApp <+> hsep (map ppT rest)
+  | operator                    = opApp
+  where
+    operator = isNameSym . getName $ n
+    opApp = ppT t1 <+> ppDN n <+> ppT t2
+
+ppTypeApp n ts ppDN ppT = ppDN n <+> hsep (map ppT ts)
+
+
+-------------------------------------------------------------------------------
+-- Contexts 
+-------------------------------------------------------------------------------
+
+
+ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Bool -> Html
+ppLContext        = ppContext        . unLoc
+ppLContextNoArrow = ppContextNoArrow . unLoc
+
+
+ppContextNoArrow :: HsContext DocName -> Bool -> Html
+ppContextNoArrow []  _ = empty
+ppContextNoArrow cxt unicode = pp_hs_context (map unLoc cxt) unicode
+
+
+ppContextNoLocs :: [HsPred DocName] -> Bool -> Html
+ppContextNoLocs []  _ = empty
+ppContextNoLocs cxt unicode = pp_hs_context cxt unicode <+> darrow unicode
+
+
+ppContext :: HsContext DocName -> Bool -> Html
+ppContext cxt unicode = ppContextNoLocs (map unLoc cxt) unicode
+
+
+pp_hs_context :: [HsPred DocName] -> Bool -> Html
+pp_hs_context []  _       = empty
+pp_hs_context [p] unicode = ppPred unicode p
+pp_hs_context cxt unicode = parenList (map (ppPred unicode) cxt)
+
+
+ppPred :: Bool -> HsPred DocName -> Html
+ppPred unicode (HsClassP n ts) = ppAppNameTypes n (map unLoc ts) unicode
+ppPred unicode (HsEqualP t1 t2) = ppLType unicode t1 <+> toHtml "~" <+> ppLType unicode t2
+ppPred unicode (HsIParam (IPName n) t)
+  = toHtml "?" +++ ppDocName n <+> dcolon unicode <+> ppLType unicode t
+
+
+-------------------------------------------------------------------------------
+-- Class declarations
+-------------------------------------------------------------------------------
+
+
+ppClassHdr :: Bool -> Located [LHsPred DocName] -> DocName
+           -> [Located (HsTyVarBndr DocName)] -> [Located ([DocName], [DocName])]
+           -> Bool -> Html
+ppClassHdr summ lctxt n tvs fds unicode = 
+  keyword "class" 
+  <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode else empty)
+  <+> ppAppDocNameNames summ n (tyvarNames $ tvs)
+        <+> ppFds fds unicode
+
+
+ppFds :: [Located ([DocName], [DocName])] -> Bool -> Html
+ppFds fds unicode =
+  if null fds then noHtml else 
+        char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds))
+  where
+        fundep (vars1,vars2) = hsep (map ppDocName vars1) <+> arrow unicode <+>
+                               hsep (map ppDocName vars2)
+
+ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan -> [(DocName, DocForDecl DocName)] -> Bool -> HtmlTable
+ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _) loc subdocs unicode = 
+  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")
+            </> 
+      (
+                                bodyBox <<
+                                        aboves
+                                        (
+                                                [ ppAssocType summary links doc at unicode | at <- ats
+                                                , let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ]  ++
+
+                                                [ ppFunSig summary links loc doc n typ unicode
+                                                | L _ (TypeSig (L _ n) (L _ typ)) <- sigs
+                                                , let doc = lookupAnySubdoc n subdocs ] 
+                                        )
+                                )
+  where
+    hdr = ppClassHdr summary lctxt (unLoc lname) tvs fds unicode
+    nm  = unLoc lname
+ppShortClassDecl _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
+    
+
+
+ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> SrcSpan
+            -> Maybe (Doc DocName) -> [(DocName, DocForDecl DocName)]
+            -> TyClDecl DocName -> Bool -> HtmlTable
+ppClassDecl summary links instances loc mbDoc subdocs
+        decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ ats _) unicode
+  | summary = ppShortClassDecl summary links decl loc subdocs unicode
+  | otherwise = classheader </> bodyBox << (classdoc </> body_ </> instancesBit)
+  where 
+    classheader
+      | null lsigs = topDeclBox links loc nm (hdr unicode)
+      | otherwise  = topDeclBox links loc nm (hdr unicode <+> keyword "where")
+
+    nm   = unLoc $ tcdLName decl
+
+    hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds
+    
+    classdoc = case mbDoc of
+      Nothing -> emptyTable
+      Just d -> ndocBox (docToHtml d)
+
+    body_
+      | null lsigs, null ats = emptyTable
+      | null ats  = s8 </> methHdr </> bodyBox << methodTable
+      | otherwise = s8 </> atHdr </> bodyBox << atTable </> 
+                    s8 </> methHdr </> bodyBox << methodTable 
+ 
+    methodTable =
+      abovesSep s8 [ ppFunSig summary links loc doc n typ unicode
+                   | L _ (TypeSig (L _ n) (L _ typ)) <- lsigs
+                   , let doc = lookupAnySubdoc n subdocs ]
+
+    atTable = abovesSep s8 $ [ ppAssocType summary links doc at unicode | at <- ats
+                             , let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ]
+
+    instId = collapseId (getName nm)
+    instancesBit
+      | null instances = emptyTable
+      | otherwise 
+        =  s8 </> instHdr instId </>
+           tda [theclass "body"] << 
+             collapsed thediv instId (
+               spacedTable1 << aboves (map (ppDocInstance unicode) instances)
+             )
+ppClassDecl _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
+
+
+-- | Print a possibly commented instance. The instance header is printed inside
+-- an 'argBox'. The comment is printed to the right of the box in normal comment
+-- style.
+ppDocInstance :: Bool -> DocInstance DocName -> HtmlTable
+ppDocInstance unicode (instHead, maybeDoc) =
+  argBox (ppInstHead unicode instHead) <-> maybeRDocBox maybeDoc
+
+
+ppInstHead :: Bool -> InstHead DocName -> Html
+ppInstHead unicode ([],   n, ts) = ppAppNameTypes n ts unicode
+ppInstHead unicode (ctxt, n, ts) = ppContextNoLocs ctxt unicode <+> ppAppNameTypes n ts unicode
+
+
+lookupAnySubdoc :: (Eq name1) =>
+                   name1 -> [(name1, DocForDecl name2)] -> DocForDecl name2
+lookupAnySubdoc n subdocs = case lookup n subdocs of
+  Nothing -> noDocForDecl
+  Just docs -> docs
+      
+
+
+-- -----------------------------------------------------------------------------
+-- Data & newtype declarations
+
+
+-- TODO: print contexts
+ppShortDataDecl :: Bool -> LinksInfo -> SrcSpan -> TyClDecl DocName -> Bool -> Html
+ppShortDataDecl summary links loc dataDecl unicode
+
+  | [lcon] <- cons, ResTyH98 <- resTy = 
+    ppDataHeader summary dataDecl unicode
+    <+> equals <+> ppShortConstr summary (unLoc lcon) unicode
+
+  | [] <- cons = ppDataHeader summary dataDecl unicode
+
+  | 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 docname)
+      ((ppDataHeader summary dataDecl unicode) <+> 
+      case resTy of ResTyGADT _ -> keyword "where"; _ -> empty)
+
+    doConstr c con = declBox (toHtml [c] <+> ppShortConstr summary (unLoc con) unicode)
+    doGADTConstr con = declBox (ppShortConstr summary (unLoc con) unicode)
+
+    docname   = unLoc . tcdLName $ dataDecl
+    cons      = tcdCons dataDecl
+    resTy     = (con_res . unLoc . head) cons 
+
+ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] ->
+              [(DocName, DocForDecl DocName)] ->
+              SrcSpan -> Maybe (Doc DocName) -> TyClDecl DocName -> Bool -> HtmlTable
+ppDataDecl summary links instances subdocs loc mbDoc dataDecl unicode
+  
+  | summary = declWithDoc summary links loc docname mbDoc 
+              (ppShortDataDecl summary links loc dataDecl unicode)
+  
+  | otherwise
+      = (if validTable then (</>) else const) header_ $
+              tda [theclass "body"] << vanillaTable << (
+                      datadoc </> 
+                      constrBit </>
+                      instancesBit
+        )
+
+
+  where
+    docname   = unLoc . tcdLName $ dataDecl
+    cons      = tcdCons dataDecl
+    resTy     = (con_res . unLoc . head) cons 
+      
+    header_ = topDeclBox links loc docname (ppDataHeader summary dataDecl unicode
+             <+> 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 -> emptyTable
+
+    constrBit 
+      | null cons = emptyTable
+      | otherwise = constrHdr </> ( 
+          tda [theclass "body"] << constrTable << 
+          aboves (map (ppSideBySideConstr subdocs unicode) cons)
+        )
+
+    instId = collapseId (getName docname)
+
+    instancesBit
+      | null instances = emptyTable
+      | otherwise 
+        = instHdr instId </>
+          tda [theclass "body"] << 
+          collapsed thediv instId (
+            spacedTable1 << aboves (map (ppDocInstance unicode) instances
+            )
+          )
+
+    validTable = isJust mbDoc || not (null cons) || not (null instances)
+
+
+isRecCon :: Located (ConDecl a) -> Bool
+isRecCon lcon = case con_details (unLoc lcon) of 
+  RecCon _ -> True
+  _ -> False
+
+
+ppShortConstr :: Bool -> ConDecl DocName -> Bool -> Html
+ppShortConstr summary con unicode = case con_res con of 
+  ResTyH98 -> case con_details con of 
+    PrefixCon args -> header_ unicode +++ hsep (ppBinder summary occ : map (ppLParendType unicode) args)
+    RecCon fields -> header_ unicode +++ ppBinder summary occ <+>
+                                              doRecordFields fields
+    InfixCon arg1 arg2 -> header_ unicode +++ 
+      hsep [ppLParendType unicode arg1, ppBinder summary occ, ppLParendType unicode arg2]    
+
+  ResTyGADT resTy -> case con_details con of 
+    -- prefix & infix could use hsConDeclArgTys if it seemed to
+    -- simplify the code.
+    PrefixCon args -> doGADTCon args resTy
+    -- display GADT records with the new syntax,
+    -- Constr :: (Context) => { field :: a, field2 :: b } -> Ty (a, b)
+    -- (except each field gets its own line in docs, to match
+    -- non-GADT records)
+    RecCon fields -> ppBinder summary occ <+> dcolon unicode <+> hsep [
+                            ppForAll forall ltvs lcontext unicode,
+                            doRecordFields fields,
+                            arrow unicode <+> ppLType unicode resTy ]
+    InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy 
+    
+  where
+    doRecordFields fields = braces (vanillaTable <<
+                        aboves (map (ppShortField summary unicode) fields))
+    doGADTCon args resTy = ppBinder summary occ <+> dcolon unicode <+> hsep [
+                             ppForAll forall ltvs lcontext unicode,
+                             ppLType unicode (foldr mkFunTy resTy args) ]
+
+    header_  = ppConstrHdr forall tyVars context
+    occ      = docNameOcc . unLoc . con_name $ con
+    ltvs     = con_qvars con
+    tyVars   = tyvarNames ltvs 
+    lcontext = con_cxt con
+    context  = unLoc (con_cxt con)
+    forall   = con_explicit con
+    mkFunTy a b = noLoc (HsFunTy a b)
+
+-- ppConstrHdr is for (non-GADT) existentials constructors' syntax
+ppConstrHdr :: HsExplicitForAll -> [Name] -> HsContext DocName -> Bool -> Html
+ppConstrHdr forall tvs ctxt unicode
+ = (if null tvs then noHtml else ppForall)
+   +++
+   (if null ctxt then noHtml else ppContextNoArrow ctxt unicode <+> darrow unicode +++ toHtml " ")
+  where
+    ppForall = case forall of 
+      Explicit -> forallSymbol unicode <+> hsep (map ppName tvs) <+> toHtml ". "
+      Implicit -> empty
+
+ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LConDecl DocName -> HtmlTable
+ppSideBySideConstr subdocs unicode (L _ con) = case con_res con of 
+ 
+  ResTyH98 -> case con_details con of 
+
+    PrefixCon args -> 
+      argBox (hsep ((header_ unicode +++ ppBinder False occ) : map (ppLParendType unicode) args)) 
+      <-> maybeRDocBox mbDoc  
+
+    RecCon fields -> 
+      argBox (header_ unicode +++ ppBinder False occ) <->
+      maybeRDocBox mbDoc
+      </>
+      doRecordFields fields
+
+    InfixCon arg1 arg2 -> 
+      argBox (hsep [header_ unicode+++ppLParendType unicode arg1, ppBinder False occ, ppLParendType unicode arg2])
+      <-> maybeRDocBox mbDoc
+ 
+  ResTyGADT resTy -> case con_details con of
+    -- prefix & infix could also use hsConDeclArgTys if it seemed to
+    -- simplify the code.
+    PrefixCon args -> doGADTCon args resTy
+    cd@(RecCon fields) -> doGADTCon (hsConDeclArgTys cd) resTy
+                                          </> doRecordFields fields
+    InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy 
+
+ where 
+    doRecordFields fields =
+        (tda [theclass "body"] << spacedTable1 <<
+        aboves (map (ppSideBySideField subdocs unicode) fields))
+    doGADTCon args resTy = argBox (ppBinder False occ <+> dcolon unicode <+> hsep [
+                               ppForAll forall ltvs (con_cxt con) unicode,
+                               ppLType unicode (foldr mkFunTy resTy args) ]
+                            ) <-> maybeRDocBox mbDoc
+
+
+    header_ = ppConstrHdr forall tyVars context
+    occ     = docNameOcc . unLoc . con_name $ con
+    ltvs    = con_qvars con
+    tyVars  = tyvarNames (con_qvars con)
+    context = unLoc (con_cxt con)
+    forall  = con_explicit con
+    -- don't use "con_doc con", in case it's reconstructed from a .hi file,
+    -- or also because we want Haddock to do the doc-parsing, not GHC.
+    -- 'join' is in Maybe.
+    mbDoc = join $ fmap fst $ lookup (unLoc $ con_name con) subdocs
+    mkFunTy a b = noLoc (HsFunTy a b)
+
+ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName ->  HtmlTable
+ppSideBySideField subdocs unicode (ConDeclField (L _ name) ltype _) =
+  argBox (ppBinder False (docNameOcc name)
+    <+> dcolon unicode <+> ppLType unicode ltype) <-> maybeRDocBox mbDoc
+  where
+    -- don't use cd_fld_doc for same reason we don't use con_doc above
+    mbDoc = join $ fmap fst $ lookup name subdocs
+
+{-
+ppHsFullConstr :: HsConDecl -> 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  = emptyTable
+
+        fields_html = 
+           td << 
+              table ! [width "100%", cellpadding 0, cellspacing 8] << (
+                   aboves (map ppFullField (concat (map expandField fields)))
+                )
+-}
+
+ppShortField :: Bool -> Bool -> ConDeclField DocName -> HtmlTable
+ppShortField summary unicode (ConDeclField (L _ name) ltype _)
+  = tda [theclass "recfield"] << (
+      ppBinder summary (docNameOcc name)
+      <+> dcolon unicode <+> ppLType unicode 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 -> Bool -> Html
+ppDataHeader summary decl unicode
+  | 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) unicode <+>
+    -- T a b c ..., or a :+: b
+    ppTyClBinderWithVars summary decl
+
+
+-- ----------------------------------------------------------------------------
+-- Types and contexts
+
+
+ppKind :: Outputable a => a -> Html
+ppKind k = toHtml $ showSDoc (ppr k)
+
+
+{-
+ppForAll Implicit _ lctxt = ppCtxtPart lctxt
+ppForAll Explicit ltvs lctxt = 
+  hsep (keyword "forall" : ppTyVars ltvs ++ [dot]) <+> ppCtxtPart lctxt 
+-}
+
+
+ppBang :: HsBang -> Html
+ppBang HsNoBang = empty 
+ppBang HsStrict = toHtml "!"
+ppBang HsUnbox  = toHtml "!" -- unboxed args is an implementation detail,
+                             -- so we just show the strictness annotation
+
+
+tupleParens :: Boxity -> [Html] -> Html
+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, pREC_FUN, pREC_OP, pREC_CON :: Int
+
+pREC_TOP = (0 :: Int)   -- type in ParseIface.y in GHC
+pREC_FUN = (1 :: Int)   -- btype in ParseIface.y in GHC
+                        -- Used for LH arg of (->)
+pREC_OP  = (2 :: Int)   -- Used for arg of any infix operator
+                        -- (we don't keep their fixities around)
+pREC_CON = (3 :: Int)   -- Used for arg of type applicn:
+                        -- always parenthesise unless atomic
+
+maybeParen :: Int           -- Precedence of context
+           -> Int           -- Precedence of top-level operator
+           -> Html -> Html  -- Wrap in parens if (ctxt >= op)
+maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p
+                               | otherwise            = p
+
+
+ppLType, ppLParendType, ppLFunLhType :: Bool -> Located (HsType DocName) -> Html
+ppLType       unicode y = ppType unicode (unLoc y)
+ppLParendType unicode y = ppParendType unicode (unLoc y) 
+ppLFunLhType  unicode y = ppFunLhType unicode (unLoc y)
+
+
+ppType, ppParendType, ppFunLhType :: Bool -> HsType DocName -> Html
+ppType       unicode ty = ppr_mono_ty pREC_TOP ty unicode 
+ppParendType unicode ty = ppr_mono_ty pREC_CON ty unicode 
+ppFunLhType  unicode ty = ppr_mono_ty pREC_FUN ty unicode
+
+
+-- Drop top-level for-all type variables in user style
+-- since they are implicit in Haskell
+
+ppForAll :: HsExplicitForAll -> [Located (HsTyVarBndr DocName)]
+         -> Located (HsContext DocName) -> Bool -> Html
+ppForAll expl tvs cxt unicode
+  | show_forall = forall_part <+> ppLContext cxt unicode
+  | otherwise   = ppLContext cxt unicode
+  where
+    show_forall = not (null tvs) && is_explicit
+    is_explicit = case expl of {Explicit -> True; Implicit -> False}
+    forall_part = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot 
+
+
+ppr_mono_lty :: Int -> LHsType DocName -> Bool -> Html
+ppr_mono_lty ctxt_prec ty unicode = ppr_mono_ty ctxt_prec (unLoc ty) unicode 
+
+
+ppr_mono_ty :: Int -> HsType DocName -> Bool -> Html
+ppr_mono_ty ctxt_prec (HsForAllTy expl tvs ctxt ty) unicode 
+  = maybeParen ctxt_prec pREC_FUN $
+    hsep [ppForAll expl tvs ctxt unicode, ppr_mono_lty pREC_TOP ty unicode]
+
+-- gaw 2004
+ppr_mono_ty _         (HsBangTy b ty)     u = ppBang b +++ ppLParendType u ty
+ppr_mono_ty _         (HsTyVar name)      _ = ppDocName name
+ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2)   u = ppr_fun_ty ctxt_prec ty1 ty2 u
+ppr_mono_ty _         (HsTupleTy con tys) u = tupleParens con (map (ppLType u) tys)
+ppr_mono_ty _         (HsKindSig ty kind) u = parens (ppr_mono_lty pREC_TOP ty u <+> dcolon u <+> ppKind kind)
+ppr_mono_ty _         (HsListTy ty)       u = brackets (ppr_mono_lty pREC_TOP ty u)
+ppr_mono_ty _         (HsPArrTy ty)       u = pabrackets (ppr_mono_lty pREC_TOP ty u)
+ppr_mono_ty _         (HsPredTy p)        u = parens (ppPred u p)
+ppr_mono_ty _         (HsNumTy n)         _ = toHtml (show n) -- generics only
+ppr_mono_ty _         (HsSpliceTy _)      _ = error "ppr_mono_ty HsSpliceTy"
+ppr_mono_ty _         (HsSpliceTyOut _)   _ = error "ppr_mono_ty HsSpliceTyOut"
+ppr_mono_ty _         (HsRecTy _)         _ = error "ppr_mono_ty HsRecTy"
+
+
+ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode 
+  = maybeParen ctxt_prec pREC_CON $
+    hsep [ppr_mono_lty pREC_FUN fun_ty unicode, ppr_mono_lty pREC_CON arg_ty unicode]
+
+ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode 
+  = maybeParen ctxt_prec pREC_FUN $
+    ppr_mono_lty pREC_OP ty1 unicode <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode
+  where
+    ppr_op = if not (isSymOcc occName) then quote (ppLDocName op) else ppLDocName op
+    occName = docNameOcc . unLoc $ op
+
+ppr_mono_ty ctxt_prec (HsParTy ty) unicode 
+--  = parens (ppr_mono_lty pREC_TOP ty)
+  = ppr_mono_lty ctxt_prec ty unicode
+
+ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode 
+  = ppr_mono_lty ctxt_prec ty unicode
+
+
+ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Bool -> Html 
+ppr_fun_ty ctxt_prec ty1 ty2 unicode
+  = let p1 = ppr_mono_lty pREC_FUN ty1 unicode
+        p2 = ppr_mono_lty pREC_TOP ty2 unicode
+    in
+    maybeParen ctxt_prec pREC_FUN $
+    hsep [p1, arrow unicode <+> p2]
+
+
diff --git a/src/Haddock/Backends/Xhtml/DocMarkup.hs b/src/Haddock/Backends/Xhtml/DocMarkup.hs
new file mode 100644
index 00000000..72314aec
--- /dev/null
+++ b/src/Haddock/Backends/Xhtml/DocMarkup.hs
@@ -0,0 +1,99 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Haddock.Backends.Html.DocMarkup
+-- Copyright   :  (c) Simon Marlow   2003-2006,
+--                    David Waern    2006-2009,
+--                    Mark Lentczner 2010
+-- License     :  BSD-like
+--
+-- Maintainer  :  haddock@projects.haskell.org
+-- Stability   :  experimental
+-- Portability :  portable
+-----------------------------------------------------------------------------
+
+module Haddock.Backends.Xhtml.DocMarkup where
+
+import Haddock.Backends.Xhtml.Names
+import Haddock.Backends.Xhtml.Util
+import Haddock.GhcUtils
+import Haddock.Types
+import Haddock.Utils
+
+import Text.XHtml hiding ( name, title, p, quote )
+
+import GHC
+import Name
+import RdrName
+
+
+parHtmlMarkup :: (a -> Html) -> (a -> Bool) -> DocMarkup a Html
+parHtmlMarkup ppId isTyCon = Markup {
+  markupParagraph     = paragraph,
+  markupEmpty         = toHtml "",
+  markupString        = toHtml,
+  markupAppend        = (+++),
+  markupIdentifier    = tt . ppId . choose,
+  markupModule        = \m -> let (mdl,ref) = break (=='#') m in ppModule (mkModuleNoPackage mdl) ref,
+  markupEmphasis      = emphasize . toHtml,
+  markupMonospaced    = tt . toHtml,
+  markupUnorderedList = ulist . concatHtml . map (li <<),
+  markupPic           = \path -> image ! [src path],
+  markupOrderedList   = olist . concatHtml . map (li <<),
+  markupDefList       = dlist . concatHtml . map markupDef,
+  markupCodeBlock     = pre,
+  markupURL           = \url -> anchor ! [href url] << toHtml url,
+  markupAName         = \aname -> namedAnchor aname << toHtml ""
+  }
+  where
+    -- If an id can refer to multiple things, we give precedence to type
+    -- constructors.  This should ideally be done during renaming from RdrName
+    -- to Name, but since we will move this process from GHC into Haddock in
+    -- the future, we fix it here in the meantime.
+    -- TODO: mention this rule in the documentation.
+    choose [] = error "empty identifier list in HsDoc"
+    choose [x] = x
+    choose (x:y:_)
+      | isTyCon x = x
+      | otherwise = y
+
+
+markupDef :: (HTML a, HTML b) => (a, b) -> Html
+markupDef (a,b) = dterm << a +++ ddef << b
+
+
+htmlMarkup :: DocMarkup DocName Html
+htmlMarkup = parHtmlMarkup ppDocName (isTyConName . getName)
+
+htmlOrigMarkup :: DocMarkup Name Html
+htmlOrigMarkup = parHtmlMarkup ppName isTyConName
+
+htmlRdrMarkup :: DocMarkup RdrName Html
+htmlRdrMarkup = parHtmlMarkup ppRdrName isRdrTc
+
+-- If the doc is a single paragraph, don't surround it with <P> (this causes
+-- ugly extra whitespace with some browsers).
+docToHtml :: Doc DocName -> Html
+docToHtml doc = markup htmlMarkup (markup htmlCleanup doc)
+
+origDocToHtml :: Doc Name -> Html
+origDocToHtml doc = markup htmlOrigMarkup (markup htmlCleanup doc)
+
+rdrDocToHtml :: Doc RdrName -> Html
+rdrDocToHtml doc = markup htmlRdrMarkup (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 :: Doc a -> Doc a
+unParagraph (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 (Doc a)
+htmlCleanup = idMarkup { 
+  markupUnorderedList = DocUnorderedList . map unParagraph,
+  markupOrderedList   = DocOrderedList   . map unParagraph
+  } 
diff --git a/src/Haddock/Backends/Xhtml/Layout.hs b/src/Haddock/Backends/Xhtml/Layout.hs
new file mode 100644
index 00000000..fa96049d
--- /dev/null
+++ b/src/Haddock/Backends/Xhtml/Layout.hs
@@ -0,0 +1,127 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Haddock.Backends.Html.Layout
+-- Copyright   :  (c) Simon Marlow   2003-2006,
+--                    David Waern    2006-2009,
+--                    Mark Lentczner 2010
+-- License     :  BSD-like
+--
+-- Maintainer  :  haddock@projects.haskell.org
+-- Stability   :  experimental
+-- Portability :  portable
+-----------------------------------------------------------------------------
+
+module Haddock.Backends.Xhtml.Layout where
+
+import Haddock.Backends.Xhtml.DocMarkup
+import Haddock.Backends.Xhtml.Types
+import Haddock.Backends.Xhtml.Util
+import Haddock.Types
+
+import Text.XHtml hiding ( name, title, p, quote )
+
+import FastString            ( unpackFS )
+import GHC
+
+
+declWithDoc :: Bool -> LinksInfo -> SrcSpan -> DocName -> Maybe (Doc 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)
+
+
+
+{-
+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 -> DocName -> Html -> HtmlTable
+topDeclBox ((_,_,Nothing), (_,_,Nothing)) _ _ html = declBox html
+topDeclBox ((_,_,maybe_source_url), (_,_,maybe_wiki_url))
+           loc name html =
+  tda [theclass "topdecl"] <<
+  (        table ! [theclass "declbar"] <<
+            ((tda [theclass "declname"] << html)
+             <-> srcLink
+             <-> wikiLink)
+  )
+  where srcLink =
+          case maybe_source_url of
+            Nothing  -> emptyTable
+            Just url -> tda [theclass "declbut"] <<
+                          let url' = spliceURL (Just fname) (Just origMod)
+                                               (Just n) (Just loc) url
+                           in anchor ! [href url'] << toHtml "Source"
+
+        wikiLink =
+          case maybe_wiki_url of
+            Nothing  -> emptyTable
+            Just url -> tda [theclass "declbut"] <<
+                          let url' = spliceURL (Just fname) (Just mdl)
+                                               (Just n) (Just loc) url
+                           in anchor ! [href url'] << toHtml "Comments"
+  
+        -- For source links, we want to point to the original module,
+        -- because only that will have the source.  
+        -- TODO: do something about type instances. They will point to
+        -- the module defining the type family, which is wrong.
+        origMod = nameModule n
+
+        -- Name must be documented, otherwise we wouldn't get here
+        Documented n mdl = name
+
+        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 (Doc DocName) -> HtmlTable
+maybeRDocBox Nothing = rdocBox (noHtml)
+maybeRDocBox (Just doc) = rdocBox (docToHtml doc)
+
+
+bodyBox :: Html -> HtmlTable
+bodyBox html = tda [theclass "body"] << vanillaTable << html
+
+-- a vanilla table has width 100%, no border, no padding, no spacing
+vanillaTable, vanillaTable2 :: Html -> Html
+vanillaTable  = table ! [theclass "vanilla",  cellspacing 0, cellpadding 0]
+vanillaTable2 = table ! [theclass "vanilla2", 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, atHdr :: HtmlTable
+constrHdr  = tda [ theclass "section4" ] << toHtml "Constructors"
+methHdr    = tda [ theclass "section4" ] << toHtml "Methods"
+atHdr      = tda [ theclass "section4" ] << toHtml "Associated Types"
+
+instHdr :: String -> HtmlTable
+instHdr id_ = 
+  tda [ theclass "section4" ] << (collapsebutton id_ +++ toHtml " Instances")
diff --git a/src/Haddock/Backends/Xhtml/Names.hs b/src/Haddock/Backends/Xhtml/Names.hs
new file mode 100644
index 00000000..cbf87c23
--- /dev/null
+++ b/src/Haddock/Backends/Xhtml/Names.hs
@@ -0,0 +1,76 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Haddock.Backends.Html.Names
+-- Copyright   :  (c) Simon Marlow   2003-2006,
+--                    David Waern    2006-2009,
+--                    Mark Lentczner 2010
+-- License     :  BSD-like
+--
+-- Maintainer  :  haddock@projects.haskell.org
+-- Stability   :  experimental
+-- Portability :  portable
+-----------------------------------------------------------------------------
+
+module Haddock.Backends.Xhtml.Names where
+
+import Haddock.Backends.Xhtml.Util
+import Haddock.GhcUtils
+import Haddock.Types
+import Haddock.Utils
+
+import Text.XHtml hiding ( name, title, p, quote )
+
+import GHC
+import Name
+import RdrName
+
+ppOccName :: OccName -> Html
+ppOccName = toHtml . occNameString
+
+ppRdrName :: RdrName -> Html
+ppRdrName = ppOccName . rdrNameOcc
+
+ppLDocName :: Located DocName -> Html
+ppLDocName (L _ d) = ppDocName d
+
+ppDocName :: DocName -> Html
+ppDocName (Documented name mdl) = 
+  linkIdOcc mdl (Just occName) << ppOccName occName
+    where occName = nameOccName name
+ppDocName (Undocumented name) = toHtml (getOccString name)
+
+linkTarget :: OccName -> Html
+linkTarget n = namedAnchor (anchorNameStr n) << toHtml "" 
+
+ppName :: Name -> Html
+ppName name = toHtml (getOccString name)
+
+
+ppBinder :: Bool -> OccName -> Html
+-- The Bool indicates whether we are generating the summary, in which case
+-- the binder will be a link to the full definition.
+ppBinder True n = linkedAnchor (anchorNameStr n) << ppBinder' n
+ppBinder False n = linkTarget n +++ bold << ppBinder' n
+
+
+ppBinder' :: OccName -> Html
+ppBinder' n
+  | isVarSym n = parens $ ppOccName n
+  | otherwise  = ppOccName n
+
+
+linkId :: Module -> Maybe Name -> Html -> Html
+linkId mdl mbName = linkIdOcc mdl (fmap nameOccName mbName)
+
+
+linkIdOcc :: Module -> Maybe OccName -> Html -> Html
+linkIdOcc mdl mbName = anchor ! [href uri]
+  where 
+    uri = case mbName of
+      Nothing   -> moduleHtmlFile mdl
+      Just name -> nameHtmlRef mdl name
+
+ppModule :: Module -> String -> Html
+ppModule mdl ref = anchor ! [href ((moduleHtmlFile mdl) ++ ref)] 
+                   << toHtml (moduleString mdl)
+
diff --git a/src/Haddock/Backends/Xhtml/Types.hs b/src/Haddock/Backends/Xhtml/Types.hs
new file mode 100644
index 00000000..e4d26fc9
--- /dev/null
+++ b/src/Haddock/Backends/Xhtml/Types.hs
@@ -0,0 +1,22 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Haddock.Backends.Html.Types
+-- Copyright   :  (c) Simon Marlow   2003-2006,
+--                    David Waern    2006-2009,
+--                    Mark Lentczner 2010
+-- License     :  BSD-like
+--
+-- Maintainer  :  haddock@projects.haskell.org
+-- Stability   :  experimental
+-- Portability :  portable
+-----------------------------------------------------------------------------
+
+module Haddock.Backends.Xhtml.Types where
+
+
+-- 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)
+
+-- The URL for source and wiki links, and the current module
+type LinksInfo = (SourceURLs, WikiURLs)
diff --git a/src/Haddock/Backends/Xhtml/Util.hs b/src/Haddock/Backends/Xhtml/Util.hs
new file mode 100644
index 00000000..b7f3a8d4
--- /dev/null
+++ b/src/Haddock/Backends/Xhtml/Util.hs
@@ -0,0 +1,203 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Haddock.Backends.Html.Util
+-- Copyright   :  (c) Simon Marlow   2003-2006,
+--                    David Waern    2006-2009,
+--                    Mark Lentczner 2010
+-- License     :  BSD-like
+--
+-- Maintainer  :  haddock@projects.haskell.org
+-- Stability   :  experimental
+-- Portability :  portable
+-----------------------------------------------------------------------------
+
+module Haddock.Backends.Xhtml.Util where
+
+import Haddock.GhcUtils
+import Haddock.Utils
+
+import Data.Maybe
+
+import Text.XHtml hiding ( name, title, p, quote )
+import qualified Text.XHtml as Html
+
+import GHC      ( SrcSpan, srcSpanStartLine, Name )
+import Module   ( Module )
+import Name     ( getOccString, nameOccName, isValOcc )
+
+
+spliceURL :: Maybe FilePath -> Maybe Module -> Maybe GHC.Name -> 
+             Maybe SrcSpan -> String -> String
+spliceURL maybe_file maybe_mod maybe_name maybe_loc url = run url
+ where
+  file = fromMaybe "" maybe_file
+  mdl = case maybe_mod of
+          Nothing           -> ""
+          Just m -> moduleString m
+  
+  (name, kind) =
+    case maybe_name of
+      Nothing             -> ("","")
+      Just n | isValOcc (nameOccName n) -> (escapeStr (getOccString n), "v")
+             | otherwise -> (escapeStr (getOccString n), "t")
+
+  line = case maybe_loc of
+    Nothing -> ""
+    Just span_ -> show $ srcSpanStartLine span_
+
+  run "" = ""
+  run ('%':'M':rest) = mdl  ++ run rest
+  run ('%':'F':rest) = file ++ run rest
+  run ('%':'N':rest) = name ++ run rest
+  run ('%':'K':rest) = kind ++ run rest
+  run ('%':'L':rest) = line ++ run rest
+  run ('%':'%':rest) = "%" ++ run rest
+
+  run ('%':'{':'M':'O':'D':'U':'L':'E':'}':rest) = mdl  ++ run rest
+  run ('%':'{':'F':'I':'L':'E':'}':rest)         = file ++ run rest
+  run ('%':'{':'N':'A':'M':'E':'}':rest)         = name ++ run rest
+  run ('%':'{':'K':'I':'N':'D':'}':rest)         = kind ++ run rest
+
+  run ('%':'{':'M':'O':'D':'U':'L':'E':'/':'.':'/':c:'}':rest) =
+    map (\x -> if x == '.' then c else x) mdl ++ run rest
+
+  run ('%':'{':'F':'I':'L':'E':'/':'/':'/':c:'}':rest) =
+    map (\x -> if x == '/' then c else x) file ++ run rest
+
+  run ('%':'{':'L':'I':'N':'E':'}':rest)         = line ++ run rest
+
+  run (c:rest) = c : run rest
+
+
+renderToString :: Html -> String
+-- renderToString = showHtml     -- for production
+renderToString = prettyHtml   -- for debugging
+
+hsep :: [Html] -> Html
+hsep [] = noHtml
+hsep htmls = foldr1 (\a b -> a+++" "+++b) htmls
+
+infixr 8 <+>, <++>
+(<+>) :: Html -> Html -> Html
+a <+> b = a +++ toHtml " " +++ b
+
+(<++>) :: Html -> Html -> Html
+a <++> b = a +++ spaceHtml +++ b
+
+keyword :: String -> Html
+keyword s = thespan ! [theclass "keyword"] << toHtml s
+
+equals, comma :: Html
+equals = char '='
+comma  = char ','
+
+char :: Char -> Html
+char c = toHtml [c]
+
+empty :: Html
+empty  = noHtml
+
+
+quote :: Html -> Html
+quote h = char '`' +++ h +++ '`'
+
+
+parens, brackets, pabrackets, braces :: Html -> Html
+parens h        = char '(' +++ h +++ char ')'
+brackets h      = char '[' +++ h +++ char ']'
+pabrackets h    = toHtml "[:" +++ h +++ toHtml ":]"
+braces h        = char '{' +++ h +++ char '}'
+
+punctuate :: Html -> [Html] -> [Html]
+punctuate _ []     = []
+punctuate h (d0:ds) = go d0 ds
+                   where
+                     go d [] = [d]
+                     go d (e:es) = (d +++ h) : go e es
+
+abovesSep :: HtmlTable -> [HtmlTable] -> HtmlTable
+abovesSep _ []      = 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 "#)"
+
+
+tda :: [HtmlAttr] -> Html -> HtmlTable
+tda as = cell . (td ! as)
+
+emptyTable :: HtmlTable
+emptyTable = cell noHtml
+
+onclick :: String -> HtmlAttr
+onclick = strAttr "onclick"
+
+
+dcolon, arrow, darrow, forallSymbol :: Bool -> Html
+dcolon unicode = toHtml (if unicode then "∷" else "::")
+arrow  unicode = toHtml (if unicode then "→" else "->")
+darrow unicode = toHtml (if unicode then "⇒" else "=>")
+forallSymbol unicode = if unicode then toHtml "∀" else keyword "forall"
+
+
+dot :: Html
+dot = toHtml "."
+
+
+s8 :: HtmlTable
+s8  = tda [ theclass "s8" ]  << noHtml
+
+
+-- | Generate a named anchor
+--
+-- This actually generates two anchor tags, one with the name unescaped, and one
+-- with the name URI-escaped. This is needed because Opera 9.52 (and later
+-- versions) needs the name to be unescaped, while IE 7 needs it to be escaped.
+-- 
+namedAnchor :: String -> Html -> Html
+namedAnchor n c = anchor ! [Html.name n] << noHtml +++
+                  anchor ! [Html.name (escapeStr n)] << c
+
+
+--
+-- 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"]) noHtml
diff --git a/src/Haddock/Options.hs b/src/Haddock/Options.hs
index 9699e6ee..9b670529 100644
--- a/src/Haddock/Options.hs
+++ b/src/Haddock/Options.hs
@@ -79,6 +79,7 @@ data Flag
   | Flag_WikiBaseURL   String
   | Flag_WikiModuleURL String
   | Flag_WikiEntityURL String
+  | Flag_Xhtml
   | Flag_Help
   | Flag_Verbosity String
   | Flag_Version
@@ -114,6 +115,7 @@ options backwardsCompat =
 --	"output in DocBook XML",
     Option ['h']  ["html"]     (NoArg Flag_Html)
 	"output in HTML",
+	Option []  ["xhtml"]  (NoArg Flag_Xhtml) "use experimental XHTML rendering",
     Option ['U'] ["use-unicode"] (NoArg Flag_UseUnicode) "use Unicode in HTML output",
     Option []  ["hoogle"]     (NoArg Flag_Hoogle)
     "output for Hoogle",