[haddock @ 2004-08-01 19:52:06 by krasimir]

fix some bugs. Now I have got the entire libraries documentation in HtmlHelp 2.0 format.

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