diff options
Diffstat (limited to 'src')
-rw-r--r-- | src/Binary.hs | 19 | ||||
-rw-r--r-- | src/HaddockHH.hs | 6 | ||||
-rw-r--r-- | src/HaddockHtml.hs | 53 | ||||
-rw-r--r-- | src/HaddockModuleTree.hs | 32 | ||||
-rw-r--r-- | src/HaddockTypes.hs | 2 | ||||
-rw-r--r-- | src/Main.hs | 39 |
6 files changed, 102 insertions, 49 deletions
diff --git a/src/Binary.hs b/src/Binary.hs index 07180a8a..2703439a 100644 --- a/src/Binary.hs +++ b/src/Binary.hs @@ -474,6 +474,25 @@ instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where d <- get bh return (a,b,c,d) +instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d,e) where + put_ bh (a,b,c,d,e) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e + get bh = do a <- get bh + b <- get bh + c <- get bh + d <- get bh + e <- get bh + return (a,b,c,d,e) + +instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f) => Binary (a,b,c,d,e,f) where + put_ bh (a,b,c,d,e,f) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; put_ bh f + get bh = do a <- get bh + b <- get bh + c <- get bh + d <- get bh + e <- get bh + f <- get bh + return (a,b,c,d,e,f) + instance Binary a => Binary (Maybe a) where put_ bh Nothing = putByte bh 0 put_ bh (Just a) = do putByte bh 1; put_ bh a diff --git a/src/HaddockHH.hs b/src/HaddockHH.hs index 9357c00c..f10c970e 100644 --- a/src/HaddockHH.hs +++ b/src/HaddockHH.hs @@ -20,7 +20,7 @@ indexHHFile = "index.hhk" ppHHContents :: FilePath -> [Module] -> IO () ppHHContents odir mods = do - let tree = mkModuleTree mods + let tree = mkModuleTree (zip mods (repeat Nothing)) --TODO: packages html = text "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">" $$ text "<HTML>" $$ @@ -47,9 +47,9 @@ ppHHContents odir mods = do fn _ [] = error "HaddockHH.ppHHContents.fn: no module trees given" ppNode :: [String] -> ModuleTree -> Doc - ppNode ss (Node s leaf []) = + ppNode ss (Node s leaf _pkg []) = ppLeaf s ss leaf - ppNode ss (Node s leaf ts) = + ppNode ss (Node s leaf _pkg ts) = ppLeaf s ss leaf $$ text "<UL>" $+$ nest 4 (fn (s:ss) ts) $+$ diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs index fd09bfaa..9c3be7b3 100644 --- a/src/HaddockHtml.hs +++ b/src/HaddockHtml.hs @@ -62,7 +62,9 @@ ppHtml doctitle source_url ifaces odir prologue do_ms_help when (not (isJust maybe_contents_url)) $ ppHtmlContents odir doctitle maybe_index_url - (map fst visible_ifaces) prologue + [ (m,iface{iface_package=Nothing}) | (m,iface) <- visible_ifaces ] + -- we don't want to display the packages in a single-package contents + prologue when (not (isJust maybe_index_url)) $ ppHtmlIndex odir doctitle maybe_contents_url visible_ifaces @@ -186,51 +188,62 @@ moduleInfo iface = ppHtmlContents :: FilePath -> String -> Maybe String - -> [Module] -> Maybe Doc + -> [(Module,Interface)] -> Maybe Doc -> IO () ppHtmlContents odir doctitle maybe_index_url mdls prologue = do - let tree = mkModuleTree mdls + let tree = mkModuleTree [(mod,iface_package iface) | (mod,iface) <- mdls] html = header (thetitle (toHtml doctitle) +++ thelink ! [href cssFile, rel "stylesheet", thetype "text/css"]) +++ body << vanillaTable << ( simpleHeader doctitle Nothing maybe_index_url </> - ppPrologue prologue </> + ppPrologue doctitle prologue </> ppModuleTree doctitle tree </> s15 </> footer ) writeFile (odir ++ pathSeparator:contentsHtmlFile) (renderHtml html) -ppPrologue :: Maybe Doc -> HtmlTable -ppPrologue Nothing = Html.emptyTable -ppPrologue (Just doc) = - (tda [theclass "section1"] << toHtml "Description") </> +ppPrologue :: String -> Maybe Doc -> HtmlTable +ppPrologue title Nothing = Html.emptyTable +ppPrologue title (Just doc) = + (tda [theclass "section1"] << toHtml title) </> docBox (docToHtml doc) ppModuleTree :: String -> [ModuleTree] -> HtmlTable ppModuleTree _ 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) + td << table ! [cellpadding 0, cellspacing 2] << + (aboves (map (mkNode 0 []) ts) <-> mkPackages ts) + +mkNode :: Int -> [String] -> ModuleTree -> HtmlTable +mkNode n ss (Node s leaf pkg []) = + mkLeaf n s ss leaf +mkNode n ss (Node s leaf pkg ts) = + mkLeaf n s ss leaf </> - (tda [theclass "children"] << - vanillaTable (toHtml (aboves (map (mkNode (s:ss)) ts)))) + aboves (map (mkNode (n+1) (s:ss)) ts) -mkLeaf :: String -> [String] -> Bool -> Html -mkLeaf s _ False = toHtml s -mkLeaf s ss True = ppHsModule mdl +mkLeaf :: Int -> String -> [String] -> Bool -> HtmlTable +mkLeaf n s _ False = pad_td n << toHtml s +mkLeaf n s ss True = pad_td n << ppHsModule mdl where mdl = foldr (++) "" (s' : map ('.':) ss') (s':ss') = reverse (s:ss) -- reconstruct the module name +pad_td 0 = td +pad_td n = tda [thestyle ("padding-left:" ++ show (n*20) ++ "px")] + +mkPackages :: [ModuleTree] -> HtmlTable +mkPackages ts = aboves (map go ts) + where go (Node s leaf pkg ts) = tda [theclass "pkg"] << mkPkg pkg </> aboves (map go ts) + +mkPkg :: Maybe String -> Html +mkPkg Nothing = empty +mkPkg (Just p) = toHtml p + -- --------------------------------------------------------------------------- -- Generate the index diff --git a/src/HaddockModuleTree.hs b/src/HaddockModuleTree.hs index 93f0f162..f052bd69 100644 --- a/src/HaddockModuleTree.hs +++ b/src/HaddockModuleTree.hs @@ -2,22 +2,28 @@ module HaddockModuleTree(ModuleTree(..), mkModuleTree) where import HsSyn -data ModuleTree = Node String Bool [ModuleTree] +data ModuleTree = Node String Bool (Maybe String) [ModuleTree] -mkModuleTree :: [Module] -> [ModuleTree] -mkModuleTree mods = foldr addToTrees [] (map splitModule mods) +mkModuleTree :: [(Module,Maybe String)] -> [ModuleTree] +mkModuleTree mods = + foldr fn [] [ (splitModule mod, pkg) | (mod,pkg) <- mods ] + where + fn (mod,pkg) trees = addToTrees mod pkg trees -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 +addToTrees :: [String] -> Maybe String -> [ModuleTree] -> [ModuleTree] +addToTrees [] pkg ts = ts +addToTrees ss pkg [] = mkSubTree ss pkg +addToTrees (s1:ss) pkg (t@(Node s2 leaf node_pkg subs) : ts) + | s1 > s2 = t : addToTrees (s1:ss) pkg ts + | s1 == s2 = Node s2 (leaf || null ss) this_pkg (addToTrees ss pkg subs) : ts + | otherwise = mkSubTree (s1:ss) pkg ++ t : ts + where + this_pkg = if null ss then pkg else node_pkg -mkSubTree :: [String] -> [ModuleTree] -mkSubTree [] = [] -mkSubTree (s:ss) = [Node s (null ss) (mkSubTree ss)] +mkSubTree :: [String] -> Maybe String -> [ModuleTree] +mkSubTree [] pkg = [] +mkSubTree [s] pkg = [Node s True pkg []] +mkSubTree (s:ss) pkg = [Node s (null ss) Nothing (mkSubTree ss pkg)] splitModule :: Module -> [String] splitModule (Module mdl) = split mdl diff --git a/src/HaddockTypes.hs b/src/HaddockTypes.hs index 74916099..174b13a2 100644 --- a/src/HaddockTypes.hs +++ b/src/HaddockTypes.hs @@ -30,6 +30,8 @@ data Interface iface_filename :: FilePath, -- ^ the filename that contains the source code for this module + iface_package :: Maybe String, + iface_env :: NameEnv, -- ^ environment mapping names to *original* names diff --git a/src/Main.hs b/src/Main.hs index 3d5f97b4..0fcd44d6 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -69,6 +69,7 @@ data Flag -- | Flag_DocBook | Flag_DumpInterface FilePath | Flag_Heading String + | Flag_Package String | Flag_Html | Flag_Lib String | Flag_MSHtmlHelp @@ -111,6 +112,8 @@ options = "file containing prologue text", Option ['t'] ["title"] (ReqArg Flag_Heading "TITLE") "page heading", + Option ['k'] ["package"] (ReqArg Flag_Package "PACKAGE") + "package name (optional)", Option ['n'] ["no-implicit-prelude"] (NoArg Flag_NoImplicitPrelude) "do not assume Prelude is imported", Option ['d'] ["debug"] (NoArg Flag_Debug) @@ -147,6 +150,10 @@ run flags files = do [] -> "" (t:_) -> t + package = case [str | Flag_Package str <- flags] of + [] -> Nothing + (t:_) -> Just t + source_url = case [str | Flag_SourceURL str <- flags] of [] -> Nothing (t:_) -> Just t @@ -187,24 +194,25 @@ run flags files = do read_ifaces_s <- mapM readIface (map snd ifaces_to_read) + let read_ifaces = concat read_ifaces_s + visible_read_ifaces = filter ((OptHide `notElem`) . iface_options . snd) + read_ifaces + external_mods = map fst read_ifaces + updateHTMLXRefs (map fst ifaces_to_read) read_ifaces_s writeIORef saved_flags flags when (Flag_GenContents `elem` flags) $ do - ppHtmlContents odir title maybe_index_url - (map fst (concat read_ifaces_s)) prologue + ppHtmlContents odir title maybe_index_url visible_read_ifaces prologue copyHtmlBits odir libdir css_file when (Flag_GenIndex `elem` flags) $ do - ppHtmlIndex odir title maybe_contents_url (concat read_ifaces_s) + ppHtmlIndex odir title maybe_contents_url visible_read_ifaces copyHtmlBits odir libdir css_file parsed_mods <- mapM parse_file files - let read_ifaces = concat read_ifaces_s - external_mods = map fst read_ifaces - sorted_mod_files <- sortModules (zip parsed_mods files) -- emits an error message if there are recursive modules @@ -214,7 +222,8 @@ run flags files = do loop ifaces [] = return ifaces loop ifaces ((hsmod,file):mdls) = do let ((mdl,iface),msgs) = runWriter $ - mkInterface no_implicit_prelude verbose ifaces file hsmod + mkInterface no_implicit_prelude verbose ifaces + file package hsmod new_ifaces = addToFM ifaces mdl iface mapM (hPutStrLn stderr) msgs loop new_ifaces mdls @@ -251,7 +260,9 @@ run flags files = do writeBinMem bh fn where prepared_ifaces = - [ (mdl, fmToList (iface_env iface), + [ (mdl, iface_package iface, + OptHide `elem` iface_options iface, + fmToList (iface_env iface), fmToList (iface_reexported iface), fmToList (iface_sub iface)) | (mdl, iface) <- these_mod_ifaces ] @@ -268,9 +279,10 @@ readIface filename = do stuff <- get bh return (map to_interface stuff) where - to_interface (mdl, env, reexported, sub) = + to_interface (mdl, package, hide, env, reexported, sub) = (mdl, Interface { iface_filename = "", + iface_package = package, iface_env = listToFM env, iface_import_env = emptyFM, iface_sub = listToFM sub, @@ -281,7 +293,7 @@ readIface filename = do iface_decls = emptyFM, iface_info = Nothing, iface_doc = Nothing, - iface_options = [] + iface_options = if hide then [OptHide] else [] } ) @@ -290,7 +302,7 @@ updateHTMLXRefs :: [FilePath] -> [[(Module,Interface)]] -> IO () updateHTMLXRefs paths ifaces_s = writeIORef html_xrefs_ref (listToFM mapping) where - mapping = [ (mdl,fpath) + mapping = [ (mdl, fpath) | (fpath, ifaces) <- zip paths ifaces_s, (mdl, _iface) <- ifaces ] @@ -323,13 +335,13 @@ getPrologue flags mkInterface :: Bool -- no implicit prelude -> Bool -- verbose - -> ModuleMap -> FilePath -> HsModule + -> ModuleMap -> FilePath -> Maybe String -> HsModule -> ErrMsgM ( Module, -- the module name Interface -- its "interface" ) -mkInterface no_implicit_prelude verbose mod_map filename +mkInterface no_implicit_prelude verbose mod_map filename package (HsModule mdl exps imps decls maybe_opts maybe_info maybe_doc) = do -- Process the options, if available @@ -453,6 +465,7 @@ mkInterface no_implicit_prelude verbose mod_map filename return (mdl, Interface { iface_filename = filename, + iface_package = package, iface_env = name_env, iface_import_env = import_env, iface_reexported = reexports, |