From af7f8c0379dc19ee831e25b64c9e94e733f331be Mon Sep 17 00:00:00 2001
From: simonmar <unknown>
Date: Mon, 9 Aug 2004 11:55:07 +0000
Subject: [haddock @ 2004-08-09 11:55:05 by simonmar] Add support for a short
 description for each module, which is included in the contents.

The short description should be given in a "Description: " field of
the header.  Included in this patch are changes that make the format
of the header a little more flexible.  From the comments:

-- all fields in the header are optional and have the form
--
-- [spaces1][field name][spaces] ":"
--    [text]"\n" ([spaces2][space][text]"\n" | [spaces]"\n")*
-- where each [spaces2] should have [spaces1] as a prefix.
--
-- Thus for the key "Description",
--
-- > Description : this is a
-- >    rather long
-- >
-- >    description
-- >
-- > The module comment starts here
--
-- the value will be "this is a .. description" and the rest will begin
-- at "The module comment".

The header fields must be in the following order: Module, Description,
Copyright, License, Maintainer, Stability, Portability.

Patches submitted by: George Russell <ger@informatik.uni-bremen.de>,
with a few small changes be me, mostly to merge with other recent
changes.

ToDo: document the module header.
---
 src/Binary.hs            |   8 +-
 src/HaddockHH.hs         |   4 +-
 src/HaddockHtml.hs       |  47 ++++++----
 src/HaddockModuleTree.hs |  31 ++++---
 src/HaddockTypes.hs      |   2 +-
 src/HaddockUtil.hs       | 232 ++++++++++++++++++++++++++++++++++++++---------
 src/HsParser.ly          |  24 +++--
 src/HsSyn.lhs            |  24 +++--
 src/Main.hs              | 143 +++++++++++++++++++++--------
 9 files changed, 384 insertions(+), 131 deletions(-)

(limited to 'src')

diff --git a/src/Binary.hs b/src/Binary.hs
index 092d29f2..eb7b9929 100644
--- a/src/Binary.hs
+++ b/src/Binary.hs
@@ -51,11 +51,11 @@ module Binary
 --   putBinFileWithDict,	-- :: Binary a => FilePath -> Module -> a -> IO ()
 
     -- re-export for the benefit of other modules.
-   openBinaryFile 
+   openBinaryFile, 
 
-  FormatVersion,
-  nullFormatVersion,
-  mkFormatVersion,
+   FormatVersion,
+   nullFormatVersion,
+   mkFormatVersion,
   ) where
 
 #include "MachDeps.h"
diff --git a/src/HaddockHH.hs b/src/HaddockHH.hs
index e0e9a97a..8ad4dfe2 100644
--- a/src/HaddockHH.hs
+++ b/src/HaddockHH.hs
@@ -57,9 +57,9 @@ ppHHContents odir doctitle maybe_package tree = do
         fn _  []     = error "HaddockHH.ppHHContents.fn: no module trees given"
 
 	ppNode :: [String] -> ModuleTree -> Doc
-	ppNode ss (Node s leaf _pkg []) =
+	ppNode ss (Node s leaf _pkg _ []) =
 	  ppLeaf s ss leaf
-	ppNode ss (Node s leaf _pkg 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 96d8d816..17cab01e 100644
--- a/src/HaddockHtml.hs
+++ b/src/HaddockHtml.hs
@@ -20,7 +20,7 @@ import HaddockHH2
 import HaddockDevHelp
 import HsSyn
 
-import Maybe	( fromJust, isJust )
+import Maybe	( fromJust, isJust, mapMaybe )
 import List 	( sortBy )
 import Char	( isUpper, toUpper )
 import Monad	( when, unless )
@@ -194,17 +194,26 @@ pageHeader mdl iface doctitle source_url maybe_contents_url maybe_index_url =
 
 moduleInfo :: Interface -> HtmlTable
 moduleInfo iface = 
-  case iface_info iface of
-    Nothing   -> Html.emptyTable
-    Just info ->
-          tda [align "right"] << narrowTable << (
-        	  (tda [theclass "infohead"] << toHtml "Portability") <->
-        	  (tda [theclass "infoval"] << toHtml (portability info)) </>
-        	  (tda [theclass "infohead"] << toHtml "Stability") <->
-        	  (tda [theclass "infoval"] << toHtml (stability info)) </>
-        	  (tda [theclass "infohead"] << toHtml "Maintainer") <->
-        	  (tda [theclass "infoval"] << toHtml (maintainer info))
-              )
+   let
+      info = iface_info iface
+
+      doOneEntry :: (String,ModuleInfo -> Maybe String) -> Maybe HtmlTable
+      doOneEntry (fieldName,field) = case field info of
+         Nothing -> Nothing
+         Just fieldValue -> 
+            Just ((tda [theclass "infohead"] << toHtml fieldName)
+               <-> (tda [theclass "infoval"]) << toHtml fieldValue)
+     
+      entries :: [HtmlTable]
+      entries = mapMaybe doOneEntry [
+         ("Portability",portability),
+         ("Stability",stability),
+         ("Maintainer",maintainer)
+         ]
+   in
+      case entries of
+         [] -> Html.emptyTable
+         _ -> tda [align "right"] << narrowTable << (foldl1 (</>) entries)
 
 -- ---------------------------------------------------------------------------
 -- Generate the module contents
@@ -219,7 +228,8 @@ ppHtmlContents
    -> IO ()
 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]
+  let tree = mkModuleTree 
+         [(mod,iface_package iface,toDescription iface) | (mod,iface) <- mdls]
       html = 
 	header 
 		(documentCharacterEncoding +++
@@ -262,13 +272,18 @@ ppModuleTree _ ts =
     (htmlTable,_) = genTable emptyTable 0 ts
 
 mkNode :: [String] -> ModuleTree -> Int -> (HtmlTable,Int)
-mkNode ss (Node s leaf pkg ts) id = htmlNode
+mkNode ss (Node s leaf pkg short ts) id = htmlNode
   where
     htmlNode = case ts of
-      [] -> ( pad_td (Just 1.25) << htmlModule                           <-> htmlPkg,id)
-      _  -> ((pad_td Nothing<< (collapsebutton id_s +++ htmlModule) <-> htmlPkg) </> 
+      [] -> ( pad_td (Just 1.25) << htmlModule  <-> shortDescr <-> htmlPkg,id)
+      _  -> ((pad_td Nothing<< (collapsebutton id_s +++ htmlModule) <-> shortDescr <-> htmlPkg) </> 
                 (pad_td (Just 2) << sub_tree), id')
 
+    shortDescr :: HtmlTable
+    shortDescr = case short of
+	Nothing -> td empty
+	Just doc -> tda [theclass "rdoc"] (docToHtml doc)
+
     htmlModule 
       | leaf      = ppHsModule mdl
       | otherwise = toHtml s
diff --git a/src/HaddockModuleTree.hs b/src/HaddockModuleTree.hs
index f052bd69..bd877bf4 100644
--- a/src/HaddockModuleTree.hs
+++ b/src/HaddockModuleTree.hs
@@ -2,28 +2,29 @@ module HaddockModuleTree(ModuleTree(..), mkModuleTree) where
 
 import HsSyn
 
-data ModuleTree = Node String Bool (Maybe String) [ModuleTree]
+data ModuleTree = Node String Bool (Maybe String) (Maybe Doc) [ModuleTree]
 
-mkModuleTree :: [(Module,Maybe String)] -> [ModuleTree]
+mkModuleTree :: [(Module,Maybe String,Maybe Doc)] -> [ModuleTree]
 mkModuleTree mods = 
-  foldr fn [] [ (splitModule mod, pkg) | (mod,pkg) <- mods ]
+  foldr fn [] [ (splitModule mod, pkg,short) | (mod,pkg,short) <- mods ]
   where 
-    fn (mod,pkg) trees = addToTrees mod pkg trees
+    fn (mod,pkg,short) trees = addToTrees mod pkg short trees
 
-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
+addToTrees :: [String] -> Maybe String -> Maybe Doc -> [ModuleTree] -> [ModuleTree]
+addToTrees [] pkg short ts = ts
+addToTrees ss pkg short [] = mkSubTree ss pkg short
+addToTrees (s1:ss) pkg short (t@(Node s2 leaf node_pkg node_short subs) : ts)
+  | s1 >  s2  = t : addToTrees (s1:ss) pkg short ts
+  | s1 == s2  = Node s2 (leaf || null ss) this_pkg this_short (addToTrees ss pkg short subs) : ts
+  | otherwise = mkSubTree (s1:ss) pkg short ++ t : ts
  where
   this_pkg = if null ss then pkg else node_pkg
+  this_short = if null ss then short else node_short
 
-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)]
+mkSubTree :: [String] -> Maybe String -> Maybe Doc -> [ModuleTree]
+mkSubTree []     pkg short = []
+mkSubTree [s]    pkg short = [Node s True pkg short []]
+mkSubTree (s:ss) pkg short = [Node s (null ss) Nothing Nothing (mkSubTree ss pkg short)]
 
 splitModule :: Module -> [String]
 splitModule (Module mdl) = split mdl
diff --git a/src/HaddockTypes.hs b/src/HaddockTypes.hs
index 4522f8c9..15c98f2d 100644
--- a/src/HaddockTypes.hs
+++ b/src/HaddockTypes.hs
@@ -64,7 +64,7 @@ data Interface
 	iface_insts :: [HsDecl],
 		-- ^ instances from this module
 
-	iface_info :: Maybe ModuleInfo,
+	iface_info :: ModuleInfo,
 		-- ^ information from the module header
 
 	iface_doc :: Maybe Doc,
diff --git a/src/HaddockUtil.hs b/src/HaddockUtil.hs
index f081a5fb..bf326b82 100644
--- a/src/HaddockUtil.hs
+++ b/src/HaddockUtil.hs
@@ -10,7 +10,7 @@ module HaddockUtil (
   -- * Misc utilities
   nameOfQName, collectNames, declBinders, declMainBinder, declSubBinders, 
   splitTyConApp, restrictTo, declDoc, parseModuleHeader, freeTyCons, unbang,
-  addFieldDoc, addFieldDocs, addConDoc, addConDocs,
+  addFieldDoc, addFieldDocs, addConDoc, addConDocs,toDescription,
 
   -- * Filename utilities
   basename, dirname, splitFilename3, 
@@ -19,12 +19,16 @@ module HaddockUtil (
   cssFile, iconFile, jsFile, plusFile, minusFile,
 
   -- * Miscellaneous utilities
-  getProgramName, bye, die, dieMsg, mapSnd, mapMaybeM, escapeStr,
+  getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr,
 
   -- * HTML cross reference mapping
   html_xrefs_ref,
  ) where
 
+import HaddockLex
+import HaddockParse
+import HaddockTypes
+
 import HsSyn
 
 import List	( intersect, isSuffixOf, intersperse )
@@ -33,15 +37,13 @@ import IO	( hPutStr, stderr )
 import System
 import Binary
 import Monad
-import Char	( isAlpha, ord )
+import Char	( isAlpha, isSpace, toUpper, ord )
 
 #if __GLASGOW_HASKELL__ < 503
-import RegexString
 import FiniteMap
 import IOExts
 import URI	( escapeString, unreserved )
 #else
-import Text.Regex
 import Data.FiniteMap
 import Data.IORef
 import System.IO.Unsafe	 ( unsafePerformIO )
@@ -114,6 +116,10 @@ freeTyCons ty = go ty []
 	go (HsTyVar _) r = r
 	go (HsTyDoc t _) r = go t r
 
+-- | extract a module's short description.
+toDescription :: Interface -> Maybe Doc
+toDescription = description. iface_info
+
 -- -----------------------------------------------------------------------------
 -- Adding documentation to record fields (used in parsing).
 
@@ -189,42 +195,148 @@ declDoc _ = Nothing
 -- -----------------------------------------------------------------------------
 -- Parsing module headers
 
-parseModuleHeader :: String -> (String, Maybe ModuleInfo)
-parseModuleHeader str =
-  case matchRegexAll moduleHeaderRE str of
-#if __GLASGOW_HASKELL__ < 503
-	Just (_, _, after, _, (_:_:_:s1:s2:s3:_)) -> 
-#else
-	Just (_, _, after, (_:_:_:s1:s2:s3:_)) -> 
-#endif
-	   (after, Just (ModuleInfo { 
-				 portability = s3,
-				 stability   = s2,
-				 maintainer  = s1 }))
-	_other -> (str, Nothing)
-
-moduleHeaderRE :: Regex
-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?).
-
-#if __GLASGOW_HASKELL__ < 500
-mkRegexWithOpts :: String -> Bool -> Bool -> Regex
-mkRegexWithOpts s single_line case_sensitive
-      = unsafePerformIO (re_compile_pattern (packString s) 
-                              single_line case_sensitive)
-#endif
+-- NB.  The headers must be given in the order Module, Description,
+-- Copyright, License, Maintainer, Stability, Portability, except that
+-- any or all may be omitted.
+parseModuleHeader :: String -> Either String (String,ModuleInfo)
+parseModuleHeader str0 = 
+   let
+      getKey :: String -> String -> (Maybe String,String)
+      getKey key str = case parseKey key str of
+         Nothing -> (Nothing,str)
+         Just (value,rest) -> (Just value,rest)
+     
+      (moduleOpt,str1) = getKey "Module" str0
+      (descriptionOpt,str2) = getKey "Description" str1
+      (copyrightOpt,str3) = getKey "Copyright" str2
+      (licenseOpt,str4) = getKey "License" str3
+      (maintainerOpt,str5) = getKey "Maintainer" str4
+      (stabilityOpt,str6) = getKey "Stability" str5
+      (portabilityOpt,str7) = getKey "Portability" str6
+
+      description1 :: Either String (Maybe Doc)
+      description1 = case descriptionOpt of
+         Nothing -> Right Nothing
+         Just description -> case parseString . tokenise $ description of
+            Left mess -> Left ("Cannot parse Description: " ++ mess)
+            Right doc -> Right (Just doc)
+   in
+      case description1 of
+         Left mess -> Left mess
+         Right docOpt -> Right (str7,ModuleInfo {
+            description = docOpt,
+            portability = portabilityOpt,
+            stability = stabilityOpt,
+            maintainer = maintainerOpt
+            })
+   
+
+-- | This function is how we read keys.
+--
+-- all fields in the header are optional and have the form
+--
+-- [spaces1][field name][spaces] ":" 
+--    [text]"\n" ([spaces2][space][text]"\n" | [spaces]"\n")*
+-- where each [spaces2] should have [spaces1] as a prefix.
+--
+-- Thus for the key "Description",
+--
+-- > Description : this is a
+-- >    rather long
+-- >
+-- >    description
+-- >
+-- > The module comment starts here
+-- 
+-- the value will be "this is a .. description" and the rest will begin
+-- at "The module comment".
+parseKey :: String -> String -> Maybe (String,String)
+parseKey key toParse0 =
+   do
+      let
+         (spaces0,toParse1) = extractLeadingSpaces toParse0
+
+         indentation = spaces0
+      afterKey0 <- extractPrefix key toParse1
+      let
+         afterKey1 = extractLeadingSpaces afterKey0
+      afterColon0 <- case snd afterKey1 of
+         ':':afterColon -> return afterColon
+         _ -> Nothing
+      let
+         (_,afterColon1) = extractLeadingSpaces afterColon0
+
+      return (scanKey True indentation afterColon1)
+   where
+      scanKey :: Bool -> String -> String -> (String,String)
+      scanKey isFirst indentation [] = ([],[])
+      scanKey isFirst indentation str =
+         let
+            (nextLine,rest1) = extractNextLine str
+
+            accept = isFirst || sufficientIndentation || allSpaces
+
+            sufficientIndentation = case extractPrefix indentation nextLine of
+               Just (c:_) | isSpace c -> True
+               _ -> False
+
+            allSpaces = case extractLeadingSpaces nextLine of
+               (_,[]) -> True
+               _ -> False
+         in
+            if accept 
+               then
+                  let
+                     (scanned1,rest2) = scanKey False indentation rest1
+
+                     scanned2 = case scanned1 of 
+                        "" -> if allSpaces then "" else nextLine
+                        _ -> nextLine ++ "\n" ++ scanned1
+                  in
+                     (scanned2,rest2)
+               else
+                  ([],str)
+
+      extractLeadingSpaces :: String -> (String,String)
+      extractLeadingSpaces [] = ([],[])
+      extractLeadingSpaces (s@(c:cs)) 
+         | isSpace c = 
+            let
+               (spaces1,cs1) = extractLeadingSpaces cs
+            in
+               (c:spaces1,cs1)
+         | True = ([],s)
+
+      extractNextLine :: String -> (String,String)
+      extractNextLine [] = ([],[])
+      extractNextLine (c:cs) 
+         | c == '\n' =
+            ([],cs)
+         | True =
+            let
+               (line,rest) = extractNextLine cs
+            in
+               (c:line,rest)
+         
+
+      -- indentation returns characters after last newline.
+      indentation :: String -> String
+      indentation s = fromMaybe s (indentation0 s)
+         where
+            indentation0 :: String -> Maybe String
+            indentation0 [] = Nothing
+            indentation0 (c:cs) =
+               case indentation0 cs of
+                  Nothing -> if c == '\n' then Just cs else Nothing
+                  in0 -> in0
+               
+      -- comparison is case-insensitive.
+      extractPrefix :: String -> String -> Maybe String
+      extractPrefix [] s = Just s
+      extractPrefix s [] = Nothing
+      extractPrefix (c1:cs1) (c2:cs2)
+         | toUpper c1 == toUpper c2 = extractPrefix cs1 cs2
+         | True = Nothing
 
 -- -----------------------------------------------------------------------------
 -- Filename mangling functions stolen from GHC's main/DriverUtil.lhs.
@@ -323,6 +435,9 @@ die s = hPutStr stderr s >> exitWith (ExitFailure 1)
 dieMsg :: String -> IO a
 dieMsg s = getProgramName >>= \prog -> die (prog ++ ": " ++ s)
 
+noDieMsg :: String -> IO ()
+noDieMsg s = getProgramName >>= \prog -> hPutStr stderr (prog ++ ": " ++ s)
+
 mapSnd :: (b -> c) -> [(a,b)] -> [(a,c)]
 mapSnd _ [] = []
 mapSnd f ((x,y):xs) = (x,f y) : mapSnd f xs
@@ -385,3 +500,38 @@ instance Binary HsIdentifier where
 		1 -> do s <- getString bh; return (HsSymbol s)
 		_ -> do s <- getString bh; return (HsSpecial s)
 
+instance Binary id => Binary (GenDoc id) where
+   put_ bh DocEmpty = putByte bh 0
+   put_ bh (DocAppend gd1 gd2) = do putByte bh 1;put_ bh gd1;put_ bh gd2
+   put_ bh (DocString s) = do putByte bh 2;putString bh s
+   put_ bh (DocParagraph gd) = do putByte bh 3;put_ bh gd
+   put_ bh (DocIdentifier id) = do putByte bh 4;put_ bh id
+   put_ bh (DocModule s) = do putByte bh 5;putString bh s
+   put_ bh (DocEmphasis gd) = do putByte bh 6;put_ bh gd
+   put_ bh (DocMonospaced gd) = do putByte bh 7;put_ bh gd
+   put_ bh (DocUnorderedList gd) = do putByte bh 8;put_ bh gd
+   put_ bh (DocOrderedList gd) = do putByte bh 9;put_ bh gd
+   put_ bh (DocDefList gd) = do putByte bh 10;put_ bh gd
+   put_ bh (DocCodeBlock gd) = do putByte bh 11;put_ bh gd
+   put_ bh (DocURL s) = do putByte bh 12;putString bh s
+   put_ bh (DocAName s) = do putByte bh 13;putString bh s
+   get bh = do b <- getByte bh
+               case b of
+                  0 -> return DocEmpty
+                  1 -> do gd1 <- get bh;gd2 <- get bh;return (DocAppend gd1 gd2)
+                  2 -> do s <- getString bh;return (DocString s)
+                  3 -> do gd <- get bh;return (DocParagraph gd)
+                  4 -> do id <- get bh;return (DocIdentifier id)
+                  5 -> do s <- getString bh;return (DocModule s)
+                  6 -> do gd <- get bh;return (DocEmphasis gd)
+                  7 -> do gd <- get bh;return (DocMonospaced gd)
+                  8 -> do gd <- get bh;return (DocUnorderedList gd)
+                  9 -> do gd <- get bh;return (DocOrderedList gd)
+                  10 -> do gd <- get bh;return (DocDefList gd)
+                  11 -> do gd <- get bh;return (DocCodeBlock gd)
+                  12 -> do s <- getString bh;return (DocURL s)
+                  13 -> do s <- getString bh;return (DocAName s) 
+                  _ -> error ("Mysterious byte in document in interface" 
+                     ++ show b)
+
+
diff --git a/src/HsParser.ly b/src/HsParser.ly
index 5ac3e4bc..21561e0a 100644
--- a/src/HsParser.ly
+++ b/src/HsParser.ly
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------------
-$Id: HsParser.ly,v 1.20 2004/04/20 13:08:04 simonmar Exp $
+$Id: HsParser.ly,v 1.21 2004/08/09 11:55:07 simonmar Exp $
 
 (c) Simon Marlow, Sven Panne 1997-2002
 
@@ -155,14 +155,14 @@ Module Header
 >		opts info doc } }
 >	| body
 >	    { HsModule main_mod Nothing (reverse (fst $1)) (snd $1)
->		Nothing Nothing Nothing }
+>		Nothing emptyModuleInfo Nothing }
 
-> optdoc :: { (Maybe String, Maybe ModuleInfo, Maybe Doc) }
+> optdoc :: { (Maybe String,ModuleInfo,Maybe Doc) }
 >	: moduleheader			{ (Nothing, fst $1, snd $1) }
->	| DOCOPTIONS			{ (Just $1, Nothing, Nothing) }
+>	| DOCOPTIONS			{ (Just $1, emptyModuleInfo,Nothing) }
 >	| DOCOPTIONS moduleheader	{ (Just $1, fst $2, snd $2) }
 >	| moduleheader DOCOPTIONS	{ (Just $2, fst $1, snd $1) }
->	| {- empty -}			{ (Nothing, Nothing, Nothing) }
+>	| {- empty -}			{ (Nothing, emptyModuleInfo,Nothing) } 
 
 > body :: { ([HsImportDecl],[HsDecl]) }
 >	:  '{' bodyaux '}'				{ $2 }
@@ -1007,11 +1007,15 @@ Documentation comments
 > 	: docnext			{ Just $1 }
 >	| {- empty -}			{ Nothing }
 
-> moduleheader :: { (Maybe ModuleInfo, Maybe Doc) }
->	: DOCNEXT 	{% let (str, info) = parseModuleHeader $1 in
->			   case parseParas (tokenise str) of {
->				Left  err -> parseError err;
->				Right doc -> returnP (info, Just doc); } }
+> moduleheader :: { (ModuleInfo,Maybe Doc) }
+>       : DOCNEXT       {% case parseModuleHeader $1 of {
+>                          Right (str,info) -> 
+>                             case parseParas (tokenise str) of {
+>                                Left err -> parseError err;
+>                                Right doc -> returnP (info,Just doc);
+>                                };
+>                          Left err -> parseError err
+>                          } }
 
 -----------------------------------------------------------------------------
 
diff --git a/src/HsSyn.lhs b/src/HsSyn.lhs
index 664c9601..82f89da9 100644
--- a/src/HsSyn.lhs
+++ b/src/HsSyn.lhs
@@ -1,5 +1,5 @@
 % -----------------------------------------------------------------------------
-% $Id: HsSyn.lhs,v 1.21 2004/08/02 20:31:13 panne Exp $
+% $Id: HsSyn.lhs,v 1.22 2004/08/09 11:55:07 simonmar Exp $
 %
 % (c) The GHC Team, 1997-2002
 %
@@ -30,6 +30,8 @@ module HsSyn (
     unit_tycon_qname, fun_tycon_qname, list_tycon_qname, tuple_tycon_qname,
     unit_tycon, fun_tycon, list_tycon, tuple_tycon,
 
+    emptyModuleInfo,
+
     hsIdentifierStr, hsAnchorNameStr, hsNameStr, 
 	
     GenDoc(..), Doc, DocMarkup(..),
@@ -81,16 +83,26 @@ instance Show HsIdentifier where
 data HsModule = HsModule Module (Maybe [HsExportSpec])
                         [HsImportDecl] [HsDecl] 
 			(Maybe String)		-- the doc options
-			(Maybe ModuleInfo)	-- the info (portability etc.)
-			(Maybe Doc)		-- the module doc
+			ModuleInfo      	-- the info (portability etc.)
+                        (Maybe Doc)             -- the module doc.
   deriving Show
 
 data ModuleInfo = ModuleInfo
-	{ portability :: String,
-	  stability   :: String,
-	  maintainer  :: String }
+	{ description :: Maybe Doc,
+          portability :: Maybe String,
+	  stability   :: Maybe String,
+	  maintainer  :: Maybe String
+          }
   deriving Show
 
+emptyModuleInfo :: ModuleInfo
+emptyModuleInfo = ModuleInfo {
+   description = Nothing,
+   portability = Nothing,
+   stability = Nothing,
+   maintainer = Nothing
+   }
+
 -- Export/Import Specifications
 
 data HsExportSpec
diff --git a/src/Main.hs b/src/Main.hs
index 5d7e3df7..08c3ba7a 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -270,48 +270,13 @@ run flags files = do
   -- dump an interface if requested
   case dump_iface of
      Nothing -> return ()
-     Just fn -> do
-	bh <- openBinMem 100000
-	put_ bh prepared_ifaces
-	writeBinMem bh fn
-      where
-	prepared_ifaces = 
-	  [ (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 ]
+     Just fn -> dumpInterfaces these_mod_ifaces fn
 
 parseIfaceOption :: String -> (FilePath,FilePath)
 parseIfaceOption s = 
   case break (==',') s of
 	(fpath,',':file) -> (fpath,file)
 	(file, _)        -> ("", file)
-
-readIface :: FilePath -> IO [(Module,Interface)]
-readIface filename = do
-  bh <- readBinMem filename
-  stuff <- get bh
-  return (map to_interface stuff)
- where 
-   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,
-		   iface_reexported   = listToFM reexported,
-		   iface_exports      = [],
-		   iface_orig_exports = [],
-		   iface_insts	      = [],
-		   iface_decls        = emptyFM,
-		   iface_info	      = Nothing,
-		   iface_doc          = Nothing,
-		   iface_options      = if hide then [OptHide] else []
-		}
-      	  )
 		
 
 updateHTMLXRefs :: [FilePath] -> [[(Module,Interface)]] -> IO ()
@@ -1127,6 +1092,112 @@ collectInstances mod_ifaces
 		    | HsInstDecl _ ctxt (cls,args) _ <- all_instances,
 		      nm <- nub (concat (map freeTyCons args))
 		    ]
+
+-- -----------------------------------------------------------------------------
+-- The interface file format.
+-- This has to read interfaces up to Haddock 0.6 (without the short
+-- document annotations), and interfaces afterwards, so we use the
+-- FormatVersion hack to work out which one the interface file contains.
+
+thisFormatVersion :: FormatVersion
+thisFormatVersion = mkFormatVersion 1
+
+-- | How we store interfaces.  Not everything is stored.
+type StoredInterface =
+   (Module,Maybe Doc,Maybe String,Bool,[(HsName,HsQName)],[(HsName,HsQName)],
+      [(HsName,[HsName])])
+
+-- | How we used to store interfaces.
+type NullVersionStoredInterface = 
+   (Module,Maybe String,Bool,[(HsName,HsQName)],[(HsName,HsQName)],
+      [(HsName,[HsName])])
+
+dumpInterfaces :: [(Module,Interface)] -> FilePath -> IO ()
+dumpInterfaces interfaces fileName =
+   do
+      let
+         preparedInterfaces :: [StoredInterface]
+         preparedInterfaces = map from_interface interfaces
+
+      bh <- openBinMem 100000
+      put_ bh thisFormatVersion
+      put_ bh preparedInterfaces
+      writeBinMem bh fileName
+
+
+readIface :: FilePath -> IO [(Module,Interface)]
+readIface fileName = do
+   bh <- readBinMem fileName
+   formatVersion <- get bh
+   if formatVersion == thisFormatVersion
+      then
+         do
+            (stuff :: [StoredInterface]) <- get bh
+            return (map to_interface stuff)
+      else
+         if formatVersion == nullFormatVersion
+            then
+               do
+                  (stuff :: [NullVersionStoredInterface]) <- get bh
+                  return (map nullVersion_to_interface stuff)
+               else
+                  do
+                     noDieMsg (
+                        "Warning: The interface file " ++ show fileName 
+                           ++ " could not be read.\n"
+                           ++ "Maybe it's from a later version of Haddock?\n")
+                     return [] 
+
+from_interface :: (Module,Interface) -> StoredInterface
+from_interface (mdl,iface) =
+   (mdl, toDescription iface,iface_package iface,
+      OptHide `elem` iface_options iface,
+      fmToList (iface_env iface), 
+      fmToList (iface_reexported iface),
+      fmToList (iface_sub iface)
+      )
+
+to_interface :: StoredInterface -> (Module,Interface)
+to_interface (mdl,descriptionOpt,package, hide, env, reexported, sub) = 
+   (mdl, Interface { 
+      iface_filename     = "",
+      iface_package      = package,
+      iface_env          = listToFM env,
+      iface_import_env   = emptyFM,
+      iface_sub          = listToFM sub,
+      iface_reexported   = listToFM reexported,
+      iface_exports      = [],
+      iface_orig_exports = [],
+      iface_insts        = [],
+      iface_decls        = emptyFM,
+      iface_info         = toModuleInfo descriptionOpt,
+      iface_doc          = Nothing,
+      iface_options      = if hide then [OptHide] else []
+      })
+
+nullVersion_to_interface :: NullVersionStoredInterface -> (Module,Interface)
+nullVersion_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,
+      iface_reexported   = listToFM reexported,
+      iface_exports      = [],
+      iface_orig_exports = [],
+      iface_insts        = [],
+      iface_decls        = emptyFM,
+      iface_info         = emptyModuleInfo,
+      iface_doc          = Nothing,
+      iface_options      = if hide then [OptHide] else []
+      })
+
+toModuleInfo :: Maybe Doc -> ModuleInfo
+toModuleInfo descriptionOpt = 
+   emptyModuleInfo {description = descriptionOpt}
+
+
  
 -- -----------------------------------------------------------------------------
 -- A monad which collects error messages
-- 
cgit v1.2.3