aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Binary.hs19
-rw-r--r--src/HaddockHH.hs6
-rw-r--r--src/HaddockHtml.hs53
-rw-r--r--src/HaddockModuleTree.hs32
-rw-r--r--src/HaddockTypes.hs2
-rw-r--r--src/Main.hs39
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,
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-29 02:19:12 +0000