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

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