From f0c653889170549f34f3a477e8201bf167c8de78 Mon Sep 17 00:00:00 2001
From: krasimir <unknown>
Date: Mon, 2 Aug 2004 16:25:53 +0000
Subject: [haddock @ 2004-08-02 16:25:53 by krasimir] Add root node to the
 table of contents. All modules in tree are not children of the root

---
 src/HaddockHH.hs   | 16 ++++++++++++----
 src/HaddockHH2.hs  |  8 +++++---
 src/HaddockHtml.hs |  4 ++--
 3 files changed, 19 insertions(+), 9 deletions(-)

(limited to 'src')

diff --git a/src/HaddockHH.hs b/src/HaddockHH.hs
index 6a41f738..d4dc07e8 100644
--- a/src/HaddockHH.hs
+++ b/src/HaddockHH.hs
@@ -17,8 +17,8 @@ import HaddockUtil
 import HaddockTypes
 
 
-ppHHContents :: FilePath -> Maybe String -> [ModuleTree] -> IO ()
-ppHHContents odir maybe_package tree = do
+ppHHContents :: FilePath -> String -> Maybe String -> [ModuleTree] -> IO ()
+ppHHContents odir doctitle maybe_package tree = do
   let contentsHHFile = package++".hhc"
 
       html =
@@ -40,9 +40,17 @@ ppHHContents odir maybe_package tree = do
 		text "<PARAM name=\"FrameName\" value=\"main\">" $$
 		text "</OBJECT>" $$
 		text "<UL>" $+$
-		nest 4 (fn [] ts) $+$
+		nest 4 (text "<LI>" <> nest 4
+		                (text "<OBJECT type=\"text/sitemap\">" $$
+		                 nest 4 (text "<PARAM name=\"Name\" value=\""<>text doctitle<>text "\">" $$
+		                         text "<PARAM name=\"Local\" value=\"index.html\">") $$
+		                 text "</OBJECT>") $+$
+		        text "</LI>" $$
+		        text "<UL>" $+$
+		        nest 4 (fn [] ts) $+$
+		        text "</UL>") $+$
 		text "</UL>"
-  	
+
 	fn :: [String] -> [ModuleTree] -> Doc
 	fn ss [x]    = ppNode ss x
 	fn ss (x:xs) = ppNode ss x $$ fn ss xs
diff --git a/src/HaddockHH2.hs b/src/HaddockHH2.hs
index ce4d488e..915f211d 100644
--- a/src/HaddockHH2.hs
+++ b/src/HaddockHH2.hs
@@ -17,8 +17,8 @@ import HaddockModuleTree
 import HaddockUtil
 import HaddockTypes
 
-ppHH2Contents :: FilePath -> Maybe String -> [ModuleTree] -> IO ()
-ppHH2Contents odir maybe_package tree = do
+ppHH2Contents :: FilePath -> String -> Maybe String -> [ModuleTree] -> IO ()
+ppHH2Contents odir doctitle maybe_package tree = do
   let 	
 	contentsHH2File = package++".HxT"
 
@@ -26,7 +26,9 @@ ppHH2Contents odir maybe_package tree = do
 		text "<?xml version=\"1.0\"?>" $$
 		text "<!DOCTYPE HelpTOC SYSTEM \"ms-help://hx/resources/HelpTOC.DTD\">" $$
 		text "<HelpTOC DTDVersion=\"1.0\">" $$
-		nest 4 (ppModuleTree [] tree) $$
+		nest 4 (text "<HelpTOCNode Title=\""<>text doctitle<>text"\" Url=\"index.html\">" $$
+		        nest 4 (ppModuleTree [] tree) $+$
+		        text "</HelpTOCNode>") $$
 		text "</HelpTOC>"
   writeFile (odir ++ pathSeparator:contentsHH2File) (render doc)
   where
diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs
index 466fd413..1d9f3c5e 100644
--- a/src/HaddockHtml.hs
+++ b/src/HaddockHtml.hs
@@ -234,8 +234,8 @@ ppHtmlContents odir doctitle maybe_package maybe_html_help_format maybe_index_ur
   -- Generate contents page for Html Help if requested
   case maybe_html_help_format of
     Nothing        -> return ()
-    Just "mshelp"  -> ppHHContents  odir maybe_package tree
-    Just "mshelp2" -> ppHH2Contents odir maybe_package tree
+    Just "mshelp"  -> ppHHContents  odir doctitle maybe_package tree
+    Just "mshelp2" -> ppHH2Contents odir doctitle maybe_package tree
     Just "devhelp" -> return ()
     Just format    -> fail ("The "++format++" format is not implemented")
 
-- 
cgit v1.2.3