From 3c0c53ba97105aef3718ccf80257d5eaaf35c94e Mon Sep 17 00:00:00 2001
From: krasimir <unknown>
Date: Sat, 31 Jul 2004 20:35:21 +0000
Subject: [haddock @ 2004-07-31 20:35:21 by krasimir] Added support for DevHelp
---
src/HaddockDevHelp.hs | 76 +++++++++++++++++++++++++++++++++++++++++++++++++++
src/HaddockHtml.hs | 10 ++++---
2 files changed, 82 insertions(+), 4 deletions(-)
create mode 100644 src/HaddockDevHelp.hs
(limited to 'src')
diff --git a/src/HaddockDevHelp.hs b/src/HaddockDevHelp.hs
new file mode 100644
index 00000000..95987230
--- /dev/null
+++ b/src/HaddockDevHelp.hs
@@ -0,0 +1,76 @@
+module HaddockDevHelp(ppDevHelpFile) where
+
+import HsSyn hiding(Doc)
+
+#if __GLASGOW_HASKELL__ < 503
+import Pretty
+import FiniteMap
+#else
+import Text.PrettyPrint
+import Data.FiniteMap
+import Data.Char
+#endif
+
+import Maybe ( fromMaybe )
+import HaddockModuleTree
+import HaddockUtil
+import HaddockTypes
+
+
+ppDevHelpFile :: FilePath -> String -> Maybe String -> [(Module,Interface)] -> IO ()
+ppDevHelpFile odir doctitle maybe_package ifaces = do
+ let devHelpFile = package++".devhelp"
+ tree = mkModuleTree [(mod,iface_package iface) | (mod,iface) <- ifaces]
+ doc =
+ text "<?xml version=\"1.0\" encoding=\"utf-8\" standalone=\"no\"?>" $$
+ (text "<book xmlns=\"http://www.devhelp.net/book\" title=\""<>text doctitle<>
+ text "\" link=\""<>text contentsHtmlFile<>text"\" author=\"\" name=\""<>text package<>text "\">") $$
+ text "<chapters>" $$
+ nest 4 (ppModuleTree [] tree) $+$
+ text "</chapters>" $$
+ text "<functions>" $$
+ nest 4 (ppList index) $+$
+ text "</functions>" $$
+ text "</book>"
+ writeFile (odir ++ pathSeparator:devHelpFile) (render doc)
+ where
+ package = fromMaybe "pkg" maybe_package
+
+ ppModuleTree :: [String] -> [ModuleTree] -> Doc
+ ppModuleTree ss [x] = ppNode ss x
+ ppModuleTree ss (x:xs) = ppNode ss x $$ ppModuleTree ss xs
+ ppModuleTree _ [] = error "HaddockHH.ppHHContents.fn: no module trees given"
+
+ ppNode :: [String] -> ModuleTree -> Doc
+ ppNode ss (Node s leaf _pkg ts) =
+ case ts of
+ [] -> text "<sub"<+>ppAttribs<>text "/>"
+ ts ->
+ text "<sub"<+>ppAttribs<>text ">" $$
+ nest 4 (ppModuleTree (s:ss) ts) $+$
+ text "</sub>"
+ where
+ ppLink | leaf = text (moduleHtmlFile "" mdl)
+ | otherwise = empty
+
+ ppAttribs = text "name="<>doubleQuotes (text s)<+>text "link="<>doubleQuotes ppLink
+
+ mdl = foldr (++) "" (s' : map ('.':) ss')
+ (s':ss') = reverse (s:ss)
+ -- reconstruct the module name
+
+ index :: [(HsName, [Module])]
+ index = fmToList (foldr getIfaceIndex emptyFM ifaces)
+
+ getIfaceIndex (mdl,iface) fm =
+ addListToFM_C (++) fm [(name, [mdl]) | (name, Qual mdl' _) <- fmToList (iface_env iface), mdl == mdl']
+
+ ppList [] = empty
+ ppList ((name,refs):mdls) =
+ ppReference name refs $$
+ ppList mdls
+
+ ppReference name [] = empty
+ ppReference name (Module mdl:refs) =
+ text "<function name=\""<>text (escapeStr (show name))<>text"\" link=\""<>text (nameHtmlRef "" mdl name)<>text"\"/>" $$
+ ppReference name refs
diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs
index 719186ab..2c6fedb9 100644
--- a/src/HaddockHtml.hs
+++ b/src/HaddockHtml.hs
@@ -17,6 +17,7 @@ import HaddockUtil
import HaddockModuleTree
import HaddockHH
import HaddockHH2
+import HaddockDevHelp
import HsSyn
import Maybe ( fromJust, isJust )
@@ -86,13 +87,12 @@ ppHtmlHelpFiles doctitle maybe_package ifaces odir maybe_html_help_format = do
-- Generate index and contents page for Html Help if requested
case maybe_html_help_format of
- Just "mshelp" -> do
- ppHHProject odir doctitle maybe_package visible_ifaces
+ Just "mshelp" -> ppHHProject odir doctitle maybe_package visible_ifaces
Just "mshelp2" -> do
ppHH2Files odir maybe_package visible_ifaces
ppHH2Collection odir doctitle maybe_package
- _ -> return ()
-
+ Just "devhelp" -> ppDevHelpFile odir doctitle maybe_package visible_ifaces
+ Just format -> fail ("The "++format++" format is not implemented")
copyFile :: FilePath -> FilePath -> IO ()
copyFile fromFPath toFPath =
@@ -234,6 +234,7 @@ ppHtmlContents odir doctitle maybe_package maybe_html_help_format maybe_index_ur
Nothing -> return ()
Just "mshelp" -> ppHHContents odir maybe_package tree
Just "mshelp2" -> ppHH2Contents odir maybe_package tree
+ Just "devhelp" -> return ()
Just format -> fail ("The "++format++" format is not implemented")
ppPrologue :: String -> Maybe Doc -> HtmlTable
@@ -319,6 +320,7 @@ ppHtmlIndex odir doctitle maybe_package maybe_html_help_format maybe_contents_ur
Nothing -> return ()
Just "mshelp" -> ppHHIndex odir maybe_package ifaces
Just "mshelp2" -> ppHH2Index odir maybe_package ifaces
+ Just "devhelp" -> return ()
Just format -> fail ("The "++format++" format is not implemented")
where
split_indices = length index > 50
--
cgit v1.2.3