[haddock @ 2004-07-30 22:15:45 by krasimir]

more stuffs - support for separated compilation of packages - the contents page now uses DHTML TreeView - fixed copyFile bug
author: krasimir <unknown> 2004-07-30 22:15:47 +0000
committer: krasimir <unknown> 2004-07-30 22:15:47 +0000
commit: 64d30b1db8d571bc3b0d8947a81c59b4bd353417 (patch)
tree: 960779535be0249a03ef78d71326379180a2e5c6
parent: c4fb4881fa80488d9939b52bf333c2ac89fd4c52 (diff)
5 files changed, 158 insertions, 86 deletions
diff --git a/html/haddock.css b/html/haddock.css
index 1807a26e..c79f9446 100644
--- a/html/haddock.css
+++ b/html/haddock.css
@@ -36,7 +36,7 @@ TD.s15 {  height: 15px; }
 SPAN.keyword { text-decoration: underline; }
 
 /* Resize the buttom image to match the text size */
-IMG.coll { width : 1em; height: 1em; }
+IMG.coll { width : 0.5em; height: 0.5em; margin-bottom: 0.125em; margin-right: 0.125em }
 
 /* --------- Documentation elements ---------- */
 
diff --git a/src/HaddockHH.hs b/src/HaddockHH.hs
index 77d97bca..26269919 100644
--- a/src/HaddockHH.hs
+++ b/src/HaddockHH.hs
@@ -18,10 +18,9 @@ contentsHHFile, indexHHFile :: String
 contentsHHFile = "index.hhc"
 indexHHFile = "index.hhk"
 
-ppHHContents :: FilePath -> [(Module,Interface)] -> IO ()
-ppHHContents odir ifaces = do
-  let tree = mkModuleTree (map (\(mod,_) -> (mod,Nothing)) ifaces) --TODO: packages
-      html =
+ppHHContents :: FilePath -> [ModuleTree] -> IO ()
+ppHHContents odir tree = do
+  let html =
       	text "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">" $$
 	text "<HTML>" $$
 	text "<HEAD>" $$
diff --git a/src/HaddockHH2.hs b/src/HaddockHH2.hs
index 2fb673b9..df739384 100644
--- a/src/HaddockHH2.hs
+++ b/src/HaddockHH2.hs
@@ -12,16 +12,16 @@ import Data.List
 import Data.Char
 #endif
 
+import Maybe	( fromMaybe )
 import HaddockModuleTree
 import HaddockUtil
 import HaddockTypes
 
-ppHH2Contents :: FilePath -> String -> [(Module,Interface)] -> IO ()
-ppHH2Contents odir package ifaces = do
+ppHH2Contents :: FilePath -> Maybe String -> [ModuleTree] -> IO ()
+ppHH2Contents odir maybe_package tree = do
   let 	
 	contentsHH2File = package++".HxT"
 
-	tree = mkModuleTree (map (\(mod,_) -> (mod,Nothing)) ifaces) --TODO: packages
 	doc  =
 		text "<?xml version=\"1.0\"?>" $$
 		text "<!DOCTYPE HelpTOC SYSTEM \"ms-help://hx/resources/HelpTOC.DTD\">" $$
@@ -30,6 +30,8 @@ ppHH2Contents odir package ifaces = do
 		text "</HelpTOC>"
   writeFile (odir ++ pathSeparator:contentsHH2File) (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
@@ -59,8 +61,8 @@ ppHH2Contents odir package ifaces = do
 
 -----------------------------------------------------------------------------------
 
-ppHH2Index :: FilePath -> String -> [(Module,Interface)] -> IO ()
-ppHH2Index odir package ifaces = do
+ppHH2Index :: FilePath -> Maybe String -> [(Module,Interface)] -> IO ()
+ppHH2Index odir maybe_package ifaces = do
   let 
 	indexKHH2File     = package++"K.HxK"
 	indexNHH2File     = package++"N.HxK"
@@ -80,7 +82,9 @@ ppHH2Index odir package ifaces = do
 		text "</HelpIndex>"
   writeFile (odir ++ pathSeparator:indexKHH2File) (render docK)
   writeFile (odir ++ pathSeparator:indexNHH2File) (render docN)
-  where	
+  where
+	package = fromMaybe "pkg" maybe_package
+    
 	index :: [(HsName, [Module])]
 	index = fmToList (foldr getIfaceIndex emptyFM ifaces)
 
@@ -103,8 +107,8 @@ ppHH2Index odir package ifaces = do
 
 -----------------------------------------------------------------------------------
 
-ppHH2Files :: FilePath -> String -> [(Module,Interface)] -> IO ()
-ppHH2Files odir package ifaces = do
+ppHH2Files :: FilePath -> Maybe String -> [(Module,Interface)] -> IO ()
+ppHH2Files odir maybe_package ifaces = do
   let filesHH2File = package++".HxF"
       doc =
         text "<?xml version=\"1.0\"?>" $$
@@ -114,14 +118,16 @@ ppHH2Files odir 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 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 "\"/>" $$
+                text "<File Url=\""<>text minusFile<>text "\"/>") $$
         text "</HelpFileList>"
   writeFile (odir ++ pathSeparator:filesHH2File) (render doc)
   where
+    package = fromMaybe "pkg" maybe_package
+	
     ppMods [] = empty
     ppMods ((Module mdl,_):ifaces) =
 		text "<File Url=\"" <> text (moduleHtmlFile "" mdl) <> text "\"/>" $$
@@ -140,15 +146,16 @@ ppHH2Files odir package ifaces = do
 
 -----------------------------------------------------------------------------------
 
-ppHH2Collection :: FilePath -> String -> [(Module,Interface)] -> IO ()
-ppHH2Collection odir package ifaces = do
+ppHH2Collection :: FilePath -> String -> Maybe String -> IO ()
+ppHH2Collection odir doctitle maybe_package = do
   let 
+	package = fromMaybe "pkg" maybe_package
 	collectionHH2File = package++".HxC"
 	
 	doc =
 		text "<?xml version=\"1.0\"?>" $$
 		text "<!DOCTYPE HelpCollection SYSTEM \"ms-help://hx/resources/HelpCollection.DTD\">" $$
-		text "<HelpCollection DTDVersion=\"1.0\" LangId=\"1033\" Title=\"" <> text package <> text "\">" $$
+		text "<HelpCollection DTDVersion=\"1.0\" LangId=\"1033\" Title=\"" <> text doctitle <> text "\">" $$
 		nest 4 (text "<CompilerOptions CreateFullTextIndex=\"Yes\">" $$
 		        nest 4 (text "<IncludeFile File=\"" <> text package <> text ".HxF\"/>") $$
 		        text "</CompilerOptions>" $$
diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs
index 523f65b5..3233c408 100644
--- a/src/HaddockHtml.hs
+++ b/src/HaddockHtml.hs
@@ -6,7 +6,8 @@
 
 module HaddockHtml ( 
 	ppHtml, copyHtmlBits, 
-	ppHtmlIndex, ppHtmlContents
+	ppHtmlIndex, ppHtmlContents,
+	ppHtmlHelpFiles
   ) where
 
 import Prelude hiding (div)
@@ -18,12 +19,15 @@ import HaddockHH
 import HaddockHH2
 import HsSyn
 
-import IO
-import Maybe	( fromJust, isJust, fromMaybe )
+import Maybe	( fromJust, isJust )
 import List 	( sortBy )
 import Char	( isUpper, toUpper )
 import Monad	( when, unless )
 
+import Foreign
+import Control.Exception ( handle, bracket )
+import System.IO
+
 #if __GLASGOW_HASKELL__ < 503
 import FiniteMap
 #else
@@ -47,38 +51,61 @@ ppHtml	:: String
 	-> Maybe String			-- the index URL (--use-index)
 	-> IO ()
 
-ppHtml doctitle package source_url ifaces odir prologue maybe_html_help_format
+ppHtml doctitle maybe_package source_url ifaces odir prologue maybe_html_help_format
 	maybe_contents_url maybe_index_url =  do
   let
 	visible_ifaces = filter visible ifaces
 	visible (_, i) = OptHide `notElem` iface_options i
 
   when (not (isJust maybe_contents_url)) $ 
-    ppHtmlContents odir doctitle maybe_index_url 
+    ppHtmlContents odir doctitle maybe_package maybe_html_help_format maybe_index_url 
 	[ (m,iface{iface_package=Nothing}) | (m,iface) <- visible_ifaces ]
 	-- we don't want to display the packages in a single-package contents
 	prologue
 
   when (not (isJust maybe_index_url)) $ 
-    ppHtmlIndex odir doctitle maybe_contents_url visible_ifaces
+    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
+
+  mapM_ (ppHtmlModule odir doctitle source_url 
+	   maybe_contents_url maybe_index_url) visible_ifaces
+
+ppHtmlHelpFiles	
+    :: String                   -- doctitle
+    -> Maybe String				-- package
+	-> [(Module, Interface)]
+	-> FilePath                 -- destination directory
+	-> Maybe String             -- the Html Help format (--html-help)
+	-> IO ()
+ppHtmlHelpFiles doctitle maybe_package ifaces odir maybe_html_help_format =  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
-    Nothing       -> return ()
-    Just "mshelp" -> do
-		ppHHContents odir visible_ifaces
-		ppHHIndex    odir visible_ifaces
     Just "mshelp2" -> do
-		let pkg_name = fromMaybe "pkg" package
-		ppHH2Contents   odir pkg_name visible_ifaces
-		ppHH2Index      odir pkg_name visible_ifaces
-		ppHH2Files      odir pkg_name visible_ifaces
-		ppHH2Collection odir pkg_name visible_ifaces
-    Just format -> do
-		fail ("The "++format++" format is not implemented")
-
-  mapM_ (ppHtmlModule odir doctitle source_url 
-	   maybe_contents_url maybe_index_url) visible_ifaces
+		ppHH2Files      odir maybe_package visible_ifaces
+		ppHH2Collection odir doctitle maybe_package
+    _ -> return ()
+
+
+copyFile :: FilePath -> FilePath -> IO ()
+copyFile fromFPath toFPath =
+	(bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom ->
+	 bracket (openBinaryFile toFPath WriteMode) hClose $ \hTo ->
+	 allocaBytes bufferSize $ \buffer ->
+		copyContents hFrom hTo buffer)
+	where
+		bufferSize = 1024
+		
+		copyContents hFrom hTo buffer = do
+			count <- hGetBuf hFrom buffer bufferSize
+			when (count > 0) $ do
+				hPutBuf hTo buffer count
+				copyContents hFrom hTo buffer
 
 
 copyHtmlBits :: FilePath -> FilePath -> Maybe FilePath -> IO ()
@@ -88,14 +115,11 @@ copyHtmlBits odir libdir maybe_css = do
 			Nothing -> libdir ++ pathSeparator:cssFile
 			Just f  -> f
 	css_destination = odir ++ pathSeparator:cssFile
-
-	copyFile f = do
-	   s <- readFile (libdir ++ pathSeparator:f)
-	   writeFile (odir ++ pathSeparator:f) s
-  
-  css_contents <- readFile css_file
-  writeFile css_destination css_contents
-  mapM_ copyFile [ iconFile, plusFile, minusFile, jsFile ]
+	copyLibFile f = do
+	   copyFile (libdir ++ pathSeparator:f) (odir ++ pathSeparator:f)
+ 
+  copyFile css_file css_destination
+  mapM_ copyLibFile [ iconFile, plusFile, minusFile, jsFile ]
 
 footer :: HtmlTable
 footer = 
@@ -179,17 +203,21 @@ moduleInfo iface =
 -- Generate the module contents
 
 ppHtmlContents
-   :: FilePath -> String
+   :: FilePath
+   -> String
+   -> Maybe String
+   -> Maybe String
    -> Maybe String
    -> [(Module,Interface)] -> Maybe Doc
    -> IO ()
-ppHtmlContents odir doctitle maybe_index_url
+ppHtmlContents odir doctitle maybe_package maybe_html_help_format maybe_index_url
   mdls prologue = do
   let tree = mkModuleTree [(mod,iface_package iface) | (mod,iface) <- mdls]
       html = 
-	header (thetitle (toHtml doctitle) +++
-		thelink ! [href cssFile, 
-		  rel "stylesheet", thetype "text/css"]) +++
+	header 
+		((thetitle (toHtml doctitle)) +++
+		 (thelink ! [href cssFile, rel "stylesheet", thetype "text/css"]) +++
+		 (script ! [src jsFile, thetype "text/javascript"] $ noHtml)) +++
         body << vanillaTable << (
    	    simpleHeader doctitle Nothing maybe_index_url </>
 	    ppPrologue doctitle prologue </>
@@ -198,6 +226,13 @@ ppHtmlContents odir doctitle maybe_index_url
 	    footer
 	  )
   writeFile (odir ++ pathSeparator:contentsHtmlFile) (renderHtml html False)
+  
+  -- Generate contents page for Html Help if requested
+  case maybe_html_help_format of
+    Nothing        -> return ()
+    Just "mshelp"  -> ppHHContents  odir tree
+    Just "mshelp2" -> ppHH2Contents odir maybe_package tree
+    Just format    -> fail ("The "++format++" format is not implemented")
 
 ppPrologue :: String -> Maybe Doc -> HtmlTable
 ppPrologue title Nothing = Html.emptyTable
@@ -208,41 +243,61 @@ ppPrologue title (Just doc) =
 ppModuleTree :: String -> [ModuleTree] -> HtmlTable
 ppModuleTree _ ts = 
   tda [theclass "section1"] << toHtml "Modules" </>
-  td <<  table ! [cellpadding 0, cellspacing 2] << 
-	(aboves (map (mkNode 0 []) ts) <-> mkPackages ts)
-
-mkNode :: Int -> [String] -> ModuleTree -> HtmlTable
-mkNode n ss (Node s leaf pkg []) =
-  mkLeaf n s ss leaf
-mkNode n ss (Node s leaf pkg ts) = 
-  mkLeaf n s ss leaf
-  </>
-  aboves (map (mkNode (n+1) (s:ss)) ts)
-
-mkLeaf :: Int -> String -> [String] -> Bool -> HtmlTable
-mkLeaf n s _ False = pad_td n << toHtml s
-mkLeaf n s ss True = pad_td n << ppHsModule mdl
-  where mdl = foldr (++) "" (s' : map ('.':) ss')
-	(s':ss') = reverse (s:ss)
-	 -- reconstruct the module name
+  td <<  table ! [cellpadding 0, cellspacing 2] << htmlTable
+  where
+    genTable htmlTable id []     = (htmlTable,id)
+    genTable htmlTable id (x:xs) = genTable (htmlTable </> u) id' xs      
+      where
+        (u,id') = mkNode [] x id
 
-pad_td 0 = td
-pad_td n = tda [thestyle ("padding-left:" ++ show (n*20) ++ "px")]
+    (htmlTable,_) = genTable emptyTable 0 ts
 
-mkPackages :: [ModuleTree] -> HtmlTable
-mkPackages ts = aboves (map go ts)
-  where go (Node s leaf pkg ts) = tda [theclass "pkg"] << mkPkg pkg </> aboves (map go ts)
+mkNode :: [String] -> ModuleTree -> Int -> (HtmlTable,Int)
+mkNode ss (Node s leaf pkg ts) id = htmlNode
+  where
+    htmlNode = case ts of
+      [] -> ( pad_td 15 << htmlModule                           <-> htmlPkg,id)
+      _  -> ((pad_td  0 << (collapsebutton id_s +++ htmlModule) <-> htmlPkg) </> 
+                (pad_td 20 << sub_tree), id')
+
+    htmlModule 
+      | leaf      = ppHsModule mdl
+      | otherwise = toHtml s
 
-mkPkg :: Maybe String -> Html
-mkPkg Nothing = empty
-mkPkg (Just p) = toHtml p
+    htmlPkg = case pkg of
+      Nothing -> td << empty
+      Just p  -> td << toHtml p
+
+    mdl = foldr (++) "" (s' : map ('.':) ss')
+    (s':ss') = reverse (s:ss)
+	 -- reconstruct the module name
+    
+    id_s = show id
+    
+    (sub_tree,id') = genSubTree emptyTable (id+1) ts
+    
+    genSubTree :: HtmlTable -> Int -> [ModuleTree] -> (Html,Int)
+    genSubTree htmlTable id [] = (sub_tree,id)
+      where
+        sub_tree = table ! [identifier id_s, thestyle "display:none;", cellpadding 0, cellspacing 0, width "100%"] << htmlTable
+    genSubTree htmlTable id (x:xs) = genSubTree (htmlTable </> u) id' xs      
+      where
+        (u,id') = mkNode (s:ss) x id
+
+    pad_td 0 = tda [width "100%"]
+    pad_td n = tda [thestyle ("padding-left:" ++ show n ++ "px"), width "100%"]
 
 -- ---------------------------------------------------------------------------
 -- Generate the index
 
-ppHtmlIndex :: FilePath -> String -> Maybe String
-   -> [(Module,Interface)] -> IO ()
-ppHtmlIndex odir doctitle maybe_contents_url ifaces = do
+ppHtmlIndex :: FilePath
+            -> String 
+            -> Maybe String
+            -> Maybe String
+            -> Maybe String
+            -> [(Module,Interface)] 
+            -> IO ()
+ppHtmlIndex odir doctitle maybe_package maybe_html_help_format maybe_contents_url ifaces = do
   let html = 
 	header (thetitle (toHtml (doctitle ++ " (Index)")) +++
 		thelink ! [href cssFile, 
@@ -256,7 +311,13 @@ ppHtmlIndex odir doctitle maybe_contents_url ifaces = do
     mapM_ (do_sub_index index) initialChars
 
   writeFile (odir ++ pathSeparator:indexHtmlFile) (renderHtml html False)
-
+  
+    -- Generate index and contents page for Html Help if requested
+  case maybe_html_help_format of
+    Nothing        -> return ()
+    Just "mshelp"  -> ppHHIndex odir ifaces
+    Just "mshelp2" -> ppHH2Index odir maybe_package ifaces
+    Just format    -> fail ("The "++format++" format is not implemented")
  where
   split_indices = length index > 50
 
diff --git a/src/Main.hs b/src/Main.hs
index 1070538b..11ce079d 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -195,6 +195,11 @@ run flags files = do
 		[] -> Nothing
 		us -> Just (last us)
 
+      maybe_html_help_format =
+	case [hhformat | Flag_HtmlHelp hhformat <- flags] of
+		[]      -> Nothing
+		formats -> Just (last formats)
+		
   prologue <- getPrologue flags
 
   read_ifaces_s <- mapM readIface (map snd ifaces_to_read)
@@ -213,12 +218,15 @@ run flags files = do
 	die ("-h cannot be used with --gen-index or --gen-contents")
 
   when (Flag_GenContents `elem` flags) $ do
-	ppHtmlContents odir title maybe_index_url visible_read_ifaces prologue
+	ppHtmlContents odir title package maybe_html_help_format maybe_index_url visible_read_ifaces prologue
         copyHtmlBits odir libdir css_file
 
   when (Flag_GenIndex `elem` flags) $ do
-	ppHtmlIndex odir title maybe_contents_url visible_read_ifaces
+	ppHtmlIndex odir title package maybe_html_help_format maybe_contents_url visible_read_ifaces
         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		
 
   parsed_mods <- mapM parse_file files
 
@@ -255,11 +263,8 @@ run flags files = do
 			     | (mdl, i) <-  these_mod_ifaces ])
 
   when (Flag_Html `elem` flags) $ do
-    let hhformat = case [hhformat | Flag_HtmlHelp hhformat <- flags] of
-		[]      -> Nothing
-		formats -> Just (last formats)
     ppHtml title package source_url these_mod_ifaces odir
-		prologue hhformat
+		prologue maybe_html_help_format
 		maybe_contents_url maybe_index_url
     copyHtmlBits odir libdir css_file
author	krasimir <unknown>	2004-07-30 22:15:47 +0000
committer	krasimir <unknown>	2004-07-30 22:15:47 +0000
commit	64d30b1db8d571bc3b0d8947a81c59b4bd353417 (patch)
tree	960779535be0249a03ef78d71326379180a2e5c6
parent	c4fb4881fa80488d9939b52bf333c2ac89fd4c52 (diff)