aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/HaddockDevHelp.hs4
-rw-r--r--src/HaddockHH.hs29
-rw-r--r--src/HaddockHH2.hs35
-rw-r--r--src/HaddockHtml.hs25
-rw-r--r--src/HaddockUtil.hs14
-rw-r--r--src/Main.hs10
6 files changed, 63 insertions, 54 deletions
diff --git a/src/HaddockDevHelp.hs b/src/HaddockDevHelp.hs
index 95987230..3ebfc1c3 100644
--- a/src/HaddockDevHelp.hs
+++ b/src/HaddockDevHelp.hs
@@ -50,7 +50,7 @@ ppDevHelpFile odir doctitle maybe_package ifaces = do
nest 4 (ppModuleTree (s:ss) ts) $+$
text "</sub>"
where
- ppLink | leaf = text (moduleHtmlFile "" mdl)
+ ppLink | leaf = text (moduleHtmlFile mdl)
| otherwise = empty
ppAttribs = text "name="<>doubleQuotes (text s)<+>text "link="<>doubleQuotes ppLink
@@ -72,5 +72,5 @@ ppDevHelpFile odir doctitle maybe_package ifaces = do
ppReference name [] = empty
ppReference name (Module mdl:refs) =
- text "<function name=\""<>text (escapeStr (show name))<>text"\" link=\""<>text (nameHtmlRef "" mdl name)<>text"\"/>" $$
+ text "<function name=\""<>text (escapeStr (show name))<>text"\" link=\""<>text (nameHtmlRef mdl name)<>text"\"/>" $$
ppReference name refs
diff --git a/src/HaddockHH.hs b/src/HaddockHH.hs
index 98dac72a..6a41f738 100644
--- a/src/HaddockHH.hs
+++ b/src/HaddockHH.hs
@@ -61,7 +61,7 @@ ppHHContents odir maybe_package tree = do
text "<LI>" <> nest 4
(text "<OBJECT type=\"text/sitemap\">" $$
text "<PARAM name=\"Name\" value=\"" <> text s <> text "\">" $$
- (if isleaf then text "<PARAM name=\"Local\" value=\"" <> text (moduleHtmlFile "" mdl) <> text "\">" else empty) $$
+ (if isleaf then text "<PARAM name=\"Local\" value=\"" <> text (moduleHtmlFile mdl) <> text "\">" else empty) $$
text "</OBJECT>") $+$
text "</LI>"
where
@@ -107,12 +107,12 @@ ppHHIndex odir maybe_package ifaces = do
ppReference name [] = empty
ppReference name (Module mdl:refs) =
- text "<PARAM name=\"Local\" value=\"" <> text (nameHtmlRef "" mdl name) <> text "\">" $$
+ text "<PARAM name=\"Local\" value=\"" <> text (nameHtmlRef mdl name) <> text "\">" $$
ppReference name refs
-ppHHProject :: FilePath -> String -> Maybe String -> [(Module,Interface)] -> IO ()
-ppHHProject odir doctitle maybe_package ifaces = do
+ppHHProject :: FilePath -> String -> Maybe String -> [(Module,Interface)] -> [FilePath] -> IO ()
+ppHHProject odir doctitle maybe_package ifaces pkg_paths = do
let projectHHFile = package++".hhp"
doc =
text "[OPTIONS]" $$
@@ -129,24 +129,33 @@ ppHHProject odir doctitle maybe_package ifaces = do
text contentsHtmlFile $$
text indexHtmlFile $$
ppIndexFiles chars $$
- text cssFile $$
- text iconFile $$
- text jsFile $$
- text plusFile $$
- text minusFile
+ ppLibFiles ("":pkg_paths)
writeFile (odir ++ pathSeparator:projectHHFile) (render doc)
where
package = fromMaybe "pkg" maybe_package
ppMods [] = empty
ppMods ((Module mdl,_):ifaces) =
- text (moduleHtmlFile "" mdl) $$
+ text (moduleHtmlFile mdl) $$
ppMods ifaces
ppIndexFiles [] = empty
ppIndexFiles (c:cs) =
text (subIndexHtmlFile c) $$
ppIndexFiles cs
+
+ ppLibFiles [] = empty
+ ppLibFiles (path:paths) =
+ ppLibFile cssFile $$
+ ppLibFile iconFile $$
+ ppLibFile jsFile $$
+ ppLibFile plusFile $$
+ ppLibFile minusFile $$
+ ppLibFiles paths
+ where
+ toPath fname | null path = fname
+ | otherwise = path++pathSeparator:fname
+ ppLibFile fname = text (toPath fname)
chars :: [Char]
chars = keysFM (foldr getIfaceIndex emptyFM ifaces)
diff --git a/src/HaddockHH2.hs b/src/HaddockHH2.hs
index cea0f2e0..ce4d488e 100644
--- a/src/HaddockHH2.hs
+++ b/src/HaddockHH2.hs
@@ -56,7 +56,7 @@ ppHH2Contents odir maybe_package tree = do
ppTitle = text "Title=" <> doubleQuotes (text (head ss))
- ppUrl | isleaf = text " Url=" <> doubleQuotes (text (moduleHtmlFile "" mdl))
+ ppUrl | isleaf = text " Url=" <> doubleQuotes (text (moduleHtmlFile mdl))
| otherwise = empty
-----------------------------------------------------------------------------------
@@ -98,17 +98,13 @@ ppHH2Index odir maybe_package ifaces = do
text "</Keyword>" $$
ppList vs
- ppJump name (Module mdl) = text "<Jump Url=\"" <> text (nameHtmlRef fp mdl name) <> text "\"/>"
- where
- fp = case lookupFM html_xrefs (Module mdl) of
- Nothing -> ""
- Just fp0 -> fp0
+ ppJump name (Module mdl) = text "<Jump Url=\"" <> text (nameHtmlRef mdl name) <> text "\"/>"
-----------------------------------------------------------------------------------
-ppHH2Files :: FilePath -> Maybe String -> [(Module,Interface)] -> IO ()
-ppHH2Files odir maybe_package ifaces = do
+ppHH2Files :: FilePath -> Maybe String -> [(Module,Interface)] -> [FilePath] -> IO ()
+ppHH2Files odir maybe_package ifaces pkg_paths = do
let filesHH2File = package++".HxF"
doc =
text "<?xml version=\"1.0\"?>" $$
@@ -118,11 +114,7 @@ ppHH2Files odir maybe_package ifaces = do
text "<File Url=\""<>text contentsHtmlFile<>text "\"/>" $$
text "<File Url=\""<>text indexHtmlFile<>text "\"/>" $$
ppIndexFiles chars $$
- text "<File Url=\""<>text cssFile <>text "\"/>" $$
- text "<File Url=\""<>text iconFile <>text "\"/>" $$
- text "<File Url=\""<>text jsFile <>text "\"/>" $$
- text "<File Url=\""<>text plusFile <>text "\"/>" $$
- text "<File Url=\""<>text minusFile<>text "\"/>") $$
+ ppLibFiles ("":pkg_paths)) $$
text "</HelpFileList>"
writeFile (odir ++ pathSeparator:filesHH2File) (render doc)
where
@@ -130,14 +122,27 @@ ppHH2Files odir maybe_package ifaces = do
ppMods [] = empty
ppMods ((Module mdl,_):ifaces) =
- text "<File Url=\"" <> text (moduleHtmlFile "" mdl) <> text "\"/>" $$
+ text "<File Url=\"" <> text (moduleHtmlFile mdl) <> text "\"/>" $$
ppMods ifaces
ppIndexFiles [] = empty
ppIndexFiles (c:cs) =
text "<File Url=\""<>text (subIndexHtmlFile c)<>text "\"/>" $$
ppIndexFiles cs
-
+
+ ppLibFiles [] = empty
+ ppLibFiles (path:paths) =
+ ppLibFile cssFile $$
+ ppLibFile iconFile $$
+ ppLibFile jsFile $$
+ ppLibFile plusFile $$
+ ppLibFile minusFile $$
+ ppLibFiles paths
+ where
+ toPath fname | null path = fname
+ | otherwise = path++pathSeparator:fname
+ ppLibFile fname = text "<File Url=\""<>text (toPath fname)<>text "\"/>"
+
chars :: [Char]
chars = keysFM (foldr getIfaceIndex emptyFM ifaces)
diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs
index 2c6fedb9..466fd413 100644
--- a/src/HaddockHtml.hs
+++ b/src/HaddockHtml.hs
@@ -68,7 +68,7 @@ ppHtml doctitle maybe_package source_url ifaces odir prologue maybe_html_help_fo
ppHtmlIndex odir doctitle maybe_package maybe_html_help_format maybe_contents_url visible_ifaces
when (not (isJust maybe_contents_url && isJust maybe_index_url)) $
- ppHtmlHelpFiles doctitle maybe_package ifaces odir maybe_html_help_format
+ ppHtmlHelpFiles doctitle maybe_package ifaces odir maybe_html_help_format []
mapM_ (ppHtmlModule odir doctitle source_url
maybe_contents_url maybe_index_url) visible_ifaces
@@ -79,17 +79,19 @@ ppHtmlHelpFiles
-> [(Module, Interface)]
-> FilePath -- destination directory
-> Maybe String -- the Html Help format (--html-help)
+ -> [FilePath] -- external packages paths
-> IO ()
-ppHtmlHelpFiles doctitle maybe_package ifaces odir maybe_html_help_format = do
+ppHtmlHelpFiles doctitle maybe_package ifaces odir maybe_html_help_format pkg_paths = do
let
visible_ifaces = filter visible ifaces
visible (_, i) = OptHide `notElem` iface_options i
-- Generate index and contents page for Html Help if requested
case maybe_html_help_format of
- Just "mshelp" -> ppHHProject odir doctitle maybe_package visible_ifaces
+ Nothing -> return ()
+ Just "mshelp" -> ppHHProject odir doctitle maybe_package visible_ifaces pkg_paths
Just "mshelp2" -> do
- ppHH2Files odir maybe_package visible_ifaces
+ ppHH2Files odir maybe_package visible_ifaces pkg_paths
ppHH2Collection odir doctitle maybe_package
Just "devhelp" -> ppDevHelpFile odir doctitle maybe_package visible_ifaces
Just format -> fail ("The "++format++" format is not implemented")
@@ -433,7 +435,7 @@ ppHtmlModule odir doctitle source_url
ifaceToHtml mdl iface </> s15 </>
footer
)
- writeFile (moduleHtmlFile odir mdl) (renderHtml html False)
+ writeFile (odir++moduleHtmlFile mdl) (renderHtml html False)
ifaceToHtml :: String -> Interface -> HtmlTable
ifaceToHtml _ iface
@@ -974,17 +976,12 @@ ppHsBindIdent (HsSpecial str) = toHtml str
linkId :: Module -> Maybe HsName -> Html -> Html
linkId (Module mdl) mbName = anchor ! [href hr]
where hr = case mbName of
- Nothing -> moduleHtmlFile fp mdl
- Just name -> nameHtmlRef fp mdl name
- fp = case lookupFM html_xrefs (Module mdl) of
- Nothing -> ""
- Just fp0 -> fp0
+ Nothing -> moduleHtmlFile mdl
+ Just name -> nameHtmlRef mdl name
ppHsModule :: String -> Html
-ppHsModule mdl = anchor ! [href ((moduleHtmlFile fp modname) ++ ref)] << toHtml mdl
- where fp = case lookupFM html_xrefs (Module modname) of
- Just fp0 -> fp0
- Nothing -> ""
+ppHsModule mdl = anchor ! [href ((moduleHtmlFile modname) ++ ref)] << toHtml mdl
+ where
(modname,ref) = break (== '#') mdl
-- -----------------------------------------------------------------------------
diff --git a/src/HaddockUtil.hs b/src/HaddockUtil.hs
index 03796532..f7dab157 100644
--- a/src/HaddockUtil.hs
+++ b/src/HaddockUtil.hs
@@ -23,7 +23,7 @@ module HaddockUtil (
getProgramName, bye, die, dieMsg, mapSnd, mapMaybeM, escapeStr,
-- * HTML cross reference mapping
- html_xrefs_ref, html_xrefs,
+ html_xrefs_ref,
) where
import HsSyn
@@ -272,12 +272,14 @@ isPathSeparator ch =
ch == '/'
#endif
-moduleHtmlFile :: FilePath -> String -> FilePath
-moduleHtmlFile "" mod0 = mod0 ++ ".html" -- ToDo: Z-encode filename?
-moduleHtmlFile dir mod0 = dir ++ pathSeparator : mod0 ++ ".html"
+moduleHtmlFile :: String -> FilePath
+moduleHtmlFile mdl =
+ case lookupFM html_xrefs (Module mdl) of
+ Nothing -> mdl ++ ".html"
+ Just fp0 -> fp0 ++ pathSeparator : mdl ++ ".html"
-nameHtmlRef :: FilePath -> String -> HsName -> String
-nameHtmlRef fp mdl str = moduleHtmlFile fp mdl ++ '#':escapeStr (hsAnchorNameStr str)
+nameHtmlRef :: String -> HsName -> String
+nameHtmlRef mdl str = moduleHtmlFile mdl ++ '#':escapeStr (hsAnchorNameStr str)
contentsHtmlFile, indexHtmlFile :: String
contentsHtmlFile = "index.html"
diff --git a/src/Main.hs b/src/Main.hs
index 797d8325..a0126fa3 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -139,9 +139,6 @@ options =
"generate an HTML index from specified interfaces"
]
-saved_flags :: IORef [Flag]
-saved_flags = unsafePerformIO (newIORef (error "no flags yet"))
-
run :: [Flag] -> [FilePath] -> IO ()
run flags files = do
when (Flag_Help `elem` flags) $ do
@@ -211,10 +208,9 @@ run flags files = do
visible_read_ifaces = filter ((OptHide `notElem`) . iface_options . snd)
read_ifaces
external_mods = map fst read_ifaces
+ pkg_paths = map fst ifaces_to_read
- updateHTMLXRefs (map fst ifaces_to_read) read_ifaces_s
-
- writeIORef saved_flags flags
+ updateHTMLXRefs pkg_paths read_ifaces_s
when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags)
&& Flag_Html `elem` flags) $
@@ -229,7 +225,7 @@ run flags files = do
copyHtmlBits odir libdir css_file
when (Flag_GenContents `elem` flags && Flag_GenIndex `elem` flags) $ do
- ppHtmlHelpFiles title package visible_read_ifaces odir maybe_html_help_format
+ ppHtmlHelpFiles title package visible_read_ifaces odir maybe_html_help_format pkg_paths
parsed_mods <- mapM parse_file files
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 03:58:21 +0000