From 972805252bba410dcc6f7093d1a8a357cab502d4 Mon Sep 17 00:00:00 2001 From: simonmar Date: Fri, 5 Apr 2002 16:11:47 +0000 Subject: [haddock @ 2002-04-05 16:11:47 by simonmar] - Update to generate more correct HTML. - Use our own non-overloaded table combinators, as the overloaded versions were giving me a headache. The improved type safety caught several errors in the HTML generation. --- src/HaddockHtml.hs | 167 ++++++++++++++++++++++++++++++++++------------------- 1 file changed, 107 insertions(+), 60 deletions(-) diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs index 82a2c474..21b69499 100644 --- a/src/HaddockHtml.hs +++ b/src/HaddockHtml.hs @@ -13,7 +13,12 @@ import HsSyn import Maybe ( fromJust, isJust ) import FiniteMap -import Html hiding (text) + +import Html hiding (text, above, beside, aboves, + besides, (), (<->), td, + renderHtml, renderMessage, renderHtml') +import qualified HtmlBlockTable as BT +import qualified Html -- ----------------------------------------------------------------------------- -- Generating HTML documentation @@ -30,7 +35,7 @@ indexHtmlFile = "index.html" styleSheetFile = "haddock.css" footer = - td ! [theclass "botbar"] << + tda [theclass "botbar"] << ( toHtml "Produced by" <+> (anchor ! [href projectUrl] << toHtml projectName) <+> toHtml ("version " ++ projectVersion) @@ -38,20 +43,19 @@ footer = simpleHeader title = - (td ! [theclass "topbar"] << + (tda [theclass "topbar"] << vanillaTable << ( (td << - image ! [src "haskell_icon.gif", width "16", height 16, - align "absmiddle"] + image ! [src "haskell_icon.gif", width "16", height 16, alt " " ] ) <-> - (td ! [theclass "title", width "100%"] << toHtml title) + (tda [theclass "title"] << toHtml title) )) buttons1 source_url mod file | Just u <- source_url = let src_url = if (last u == '/') then u ++ file else u ++ '/':file in - (td ! [theclass "topbut", nowrap] << + (tda [theclass "topbut", nowrap] << anchor ! [href src_url] << toHtml "Source code") <-> buttons2 mod | otherwise = buttons2 mod @@ -60,41 +64,40 @@ buttons1 source_url mod file buttons2 mod = case span (/= '.') (reverse mod) of (m, '.':rest) -> - (td ! [theclass "topbut", nowrap] << + (tda [theclass "topbut", nowrap] << anchor ! [href (moduleHtmlFile (reverse rest))] << toHtml "Parent") <-> contentsButton _ -> cell contentsButton -contentsButton = (td ! [theclass "topbut", nowrap] << +contentsButton = (tda [theclass "topbut", nowrap] << anchor ! [href indexHtmlFile] << toHtml "Contents") pageHeader mod iface title source_url = - (td ! [theclass "topbar"] << + (tda [theclass "topbar"] << vanillaTable << ( (td << - image ! [src "haskell_icon.gif", width "16", height 16, - align "absmiddle"] + image ! [src "haskell_icon.gif", width "16", height 16, alt " "] ) <-> - (td ! [theclass "title", width "100%"] << toHtml title) <-> + (tda [theclass "title"] << toHtml title) <-> buttons1 source_url mod (iface_filename iface) ) ) - td ! [theclass "modulebar"] << + tda [theclass "modulebar"] << (vanillaTable << ( (td << font ! [size "6"] << toHtml mod) <-> - (td ! [align "right"] << + (tda [align "right"] << (table ! [width "300", border 0, cellspacing 0, cellpadding 0] << ( - (td ! [width "50%"] << font ! [color "#ffffff"] << + (tda [width "50%"] << font ! [color "#ffffff"] << bold << toHtml "Portability") <-> - (td ! [width "50%"] << font ! [color "#ffffff"] << + (tda [width "50%"] << font ! [color "#ffffff"] << toHtml (iface_portability iface)) - (td ! [width "50%"] << font ! [color "#ffffff"] << + (tda [width "50%"] << font ! [color "#ffffff"] << bold << toHtml "Stability") <-> - (td ! [width "50%"] << font ! [color "#ffffff"] << + (tda [width "50%"] << font ! [color "#ffffff"] << toHtml (iface_stability iface)) - (td ! [width "50%"] << font ! [color "#ffffff"] << + (tda [width "50%"] << font ! [color "#ffffff"] << bold << toHtml "Maintainer") <-> - (td ! [width "50%"] << font ! [color "#ffffff"] << + (tda [width "50%"] << font ! [color "#ffffff"] << toHtml (iface_maintainer iface)) )) )) @@ -107,28 +110,30 @@ ppHtmlIndex :: String -> Maybe String -> [Module] -> IO () ppHtmlIndex title source_url mods = do let tree = mkModuleTree mods html = - header (thetitle (toHtml title)) +++ - mylink ! [href styleSheetFile, - rel "stylesheet", thetype "text/css"] +++ + header (thetitle (toHtml title) +++ + mylink ! [href styleSheetFile, + rel "stylesheet", thetype "text/css"]) +++ body << table ! [width "100%", cellpadding 0, cellspacing 1] << ( simpleHeader title td << (ppModuleTree title tree) footer ) - writeFile indexHtmlFile (Html.renderHtml html) + writeFile indexHtmlFile (renderHtml html) ppModuleTree :: String -> [ModuleTree] -> Html ppModuleTree title ts = h1 << toHtml "Modules" +++ table ! [cellpadding 0, cellspacing 2] << aboves (map (mkNode []) ts) +mkNode :: [String] -> ModuleTree -> HtmlTable mkNode ss (Node s leaf []) = td << mkLeaf s ss leaf mkNode ss (Node s leaf ts) = - td << table ! [cellpadding 0, cellspacing 2] << - ((td << mkLeaf s ss leaf) - indent <-> aboves (map (mkNode (s:ss)) ts)) + (td << mkLeaf s ss leaf) + + (tda [theclass "children"] << + vanillaTable (toHtml (aboves (map (mkNode (s:ss)) ts)))) mkLeaf s ss False = toHtml s mkLeaf s ss True = anchor ! [href (moduleHtmlFile mod)] << toHtml s @@ -163,20 +168,20 @@ splitModule (Module mod) = split mod ppHtmlModule :: String -> Maybe String -> (Module,Interface) -> IO () ppHtmlModule title source_url (Module mod,iface) = do let html = - header (thetitle (toHtml mod)) +++ - mylink ! [href styleSheetFile, - rel "stylesheet", thetype "text/css"] +++ + header (thetitle (toHtml mod) +++ + mylink ! [href styleSheetFile, + rel "stylesheet", thetype "text/css"]) +++ body << table ! [width "100%", cellpadding 0, cellspacing 1] << ( pageHeader mod iface title source_url ifaceToHtml mod iface footer ) - writeFile (moduleHtmlFile mod) (Html.renderHtml html) + writeFile (moduleHtmlFile mod) (renderHtml html) -ifaceToHtml :: String -> Interface -> Html +ifaceToHtml :: String -> Interface -> HtmlTable ifaceToHtml mod iface - | null exports = noHtml + | null exports = td << noHtml | otherwise = td << table ! [width "100%", cellpadding 0, cellspacing 15] << body1 where exports = iface_exports iface @@ -184,45 +189,45 @@ ifaceToHtml mod iface body1 | Just doc <- iface_doc iface - = td ! [theclass "section1"] << toHtml "Description" + = (tda [theclass "section1"] << toHtml "Description") docBox (markup htmlMarkup doc) body2 | otherwise = body2 body2 = - (td ! [theclass "section1"] << toHtml "Synopsis") - (td ! [width "100%", theclass "synopsis"] << + (tda [theclass "section1"] << toHtml "Synopsis") + (tda [width "100%", theclass "synopsis"] << table ! [width "100%", cellpadding 0, cellspacing 8, border 0] << aboves (map (processExport doc_map True) exports)) td << hr aboves (map (processExport doc_map False) exports) -processExport :: FiniteMap HsName Doc -> Bool -> ExportItem -> Html +processExport :: FiniteMap HsName Doc -> Bool -> ExportItem -> HtmlTable processExport doc_map summary (ExportGroup lev doc) - | summary = noHtml + | summary = td << noHtml | otherwise = ppDocGroup lev (markup htmlMarkup doc) processExport doc_map summary (ExportDecl decl) = doDecl doc_map summary decl ppDocGroup lev doc - | lev == 1 = td ! [ theclass "section1" ] << doc - | lev == 2 = td ! [ theclass "section2" ] << doc - | lev == 3 = td ! [ theclass "section3" ] << doc - | otherwise = td ! [ theclass "section4" ] << doc + | lev == 1 = tda [ theclass "section1" ] << doc + | lev == 2 = tda [ theclass "section2" ] << doc + | lev == 3 = tda [ theclass "section3" ] << doc + | otherwise = tda [ theclass "section4" ] << doc -- ----------------------------------------------------------------------------- -- Converting declarations to HTML -declWithDoc :: Bool -> Maybe Doc -> Html -> Html +declWithDoc :: Bool -> Maybe Doc -> Html -> HtmlTable declWithDoc True doc html_decl = declBox html_decl declWithDoc False Nothing html_decl = declBox html_decl declWithDoc False (Just doc) html_decl = - td ! [width "100%"] << + tda [width "100%"] << vanillaTable << (declBox html_decl docBox (markup htmlMarkup doc)) -doDecl :: FiniteMap HsName Doc -> Bool -> HsDecl -> Html +doDecl :: FiniteMap HsName Doc -> Bool -> HsDecl -> HtmlTable doDecl doc_map summary decl = do_decl decl where doc | Just n <- declMainBinder decl = lookupFM doc_map n @@ -255,7 +260,7 @@ doDecl doc_map summary decl = do_decl decl = ppHsClassDecl doc_map summary decl do_decl (HsDocGroup lev str) - = if summary then noHtml else ppDocGroup lev str + = if summary then td << noHtml else ppDocGroup lev str do_decl _ = error (show decl) @@ -295,7 +300,7 @@ ppHsDataDecl doc_map True (HsDataDecl loc ctx nm args cons drv) = ) ) )) - where do_constr c con = td ! [theclass "condecl"] << ( + where do_constr c con = tda [theclass "condecl"] << ( toHtml [c] <+> ppHsSummaryConstr con) -- Now, the full expanded documented version: @@ -311,9 +316,9 @@ ppHsDataDecl doc_map False decl@(HsDataDecl loc ctx nm args cons drv) = where header = declBox (ppHsDataHeader False nm args) datadoc = docBox (markup htmlMarkup (fromJust doc)) - constr_hdr = td ! [ theclass "section4" ] << toHtml "Constructors" + constr_hdr = tda [ theclass "section4" ] << toHtml "Constructors" - constrs = td ! [theclass "databody"] << ( + constrs = tda [theclass "databody"] << ( table ! [width "100%", cellpadding 0, cellspacing 10] << aboves (constr_hdr : map do_constr cons) ) @@ -329,7 +334,7 @@ ppHsSummaryConstr (HsConDecl pos nm typeList _maybe_doc) = hsep (ppHsBinder True nm : map ppHsBangType typeList) ppHsSummaryConstr (HsRecDecl pos nm fields maybe_doc) = ppHsBinder True nm +++ - braces (vanillaTable << aboves (map (td . ppSummaryField) fields)) + braces (vanillaTable << aboves (map ppSummaryField fields)) ppHsFullConstr doc_map (HsConDecl pos nm typeList _maybe_doc) = declWithDoc False doc ( @@ -356,7 +361,7 @@ ppHsFullConstr doc_map (HsRecDecl pos nm fields maybe_doc) = ppSummaryField (HsFieldDecl ns ty _doc) - = td ! [theclass "recfield"] << ( + = tda [theclass "recfield"] << ( hsep (punctuate comma (map (ppHsBinder True) ns)) <+> toHtml "::" <+> ppHsBangType ty ) @@ -388,7 +393,7 @@ ppHsClassDecl doc_map True (HsClassDecl loc ty decls) = vanillaTable << ( declBox (ppClassHdr ty <+> keyword "where") - td ! [theclass "cbody"] << ( + tda [theclass "cbody"] << ( vanillaTable << ( aboves (map (doDecl doc_map True) (filter keepDecl decls)) )) @@ -405,7 +410,7 @@ ppHsClassDecl doc_map False decl@(HsClassDecl loc ty decls) = )) where header = declBox (linkTarget c +++ ppClassHdr ty <+> keyword "where") classdoc = docBox (markup htmlMarkup (fromJust doc)) - meth_hdr = td ! [ theclass "section4" ] << toHtml "Methods" + meth_hdr = tda [ theclass "section4" ] << toHtml "Methods" body = td << ( table ! [width "100%", cellpadding 0, cellspacing 8] << ( meth_hdr @@ -550,17 +555,59 @@ ubxParenList = ubxparens . hsep . punctuate comma ubxparens p = toHtml "(#" +++ p +++ toHtml "#)" -indent = td ! [width "10"] << "" - text = strAttr "TEXT" div = tag "DIV" mylink = itag "LINK" -declBox :: Html -> Html -declBox html = td ! [theclass "decl"] << html +declBox :: Html -> HtmlTable +declBox html = tda [theclass "decl"] << html -docBox :: Html -> Html -docBox html = td ! [theclass "doc"] << html +docBox :: Html -> HtmlTable +docBox html = tda [theclass "doc"] << html vanillaTable = table ! [width "100%", cellpadding 0, cellspacing 0, border 0] +renderHtml :: (HTML html) => html -> String +renderHtml theHtml = + renderMessage ++ + foldr (.) id (map (renderHtml' 0) + (getHtmlElements (tag "HTML" << theHtml))) "\n" + +renderMessage = + "\n" ++ + "\n" + +renderHtml' :: Int -> HtmlElement -> ShowS +renderHtml' _ (HtmlString str) = (++) str +renderHtml' n (HtmlTag + { markupTag = name, + markupContent = html, + markupAttrs = markupAttrs }) + = if isNoHtml html && elem name myValidHtmlITags + then renderTag True name markupAttrs n + else (renderTag True name markupAttrs n + . foldr (.) id (map (renderHtml' (n+2)) (getHtmlElements html)) + . renderTag False name [] n) + +myValidHtmlITags = "LINK" : validHtmlITags + +-- ----------------------------------------------------------------------------- +-- a "better" implementation of the table combinators (less confusing, anyhow) + +td :: Html -> HtmlTable +td = cell . Html.td + +tda :: [HtmlAttr] -> Html -> HtmlTable +tda as = cell . (Html.td ! as) + +above a b = combine BT.above a b +beside a b = combine BT.beside a b + +infixr 3 -- combining table cells +infixr 4 <-> -- combining table cells +() = above +(<->) = beside + +aboves = foldr1 above +besides = foldr1 beside + -- cgit v1.2.3