From 1a7ccb86bb10ebc44e17c90ac5e27e7783958a22 Mon Sep 17 00:00:00 2001
From: simonmar <unknown>
Date: Wed, 5 Nov 2003 17:16:05 +0000
Subject: [haddock @ 2003-11-05 17:16:04 by simonmar] Support for generating a
single unified index for several packages.
--use-index=URL turns off normal index generation, causes Index
links to point to URL.
--gen-index generates an combined index from the specified
interfaces.
Currently doesn't work exactly right, because the interfaces don't
contain the iface_reexported info. I'll need to fix that up.
---
src/HaddockHtml.hs | 76 ++++++++++++++++++++++++++++++------------------------
src/Main.hs | 28 +++++++++++++++++---
2 files changed, 67 insertions(+), 37 deletions(-)
(limited to 'src')
diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs
index 9bdc9875..e1604fad 100644
--- a/src/HaddockHtml.hs
+++ b/src/HaddockHtml.hs
@@ -4,7 +4,7 @@
-- (c) Simon Marlow 2002
--
-module HaddockHtml ( ppHtml ) where
+module HaddockHtml ( ppHtml, copyHtmlBits, ppHtmlIndex ) where
import Prelude hiding (div)
import HaddockVersion
@@ -45,13 +45,29 @@ ppHtml :: String
-> Maybe String
-> [(Module, Interface)]
-> FilePath -- destination directory
- -> Maybe String -- CSS file
- -> String -- $libdir
-> Maybe Doc -- prologue text, maybe
-> Bool -- do MS Help stuff
+ -> Maybe String -- the index URL (--use-index)
-> IO ()
-ppHtml doctitle source_url ifaces odir maybe_css libdir prologue do_ms_help = do
+ppHtml doctitle source_url ifaces odir prologue do_ms_help maybe_index_url = do
+ let
+ visible_ifaces = filter visible ifaces
+ visible (_, i) = OptHide `notElem` iface_options i
+
+ ppHtmlContents odir doctitle maybe_index_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 doctitle source_url maybe_index_url) visible_ifaces
+
+
+copyHtmlBits :: FilePath -> FilePath -> Maybe FilePath -> IO ()
+copyHtmlBits odir libdir maybe_css = do
let
css_file = case maybe_css of
Nothing -> libdir ++ pathSeparator:cssFile
@@ -60,28 +76,16 @@ ppHtml doctitle source_url ifaces odir maybe_css libdir prologue do_ms_help = d
icon_file = libdir ++ pathSeparator:iconFile
icon_destination = odir ++ pathSeparator:iconFile
-
- visible_ifaces = filter visible ifaces
- 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 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 doctitle source_url) visible_ifaces
contentsHtmlFile, indexHtmlFile :: String
contentsHtmlFile = "index.html"
-indexHtmlFile = "doc-index.html"
+indexHtmlFile = "doc-index.html"
subIndexHtmlFile :: Char -> String
subIndexHtmlFile a = "doc-index-" ++ b ++ ".html"
@@ -119,22 +123,26 @@ contentsButton :: HtmlTable
contentsButton = topButBox (anchor ! [href contentsHtmlFile] <<
toHtml "Contents")
-indexButton :: HtmlTable
-indexButton = topButBox (anchor ! [href indexHtmlFile] << toHtml "Index")
+indexButton :: Maybe String -> HtmlTable
+indexButton maybe_index_url
+ = topButBox (anchor ! [href url] << toHtml "Index")
+ where url = case maybe_index_url of
+ Nothing -> indexHtmlFile
+ Just url -> url
-simpleHeader :: String -> HtmlTable
-simpleHeader doctitle =
+simpleHeader :: String -> Maybe String -> HtmlTable
+simpleHeader doctitle maybe_index_url =
(tda [theclass "topbar"] <<
vanillaTable << (
(td <<
image ! [src "haskell_icon.gif", width "16", height 16, alt " " ]
) <->
(tda [theclass "title"] << toHtml doctitle) <->
- contentsButton <-> indexButton
+ contentsButton <-> indexButton maybe_index_url
))
-pageHeader :: String -> Interface -> String -> Maybe String -> HtmlTable
-pageHeader mdl iface doctitle source_url =
+pageHeader :: String -> Interface -> String -> Maybe String -> Maybe String -> HtmlTable
+pageHeader mdl iface doctitle source_url maybe_index_url =
(tda [theclass "topbar"] <<
vanillaTable << (
(td <<
@@ -144,7 +152,7 @@ pageHeader mdl iface doctitle source_url =
src_button source_url mdl (iface_filename iface) <->
parent_button mdl <->
contentsButton <->
- indexButton
+ indexButton maybe_index_url
)
) </>
tda [theclass "modulebar"] <<
@@ -173,14 +181,14 @@ moduleInfo iface =
ppHtmlContents :: FilePath -> String -> Maybe String -> [Module] -> Maybe Doc
-> IO ()
-ppHtmlContents odir doctitle _ mdls prologue = do
+ppHtmlContents odir doctitle maybe_index_url mdls prologue = do
let tree = mkModuleTree mdls
html =
header (thetitle (toHtml doctitle) +++
thelink ! [href cssFile,
rel "stylesheet", thetype "text/css"]) +++
body << vanillaTable << (
- simpleHeader doctitle </>
+ simpleHeader doctitle maybe_index_url </>
ppPrologue prologue </>
ppModuleTree doctitle tree </>
s15 </>
@@ -225,7 +233,7 @@ ppHtmlIndex odir doctitle ifaces = do
thelink ! [href cssFile,
rel "stylesheet", thetype "text/css"]) +++
body << vanillaTable << (
- simpleHeader doctitle </>
+ simpleHeader doctitle Nothing </>
index_html
)
@@ -262,7 +270,7 @@ ppHtmlIndex odir doctitle ifaces = do
thelink ! [href cssFile,
rel "stylesheet", thetype "text/css"]) +++
body << vanillaTable << (
- simpleHeader doctitle </>
+ simpleHeader doctitle Nothing </>
indexInitialLetterLinks </>
tda [theclass "section1"] <<
toHtml ("Index (" ++ c:")") </>
@@ -329,15 +337,15 @@ ppHtmlIndex odir doctitle ifaces = do
-- ---------------------------------------------------------------------------
-- Generate the HTML page for a module
-ppHtmlModule :: FilePath -> String -> Maybe String ->
+ppHtmlModule :: FilePath -> String -> Maybe String -> Maybe String ->
(Module,Interface) -> IO ()
-ppHtmlModule odir doctitle source_url (Module mdl,iface) = do
+ppHtmlModule odir doctitle source_url maybe_index_url (Module mdl,iface) = do
let html =
header (thetitle (toHtml mdl) +++
thelink ! [href cssFile,
rel "stylesheet", thetype "text/css"]) +++
body << vanillaTable << (
- pageHeader mdl iface doctitle source_url </> s15 </>
+ pageHeader mdl iface doctitle source_url maybe_index_url </> s15 </>
ifaceToHtml mdl iface </> s15 </>
footer
)
@@ -542,6 +550,8 @@ ppHsDataDecl summary instances is_newty
)
instances_bit
+ | null instances = Html.emptyTable
+ | otherwise
= inst_hdr </>
tda [theclass "body"] << spacedTable1 << (
aboves (map (declBox.ppInstHead) instances)
diff --git a/src/Main.hs b/src/Main.hs
index c6afd9d3..f3ccde26 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -80,6 +80,8 @@ data Flag
| Flag_Help
| Flag_Verbose
| Flag_Version
+ | Flag_UseIndex String
+ | Flag_GenIndex
deriving (Eq)
options :: [OptDescr Flag]
@@ -116,7 +118,11 @@ options =
Option ['V'] ["version"] (NoArg Flag_Version)
"output version information and exit",
Option ['v'] ["verbose"] (NoArg Flag_Verbose)
- "increase verbosity"
+ "increase verbosity",
+ Option [] ["use-index"] (ReqArg Flag_UseIndex "URL")
+ "use a separately-generated HTML index",
+ Option [] ["gen-index"] (NoArg Flag_GenIndex)
+ "generate an HTML index from specified interfaces"
]
saved_flags :: IORef [Flag]
@@ -161,12 +167,25 @@ run flags files = do
no_implicit_prelude = Flag_NoImplicitPrelude `elem` flags
verbose = Flag_Verbose `elem` flags
+ maybe_index_url =
+ case [url | Flag_UseIndex url <- flags] of
+ [] -> Nothing
+ us -> Just (last us)
+
prologue <- getPrologue flags
read_ifaces_s <- mapM readIface (map snd ifaces_to_read)
updateHTMLXRefs (map fst ifaces_to_read) read_ifaces_s
+ if Flag_GenIndex `elem` flags
+ then do
+ when (not (null files)) $
+ die ("--gen-index: expected no additional file arguments")
+ ppHtmlIndex odir title (concat read_ifaces_s)
+ copyHtmlBits odir libdir css_file
+ else do
+
writeIORef saved_flags flags
parsed_mods <- mapM parse_file files
@@ -204,9 +223,10 @@ run flags files = do
fmToList (iface_sub i))
| (mdl, i) <- these_mod_ifaces ])
- when (Flag_Html `elem` flags) $
- ppHtml title source_url these_mod_ifaces odir css_file
- libdir prologue (Flag_MSHtmlHelp `elem` flags)
+ when (Flag_Html `elem` flags) $ do
+ ppHtml title source_url these_mod_ifaces odir
+ prologue (Flag_MSHtmlHelp `elem` flags) maybe_index_url
+ copyHtmlBits odir libdir css_file
-- dump an interface if requested
case dump_iface of
--
cgit v1.2.3