From db6d762f755e94540ce1d42e03c4fde8f26cb4c2 Mon Sep 17 00:00:00 2001
From: simonmar <unknown>
Date: Thu, 6 Nov 2003 16:48:14 +0000
Subject: [haddock @ 2003-11-06 16:48:11 by simonmar] - Include the OptHide
 setting in the interface, so we don't include   hidden modules in the
 combined index/contents.

- Add a -k/--package flag to set the package name for the current set
  of modules.  The package name for each module is now shown in the
  right-hand column of the contents, in a combined contents page.
---
 src/Binary.hs            | 19 +++++++++++++++++
 src/HaddockHH.hs         |  6 +++---
 src/HaddockHtml.hs       | 53 ++++++++++++++++++++++++++++++------------------
 src/HaddockModuleTree.hs | 32 +++++++++++++++++------------
 src/HaddockTypes.hs      |  2 ++
 src/Main.hs              | 39 +++++++++++++++++++++++------------
 6 files changed, 102 insertions(+), 49 deletions(-)
diff --git a/src/Binary.hs b/src/Binary.hs
index 07180a8a..2703439a 100644
--- a/src/Binary.hs
+++ b/src/Binary.hs
@@ -474,6 +474,25 @@ instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where
                          d <- get bh
                          return (a,b,c,d)
 
+instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d,e) where
+    put_ bh (a,b,c,d,e) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e
+    get bh          = do a <- get bh
+                         b <- get bh
+                         c <- get bh
+                         d <- get bh
+                         e <- get bh
+                         return (a,b,c,d,e)
+
+instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f) => Binary (a,b,c,d,e,f) where
+    put_ bh (a,b,c,d,e,f) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; put_ bh f
+    get bh          = do a <- get bh
+                         b <- get bh
+                         c <- get bh
+                         d <- get bh
+                         e <- get bh
+                         f <- get bh
+                         return (a,b,c,d,e,f)
+
 instance Binary a => Binary (Maybe a) where
     put_ bh Nothing  = putByte bh 0
     put_ bh (Just a) = do putByte bh 1; put_ bh a
diff --git a/src/HaddockHH.hs b/src/HaddockHH.hs
index 9357c00c..f10c970e 100644
--- a/src/HaddockHH.hs
+++ b/src/HaddockHH.hs
@@ -20,7 +20,7 @@ indexHHFile = "index.hhk"
 
 ppHHContents :: FilePath -> [Module] -> IO ()
 ppHHContents odir mods = do
-  let tree = mkModuleTree mods
+  let tree = mkModuleTree (zip mods (repeat Nothing)) --TODO: packages
       html =
       	text "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">" $$
 	text "<HTML>" $$
@@ -47,9 +47,9 @@ ppHHContents odir mods = do
         fn _  []     = error "HaddockHH.ppHHContents.fn: no module trees given"
 
 	ppNode :: [String] -> ModuleTree -> Doc
-	ppNode ss (Node s leaf []) =
+	ppNode ss (Node s leaf _pkg []) =
 	  ppLeaf s ss leaf
-	ppNode ss (Node s leaf ts) =
+	ppNode ss (Node s leaf _pkg ts) =
 	  ppLeaf s ss leaf $$
 	  text "<UL>" $+$
 	  nest 4 (fn (s:ss) ts) $+$
diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs
index fd09bfaa..9c3be7b3 100644
--- a/src/HaddockHtml.hs
+++ b/src/HaddockHtml.hs
@@ -62,7 +62,9 @@ ppHtml doctitle source_url ifaces odir prologue do_ms_help
 
   when (not (isJust maybe_contents_url)) $ 
     ppHtmlContents odir doctitle maybe_index_url 
-	(map fst visible_ifaces) prologue
+	[ (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
@@ -186,51 +188,62 @@ moduleInfo iface =
 ppHtmlContents
    :: FilePath -> String
    -> Maybe String
-   -> [Module] -> Maybe Doc
+   -> [(Module,Interface)] -> Maybe Doc
    -> IO ()
 ppHtmlContents odir doctitle maybe_index_url
   mdls prologue = do
-  let tree = mkModuleTree mdls  
+  let tree = mkModuleTree [(mod,iface_package iface) | (mod,iface) <- mdls]
       html = 
 	header (thetitle (toHtml doctitle) +++
 		thelink ! [href cssFile, 
 		  rel "stylesheet", thetype "text/css"]) +++
         body << vanillaTable << (
    	    simpleHeader doctitle Nothing maybe_index_url </>
-	    ppPrologue prologue </>
+	    ppPrologue doctitle prologue </>
 	    ppModuleTree doctitle tree </>
 	    s15 </>
 	    footer
 	  )
   writeFile (odir ++ pathSeparator:contentsHtmlFile) (renderHtml html)
 
-ppPrologue :: Maybe Doc -> HtmlTable
-ppPrologue Nothing = Html.emptyTable
-ppPrologue (Just doc) = 
-  (tda [theclass "section1"] << toHtml "Description") </>
+ppPrologue :: String -> Maybe Doc -> HtmlTable
+ppPrologue title Nothing = Html.emptyTable
+ppPrologue title (Just doc) = 
+  (tda [theclass "section1"] << toHtml title) </>
   docBox (docToHtml doc)
 
 ppModuleTree :: String -> [ModuleTree] -> HtmlTable
 ppModuleTree _ ts = 
   tda [theclass "section1"] << toHtml "Modules" </>
-  td <<  table ! [cellpadding 0, cellspacing 2] << aboves (map (mkNode []) ts)
-
-mkNode :: [String] -> ModuleTree -> HtmlTable
-mkNode ss (Node s leaf []) =
-  td << mkLeaf s ss leaf
-mkNode ss (Node s leaf ts) = 
-  (td << mkLeaf s ss leaf)
+  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
   </>
-  (tda [theclass "children"] << 
-     vanillaTable (toHtml (aboves (map (mkNode (s:ss)) ts))))
+  aboves (map (mkNode (n+1) (s:ss)) ts)
 
-mkLeaf :: String -> [String] -> Bool -> Html
-mkLeaf s _ False = toHtml s
-mkLeaf s ss True  = ppHsModule mdl
+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
 
+pad_td 0 = td
+pad_td n = tda [thestyle ("padding-left:" ++ show (n*20) ++ "px")]
+
+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)
+
+mkPkg :: Maybe String -> Html
+mkPkg Nothing = empty
+mkPkg (Just p) = toHtml p
+
 -- ---------------------------------------------------------------------------
 -- Generate the index
 
diff --git a/src/HaddockModuleTree.hs b/src/HaddockModuleTree.hs
index 93f0f162..f052bd69 100644
--- a/src/HaddockModuleTree.hs
+++ b/src/HaddockModuleTree.hs
@@ -2,22 +2,28 @@ module HaddockModuleTree(ModuleTree(..), mkModuleTree) where
 
 import HsSyn
 
-data ModuleTree = Node String Bool [ModuleTree]
+data ModuleTree = Node String Bool (Maybe String) [ModuleTree]
 
-mkModuleTree :: [Module] -> [ModuleTree]
-mkModuleTree mods = foldr addToTrees [] (map splitModule mods)
+mkModuleTree :: [(Module,Maybe String)] -> [ModuleTree]
+mkModuleTree mods = 
+  foldr fn [] [ (splitModule mod, pkg) | (mod,pkg) <- mods ]
+  where 
+    fn (mod,pkg) trees = addToTrees mod pkg trees
 
-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
+addToTrees :: [String] -> Maybe String -> [ModuleTree] -> [ModuleTree]
+addToTrees [] pkg ts = ts
+addToTrees ss pkg [] = mkSubTree ss pkg
+addToTrees (s1:ss) pkg (t@(Node s2 leaf node_pkg subs) : ts)
+  | s1 >  s2  = t : addToTrees (s1:ss) pkg ts
+  | s1 == s2  = Node s2 (leaf || null ss) this_pkg (addToTrees ss pkg subs) : ts
+  | otherwise = mkSubTree (s1:ss) pkg ++ t : ts
+ where
+  this_pkg = if null ss then pkg else node_pkg
 
-mkSubTree :: [String] -> [ModuleTree]
-mkSubTree [] = []
-mkSubTree (s:ss) = [Node s (null ss) (mkSubTree ss)]
+mkSubTree :: [String] -> Maybe String -> [ModuleTree]
+mkSubTree []     pkg = []
+mkSubTree [s]    pkg = [Node s True pkg []]
+mkSubTree (s:ss) pkg = [Node s (null ss) Nothing (mkSubTree ss pkg)]
 
 splitModule :: Module -> [String]
 splitModule (Module mdl) = split mdl
diff --git a/src/HaddockTypes.hs b/src/HaddockTypes.hs
index 74916099..174b13a2 100644
--- a/src/HaddockTypes.hs
+++ b/src/HaddockTypes.hs
@@ -30,6 +30,8 @@ data Interface
 	iface_filename :: FilePath,
 		-- ^ the filename that contains the source code for this module
 
+	iface_package :: Maybe String,
+
 	iface_env :: NameEnv,
 		-- ^ environment mapping names to *original* names
 
diff --git a/src/Main.hs b/src/Main.hs
index 3d5f97b4..0fcd44d6 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -69,6 +69,7 @@ data Flag
 --  | Flag_DocBook
   | Flag_DumpInterface FilePath
   | Flag_Heading String
+  | Flag_Package String
   | Flag_Html
   | Flag_Lib String
   | Flag_MSHtmlHelp
@@ -111,6 +112,8 @@ options =
 	"file containing prologue text",
     Option ['t']  ["title"]    (ReqArg Flag_Heading "TITLE")
 	"page heading",
+    Option ['k']  ["package"]  (ReqArg Flag_Package "PACKAGE")
+	"package name (optional)",
     Option ['n']  ["no-implicit-prelude"] (NoArg Flag_NoImplicitPrelude)
  	"do not assume Prelude is imported",
     Option ['d']  ["debug"]  (NoArg Flag_Debug)
@@ -147,6 +150,10 @@ run flags files = do
 		[] -> ""
 		(t:_) -> t
 
+      package = case [str | Flag_Package str <- flags] of
+		[] -> Nothing
+		(t:_) -> Just t
+
       source_url = case [str | Flag_SourceURL str <- flags] of
 			[] -> Nothing
 			(t:_) -> Just t
@@ -187,24 +194,25 @@ run flags files = do
 
   read_ifaces_s <- mapM readIface (map snd ifaces_to_read)
 
+  let read_ifaces = concat read_ifaces_s
+      visible_read_ifaces = filter ((OptHide `notElem`) . iface_options . snd) 
+				read_ifaces
+      external_mods = map fst read_ifaces
+
   updateHTMLXRefs (map fst ifaces_to_read) read_ifaces_s
 
   writeIORef saved_flags flags
 
   when (Flag_GenContents `elem` flags) $ do
-	ppHtmlContents odir title maybe_index_url 
-		(map fst (concat read_ifaces_s)) prologue
+	ppHtmlContents odir title maybe_index_url visible_read_ifaces prologue
         copyHtmlBits odir libdir css_file
 
   when (Flag_GenIndex `elem` flags) $ do
-	ppHtmlIndex odir title maybe_contents_url (concat read_ifaces_s)
+	ppHtmlIndex odir title maybe_contents_url visible_read_ifaces
         copyHtmlBits odir libdir css_file
 
   parsed_mods <- mapM parse_file files
 
-  let read_ifaces = concat read_ifaces_s
-      external_mods = map fst read_ifaces
-
   sorted_mod_files <- sortModules (zip parsed_mods files)
 	-- emits an error message if there are recursive modules
 
@@ -214,7 +222,8 @@ run flags files = do
 	loop ifaces [] = return ifaces
 	loop ifaces ((hsmod,file):mdls)  = do 
 	   let ((mdl,iface),msgs) = runWriter $
-		   mkInterface no_implicit_prelude verbose ifaces file hsmod
+		   mkInterface no_implicit_prelude verbose ifaces 
+			file package hsmod
 	       new_ifaces = addToFM ifaces mdl iface
 	   mapM (hPutStrLn stderr) msgs
 	   loop new_ifaces mdls
@@ -251,7 +260,9 @@ run flags files = do
 	writeBinMem bh fn
       where
 	prepared_ifaces = 
-	  [ (mdl, fmToList (iface_env iface), 
+	  [ (mdl, iface_package iface,
+		  OptHide `elem` iface_options iface,
+		  fmToList (iface_env iface), 
 		  fmToList (iface_reexported iface),
 		  fmToList (iface_sub iface))
 	  | (mdl, iface) <- these_mod_ifaces ]
@@ -268,9 +279,10 @@ readIface filename = do
   stuff <- get bh
   return (map to_interface stuff)
  where 
-   to_interface (mdl, env, reexported, sub) = 
+   to_interface (mdl, package, hide, env, reexported, sub) = 
 	  (mdl, Interface { 
 		   iface_filename     = "",
+		   iface_package      = package,
 		   iface_env          = listToFM env,
 		   iface_import_env   = emptyFM,
 		   iface_sub	      = listToFM sub,
@@ -281,7 +293,7 @@ readIface filename = do
 		   iface_decls        = emptyFM,
 		   iface_info	      = Nothing,
 		   iface_doc          = Nothing,
-		   iface_options      = []
+		   iface_options      = if hide then [OptHide] else []
 		}
       	  )
 		
@@ -290,7 +302,7 @@ updateHTMLXRefs :: [FilePath] -> [[(Module,Interface)]] -> IO ()
 updateHTMLXRefs paths ifaces_s =
   writeIORef html_xrefs_ref (listToFM mapping)
  where
-  mapping = [ (mdl,fpath) 
+  mapping = [ (mdl, fpath)
 	    | (fpath, ifaces) <- zip paths ifaces_s,
 	      (mdl, _iface) <- ifaces
 	    ]
@@ -323,13 +335,13 @@ getPrologue flags
 mkInterface
    :: Bool				-- no implicit prelude
    -> Bool				-- verbose
-   -> ModuleMap -> FilePath -> HsModule
+   -> ModuleMap -> FilePath -> Maybe String -> HsModule
    -> ErrMsgM (
 	       Module, 		-- the module name
 	       Interface	-- its "interface"
 	      )
 
-mkInterface no_implicit_prelude verbose mod_map filename 
+mkInterface no_implicit_prelude verbose mod_map filename package
 	(HsModule mdl exps imps decls maybe_opts maybe_info maybe_doc) = do  
 
   -- Process the options, if available
@@ -453,6 +465,7 @@ mkInterface no_implicit_prelude verbose mod_map filename
 
   return (mdl, Interface { 
 		   iface_filename     = filename,
+		   iface_package      = package,
 		   iface_env          = name_env,
 		   iface_import_env   = import_env,
 		   iface_reexported   = reexports,
-- 
cgit v1.2.3

