[haddock @ 2002-04-10 15:50:10 by simonmar]

Generate a little table of contents at the top of the module doc (only
if the module actually contains some section headings, though).

4 files changed, 51 insertions, 11 deletions

diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs
index 2ba34af0..daf9732c 100644
--- a/src/HaddockHtml.hs
+++ b/src/HaddockHtml.hs
@@ -284,9 +284,9 @@ ifaceToHtml mod iface
   | null exports = Html.emptyTable
   | otherwise =
     td << table ! [width "100%", cellpadding 0, cellspacing 15] << 
-	(description </> synopsis </> maybe_hr </> body)
+	(contents </> description </> synopsis </> maybe_hr </> body)
   where 
-	exports = iface_exports iface
+	exports = numberSectionHeadings (iface_exports iface)
 	doc_map = iface_name_docs iface
 
 	has_doc (ExportDecl d)
@@ -295,6 +295,8 @@ ifaceToHtml mod iface
 
 	no_doc_at_all = not (any has_doc exports)
 
+	contents = td << ppModuleContents exports
+
 	description
          | Just doc <- iface_doc iface
          = (tda [theclass "section1"] << toHtml "Description") </>
@@ -312,16 +314,49 @@ ifaceToHtml mod iface
   	        aboves (map (processExport doc_map True)  exports))
 
 	maybe_hr
-	     | not (no_doc_at_all),  ExportGroup 1 _ <- head exports
+	     | not (no_doc_at_all),  ExportGroup 1 _ _ <- head exports
 		 = td << hr
 	     | otherwise  = Html.emptyTable
 
 	body = aboves (map (processExport doc_map False) exports)
 
+ppModuleContents :: [ExportItem] -> HtmlTable
+ppModuleContents exports
+  | null sections = Html.emptyTable
+  | otherwise     = tda [theclass "section4"] << bold << toHtml "Contents"
+  		     </> td << dlist << concatHtml sections
+ where
+  (sections, _leftovers{-should be []-}) = process 0 exports
+
+  process :: Int -> [ExportItem] -> ([Html],[ExportItem])
+  process n [] = ([], [])
+  process n (ExportDecl _ : rest) = process n rest
+  process n items@(ExportGroup lev id doc : rest) 
+    | lev <= n  = ( [], items )
+    | otherwise = ( html:sections, rest2 )
+    where
+	html = (dterm << anchor ! [href ('#':id)] << markup htmlMarkup doc)
+		 +++ mk_subsections subsections
+	(subsections, rest1) = process lev rest
+	(sections,    rest2) = process n   rest1
+
+  mk_subsections [] = noHtml
+  mk_subsections ss = ddef << dlist << concatHtml ss
+
+-- we need to assign a unique id to each section heading so we can hyperlink
+-- them from the contents:
+numberSectionHeadings :: [ExportItem] -> [ExportItem]
+numberSectionHeadings exports = go 1 exports
+  where go n [] = []
+	go n (ExportGroup lev _ doc : es) 
+	  = ExportGroup lev (show n) doc : go (n+1) es
+	go n (other:es)
+	  = other : go n es
+
 processExport :: FiniteMap HsName Doc -> Bool -> ExportItem -> HtmlTable
-processExport doc_map summary (ExportGroup lev doc)
+processExport doc_map summary (ExportGroup lev id doc)
   | summary   = Html.emptyTable
-  | otherwise = ppDocGroup lev (markup htmlMarkup doc)
+  | otherwise = ppDocGroup lev (anchor ! [name id] << markup htmlMarkup doc)
 processExport doc_map summary (ExportDecl decl)
   = doDecl doc_map summary decl
 
diff --git a/src/HaddockRename.hs b/src/HaddockRename.hs
index 4c5a631b..d43fb959 100644
--- a/src/HaddockRename.hs
+++ b/src/HaddockRename.hs
@@ -191,9 +191,9 @@ lookupIdString str = do
 
 renameExportItems items = mapM rn items
   where
- 	rn (ExportGroup lev doc) 
+ 	rn (ExportGroup lev id doc) 
 	   = do doc <- renameDoc doc
-	        return (ExportGroup lev doc)
+	        return (ExportGroup lev id doc)
 	rn (ExportDecl decl)
 	   = do decl <- renameDecl decl
 		return (ExportDecl decl)
diff --git a/src/HaddockTypes.hs b/src/HaddockTypes.hs
index e13fcb1a..e29d5dae 100644
--- a/src/HaddockTypes.hs
+++ b/src/HaddockTypes.hs
@@ -66,8 +66,13 @@ data Interface
 type DocString = String
 
 data ExportItem 
-  = ExportDecl    HsDecl		-- a declaration
-  | ExportGroup   Int Doc		-- a section heading
+  = ExportDecl
+	HsDecl		-- a declaration
+
+  | ExportGroup		-- a section heading
+	Int		-- section level (1, 2, 3, ... )
+	String		-- section "id" (for hyperlinks)
+	Doc		-- section heading text
 
 type ModuleMap = FiniteMap Module Interface
 
diff --git a/src/Main.hs b/src/Main.hs
index f57d5dd6..796f4939 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -274,7 +274,7 @@ mkExportItems mod_map mod env decl_map decls (Just specs)
 	= [ ExportDecl (restrictTo (map nameOfQName cs) decl) ]
     lookupExport (HsEModuleContents m) = fullContentsOf m
     lookupExport (HsEGroup lev str)
-	= [ ExportGroup lev doc ]
+	= [ ExportGroup lev "" doc ]
 	where (doc, _names) = formatDocHeading (lookupForDoc env) str
 	-- ToDo: report the unresolved names
     lookupExport _ = [] -- didn't find it?
@@ -300,7 +300,7 @@ mkExportItems mod_map mod env decl_map decls (Just specs)
 fullContentsOfThisModule decls env = 
   [ mkExportItem decl | decl <- decls, keepDecl decl ]
   where mkExportItem (HsDocGroup lev str) =
-	   ExportGroup lev doc
+	   ExportGroup lev "" doc
 	  where
 	   (doc, _names) = formatDocHeading (lookupForDoc env) str
 	   -- ToDo: report the unresolved names