diff options
Diffstat (limited to 'src/HaddockHtml.hs')
| -rw-r--r-- | src/HaddockHtml.hs | 359 |
1 files changed, 209 insertions, 150 deletions
diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs index bfe19114..cdca7672 100644 --- a/src/HaddockHtml.hs +++ b/src/HaddockHtml.hs @@ -4,7 +4,7 @@ -- (c) Simon Marlow 2002 -- -module HaddockHtml (ppHtml) where +module HaddockHtml ( ppHtml ) where import Prelude hiding (div) import HaddockVersion @@ -21,16 +21,13 @@ import List ( sortBy ) import Char ( toUpper, toLower ) import Monad ( when ) -#ifdef __GLASGOW_HASKELL__ -import IOExts -#endif - import Html import qualified Html -- ----------------------------------------------------------------------------- -- Files we need to copy from our $libdir +cssFile, iconFile :: String cssFile = "haddock.css" iconFile = "haskell_icon.gif" @@ -52,8 +49,7 @@ ppHtml :: String -> Bool -- do MS Help stuff -> IO () -ppHtml title source_url ifaces odir maybe_css libdir inst_maps prologue - do_ms_help = do +ppHtml doctitle source_url ifaces odir maybe_css libdir inst_maps prologue do_ms_help = do let css_file = case maybe_css of Nothing -> libdir ++ pathSeparator:cssFile @@ -64,28 +60,31 @@ ppHtml title source_url ifaces odir maybe_css libdir inst_maps prologue icon_destination = odir ++ pathSeparator:iconFile visible_ifaces = filter visible ifaces - visible (m,i) = OptHide `notElem` iface_options i + visible (_, 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) prologue - ppHtmlIndex odir title visible_ifaces + ppHtmlContents odir doctitle source_url (map fst visible_ifaces) prologue + ppHtmlIndex odir doctitle visible_ifaces -- Generate index and contents page for MS help if requested when do_ms_help $ do ppHHContents odir (map fst visible_ifaces) ppHHIndex odir visible_ifaces - mapM_ (ppHtmlModule odir title source_url inst_maps) visible_ifaces - + mapM_ (ppHtmlModule odir doctitle source_url inst_maps) visible_ifaces +contentsHtmlFile, indexHtmlFile :: String contentsHtmlFile = "index.html" indexHtmlFile = "doc-index.html" + +subIndexHtmlFile :: Char -> Char -> String subIndexHtmlFile k a = "doc-index-" ++ k:a:".html" +footer :: HtmlTable footer = tda [theclass "botbar"] << ( toHtml "Produced by" <+> @@ -94,7 +93,8 @@ footer = ) -src_button source_url mod file +src_button :: Maybe String -> String -> String -> HtmlTable +src_button source_url _ file | Just u <- source_url = let src_url = if (last u == '/') then u ++ file else u ++ '/':file in @@ -102,50 +102,55 @@ src_button source_url mod file | otherwise = Html.emptyTable - -parent_button mod = - case span (/= '.') (reverse mod) of - (m, '.':rest) -> +parent_button :: String -> HtmlTable +parent_button mdl = + case span (/= '.') (reverse mdl) of + (_, '.':rest) -> topButBox ( anchor ! [href (moduleHtmlFile "" (reverse rest))] << toHtml "Parent") _ -> Html.emptyTable +contentsButton :: HtmlTable contentsButton = topButBox (anchor ! [href contentsHtmlFile] << toHtml "Contents") +indexButton :: HtmlTable indexButton = topButBox (anchor ! [href indexHtmlFile] << toHtml "Index") -simpleHeader title = +simpleHeader :: String -> HtmlTable +simpleHeader doctitle = (tda [theclass "topbar"] << vanillaTable << ( (td << image ! [src "haskell_icon.gif", width "16", height 16, alt " " ] ) <-> - (tda [theclass "title"] << toHtml title) <-> + (tda [theclass "title"] << toHtml doctitle) <-> contentsButton <-> indexButton )) -pageHeader mod iface title source_url = +pageHeader :: String -> Interface -> String -> Maybe String -> HtmlTable +pageHeader mdl iface doctitle 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 <-> + (tda [theclass "title"] << toHtml doctitle) <-> + src_button source_url mdl (iface_filename iface) <-> + parent_button mdl <-> contentsButton <-> indexButton ) ) </> tda [theclass "modulebar"] << (vanillaTable << ( - (td << font ! [size "6"] << toHtml mod) <-> + (td << font ! [size "6"] << toHtml mdl) <-> moduleInfo iface ) ) +moduleInfo :: Interface -> HtmlTable moduleInfo iface = case iface_info iface of Nothing -> Html.emptyTable @@ -164,16 +169,16 @@ moduleInfo iface = ppHtmlContents :: FilePath -> String -> Maybe String -> [Module] -> Maybe Doc -> IO () -ppHtmlContents odir title source_url mods prologue = do - let tree = mkModuleTree mods +ppHtmlContents odir doctitle _ mdls prologue = do + let tree = mkModuleTree mdls html = - header (thetitle (toHtml title) +++ + header (thetitle (toHtml doctitle) +++ thelink ! [href cssFile, rel "stylesheet", thetype "text/css"]) +++ body << vanillaTable << ( - simpleHeader title </> + simpleHeader doctitle </> ppPrologue prologue </> - ppModuleTree title tree </> + ppModuleTree doctitle tree </> s15 </> footer ) @@ -186,7 +191,7 @@ ppPrologue (Just doc) = docBox (docToHtml doc) ppModuleTree :: String -> [ModuleTree] -> HtmlTable -ppModuleTree title ts = +ppModuleTree _ ts = tda [theclass "section1"] << toHtml "Modules" </> td << table ! [cellpadding 0, cellspacing 2] << aboves (map (mkNode []) ts) @@ -199,9 +204,10 @@ mkNode ss (Node s leaf ts) = (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') +mkLeaf :: String -> [String] -> Bool -> Html +mkLeaf s _ False = toHtml s +mkLeaf s ss True = anchor ! [href (moduleHtmlFile "" mdl)] << toHtml s + where mdl = foldr (++) "" (s' : map ('.':) ss') (s':ss') = reverse (s:ss) -- reconstruct the module name @@ -209,13 +215,13 @@ mkLeaf s ss True = anchor ! [href (moduleHtmlFile "" mod)] << toHtml s -- Generate the index ppHtmlIndex :: FilePath -> String -> [(Module,Interface)] -> IO () -ppHtmlIndex odir title ifaces = do +ppHtmlIndex odir doctitle ifaces = do let html = - header (thetitle (toHtml (title ++ " (Index)")) +++ + header (thetitle (toHtml (doctitle ++ " (Index)")) +++ thelink ! [href cssFile, rel "stylesheet", thetype "text/css"]) +++ body << vanillaTable << ( - simpleHeader title </> + simpleHeader doctitle </> tda [theclass "section1"] << toHtml "Type/Class Index" </> index_html tycls_index 't' </> tda [theclass "section1"] << toHtml "Function/Constructor Index" </> @@ -246,11 +252,11 @@ ppHtmlIndex odir title ifaces = do = writeFile (odir ++ pathSeparator:subIndexHtmlFile kind c) (renderHtml html) where - html = header (thetitle (toHtml (title ++ " (" ++ descr ++ "Index)")) +++ + html = header (thetitle (toHtml (doctitle ++ " (" ++ descr ++ "Index)")) +++ thelink ! [href cssFile, rel "stylesheet", thetype "text/css"]) +++ body << vanillaTable << ( - simpleHeader title </> + simpleHeader doctitle </> tda [theclass "section1"] << toHtml (descr ++ " Index (" ++ c:")") </> td << table ! [cellpadding 0, cellspacing 5] << @@ -272,24 +278,25 @@ ppHtmlIndex odir title ifaces = do iface_indices f = map (getIfaceIndex f) ifaces full_index f = foldr (plusFM_C (++)) emptyFM (iface_indices f) - getIfaceIndex f (mod,iface) = listToFM - [ (name, [(mod, mod == mod')]) - | (name, Qual mod' _) <- fmToList (iface_env iface), - f name ] + getIfaceIndex f (mdl,iface) = listToFM + [ (nm, [(mdl, mdl == mdl')]) + | (nm, Qual mdl' _) <- fmToList (iface_env iface), f nm ] indexElt :: (HsName, [(Module,Bool)]) -> HtmlTable indexElt (nm, entries) = td << ppHsName nm <-> td << (hsep [ if defining then - bold << anchor ! [href (linkId (Module mod) nm)] - << toHtml mod + bold << anchor ! [href (linkId (Module mdl) nm)] + << toHtml mdl else - anchor ! [href (linkId (Module mod) nm)] << toHtml mod - | (Module mod, defining) <- entries ]) + anchor ! [href (linkId (Module mdl) nm)] << toHtml mdl + | (Module mdl, defining) <- entries ]) -nameBeginsWith (HsTyClsName id) c = idBeginsWith id c -nameBeginsWith (HsVarName id) c = idBeginsWith id c +nameBeginsWith :: HsName -> Char -> Bool +nameBeginsWith (HsTyClsName id0) c = idBeginsWith id0 c +nameBeginsWith (HsVarName id0) c = idBeginsWith id0 c +idBeginsWith :: HsIdentifier -> Char -> Bool 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] @@ -299,21 +306,21 @@ idBeginsWith (HsSpecial s) c = head s `elem` [toLower c, toUpper c] ppHtmlModule :: FilePath -> String -> Maybe String -> InstMaps -> (Module,Interface) -> IO () -ppHtmlModule odir title source_url inst_maps (Module mod,iface) = do +ppHtmlModule odir doctitle source_url inst_maps (Module mdl,iface) = do let html = - header (thetitle (toHtml mod) +++ + header (thetitle (toHtml mdl) +++ thelink ! [href cssFile, rel "stylesheet", thetype "text/css"]) +++ body << vanillaTable << ( - pageHeader mod iface title source_url </> s15 </> - ifaceToHtml mod iface inst_maps </> s15 </> + pageHeader mdl iface doctitle source_url </> s15 </> + ifaceToHtml mdl iface inst_maps </> s15 </> footer ) - writeFile (moduleHtmlFile odir mod) (renderHtml html) + writeFile (moduleHtmlFile odir mdl) (renderHtml html) ifaceToHtml :: String -> Interface -> InstMaps -> HtmlTable -ifaceToHtml mod iface inst_maps - = abovesSep s15 (contents: description: synopsis: maybe_doc_hdr: body) +ifaceToHtml _ iface inst_maps + = abovesSep s15 (contents: description: synopsis: maybe_doc_hdr: bdy) where exports = numberSectionHeadings (iface_exports iface) @@ -353,7 +360,7 @@ ifaceToHtml mod iface inst_maps _ -> tda [ theclass "section1" ] << toHtml "Documentation" | otherwise = Html.emptyTable - body = map (processExport False inst_maps) exports + bdy = map (processExport False inst_maps) exports ppModuleContents :: [ExportItem] -> HtmlTable ppModuleContents exports @@ -364,15 +371,15 @@ ppModuleContents exports (sections, _leftovers{-should be []-}) = process 0 exports process :: Int -> [ExportItem] -> ([Html],[ExportItem]) - process n [] = ([], []) - process n items@(ExportGroup lev id doc : rest) + process _ [] = ([], []) + process n items@(ExportGroup lev id0 doc : rest) | lev <= n = ( [], items ) - | otherwise = ( html:sections, rest2 ) + | otherwise = ( html:secs, rest2 ) where - html = (dterm << anchor ! [href ('#':id)] << docToHtml doc) - +++ mk_subsections subsections - (subsections, rest1) = process lev rest - (sections, rest2) = process n rest1 + html = (dterm << anchor ! [href ('#':id0)] << docToHtml doc) + +++ mk_subsections ssecs + (ssecs, rest1) = process lev rest + (secs, rest2) = process n rest1 process n (_ : rest) = process n rest mk_subsections [] = noHtml @@ -382,26 +389,29 @@ ppModuleContents exports -- them from the contents: numberSectionHeadings :: [ExportItem] -> [ExportItem] numberSectionHeadings exports = go 1 exports - where go n [] = [] + where go :: Int -> [ExportItem] -> [ExportItem] + go _ [] = [] 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 -> InstMaps -> ExportItem -> HtmlTable -processExport summary inst_maps (ExportGroup lev id doc) - = ppDocGroup lev (anchor ! [name id] << docToHtml doc) +processExport _ _ (ExportGroup lev id0 doc) + = ppDocGroup lev (anchor ! [name id0] << docToHtml doc) processExport summary inst_maps (ExportDecl x decl) = doDecl summary inst_maps x decl -processExport summary inst_maps (ExportDoc doc) +processExport _ _ (ExportDoc doc) = docBox (docToHtml doc) -processExport summary inst_maps (ExportModule (Module mod)) - = declBox (toHtml "module" <+> ppHsModule mod) +processExport _ _ (ExportModule (Module mdl)) + = declBox (toHtml "module" <+> ppHsModule mdl) +forSummary :: ExportItem -> Bool forSummary (ExportGroup _ _ _) = False -forSummary (ExportDoc _) = False -forSummary _ = True +forSummary (ExportDoc _) = False +forSummary _ = True +ppDocGroup :: Int -> Html -> HtmlTable ppDocGroup lev doc | lev == 1 = tda [ theclass "section1" ] << doc | lev == 2 = tda [ theclass "section2" ] << doc @@ -412,13 +422,13 @@ ppDocGroup lev doc -- Converting declarations to HTML declWithDoc :: Bool -> Maybe Doc -> Html -> HtmlTable -declWithDoc True doc html_decl = declBox html_decl +declWithDoc True _ html_decl = declBox html_decl declWithDoc False Nothing html_decl = declBox html_decl declWithDoc False (Just doc) html_decl = declBox html_decl </> docBox (docToHtml doc) doDecl :: Bool -> InstMaps -> HsQName -> HsDecl -> HtmlTable -doDecl summary inst_maps x decl = do_decl decl +doDecl summary inst_maps x d = do_decl d where do_decl (HsTypeSig _ [nm] ty doc) = ppFunSig summary nm ty doc @@ -436,19 +446,20 @@ doDecl summary inst_maps x decl = do_decl decl (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 inst_maps False{-not newtype-} x decl + do_decl d0@(HsDataDecl{}) + = ppHsDataDecl summary inst_maps False{-not newtype-} x d0 - do_decl decl@(HsClassDecl{}) - = ppHsClassDecl summary inst_maps x decl + do_decl d0@(HsClassDecl{}) + = ppHsClassDecl summary inst_maps x d0 - do_decl (HsDocGroup loc lev str) + do_decl (HsDocGroup _ lev str) = if summary then Html.emptyTable else ppDocGroup lev (docToHtml str) - do_decl _ = error ("do_decl: " ++ show decl) + do_decl _ = error ("do_decl: " ++ show d) +ppTypeSig :: Bool -> HsName -> HsType -> Html ppTypeSig summary nm ty = ppHsBinder summary nm <+> toHtml "::" <+> ppHsType ty -- ----------------------------------------------------------------------------- @@ -456,11 +467,11 @@ ppTypeSig summary nm ty = ppHsBinder summary nm <+> toHtml "::" <+> ppHsType ty ppShortDataDecl :: Bool -> Bool -> HsDecl -> Html ppShortDataDecl summary is_newty - (HsDataDecl loc ctx nm args [con] drv _doc) = + (HsDataDecl _ _ nm args [con] _ _doc) = ppHsDataHeader summary is_newty nm args <+> equals <+> ppShortConstr summary con ppShortDataDecl summary is_newty - (HsDataDecl loc ctx nm args cons drv _doc) = + (HsDataDecl _ _ nm args cons _ _doc) = vanillaTable << ( declBox (ppHsDataHeader summary is_newty nm args) </> tda [theclass "body"] << vanillaTable << ( @@ -468,22 +479,25 @@ ppShortDataDecl summary is_newty ) ) where do_constr c con = declBox (toHtml [c] <+> ppShortConstr summary con) +ppShortDataDecl _ _ d = + error $ "HaddockHtml.ppShortDataDecl: unexpected decl " ++ show d -- The rest of the cases: - +ppHsDataDecl :: Ord key => Bool -> (a, FiniteMap key [InstHead]) + -> Bool -> key -> HsDecl -> HtmlTable ppHsDataDecl summary (_, ty_inst_map) is_newty - x decl@(HsDataDecl loc ctx nm args cons drv doc) + x decl@(HsDataDecl _ _ nm args cons _ doc) | summary = declWithDoc summary doc (ppShortDataDecl summary is_newty decl) | otherwise - = header </> + = dataheader </> tda [theclass "body"] << vanillaTable << ( datadoc </> constr_bit </> instances_bit ) where - header = declBox (ppHsDataHeader False is_newty nm args) + dataheader = declBox (ppHsDataHeader False is_newty nm args) constr_table | any isRecDecl cons = spacedTable5 @@ -511,19 +525,23 @@ ppHsDataDecl summary (_, ty_inst_map) is_newty tda [theclass "body"] << spacedTable1 << ( aboves (map (declBox.ppInstHead) is) ) +ppHsDataDecl _ _ _ _ d = + error $ "HaddockHtml.ppHsDataDecl: unexpected decl " ++ show d -isRecDecl (HsRecDecl pos nm tvs ctxt fields maybe_doc) = True -isRecDecl _ = False +isRecDecl :: HsConDecl -> Bool +isRecDecl (HsRecDecl{}) = True +isRecDecl _ = False ppShortConstr :: Bool -> HsConDecl -> Html -ppShortConstr summary (HsConDecl pos nm tvs ctxt typeList _maybe_doc) = +ppShortConstr summary (HsConDecl _ 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) = +ppShortConstr summary (HsRecDecl _ nm tvs ctxt fields _) = ppHsConstrHdr tvs ctxt +++ ppHsBinder summary nm <+> braces (vanillaTable << aboves (map (ppShortField summary) fields)) +ppHsConstrHdr :: [HsName] -> HsContext -> Html ppHsConstrHdr tvs ctxt = (if null tvs then noHtml else keyword "forall" <+> hsep (map ppHsName tvs) <+> @@ -531,31 +549,35 @@ ppHsConstrHdr tvs ctxt +++ (if null ctxt then noHtml else ppHsContext ctxt <+> toHtml "=> ") -ppSideBySideConstr (HsConDecl pos nm tvs ctxt typeList doc) = +ppSideBySideConstr :: HsConDecl -> HtmlTable +ppSideBySideConstr (HsConDecl _ nm tvs ctxt typeList doc) = declBox (hsep ((ppHsConstrHdr tvs ctxt +++ ppHsBinder False nm) : map ppHsBangType typeList)) <-> maybeRDocBox doc -ppSideBySideConstr (HsRecDecl pos nm tvs ctxt fields doc) = +ppSideBySideConstr (HsRecDecl _ nm tvs ctxt fields doc) = declBox (ppHsConstrHdr tvs ctxt +++ ppHsBinder False nm) <-> maybeRDocBox doc </> (tda [theclass "body"] << spacedTable1 << aboves (map ppSideBySideField fields)) +ppSideBySideField :: HsFieldDecl -> HtmlTable 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) = +{- +ppHsFullConstr :: HsConDecl -> Html +ppHsFullConstr (HsConDecl _ 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) = +ppHsFullConstr (HsRecDecl _ nm tvs ctxt fields doc) = td << vanillaTable << ( case doc of - Nothing -> aboves [hdr, fields_html] - Just doc -> aboves [hdr, constr_doc, fields_html] + Nothing -> aboves [hdr, fields_html] + Just _ -> aboves [hdr, constr_doc, fields_html] ) where hdr = declBox (ppHsConstrHdr tvs ctxt +++ ppHsBinder False nm) @@ -569,22 +591,28 @@ ppHsFullConstr (HsRecDecl pos nm tvs ctxt fields doc) = table ! [width "100%", cellpadding 0, cellspacing 8] << ( aboves (map ppFullField (concat (map expandField fields))) ) +-} - +ppShortField :: Bool -> HsFieldDecl -> HtmlTable ppShortField summary (HsFieldDecl ns ty _doc) = tda [theclass "recfield"] << ( hsep (punctuate comma (map (ppHsBinder summary) ns)) <+> toHtml "::" <+> ppHsBangType ty ) +{- +ppFullField :: HsFieldDecl -> Html ppFullField (HsFieldDecl [n] ty doc) = declWithDoc False doc ( ppHsBinder False n <+> toHtml "::" <+> ppHsBangType ty ) ppFullField _ = error "ppFullField" +expandField :: HsFieldDecl -> [HsFieldDecl] expandField (HsFieldDecl ns ty doc) = [ HsFieldDecl [n] ty doc | n <- ns ] +-} +ppHsDataHeader :: Bool -> Bool -> HsName -> [HsName] -> Html ppHsDataHeader summary is_newty nm args = (if is_newty then keyword "newtype" else keyword "data") <+> ppHsBinder summary nm <+> hsep (map ppHsName args) @@ -596,6 +624,7 @@ ppHsBangType (HsUnBangedTy ty) = ppHsAType ty -- ----------------------------------------------------------------------------- -- Class declarations +ppClassHdr :: Bool -> HsContext -> HsName -> [HsName] -> [HsFunDep] -> Html ppClassHdr summ [] n tvs fds = keyword "class" <+> ppHsBinder summ n <+> hsep (map ppHsName tvs) @@ -605,6 +634,7 @@ ppClassHdr summ ctxt n tvs fds = <+> ppHsBinder summ n <+> hsep (map ppHsName tvs) <+> ppFds fds +ppFds :: [HsFunDep] -> Html ppFds fds = if null fds then noHtml else char '|' <+> hsep (punctuate comma (map fundep fds)) @@ -612,8 +642,9 @@ ppFds fds = fundep (vars1,vars2) = hsep (map ppHsName vars1) <+> toHtml "->" <+> hsep (map ppHsName vars2) -ppShortClassDecl summary inst_maps - decl@(HsClassDecl loc ctxt nm tvs fds decls doc) = +ppShortClassDecl :: Bool -> a -> HsDecl -> HtmlTable +ppShortClassDecl summary _ + (HsClassDecl _ ctxt nm tvs fds decls _) = if null decls then declBox hdr else declBox (hdr <+> keyword "where") @@ -627,19 +658,23 @@ ppShortClassDecl summary inst_maps where hdr = ppClassHdr summary ctxt nm tvs fds +ppShortClassDecl _ _ d = + error $ "HaddockHtml.ppShortClassDecl: unexpected decl: " ++ show d +ppHsClassDecl :: Ord key => Bool -> (FiniteMap key [InstHead], t_a4nrR) + -> key -> HsDecl -> HtmlTable ppHsClassDecl summary inst_maps@(cls_inst_map, _) orig_c - decl@(HsClassDecl loc ctxt nm tvs fds decls doc) + decl@(HsClassDecl _ ctxt nm tvs fds decls doc) | summary = ppShortClassDecl summary inst_maps decl | otherwise - = header </> + = classheader </> tda [theclass "body"] << vanillaTable << ( classdoc </> methods_bit </> instances_bit ) where - header + classheader | null decls = declBox hdr | otherwise = declBox (hdr <+> keyword "where") @@ -654,8 +689,8 @@ ppHsClassDecl summary inst_maps@(cls_inst_map, _) orig_c | otherwise = s8 </> meth_hdr </> tda [theclass "body"] << vanillaTable << ( - abovesSep s8 [ ppFunSig summary n ty doc - | HsTypeSig _ [n] ty doc <- decls + abovesSep s8 [ ppFunSig summary n ty doc0 + | HsTypeSig _ [n] ty doc0 <- decls ] ) @@ -670,6 +705,8 @@ ppHsClassDecl summary inst_maps@(cls_inst_map, _) orig_c ) instances = lookupFM cls_inst_map orig_c +ppHsClassDecl _ _ _ d = + error $ "HaddockHtml.ppHsClassDecl: unexpected decl: " ++ show d ppInstHead :: InstHead -> Html @@ -679,14 +716,15 @@ ppInstHead (ctxt,asst) = ppHsContext ctxt <+> darrow <+> ppHsAsst asst -- ---------------------------------------------------------------------------- -- Type signatures -ppFunSig summary nm ty doc - | summary || no_arg_docs ty = - declWithDoc summary doc (ppTypeSig summary nm ty) +ppFunSig :: Bool -> HsName -> HsType -> Maybe Doc -> HtmlTable +ppFunSig summary nm ty0 doc + | summary || no_arg_docs ty0 = + declWithDoc summary doc (ppTypeSig summary nm ty0) | otherwise = declBox (ppHsBinder False nm) </> (tda [theclass "body"] << vanillaTable << ( - do_args dcolon ty </> + do_args dcolon ty0 </> (if (isJust doc) then ndocBox (docToHtml (fromJust doc)) else Html.emptyTable) @@ -710,18 +748,18 @@ ppFunSig summary nm ty doc = (declBox (leader <+> ppHsContext ctxt) <-> rdocBox noHtml) </> do_args darrow ty - do_args leader (HsTyFun (HsTyDoc ty doc) r) - = (declBox (leader <+> ppHsBType ty) <-> rdocBox (docToHtml doc)) </> - do_args arrow r + do_args leader (HsTyFun (HsTyDoc ty doc0) r) + = (declBox (leader <+> ppHsBType ty) <-> rdocBox (docToHtml doc0)) + </> do_args arrow r do_args leader (HsTyFun ty r) = (declBox (leader <+> ppHsBType ty) <-> rdocBox noHtml) </> do_args arrow r - do_args leader (HsTyDoc ty doc) - = (declBox (leader <+> ppHsBType ty) <-> rdocBox (docToHtml doc)) + do_args leader (HsTyDoc ty doc0) + = (declBox (leader <+> ppHsBType ty) <-> rdocBox (docToHtml doc0)) do_args leader ty = declBox (leader <+> ppHsBType ty) <-> rdocBox (noHtml) --- ----------------------------------------------------------------------------- +-- ---------------------------------------------------------------------------- -- Types and contexts ppHsAsst :: (HsQName,[HsType]) -> Html @@ -731,6 +769,7 @@ ppHsContext :: HsContext -> Html ppHsContext [] = empty ppHsContext context = parenList (map ppHsAsst context) +ppHsForAll :: Maybe [HsName] -> HsContext -> Html ppHsForAll Nothing context = hsep [ ppHsContext context, darrow ] ppHsForAll (Just tvs) [] = @@ -745,7 +784,8 @@ ppHsType (HsForAllType maybe_tvs context htype) = ppHsType (HsTyFun a b) = hsep [ppHsBType a, toHtml "->", ppHsType b] ppHsType t = ppHsBType t -ppHsBType (HsTyDoc ty doc) = ppHsBType ty +ppHsBType :: HsType -> Html +ppHsBType (HsTyDoc ty _) = ppHsBType ty ppHsBType (HsTyApp (HsTyCon (Qual _ (HsTyClsName (HsSpecial "[]")))) b ) = brackets $ ppHsType b ppHsBType (HsTyApp a b) = ppHsBType a <+> ppHsAType b @@ -754,15 +794,15 @@ 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) - | name == fun_tycon_qname = parens $ ppHsQName name - | otherwise = ppHsQName name +ppHsAType (HsTyVar nm) = ppHsName nm +ppHsAType (HsTyCon nm) + | nm == fun_tycon_qname = parens $ ppHsQName nm + | otherwise = ppHsQName nm ppHsAType (HsTyApp (HsTyCon (Qual _ (HsTyClsName (HsSpecial "[]")))) b ) = brackets $ ppHsType b ppHsAType t = parens $ ppHsType t --- ----------------------------------------------------------------------------- +-- ---------------------------------------------------------------------------- -- Names linkTarget :: HsName -> Html @@ -770,21 +810,22 @@ linkTarget nm = anchor ! [name (hsNameStr nm)] << toHtml "" ppHsQName :: HsQName -> Html ppHsQName (UnQual str) = ppHsName str -ppHsQName n@(Qual mod str) +ppHsQName n@(Qual mdl str) | n == unit_con_name = ppHsName str | isSpecial str = ppHsName str - | otherwise = anchor ! [href (linkId mod str)] << ppHsName str + | otherwise = anchor ! [href (linkId mdl str)] << ppHsName str -isSpecial (HsTyClsName id) | HsSpecial _ <- id = True -isSpecial (HsVarName id) | HsSpecial _ <- id = True -isSpecial _ = False +isSpecial :: HsName -> Bool +isSpecial (HsTyClsName id0) | HsSpecial _ <- id0 = True +isSpecial (HsVarName id0) | HsSpecial _ <- id0 = True +isSpecial _ = False ppHsName :: HsName -> Html ppHsName nm = toHtml (hsNameStr nm) hsNameStr :: HsName -> String -hsNameStr (HsTyClsName id) = ppHsIdentifier id -hsNameStr (HsVarName id) = ppHsIdentifier id +hsNameStr (HsTyClsName id0) = ppHsIdentifier id0 +hsNameStr (HsVarName id0) = ppHsIdentifier id0 ppHsIdentifier :: HsIdentifier -> String ppHsIdentifier (HsIdent str) = str @@ -795,8 +836,9 @@ ppHsBinder :: Bool -> HsName -> Html ppHsBinder True nm = anchor ! [href ('#':hsNameStr nm)] << ppHsBinder' nm ppHsBinder False nm = linkTarget nm +++ bold << ppHsBinder' nm -ppHsBinder' (HsTyClsName id) = ppHsBindIdent id -ppHsBinder' (HsVarName id) = ppHsBindIdent id +ppHsBinder' :: HsName -> Html +ppHsBinder' (HsTyClsName id0) = ppHsBindIdent id0 +ppHsBinder' (HsVarName id0) = ppHsBindIdent id0 ppHsBindIdent :: HsIdentifier -> Html ppHsBindIdent (HsIdent str) = toHtml str @@ -804,20 +846,20 @@ ppHsBindIdent (HsSymbol str) = parens (toHtml str) ppHsBindIdent (HsSpecial str) = toHtml str linkId :: Module -> HsName -> String -linkId (Module mod) str = moduleHtmlFile fp mod ++ '#': hsNameStr str - where fp = case lookupFM html_xrefs (Module mod) of - Just fp -> fp - Nothing -> "" +linkId (Module mdl) str = moduleHtmlFile fp mdl ++ '#': hsNameStr str + where fp = case lookupFM html_xrefs (Module mdl) of + Just fp0 -> fp0 + Nothing -> "" ppHsModule :: String -> Html -ppHsModule mod = anchor ! [href (moduleHtmlFile fp mod)] << toHtml mod - where fp = case lookupFM html_xrefs (Module mod) of - Just fp -> fp - Nothing -> "" +ppHsModule mdl = anchor ! [href (moduleHtmlFile fp mdl)] << toHtml mdl + where fp = case lookupFM html_xrefs (Module mdl) of + Just fp0 -> fp0 + Nothing -> "" -- ----------------------------------------------------------------------------- -- * Doc Markup - +htmlMarkup :: DocMarkup [HsQName] Html htmlMarkup = Markup { markupParagraph = paragraph, markupEmpty = toHtml "", @@ -835,9 +877,10 @@ htmlMarkup = Markup { -- If the doc is a single paragraph, don't surround it with <P> (this causes -- ugly extra whitespace with some browsers). -docToHtml (DocParagraph p) = docToHtml p -docToHtml (DocCodeBlock p) = docToHtml (DocMonospaced p) -docToHtml doc = markup htmlMarkup doc +docToHtml :: Doc -> Html +docToHtml (DocParagraph d) = docToHtml d +docToHtml (DocCodeBlock d) = docToHtml (DocMonospaced d) +docToHtml doc = markup htmlMarkup doc -- ----------------------------------------------------------------------------- -- * Misc @@ -847,33 +890,40 @@ hsep [] = noHtml hsep htmls = foldr1 (\a b -> a+++" "+++b) htmls infixr 8 <+> +(<+>) :: Html -> Html -> Html a <+> b = Html (getHtmlElements (toHtml a) ++ HtmlString " ": getHtmlElements (toHtml b)) +keyword :: String -> Html keyword s = thespan ! [theclass "keyword"] << toHtml s +equals, comma :: Html equals = char '=' comma = char ',' +char :: Char -> Html char c = toHtml [c] + +empty :: Html empty = noHtml -parens p = char '(' +++ p +++ char ')' -brackets p = char '[' +++ p +++ char ']' -braces p = char '{' +++ p +++ char '}' +parens, brackets, braces :: Html -> Html +parens h = char '(' +++ h +++ char ')' +brackets h = char '[' +++ h +++ char ']' +braces h = char '{' +++ h +++ char '}' punctuate :: Html -> [Html] -> [Html] -punctuate p [] = [] -punctuate p (d:ds) = go d ds +punctuate _ [] = [] +punctuate h (d0:ds) = go d0 ds where go d [] = [d] - go d (e:es) = (d +++ p) : go e es + go d (e:es) = (d +++ h) : go e es abovesSep :: HtmlTable -> [HtmlTable] -> HtmlTable -abovesSep p [] = Html.emptyTable -abovesSep p (d:ds) = go d ds +abovesSep _ [] = Html.emptyTable +abovesSep h (d0:ds) = go d0 ds where go d [] = d - go d (e:es) = d </> p </> go e es + go d (e:es) = d </> h </> go e es parenList :: [Html] -> Html parenList = parens . hsep . punctuate comma @@ -881,9 +931,13 @@ parenList = parens . hsep . punctuate comma ubxParenList :: [Html] -> Html ubxParenList = ubxparens . hsep . punctuate comma -ubxparens p = toHtml "(#" +++ p +++ toHtml "#)" +ubxparens :: Html -> Html +ubxparens h = toHtml "(#" +++ h +++ toHtml "#)" +{- +text :: Html text = strAttr "TEXT" +-} -- a box for displaying code declBox :: Html -> HtmlTable @@ -907,20 +961,25 @@ maybeRDocBox Nothing = rdocBox (noHtml) maybeRDocBox (Just doc) = rdocBox (docToHtml doc) -- a box for the buttons at the top of the page +topButBox :: Html -> HtmlTable 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, narrowTable :: Html -> Html vanillaTable = table ! [theclass "vanilla", cellspacing 0, cellpadding 0] narrowTable = table ! [theclass "narrow", cellspacing 0, cellpadding 0] +spacedTable1, spacedTable5 :: Html -> Html spacedTable1 = table ! [theclass "vanilla", cellspacing 1, cellpadding 0] spacedTable5 = table ! [theclass "vanilla", cellspacing 5, cellpadding 0] +constr_hdr, meth_hdr, inst_hdr :: HtmlTable constr_hdr = tda [ theclass "section4" ] << toHtml "Constructors" meth_hdr = tda [ theclass "section4" ] << toHtml "Methods" inst_hdr = tda [ theclass "section4" ] << toHtml "Instances" +dcolon, arrow, darrow :: Html dcolon = toHtml "::" arrow = toHtml "->" darrow = toHtml "=>" |