[haddock @ 2002-04-24 15:14:11 by simonmar]

Grok the kind of module headers we use in fptools/libraries, and pass
the "portability", "stability", and "maintainer" strings through into
the generated HTML.  If the module header doesn't match the pattern,
then we don't include the info in the HTML.

4 files changed, 78 insertions, 36 deletions

diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs
index 8e02e535..2b2c4f3e 100644
--- a/src/HaddockHtml.hs
+++ b/src/HaddockHtml.hs
@@ -108,23 +108,28 @@ pageHeader mod iface title source_url =
    tda [theclass "modulebar"] <<
 	(vanillaTable << (
 	  (td << font ! [size "6"] << toHtml mod) <->
-          (tda [align "right"] <<
+	  moduleInfo iface
+	)
+    )
+
+moduleInfo iface 
+  | Nothing   <- iface_info iface = Html.emptyTable
+  | Just info <- iface_info iface =
+          tda [align "right"] <<
              (table ! [width "300", border 0, cellspacing 0, cellpadding 0] << (
         	  (tda [width "50%"] << font ! [color "#ffffff"] <<
         		bold << toHtml "Portability") <->
         	  (tda [width "50%"] << font ! [color "#ffffff"] <<
-        		toHtml (iface_portability iface)) </>
+        		toHtml (portability info)) </>
         	  (tda [width "50%"] << font ! [color "#ffffff"] <<
         		bold << toHtml "Stability") <->
         	  (tda [width "50%"] << font ! [color "#ffffff"] <<
-        		toHtml (iface_stability iface)) </>
+        		toHtml (stability info)) </>
         	  (tda [width "50%"] << font ! [color "#ffffff"] <<
         		bold << toHtml "Maintainer") <->
         	  (tda [width "50%"] << font ! [color "#ffffff"] <<
-        		toHtml (iface_maintainer iface))
+        		toHtml (maintainer info))
               ))
-	  ))
-    )
 
 -- ---------------------------------------------------------------------------
 -- Generate the module contents
diff --git a/src/HaddockTypes.hs b/src/HaddockTypes.hs
index c157a753..21ee513c 100644
--- a/src/HaddockTypes.hs
+++ b/src/HaddockTypes.hs
@@ -6,7 +6,7 @@
 
 module HaddockTypes (
   -- * Module interfaces
-  NameEnv, Interface(..), ExportItem(..), ModuleMap,
+  NameEnv, Interface(..), ModuleInfo(..), ExportItem(..), ModuleMap,
 
   -- * User documentation strings
   DocString, GenDoc(..), Doc, ParsedDoc, DocMarkup(..),
@@ -49,15 +49,18 @@ data Interface
 		-- Includes not just "main names" but names of constructors,
 		-- record fields, etc.
 
-	iface_portability :: String,
-	iface_stability   :: String,
-	iface_maintainer  :: String,
+	iface_info :: Maybe ModuleInfo,
 		-- ^ information from the module header
 
-	iface_doc	  :: Maybe Doc
+	iface_doc :: Maybe Doc
 		-- ^ documentation from the module header
   }
 
+data ModuleInfo = ModuleInfo
+	{ portability :: String,
+	  stability   :: String,
+	  maintainer  :: String }
+
 type DocString = String
 
 data ExportItem 
diff --git a/src/HaddockUtil.hs b/src/HaddockUtil.hs
index 51c31438..8173cedf 100644
--- a/src/HaddockUtil.hs
+++ b/src/HaddockUtil.hs
@@ -13,12 +13,18 @@ module HaddockUtil (
 
   -- * Filename utilities
   basename, dirname, splitFilename3, 
-  isPathSeparator, pathSeparator
+  isPathSeparator, pathSeparator,
+
+  -- * Miscellaneous utilities
+  die, dieMsg, mapSnd, mapMaybeM
 
  ) where
 
 import HsSyn
-import List (intersect)
+
+import List	( intersect )
+import IO	( hPutStr, stderr )
+import System
 
 -- -----------------------------------------------------------------------------
 -- Some Utilities
@@ -136,3 +142,19 @@ isPathSeparator ch =
 #else
   ch == '/'
 #endif
+
+-----------------------------------------------------------------------------
+-- misc.
+
+die :: String -> IO a
+die s = hPutStr stderr s >> exitWith (ExitFailure 1)
+
+dieMsg :: String -> IO a
+dieMsg s = getProgName >>= \prog -> die (prog ++ ": " ++ s)
+
+mapSnd f [] = []
+mapSnd f ((x,y):xs) = (x,f y) : mapSnd f xs
+
+mapMaybeM :: Monad m => (a -> m b) -> Maybe a -> m (Maybe b)
+mapMaybeM f Nothing = return Nothing
+mapMaybeM f (Just a) = f a >>= return . Just
diff --git a/src/Main.hs b/src/Main.hs
index 7be91b9a..ee6c0d3b 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -24,6 +24,7 @@ import FiniteMap
 
 --import Pretty
 
+import RegexString
 import List	( nub )
 import Monad	( when )
 import Char	( isSpace )
@@ -144,9 +145,7 @@ mkInterface mod_map filename (HsModule mod exps imps decls maybe_doc)
 	   iface_exports = renamed_export_list,
 	   iface_orig_exports = orig_export_list,
 	   iface_decls =  decl_map,
-	   iface_portability = "portable",
-	   iface_maintainer  = "libraries@haskell.org",
-	   iface_stability   = "stable",
+	   iface_info = maybe_info,
 	   iface_name_docs   = doc_map,
 	   iface_doc         = module_doc
 	},
@@ -154,11 +153,13 @@ mkInterface mod_map filename (HsModule mod exps imps decls maybe_doc)
       missing_names1 ++ missing_names2 --ignore missing_names3 for now,
     )
   where
-  (module_doc, missing_names_doc1) = 
+  (module_doc, maybe_info, missing_names_doc1) = 
     case maybe_doc of
-	Nothing  -> (Nothing, [])
-	Just doc -> (Just doc', ns)
-	  where (doc',ns) = formatDocString (lookupForDoc import_env) doc
+	Nothing  -> (Nothing, Nothing, [])
+	Just doc -> (Just doc2, maybe_info, ns)
+	  where 
+	    (doc1, maybe_info) = parseModuleHeader doc
+	    (doc2,ns) = formatDocString (lookupForDoc import_env) doc1
 
   locally_defined_names = collectNames decls
 
@@ -524,19 +525,30 @@ strToHsQNames str
 		     Qual (Module mod) (HsVarName (HsSymbol str)) ]
 	other -> []
 
------------------------------------------------------------------------------
--- misc.
-
-die :: String -> IO a
-die s = hPutStr stderr s >> exitWith (ExitFailure 1)
-
-dieMsg :: String -> IO a
-dieMsg s = getProgName >>= \prog -> die (prog ++ ": " ++ s)
-
-mapSnd f [] = []
-mapSnd f ((x,y):xs) = (x,f y) : mapSnd f xs
-
-mapMaybeM :: Monad m => (a -> m b) -> Maybe a -> m (Maybe b)
-mapMaybeM f Nothing = return Nothing
-mapMaybeM f (Just a) = f a >>= return . Just
-
+-- -----------------------------------------------------------------------------
+-- Parsing module headers
+
+parseModuleHeader :: String -> (String, Maybe ModuleInfo)
+parseModuleHeader str =
+  case matchRegexAll moduleHeaderRE str of
+	Just (before, match, after, _, (_:_:_:s1:s2:s3:_)) -> 
+	   (after, Just (ModuleInfo { 
+				 portability = s3,
+				 stability   = s2,
+				 maintainer  = s1 }))
+	_other -> (str, Nothing)
+
+moduleHeaderRE = mkRegexWithOpts
+			 "^([ \t\n]*Module[ \t]*:.*\n)?\ 
+			  \([ \t\n]*Copyright[ \t]*:.*\n)?\ 
+			  \([ \t\n]*License[ \t]*:.*\n)?\ 
+			  \[ \t\n]*Maintainer[ \t]*:(.*)\n\ 
+			  \[ \t\n]*Stability[ \t]*:(.*)\n\ 
+			  \[ \t\n]*Portability[ \t]*:([^\n]*)\n"
+		True -- match "\n" with "."
+		False -- not case sensitive
+	-- All fields except the last (Portability) may be multi-line.
+	-- This is so that the portability field doesn't swallow up the
+	-- rest of the module documentation - we might want to revist
+	-- this at some point (perhaps have a separator between the 
+	-- portability field and the module documentation?).