diff options
| -rw-r--r-- | src/HaddockHtml.hs | 45 | ||||
| -rw-r--r-- | src/HaddockRename.hs | 4 | ||||
| -rw-r--r-- | src/HaddockTypes.hs | 9 | ||||
| -rw-r--r-- | src/Main.hs | 4 |
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 |