-- -- 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 IO 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 topButBox (anchor ! [href src_url] << toHtml "Source code") | otherwise = Html.emptyTable parent_button mod = case span (/= '.') (reverse mod) of (m, '.':rest) -> topButBox ( anchor ! [href (moduleHtmlFile (reverse rest))] << toHtml "Parent") _ -> Html.emptyTable contentsButton = topButBox (anchor ! [href contentsHtmlFile] << toHtml "Contents") indexButton = topButBox (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 << vanillaTable << ( 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 << vanillaTable << ( 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 << vanillaTable << ( 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 << vanillaTable << ( 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) has_doc (ExportDecl d) = isJust (declDoc d) has_doc (ExportModule _) = False 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 (docToHtml 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 True) exports)) maybe_hr | not (no_doc_at_all), ExportGroup 1 _ _ <- head exports = td << hr | otherwise = Html.emptyTable body = aboves (map (processExport False) exports) ppModuleContents :: [ExportItem] -> HtmlTable ppModuleContents exports | length sections < 2 = 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)] << docToHtml 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 :: Bool -> ExportItem -> HtmlTable processExport summary (ExportGroup lev id doc) | summary = Html.emptyTable | otherwise = ppDocGroup lev (anchor ! [name id] << docToHtml doc) processExport summary (ExportDecl decl) = doDecl summary decl processExport summary (ExportDoc doc) | summary = Html.emptyTable | otherwise = docBox (docToHtml doc) processExport 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 (docToHtml doc)) doDecl :: Bool -> HsDecl -> HtmlTable doDecl summary decl = do_decl decl where do_decl (HsTypeSig _ [nm] ty doc) = ppFunSig summary nm ty doc do_decl (HsForeignImport _ _ _ _ n ty doc) = declWithDoc summary doc (ppTypeSig summary n ty) do_decl (HsTypeDecl _ nm args ty doc) = declWithDoc summary doc ( hsep ([keyword "type", ppHsBinder summary nm] ++ map ppHsName args) <+> equals <+> ppHsType ty) do_decl (HsNewTypeDecl loc ctx nm args con drv doc) = ppHsDataDecl summary True{-is newtype-} (HsDataDecl loc ctx nm args [con] drv doc) -- print it as a single-constructor datatype do_decl decl@(HsDataDecl loc ctx nm args cons drv doc) = ppHsDataDecl summary False{-not newtype-} decl do_decl decl@(HsClassDecl _ _ _ _ _) = ppHsClassDecl summary decl do_decl (HsDocGroup loc lev str) = if summary then Html.emptyTable else ppDocGroup lev (docToHtml str) do_decl _ = error ("do_decl: " ++ 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 _doc) = ppHsDataHeader summary is_newty nm args <+> equals <+> ppShortConstr summary con ppShortDataDecl summary is_newty (HsDataDecl loc ctx nm args cons drv _doc) = vanillaTable << ( declBox (ppHsDataHeader summary is_newty nm args) tda [theclass "body"] << vanillaTable << ( aboves (zipWith do_constr ('=':repeat '|') cons) ) ) where do_constr c con = declBox (toHtml [c] <+> ppShortConstr summary con) -- First, the abstract case: ppHsDataDecl summary is_newty (HsDataDecl loc ctx nm args [] drv doc) = declWithDoc summary doc (ppHsDataHeader summary is_newty nm args) -- The rest of the cases: ppHsDataDecl summary is_newty decl@(HsDataDecl loc ctx nm args cons drv doc) | summary || (isNothing doc && no_constr_docs) = declWithDoc summary doc (ppShortDataDecl summary is_newty decl) | otherwise = td << vanillaTable << ( header tda [theclass "body"] << vanillaTable << ( datadoc constr_hdr (tda [theclass "body"] << table << constrs)) ) where header = declBox (ppHsDataHeader False is_newty nm args) table | any isRecDecl cons = spacedTable5 | otherwise = spacedTable1 datadoc | isJust doc = ndocBox (docToHtml (fromJust doc)) | otherwise = Html.emptyTable constr_hdr = tda [ theclass "section4" ] << toHtml "Constructors" constrs | null cons = Html.emptyTable | otherwise = aboves (map ppSideBySideConstr cons) no_constr_docs = all constr_has_no_doc cons constr_has_no_doc (HsConDecl _ nm _ _ _ doc) = isNothing doc constr_has_no_doc (HsRecDecl _ nm _ _ fields doc) = isNothing doc && all field_has_no_doc fields field_has_no_doc (HsFieldDecl nms _ doc) = isNothing doc isRecDecl (HsRecDecl pos nm tvs ctxt fields maybe_doc) = True isRecDecl _ = False ppShortConstr :: Bool -> HsConDecl -> Html ppShortConstr summary (HsConDecl pos nm tvs ctxt typeList _maybe_doc) = ppHsConstrHdr tvs ctxt +++ hsep (ppHsBinder summary nm : map ppHsBangType typeList) ppShortConstr summary (HsRecDecl pos nm tvs ctxt fields maybe_doc) = ppHsConstrHdr tvs ctxt +++ ppHsBinder summary nm +++ braces (vanillaTable << aboves (map (ppShortField summary) fields)) ppHsConstrHdr tvs ctxt = (if null tvs then noHtml else keyword "forall" <+> hsep (map ppHsName tvs) <+> toHtml ". ") +++ (if null ctxt then noHtml else ppHsContext ctxt <+> toHtml "=> ") ppSideBySideConstr (HsConDecl pos nm tvs ctxt typeList doc) = narrowDeclBox (hsep ((ppHsConstrHdr tvs ctxt +++ ppHsBinder False nm) : map ppHsBangType typeList)) <-> maybeRDocBox doc ppSideBySideConstr (HsRecDecl pos nm tvs ctxt fields doc) = narrowDeclBox (ppHsConstrHdr tvs ctxt +++ ppHsBinder False nm) <-> maybeRDocBox doc (tda [theclass "body"] << spacedTable1 << aboves (map ppSideBySideField fields)) ppSideBySideField (HsFieldDecl ns ty doc) = declBox (hsep (punctuate comma (map (ppHsBinder False) ns)) <+> toHtml "::" <+> ppHsBangType ty) <-> maybeRDocBox doc ppHsFullConstr (HsConDecl pos nm tvs ctxt typeList doc) = declWithDoc False doc ( hsep ((ppHsConstrHdr tvs ctxt +++ ppHsBinder False nm) : map ppHsBangType typeList) ) ppHsFullConstr (HsRecDecl pos nm tvs ctxt fields doc) = td << vanillaTable << ( case doc of Nothing -> aboves [hdr, fields_html] Just doc -> aboves [hdr, constr_doc, fields_html] ) where hdr = declBox (ppHsConstrHdr tvs ctxt +++ ppHsBinder False nm) constr_doc | isJust doc = docBox (docToHtml (fromJust doc)) | otherwise = Html.emptyTable fields_html = td << table ! [width "100%", cellpadding 0, cellspacing 8] << ( aboves (map ppFullField (concat (map expandField fields))) ) ppShortField summary (HsFieldDecl ns ty _doc) = tda [theclass "recfield"] << ( hsep (punctuate comma (map (ppHsBinder summary) ns)) <+> toHtml "::" <+> ppHsBangType ty ) ppFullField (HsFieldDecl [n] ty doc) = declWithDoc False doc ( 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 summary decl@(HsClassDecl loc ty fds decls doc) = if null decls then declBox hdr else td << ( vanillaTable << ( declBox (hdr <+> keyword "where") tda [theclass "body"] << ( vanillaTable << ( aboves (map (doDecl summary) (filter keepDecl decls)) )) )) where Just c = declMainBinder decl hdr | not summary = linkTarget c +++ ppClassHdr ty fds | otherwise = ppClassHdr ty fds ppHsClassDecl summary decl@(HsClassDecl loc ty fds decls doc) | summary || (isNothing doc && all decl_has_no_doc kept_decls) = ppShortClassDecl summary decl | otherwise = td << vanillaTable << (header classdoc body) where 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 (docToHtml 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 False) kept_decls) ) kept_decls = filter keepDecl decls decl_has_no_doc decl = isNothing (declDoc decl) -- ----------------------------------------------------------------------------- -- Type signatures ppFunSig summary nm ty doc | summary || no_arg_docs ty = declWithDoc summary doc (ppTypeSig summary nm ty) | otherwise = td << vanillaTable << ( declBox (ppHsBinder False nm) (tda [theclass "body"] << vanillaTable << ( (if (isJust doc) then ndocBox (docToHtml (fromJust doc)) else Html.emptyTable) do_args True ty )) ) where no_arg_docs (HsForAllType _ _ ty) = no_arg_docs ty no_arg_docs (HsTyFun (HsTyDoc _ _) _) = False no_arg_docs (HsTyFun _ r) = no_arg_docs r no_arg_docs (HsTyDoc _ _) = False no_arg_docs _ = True do_args :: Bool -> HsType -> HtmlTable do_args first (HsForAllType maybe_tvs ctxt ty) = narrowDeclBox (leader first <+> ppHsForAll maybe_tvs ctxt) do_args False ty do_args first (HsTyFun (HsTyDoc ty doc) r) = (narrowDeclBox (leader first <+> ppHsBType ty) <-> rdocBox (docToHtml doc)) do_args False r do_args first (HsTyFun ty r) = (narrowDeclBox (leader first <+> ppHsBType ty) <-> rdocBox noHtml) do_args False r do_args first (HsTyDoc ty doc) = (narrowDeclBox (leader first <+> ppHsBType ty) <-> rdocBox (docToHtml doc)) do_args first ty = declBox (leader first <+> ppHsBType ty) <-> rdocBox (noHtml) leader True = toHtml "::" leader False = toHtml "->" -- ----------------------------------------------------------------------------- -- Types and contexts ppHsContext :: HsContext -> Html ppHsContext [] = empty ppHsContext context = parenList (map (\ (a,b) -> ppHsQName a <+> hsep (map ppHsAType b)) context) ppHsForAll Nothing context = hsep [ ppHsContext context, toHtml "=>" ] ppHsForAll (Just tvs) [] = hsep (keyword "forall" : map ppHsName tvs ++ [toHtml "."]) ppHsForAll (Just tvs) context = hsep (keyword "forall" : map ppHsName tvs ++ [toHtml ".", ppHsContext context, toHtml "=>"]) ppHsType :: HsType -> Html ppHsType (HsForAllType maybe_tvs context htype) = ppHsForAll maybe_tvs context <+> ppHsType htype ppHsType (HsTyFun a b) = hsep [ppHsBType a, toHtml "->", ppHsType b] ppHsType (HsTyDoc ty doc) = ppHsBType ty 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 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 (HsTyApp (HsTyCon (Qual (Module "Prelude") (HsTyClsName (HsSpecial "[]")))) b ) = brackets $ ppHsType b ppHsAType t = parens $ ppHsType t -- ----------------------------------------------------------------------------- -- Names linkTarget :: HsName -> Html linkTarget nm = anchor ! [name (hsNameStr nm)] << toHtml "" 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 . head, 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 } -- If the doc is a single paragraph, don't surround it with

(this causes -- ugly extra whitespace with some browsers). docToHtml (DocParagraph p) = docToHtml p docToHtml doc = markup htmlMarkup doc -- ----------------------------------------------------------------------------- -- * 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 = noHtml 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" -- a box for displaying code declBox :: Html -> HtmlTable declBox html = tda [theclass "decl"] << html -- a horrible hack to keep a box from expanding width-wise narrowDeclBox :: Html -> HtmlTable narrowDeclBox html = tda [theclass "decl", width "1"] << html -- a box for displaying documentation, -- indented and with a little padding at the top docBox :: Html -> HtmlTable docBox html = tda [theclass "doc"] << html -- a box for displaying documentation, not indented. ndocBox :: Html -> HtmlTable ndocBox html = tda [theclass "ndoc"] << html -- a box for displaying documentation, padded on the left a little rdocBox :: Html -> HtmlTable rdocBox html = tda [theclass "rdoc"] << html maybeRDocBox :: Maybe Doc -> HtmlTable maybeRDocBox Nothing = rdocBox (noHtml) maybeRDocBox (Just doc) = rdocBox (docToHtml doc) -- a box for the buttons at the top of the page topButBox html = tda [theclass "topbut"] << html -- a vanilla table has width 100%, no border, no padding, no spacing -- a narrow table is the same but without width 100%. vanillaTable = table ! [theclass "vanilla", cellspacing 0, cellpadding 0] narrowTable = table ! [theclass "narrow", cellspacing 0, cellpadding 0] spacedTable1 = table ! [theclass "vanilla", cellspacing 1, cellpadding 0] spacedTable5 = table ! [theclass "vanilla", cellspacing 5, cellpadding 0]