-- -- Haddock - A Haskell Documentation Tool -- -- (c) Simon Marlow 2002 -- module HaddockHtml (ppHtml) where import Prelude hiding (div) import HaddockVersion import HaddockTypes import HaddockUtil import HsSyn import Maybe ( fromJust, isNothing, isJust ) import FiniteMap import List ( sortBy ) import Char ( toUpper, toLower ) import Monad ( when ) --import IOExts import Html import qualified Html -- ----------------------------------------------------------------------------- -- Files we need to copy from our $libdir cssFile = "haddock.css" iconFile = "haskell_icon.gif" -- ----------------------------------------------------------------------------- -- Generating HTML documentation ppHtml :: String -> Maybe String -> [(Module, Interface)] -> FilePath -- destination directory -> Maybe String -- CSS file -> String -- $libdir -> IO () ppHtml title source_url ifaces odir maybe_css libdir = do let css_file = case maybe_css of Nothing -> libdir ++ pathSeparator:cssFile Just f -> f css_destination = odir ++ pathSeparator:cssFile icon_file = libdir ++ pathSeparator:iconFile icon_destination = odir ++ pathSeparator:iconFile visible_ifaces = filter visible ifaces visible (m,i) = OptHide `notElem` iface_options i css_contents <- readFile css_file writeFile css_destination css_contents icon_contents <- readFile icon_file writeFile icon_destination icon_contents ppHtmlContents odir title source_url (map fst visible_ifaces) ppHtmlIndex odir title visible_ifaces mapM_ (ppHtmlModule odir title source_url) visible_ifaces moduleHtmlFile :: String -> FilePath moduleHtmlFile mod = mod ++ ".html" -- ToDo: Z-encode filename? contentsHtmlFile = "index.html" indexHtmlFile = "doc-index.html" subIndexHtmlFile k a = "doc-index-" ++ k:a:".html" footer = tda [theclass "botbar"] << ( toHtml "Produced by" <+> (anchor ! [href projectUrl] << toHtml projectName) <+> toHtml ("version " ++ projectVersion) ) src_button source_url mod file | Just u <- source_url = let src_url = if (last u == '/') then u ++ file else u ++ '/':file in (tda [theclass "topbut", nowrap] << anchor ! [href src_url] << toHtml "Source code") | otherwise = Html.emptyTable parent_button mod = case span (/= '.') (reverse mod) of (m, '.':rest) -> (tda [theclass "topbut", nowrap] << anchor ! [href (moduleHtmlFile (reverse rest))] << toHtml "Parent") _ -> Html.emptyTable contentsButton = tda [theclass "topbut", nowrap] << anchor ! [href contentsHtmlFile] << toHtml "Contents" indexButton = tda [theclass "topbut", nowrap] << anchor ! [href indexHtmlFile] << toHtml "Index" simpleHeader title = (tda [theclass "topbar"] << vanillaTable << ( (td << image ! [src "haskell_icon.gif", width "16", height 16, alt " " ] ) <-> (tda [theclass "title"] << toHtml title) <-> contentsButton <-> indexButton )) pageHeader mod iface title source_url = (tda [theclass "topbar"] << vanillaTable << ( (td << image ! [src "haskell_icon.gif", width "16", height 16, alt " "] ) <-> (tda [theclass "title"] << toHtml title) <-> src_button source_url mod (iface_filename iface) <-> parent_button mod <-> contentsButton <-> indexButton ) ) tda [theclass "modulebar"] << (vanillaTable << ( (td << font ! [size "6"] << toHtml mod) <-> moduleInfo iface ) ) moduleInfo iface | Nothing <- iface_info iface = Html.emptyTable | Just info <- iface_info iface = tda [align "right"] << (table ! [border 0, cellspacing 0, cellpadding 0] << ( (tda [theclass "infohead"] << toHtml "Portability") <-> (tda [theclass "infoval"] << toHtml (portability info)) (tda [theclass "infohead"] << toHtml "Stability") <-> (tda [theclass "infoval"] << toHtml (stability info)) (tda [theclass "infohead"] << toHtml "Maintainer") <-> (tda [theclass "infoval"] << toHtml (maintainer info)) )) -- --------------------------------------------------------------------------- -- Generate the module contents ppHtmlContents :: FilePath -> String -> Maybe String -> [Module] -> IO () ppHtmlContents odir title source_url mods = do let tree = mkModuleTree mods html = header (thetitle (toHtml title) +++ thelink ! [href cssFile, rel "stylesheet", thetype "text/css"]) +++ body << table ! [width "100%", cellpadding 0, cellspacing 1] << ( simpleHeader title ppModuleTree title tree footer ) writeFile (odir ++ pathSeparator:contentsHtmlFile) (renderHtml html) ppModuleTree :: String -> [ModuleTree] -> HtmlTable ppModuleTree title ts = tda [theclass "section1"] << toHtml "Modules" td << 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 << 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 where mod = foldr (++) "" (s' : map ('.':) ss') (s':ss') = reverse (s:ss) -- reconstruct the module name data ModuleTree = Node String Bool [ModuleTree] mkModuleTree :: [Module] -> [ModuleTree] mkModuleTree mods = foldr addToTrees [] (map splitModule mods) addToTrees :: [String] -> [ModuleTree] -> [ModuleTree] addToTrees [] ts = ts addToTrees ss [] = mkSubTree ss addToTrees (s1:ss) (t@(Node s2 leaf subs) : ts) | s1 > s2 = t : addToTrees (s1:ss) ts | s1 == s2 = Node s2 (leaf || null ss) (addToTrees ss subs) : ts | otherwise = mkSubTree (s1:ss) ++ t : ts mkSubTree [] = [] mkSubTree (s:ss) = [Node s (null ss) (mkSubTree ss)] splitModule :: Module -> [String] splitModule (Module mod) = split mod where split mod = case break (== '.') mod of (s1, '.':s2) -> s1 : split s2 (s1, _) -> [s1] -- --------------------------------------------------------------------------- -- Generate the index ppHtmlIndex :: FilePath -> String -> [(Module,Interface)] -> IO () ppHtmlIndex odir title ifaces = do let html = header (thetitle (toHtml (title ++ " (Index)")) +++ thelink ! [href cssFile, rel "stylesheet", thetype "text/css"]) +++ body << table ! [width "100%", cellpadding 0, cellspacing 1] << ( simpleHeader title tda [theclass "section1"] << toHtml "Type/Class Index" index_html tycls_index 't' tda [theclass "section1"] << toHtml "Function/Constructor Index" index_html var_index 'v' ) when split_indices (do mapM_ (do_sub_index "Type/Class" tycls_index 't') ['A'..'Z'] mapM_ (do_sub_index "Function/Constructor" var_index 'v') ['A'..'Z'] ) writeFile (odir ++ pathSeparator:indexHtmlFile) (renderHtml html) where split_indices = length tycls_index > 50 || length var_index > 50 index_html this_ix kind | split_indices = td << table ! [cellpadding 0, cellspacing 5] << besides [ td << anchor ! [href (subIndexHtmlFile kind c)] << toHtml [c] | c <- ['A'..'Z'] ] | otherwise = td << table ! [cellpadding 0, cellspacing 5] << aboves (map indexElt this_ix) do_sub_index descr this_ix kind c = writeFile (odir ++ pathSeparator:subIndexHtmlFile kind c) (renderHtml html) where html = header (thetitle (toHtml (title ++ " (" ++ descr ++ "Index)")) +++ thelink ! [href cssFile, rel "stylesheet", thetype "text/css"]) +++ body << table ! [width "100%", cellpadding 0, cellspacing 1] << ( simpleHeader title tda [theclass "section1"] << toHtml (descr ++ " Index (" ++ c:")") td << table ! [cellpadding 0, cellspacing 5] << aboves (map indexElt index_part) ) index_part = [(n,stuff) | (n,stuff) <- this_ix, n `nameBeginsWith` c] tycls_index = index isTyClsName var_index = index (not.isTyClsName) isTyClsName (HsTyClsName _) = True isTyClsName _ = False index :: (HsName -> Bool) -> [(HsName, [(Module,Bool)])] index f = sortBy cmp (fmToList (full_index f)) where cmp (n1,_) (n2,_) = n1 `compare` n2 iface_indices f = map (getIfaceIndex f) ifaces full_index f = foldr1 (plusFM_C (++)) (iface_indices f) getIfaceIndex f (mod,iface) = listToFM [ (name, [(mod, mod == mod')]) | (name, Qual mod' _) <- fmToList (iface_env iface), f name ] indexElt :: (HsName, [(Module,Bool)]) -> HtmlTable indexElt (nm, entries) = td << ppHsName nm <-> td << (hsep [ if defining then bold << anchor ! [href (linkId mod nm)] << toHtml mod else anchor ! [href (linkId mod nm)] << toHtml mod | (Module mod, defining) <- entries ]) nameBeginsWith (HsTyClsName id) c = idBeginsWith id c nameBeginsWith (HsVarName id) c = idBeginsWith id c idBeginsWith (HsIdent s) c = head s `elem` [toLower c, toUpper c] idBeginsWith (HsSymbol s) c = head s `elem` [toLower c, toUpper c] idBeginsWith (HsSpecial s) c = head s `elem` [toLower c, toUpper c] -- --------------------------------------------------------------------------- -- Generate the HTML page for a module ppHtmlModule :: FilePath -> String -> Maybe String -> (Module,Interface) -> IO () ppHtmlModule odir title source_url (Module mod,iface) = do let html = header (thetitle (toHtml mod) +++ thelink ! [href cssFile, rel "stylesheet", thetype "text/css"]) +++ body << table ! [width "100%", cellpadding 0, cellspacing 1] << ( pageHeader mod iface title source_url ifaceToHtml mod iface footer ) writeFile (odir ++ pathSeparator:moduleHtmlFile mod) (renderHtml html) ifaceToHtml :: String -> Interface -> HtmlTable ifaceToHtml mod iface | null exports = Html.emptyTable | otherwise = td << table ! [width "100%", cellpadding 0, cellspacing 15] << (contents description synopsis maybe_hr body) where exports = numberSectionHeadings (iface_exports iface) doc_map = iface_name_docs iface has_doc (ExportDecl d) | Just x <- declMainBinder d = isJust (lookupFM doc_map x) has_doc _ = True no_doc_at_all = not (any has_doc exports) contents = td << ppModuleContents exports description | Just doc <- iface_doc iface = (tda [theclass "section1"] << toHtml "Description") docBox (markup htmlMarkup doc) | otherwise = Html.emptyTable -- omit the synopsis if there are no documentation annotations at all synopsis | no_doc_at_all = Html.emptyTable | otherwise = (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)) maybe_hr | 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 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 process n (_ : rest) = process n rest 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 id doc) | summary = Html.emptyTable | otherwise = ppDocGroup lev (anchor ! [name id] << markup htmlMarkup doc) processExport doc_map summary (ExportDecl decl) = doDecl doc_map summary decl processExport doc_map summary (ExportDoc doc) | summary = Html.emptyTable | otherwise = docBox (markup htmlMarkup doc) processExport doc_map summary (ExportModule (Module mod)) = declBox (toHtml "module" <+> ppHsModule mod) ppDocGroup lev 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 -> HtmlTable declWithDoc True doc html_decl = declBox html_decl declWithDoc False Nothing html_decl = declBox html_decl declWithDoc False (Just doc) html_decl = tda [width "100%"] << vanillaTable << (declBox html_decl docBox (markup htmlMarkup doc)) 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 | otherwise = Nothing do_decl (HsTypeSig _ [nm] ty) = declWithDoc summary doc (ppTypeSig summary nm ty) do_decl (HsTypeSig _ nms ty) = declWithDoc summary doc ( vanillaTable << aboves (map do_one nms)) where do_one nm = declBox (ppTypeSig summary nm ty) do_decl (HsForeignImport _ _ _ _ n ty) = declWithDoc summary doc (ppTypeSig summary n ty) do_decl (HsTypeDecl _ nm args ty) = declWithDoc summary doc ( hsep ([keyword "type", ppHsBinder summary nm] ++ map ppHsName args) <+> equals <+> ppHsType ty) do_decl (HsNewTypeDecl loc ctx nm args con drv) = ppHsDataDecl doc_map summary True{-is newtype-} (HsDataDecl loc ctx nm args [con] drv) -- print it as a single-constructor datatype do_decl decl@(HsDataDecl loc ctx nm args cons drv) = ppHsDataDecl doc_map summary False{-not newtype-} decl do_decl decl@(HsClassDecl _ _ _ _) = ppHsClassDecl doc_map summary decl do_decl (HsDocGroup lev str) = if summary then Html.emptyTable else ppDocGroup lev str do_decl _ = error (show decl) ppTypeSig summary nm ty = ppHsBinder summary nm <+> toHtml "::" <+> ppHsType ty keepDecl HsTypeSig{} = True keepDecl HsTypeDecl{} = True keepDecl HsNewTypeDecl{} = True keepDecl HsDataDecl{} = True keepDecl HsClassDecl{} = True keepDecl _ = False -- ----------------------------------------------------------------------------- -- Data & newtype declarations ppShortDataDecl :: Bool -> Bool -> HsDecl -> Html ppShortDataDecl summary is_newty (HsDataDecl loc ctx nm args [con] drv) = ppHsDataHeader summary is_newty nm args <+> equals <+> ppShortConstr summary con ppShortDataDecl summary is_newty (HsDataDecl loc ctx nm args cons drv) = vanillaTable << ( aboves ( (declBox (ppHsDataHeader summary is_newty nm args) : zipWith do_constr ('=':repeat '|') cons ) ) ) where do_constr c con = tda [theclass "condecl"] << ( toHtml [c] <+> ppShortConstr summary con) -- First, the abstract case: ppHsDataDecl doc_map summary is_newty (HsDataDecl loc ctx nm args [] drv) = declWithDoc summary (lookupFM doc_map nm) (ppHsDataHeader summary is_newty nm args) -- The rest of the cases: ppHsDataDecl doc_map summary is_newty decl@(HsDataDecl loc ctx nm args cons drv) | summary || no_constr_docs = declWithDoc summary (lookupFM doc_map nm) (ppShortDataDecl summary is_newty decl) | otherwise = td << vanillaTable << (header datadoc constrs) where header = declBox (ppHsDataHeader False is_newty nm args) datadoc = docBox (markup htmlMarkup (fromJust doc)) constr_hdr = tda [ theclass "section4" ] << toHtml "Constructors" constrs | null cons = Html.emptyTable | otherwise = tda [theclass "databody"] << ( table ! [width "100%", cellpadding 0, cellspacing 10] << aboves (constr_hdr : map do_constr cons) ) do_constr con = ppHsFullConstr doc_map con Just c = declMainBinder decl doc = lookupFM doc_map c no_constr_docs = all constr_has_no_doc cons constr_has_no_doc (HsConDecl _ nm _ _) = isNothing (lookupFM doc_map nm) constr_has_no_doc (HsRecDecl _ nm fields _) = isNothing (lookupFM doc_map nm) && all field_has_no_doc fields field_has_no_doc (HsFieldDecl nms _ _) = all isNothing (map (lookupFM doc_map) nms) ppShortConstr :: Bool -> HsConDecl -> Html ppShortConstr summary (HsConDecl pos nm typeList _maybe_doc) = hsep (ppHsBinder summary nm : map ppHsBangType typeList) ppShortConstr summary (HsRecDecl pos nm fields maybe_doc) = ppHsBinder summary nm +++ braces (vanillaTable << aboves (map (ppShortField summary) fields)) ppHsFullConstr doc_map (HsConDecl pos nm typeList _maybe_doc) = declWithDoc False doc ( hsep (ppHsBinder False nm : map ppHsBangType typeList) ) where doc = lookupFM doc_map nm ppHsFullConstr doc_map (HsRecDecl pos nm fields maybe_doc) = td << vanillaTable << ( case doc of Nothing -> aboves [hdr, fields_html] Just doc -> aboves [hdr, constr_doc, fields_html] ) where hdr = declBox (ppHsBinder False nm) constr_doc = docBox (markup htmlMarkup (fromJust doc)) fields_html = td << table ! [width "100%", cellpadding 0, cellspacing 8] << ( aboves (map (ppFullField doc_map) (concat (map expandField fields))) ) doc = lookupFM doc_map nm ppShortField summary (HsFieldDecl ns ty _doc) = tda [theclass "recfield"] << ( hsep (punctuate comma (map (ppHsBinder summary) ns)) <+> toHtml "::" <+> ppHsBangType ty ) ppFullField doc_map (HsFieldDecl [n] ty _doc) = declWithDoc False (lookupFM doc_map n) ( ppHsBinder False n <+> toHtml "::" <+> ppHsBangType ty ) ppFullField _ _ = error "ppFullField" expandField (HsFieldDecl ns ty doc) = [ HsFieldDecl [n] ty doc | n <- ns ] ppHsDataHeader summary is_newty nm args = (if is_newty then keyword "newtype" else keyword "data") <+> ppHsBinder summary nm <+> hsep (map ppHsName args) ppHsBangType :: HsBangType -> Html ppHsBangType (HsBangedTy ty) = char '!' +++ ppHsAType ty ppHsBangType (HsUnBangedTy ty) = ppHsAType ty -- ----------------------------------------------------------------------------- -- Class declarations ppClassHdr ty fds = keyword "class" <+> ppHsType ty <+> if null fds then noHtml else char '|' <+> hsep (punctuate comma (map fundep fds)) where fundep (vars1,vars2) = hsep (map ppHsName vars1) <+> toHtml "->" <+> hsep (map ppHsName vars2) ppShortClassDecl doc_map summary decl@(HsClassDecl loc ty fds decls) = if null decls then declBox hdr else td << ( vanillaTable << ( declBox (hdr <+> keyword "where") tda [theclass "cbody"] << ( vanillaTable << ( aboves (map (doDecl doc_map summary) (filter keepDecl decls)) )) )) where Just c = declMainBinder decl hdr | not summary = linkTarget c +++ ppClassHdr ty fds | otherwise = ppClassHdr ty fds ppHsClassDecl doc_map summary decl@(HsClassDecl loc ty fds decls) | summary || (isNothing doc && all decl_has_no_doc kept_decls) = ppShortClassDecl doc_map summary decl | otherwise = td << vanillaTable << (header classdoc body) where doc = lookupFM doc_map c Just c = declMainBinder decl header | null decls = declBox (linkTarget c +++ ppClassHdr ty fds) | otherwise = declBox (linkTarget c +++ ppClassHdr ty fds <+> keyword "where") classdoc | Just d <- doc = docBox (markup htmlMarkup d) | otherwise = Html.emptyTable meth_hdr = tda [ theclass "section4" ] << toHtml "Methods" body | null decls = Html.emptyTable | otherwise = td << table ! [width "100%", cellpadding 0, cellspacing 8] << ( meth_hdr aboves (map (doDecl doc_map False) kept_decls) ) kept_decls = filter keepDecl decls decl_has_no_doc decl | Just b <- declMainBinder decl = isNothing (lookupFM doc_map b) | otherwise = True -- ----------------------------------------------------------------------------- -- Types and contexts ppHsContext :: HsContext -> Html ppHsContext [] = empty ppHsContext context = parenList (map (\ (a,b) -> ppHsQName a <+> hsep (map ppHsAType b)) context) ppHsType :: HsType -> Html ppHsType (HsForAllType Nothing context htype) = hsep [ ppHsContext context, toHtml "=>", ppHsType htype] ppHsType (HsForAllType (Just tvs) [] htype) = hsep (keyword "forall" : map ppHsName tvs ++ toHtml "." : [ppHsType htype]) ppHsType (HsForAllType (Just tvs) context htype) = hsep (keyword "forall" : map ppHsName tvs ++ toHtml "." : ppHsContext context : toHtml "=>" : [ppHsType htype]) ppHsType (HsTyFun a b) = hsep [ppHsBType a, toHtml "->", ppHsType b] ppHsType t = ppHsBType t ppHsBType (HsTyApp (HsTyCon (Qual (Module "Prelude") (HsTyClsName (HsSpecial "[]")))) b ) = brackets $ ppHsType b ppHsBType (HsTyApp a b) = ppHsBType a <+> ppHsAType b ppHsBType t = ppHsAType t -- ----------------------------------------------------------------------------- -- Names linkTarget :: HsName -> Html linkTarget nm = anchor ! [name (hsNameStr nm)] << toHtml "" ppHsAType :: HsType -> Html ppHsAType (HsTyTuple True l) = parenList . map ppHsType $ l ppHsAType (HsTyTuple False l) = ubxParenList . map ppHsType $ l ppHsAType (HsTyVar name) = ppHsName name ppHsAType (HsTyCon name) = ppHsQName name ppHsAType t = parens $ ppHsType t ppHsQName :: HsQName -> Html ppHsQName (UnQual str) = ppHsName str ppHsQName n@(Qual (Module mod) str) | n == unit_con_name = ppHsName str | isSpecial str = ppHsName str | otherwise = anchor ! [href (linkId mod str)] << ppHsName str isSpecial (HsTyClsName id) | HsSpecial _ <- id = True isSpecial (HsVarName id) | HsSpecial _ <- id = True isSpecial _ = False ppHsName :: HsName -> Html ppHsName nm = toHtml (hsNameStr nm) hsNameStr :: HsName -> String hsNameStr (HsTyClsName id) = ppHsIdentifier id hsNameStr (HsVarName id) = ppHsIdentifier id ppHsIdentifier :: HsIdentifier -> String ppHsIdentifier (HsIdent str) = str ppHsIdentifier (HsSymbol str) = str ppHsIdentifier (HsSpecial str) = str ppHsBinder :: Bool -> HsName -> Html ppHsBinder True nm = anchor ! [href ('#':hsNameStr nm)] << ppHsBinder' nm ppHsBinder False nm = linkTarget nm +++ ppHsBinder' nm ppHsBinder' (HsTyClsName id) = ppHsBindIdent id ppHsBinder' (HsVarName id) = ppHsBindIdent id ppHsBindIdent :: HsIdentifier -> Html ppHsBindIdent (HsIdent str) = toHtml str ppHsBindIdent (HsSymbol str) = parens (toHtml str) ppHsBindIdent (HsSpecial str) = toHtml str linkId :: String -> HsName -> String linkId mod str = moduleHtmlFile mod ++ '#': hsNameStr str ppHsModule :: String -> Html ppHsModule mod = anchor ! [href (moduleHtmlFile mod)] << toHtml mod -- ----------------------------------------------------------------------------- -- * Doc Markup htmlMarkup = Markup { markupParagraph = paragraph, markupEmpty = toHtml "", markupString = toHtml, markupAppend = (+++), markupIdentifier = ppHsQName, markupModule = ppHsModule, markupEmphasis = emphasize . toHtml, markupMonospaced = tt . toHtml, markupUnorderedList = ulist . concatHtml . map (li <<), markupOrderedList = olist . concatHtml . map (li <<), markupCodeBlock = pre, markupURL = \url -> anchor ! [href url] << toHtml url } -- ----------------------------------------------------------------------------- -- * Misc hsep :: [Html] -> Html hsep [] = noHtml hsep htmls = foldr1 (\a b -> a+++" "+++b) htmls infixr 8 <+> a <+> b = Html (getHtmlElements (toHtml a) ++ HtmlString " ": getHtmlElements (toHtml b)) keyword s = bold << toHtml s equals = char '=' comma = char ',' char c = toHtml [c] empty = toHtml "" parens p = char '(' +++ p +++ char ')' brackets p = char '[' +++ p +++ char ']' braces p = char '{' +++ p +++ char '}' punctuate :: Html -> [Html] -> [Html] punctuate p [] = [] punctuate p (d:ds) = go d ds where go d [] = [d] go d (e:es) = (d +++ p) : go e es parenList :: [Html] -> Html parenList = parens . hsep . punctuate comma ubxParenList :: [Html] -> Html ubxParenList = ubxparens . hsep . punctuate comma ubxparens p = toHtml "(#" +++ p +++ toHtml "#)" text = strAttr "TEXT" declBox :: Html -> HtmlTable declBox html = tda [theclass "decl"] << html docBox :: Html -> HtmlTable docBox html = tda [theclass "doc"] << html vanillaTable = table ! [width "100%", cellpadding 0, cellspacing 0, border 0]