convert index.html to new markup, adjust module markup

2 files changed, 110 insertions, 130 deletions

diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs
index 31690b07..743e95df 100644
--- a/src/Haddock/Backends/Xhtml.hs
+++ b/src/Haddock/Backends/Xhtml.hs
@@ -315,15 +315,17 @@ mkNode ss p (Node s leaf pkg short ts) =
       [] -> noHtml
       _ -> collapsebutton p
   
-    htmlModule 
-      | leaf      = ppModule (mkModule (stringToPackageId (fromMaybe "" pkg)) 
+    htmlModule = thespan ! [theclass "module" ] <<
+      (if leaf
+        then ppModule (mkModule (stringToPackageId (fromMaybe "" pkg)) 
                                        (mkModuleName mdl)) ""
-      | otherwise = toHtml s
-
+        else toHtml s
+      )
+      
     mdl = intercalate "." (reverse (s:ss))
     
     shortDescr = maybe noHtml origDocToHtml short
-    htmlPkg = maybe noHtml toHtml pkg
+    htmlPkg = maybe noHtml (thespan ! [theclass "package"] <<) pkg
 
     subtree = mkNodeList (s:ss) p ts ! [identifier p]
 
@@ -358,7 +360,8 @@ ppHtmlContentsFrame odir doctitle ifaces = do
              styleSheet +++
              (script ! [src jsFile, thetype "text/javascript"] $ noHtml)) +++
         miniBody << divModuleList << 
-          (sectionName << "Modules" +++ unordList mods)
+          (sectionName << "Modules" +++
+           ulist << [ li ! [theclass "module"] << m | m <- mods ])
   createDirectoryIfMissing True odir
   writeFile (joinPath [odir, frameIndexHtmlFile]) (renderToString html)
 
@@ -376,16 +379,8 @@ ppHtmlIndex :: FilePath
             -> 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
-           )
+  let html = indexPage split_indices Nothing
+              (if split_indices then [] else index)
 
   createDirectoryIfMissing True odir
 
@@ -401,118 +396,101 @@ ppHtmlIndex odir doctitle maybe_package maybe_html_help_format
     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 (joinPath [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 ])
+  where
+    indexPage showLetters ch items =
+      header (documentCharacterEncoding +++
+              thetitle (toHtml (doctitle ++ " (" ++ indexName ch ++ ")")) +++
+              styleSheet +++
+              (script ! [src jsFile, thetype "text/javascript"] $ noHtml)
+              ) +++
+       body <<
+        (simpleHeader doctitle maybe_contents_url Nothing
+                      maybe_source_url maybe_wiki_url +++
+         divIndex <<
+            (sectionName << indexName ch +++
+             (if showLetters then indexInitialLetterLinks else noHtml) +++
+             (if null items then noHtml else buildIndex items)
+            )
+        )
+    
+    indexName ch = "Index" ++ maybe "" (\c -> " - " ++ [c]) ch
+ 
+    buildIndex items = table << aboves (map indexElt items)
+
+    -- 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
+  
+    indexInitialLetterLinks = 
+          unordList [ anchor ! [href (subIndexHtmlFile c)] << [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 (joinPath [odir, subIndexHtmlFile c]) (renderToString html)
+      where 
+        html = indexPage True (Just c) 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)] -> 
+              td ! [ theclass "src" ] << toHtml str <-> 
+                          indexLinks nm entries
+          many_entities ->
+              td ! [ theclass "src" ] << toHtml str <-> td << spaceHtml </> 
+                  aboves (map doAnnotatedEntity (zip [1..] many_entities))
+  
+    doAnnotatedEntity :: (Integer, (Name, [(Module, Bool)])) -> HtmlTable
+    doAnnotatedEntity (j,(nm,entries))
+          = td ! [ theclass "alt" ] << 
+                  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 = 
+       td ! [ theclass "module" ] << 
+          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
diff --git a/src/Haddock/Backends/Xhtml/Layout.hs b/src/Haddock/Backends/Xhtml/Layout.hs
index 616b3b95..98801d1e 100644
--- a/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/src/Haddock/Backends/Xhtml/Layout.hs
@@ -14,7 +14,7 @@ module Haddock.Backends.Xhtml.Layout (
   miniBody,
   
   divPackageHeader, divModuleHeader, divFooter,
-  divModuleList, divTableOfContents,
+  divIndex, divModuleList, divTableOfContents,
   divDescription, divSynposis, divInterface,
 
   sectionName,
@@ -57,10 +57,12 @@ divPackageHeader = thediv ! [identifier "package-header"]
 divModuleHeader  = thediv ! [identifier "module-header"]
 divFooter        = thediv ! [identifier "footer"]
 
-divModuleList, divTableOfContents,
-  divDescription, divSynposis, divInterface :: Html -> Html
+divIndex, divModuleList, divTableOfContents :: Html -> Html
+divIndex           = thediv ! [identifier "index"]
 divModuleList      = thediv ! [identifier "module-list"]
 divTableOfContents = thediv ! [identifier "table-of-contents"]
+
+divDescription, divSynposis, divInterface :: Html -> Html
 divDescription     = thediv ! [identifier "description"]
 divSynposis        = thediv ! [identifier "synopsis"]
 divInterface       = thediv ! [identifier "interface"]