[haddock @ 2002-07-09 16:33:31 by krasimir]

'Microsoft HTML Help' support
author: krasimir <unknown> 2002-07-09 16:33:33 +0000
committer: krasimir <unknown> 2002-07-09 16:33:33 +0000
commit: 9728087302a03143624d030642770f17be1eb097 (patch)
tree: 0744abe99116d9b9927ff2003f560429702ffe1f /src
parent: 44f3891a021a5d10d2f5fc1263ac0633573d86a8 (diff)
4 files changed, 128 insertions, 26 deletions
diff --git a/src/HaddockHH.hs b/src/HaddockHH.hs
new file mode 100644
index 00000000..05ff9243
--- /dev/null
+++ b/src/HaddockHH.hs
@@ -0,0 +1,94 @@
+module HaddockHH(ppHHContents, ppHHIndex) where
+
+import HsSyn hiding(Doc)
+import Text.PrettyPrint
+import Data.FiniteMap
+import HaddockModuleTree
+import HaddockUtil
+import HaddockTypes
+
+contentsHHFile = "index.hhc"
+indexHHFile = "index.hhk"
+
+ppHHContents :: FilePath -> [Module] -> IO ()
+ppHHContents odir mods = do
+  let tree = mkModuleTree mods
+      html =
+      	text "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">" $$
+	text "<HTML>" $$
+	text "<HEAD>" $$
+	text "<META name=\"GENERATOR\" content=\"Haddock\">" $$
+	text "<!-- Sitemap 1.0 -->" $$
+	text "</HEAD><BODY>" $$
+	ppModuleTree tree $$
+	text "</BODY><HTML>"
+  writeFile (odir ++ pathSeparator:contentsHHFile) (render html)
+  where
+	ppModuleTree :: [ModuleTree] -> Doc
+	ppModuleTree ts =
+		text "<OBJECT type=\"text/site properties\">" $$
+		text "<PARAM name=\"FrameName\" value=\"main\">" $$
+		text "</OBJECT>" $$
+		text "<UL>" $+$
+		nest 4 (fn [] ts) $+$
+		text "</UL>"
+  	
+	fn :: [String] -> [ModuleTree] -> Doc
+	fn ss [x]    = ppNode ss x
+	fn ss (x:xs) = ppNode ss x $$ fn ss xs
+
+	ppNode :: [String] -> ModuleTree -> Doc
+	ppNode ss (Node s leaf []) =
+	  ppLeaf s ss leaf
+	ppNode ss (Node s leaf ts) =
+	  ppLeaf s ss leaf $$
+	  text "<UL>" $+$
+	  nest 4 (fn (s:ss) ts) $+$
+	  text "</UL>"
+
+	ppLeaf s ss isleaf  =
+		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 "" mod) <> text "\">" else empty) $$
+			 text "</OBJECT>") $+$
+		text "</LI>"
+		where 
+			mod = foldr (++) "" (s' : map ('.':) ss')
+			(s':ss') = reverse (s:ss)
+			-- reconstruct the module name
+		
+-------------------------------
+ppHHIndex :: FilePath -> [(Module,Interface)] -> IO ()
+ppHHIndex odir ifaces = do
+  let html = 
+      	text "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">" $$
+	text "<HTML>" $$
+	text "<HEAD>" $$
+	text "<META name=\"GENERATOR\" content=\"Haddock\">" $$
+	text "<!-- Sitemap 1.0 -->" $$
+	text "</HEAD><BODY>" $$
+	text "<UL>" $+$
+	nest 4 (ppList index) $+$
+	text "</UL>" $$
+	text "</BODY><HTML>"
+  writeFile (odir ++ pathSeparator:indexHHFile) (render html)
+  where	
+	index :: [(HsName, Module)]
+	index = fmToList full_index
+
+	iface_indices = map getIfaceIndex ifaces
+	full_index = foldr1 plusFM iface_indices
+
+	getIfaceIndex (mod,iface) = listToFM
+	    [ (name, mod) | (name, Qual mod' _) <- fmToList (iface_env iface), mod == mod']
+	
+	ppList [] = empty
+	ppList ((name,Module mod):mods)  =
+		text "<LI>" <> nest 4
+				(text "<OBJECT type=\"text/sitemap\">" $$
+				 text "<PARAM name=\"Name\" value=\"" <> text (show name) <> text "\">" $$
+				 text "<PARAM name=\"Local\" value=\"" <> text (moduleHtmlFile "" mod) <> char '#' <> text (show name) <> text "\">" $$
+				 text "</OBJECT>") $+$
+		text "</LI>" $$
+		ppList mods
+\ No newline at end of file
diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs
index 209d9689..a503d50f 100644
--- a/src/HaddockHtml.hs
+++ b/src/HaddockHtml.hs
@@ -10,6 +10,8 @@ import Prelude hiding (div)
 import HaddockVersion
 import HaddockTypes
 import HaddockUtil
+import HaddockModuleTree
+import HaddockHH
 import HsSyn
 
 import IO
@@ -69,12 +71,10 @@ ppHtml title source_url ifaces odir maybe_css libdir inst_maps prologue =  do
 
   ppHtmlContents odir title source_url (map fst visible_ifaces) prologue
   ppHtmlIndex odir title visible_ifaces
+  ppHHContents odir (map fst visible_ifaces)
+  ppHHIndex odir visible_ifaces
   mapM_ (ppHtmlModule odir title source_url inst_maps) visible_ifaces
 
-moduleHtmlFile :: FilePath -> String -> FilePath
-moduleHtmlFile "" mod  = mod ++ ".html" -- ToDo: Z-encode filename?
-moduleHtmlFile dir mod = dir ++ pathSeparator : mod ++ ".html"
-
 contentsHtmlFile = "index.html"
 indexHtmlFile    = "doc-index.html"
 subIndexHtmlFile k a = "doc-index-" ++ k:a:".html"
@@ -198,28 +198,6 @@ mkLeaf s ss True  = anchor ! [href (moduleHtmlFile "" mod)] << toHtml s
 	(s':ss') = reverse (s:ss)
 	 -- reconstruct the module name
 
-data ModuleTree = Node String Bool [ModuleTree]
-
-mkModuleTree :: [Module] -> [ModuleTree]
-mkModuleTree mods = foldr addToTrees [] (map splitModule mods)
-
-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
-
-mkSubTree [] = []
-mkSubTree (s:ss) = [Node s (null ss) (mkSubTree ss)]
-
-splitModule :: Module -> [String]
-splitModule (Module mod) = split mod
-  where split mod = case break (== '.') mod of
-     			(s1, '.':s2) -> s1 : split s2
-     			(s1, _) -> [s1]
-
 -- ---------------------------------------------------------------------------
 -- Generate the index
 
diff --git a/src/HaddockModuleTree.hs b/src/HaddockModuleTree.hs
new file mode 100644
index 00000000..21cd404e
--- /dev/null
+++ b/src/HaddockModuleTree.hs
@@ -0,0 +1,25 @@
+module HaddockModuleTree(ModuleTree(..), mkModuleTree) where
+
+import HsSyn
+
+data ModuleTree = Node String Bool [ModuleTree]
+
+mkModuleTree :: [Module] -> [ModuleTree]
+mkModuleTree mods = foldr addToTrees [] (map splitModule mods)
+
+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
+
+mkSubTree [] = []
+mkSubTree (s:ss) = [Node s (null ss) (mkSubTree ss)]
+
+splitModule :: Module -> [String]
+splitModule (Module mod) = split mod
+  where split mod = case break (== '.') mod of
+     			(s1, '.':s2) -> s1 : split s2
+     			(s1, _) -> [s1]
+\ No newline at end of file
diff --git a/src/HaddockUtil.hs b/src/HaddockUtil.hs
index 1e8e2ca8..3e7660bb 100644
--- a/src/HaddockUtil.hs
+++ b/src/HaddockUtil.hs
@@ -14,6 +14,7 @@ module HaddockUtil (
   -- * Filename utilities
   basename, dirname, splitFilename3, 
   isPathSeparator, pathSeparator,
+  moduleHtmlFile,
 
   -- * Miscellaneous utilities
   die, dieMsg, mapSnd, mapMaybeM,
@@ -209,6 +210,10 @@ isPathSeparator ch =
   ch == '/'
 #endif
 
+moduleHtmlFile :: FilePath -> String -> FilePath
+moduleHtmlFile "" mod  = mod ++ ".html" -- ToDo: Z-encode filename?
+moduleHtmlFile dir mod = dir ++ pathSeparator : mod ++ ".html"
+
 -----------------------------------------------------------------------------
 -- misc.
author	krasimir <unknown>	2002-07-09 16:33:33 +0000
committer	krasimir <unknown>	2002-07-09 16:33:33 +0000
commit	9728087302a03143624d030642770f17be1eb097 (patch)
tree	0744abe99116d9b9927ff2003f560429702ffe1f /src
parent	44f3891a021a5d10d2f5fc1263ac0633573d86a8 (diff)