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)

1 files changed, 758 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
+
+
+
+