[haddock @ 2003-11-06 12:39:46 by simonmar]

- Add definition lists, marked up like this:

	-- | This is a definition list:
	--
	--   [@foo@] The description of @foo@.
	--
	--   [@bar@] The description of @bar@.

  Cunningly, the [] characters are not treated specially unless a [ is
  found at the beginning of a paragraph, in which case the ] becomes
  special in the following text.


- Add --use-contents and --gen-contents, along the lines of
  --use-index and --gen-index added yesterday.  Now we can generate a
  combined index and contents for the whole of the hierarchical
  libraries, and in theory the index/contents on the system could
  be updated as new packages are added.

6 files changed, 116 insertions, 45 deletions

diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs
index e1604fad..03a837c3 100644
--- a/src/HaddockHtml.hs
+++ b/src/HaddockHtml.hs
@@ -1,10 +1,13 @@
 --
 -- Haddock - A Haskell Documentation Tool
 --
--- (c) Simon Marlow 2002
+-- (c) Simon Marlow 2002-2003
 --
 
-module HaddockHtml ( ppHtml, copyHtmlBits, ppHtmlIndex ) where
+module HaddockHtml ( 
+	ppHtml, copyHtmlBits, 
+	ppHtmlIndex, ppHtmlContents
+  ) where
 
 import Prelude hiding (div)
 import HaddockVersion
@@ -47,23 +50,30 @@ ppHtml	:: String
 	-> FilePath			-- destination directory
 	-> Maybe Doc			-- prologue text, maybe
 	-> Bool				-- do MS Help stuff
+	-> Maybe String			-- the contents URL (--use-contents)
 	-> Maybe String			-- the index URL (--use-index)
 	-> IO ()
 
-ppHtml doctitle source_url ifaces odir prologue do_ms_help maybe_index_url =  do
+ppHtml doctitle source_url ifaces odir prologue do_ms_help 
+	maybe_contents_url maybe_index_url =  do
   let
 	visible_ifaces = filter visible ifaces
 	visible (_, i) = OptHide `notElem` iface_options i
 
-  ppHtmlContents odir doctitle maybe_index_url (map fst visible_ifaces) prologue
-  ppHtmlIndex odir doctitle visible_ifaces
+  when (not (isJust maybe_contents_url)) $ 
+    ppHtmlContents odir doctitle maybe_index_url 
+	(map fst visible_ifaces) prologue
+
+  when (not (isJust maybe_index_url)) $ 
+    ppHtmlIndex odir doctitle maybe_contents_url visible_ifaces
 
   -- Generate index and contents page for MS help if requested
   when do_ms_help $ do
     ppHHContents odir (map fst visible_ifaces)
     ppHHIndex odir visible_ifaces
 
-  mapM_ (ppHtmlModule odir doctitle source_url maybe_index_url) visible_ifaces
+  mapM_ (ppHtmlModule odir doctitle source_url 
+	   maybe_contents_url maybe_index_url) visible_ifaces
 
 
 copyHtmlBits :: FilePath -> FilePath -> Maybe FilePath -> IO ()
@@ -119,30 +129,34 @@ parent_button mdl =
    _ -> 
 	Html.emptyTable
 
-contentsButton :: HtmlTable
-contentsButton = topButBox (anchor ! [href contentsHtmlFile] << 
-				toHtml "Contents")
+contentsButton :: Maybe String -> HtmlTable
+contentsButton maybe_contents_url 
+  = topButBox (anchor ! [href url] << toHtml "Contents")
+  where url = case maybe_contents_url of
+			Nothing -> contentsHtmlFile
+			Just url -> url
 
 indexButton :: Maybe String -> HtmlTable
 indexButton maybe_index_url 
- = topButBox (anchor ! [href url] << toHtml "Index")
+  = topButBox (anchor ! [href url] << toHtml "Index")
   where url = case maybe_index_url of
 			Nothing -> indexHtmlFile
 			Just url -> url
 
-simpleHeader :: String -> Maybe String -> HtmlTable
-simpleHeader doctitle maybe_index_url = 
+simpleHeader :: String -> Maybe String -> Maybe String -> HtmlTable
+simpleHeader doctitle maybe_contents_url maybe_index_url = 
   (tda [theclass "topbar"] << 
      vanillaTable << (
        (td << 
   	image ! [src "haskell_icon.gif", width "16", height 16, alt " " ]
        ) <->
        (tda [theclass "title"] << toHtml doctitle) <->
-	contentsButton <-> indexButton maybe_index_url
+	contentsButton maybe_contents_url <-> indexButton maybe_index_url
    ))
 
-pageHeader :: String -> Interface -> String -> Maybe String -> Maybe String -> HtmlTable
-pageHeader mdl iface doctitle source_url maybe_index_url =
+pageHeader :: String -> Interface -> String
+    -> Maybe String -> Maybe String -> Maybe String -> HtmlTable
+pageHeader mdl iface doctitle source_url maybe_contents_url maybe_index_url =
   (tda [theclass "topbar"] << 
     vanillaTable << (
        (td << 
@@ -151,7 +165,7 @@ pageHeader mdl iface doctitle source_url maybe_index_url =
        (tda [theclass "title"] << toHtml doctitle) <->
 	src_button source_url mdl (iface_filename iface) <->
 	parent_button mdl <->
-	contentsButton <->
+	contentsButton maybe_contents_url <->
 	indexButton maybe_index_url
     )
    ) </>
@@ -179,16 +193,20 @@ moduleInfo iface =
 -- ---------------------------------------------------------------------------
 -- Generate the module contents
 
-ppHtmlContents :: FilePath -> String -> Maybe String -> [Module] -> Maybe Doc
+ppHtmlContents
+   :: FilePath -> String
+   -> Maybe String
+   -> [Module] -> Maybe Doc
    -> IO ()
-ppHtmlContents odir doctitle maybe_index_url mdls prologue = do
+ppHtmlContents odir doctitle maybe_index_url
+  mdls prologue = do
   let tree = mkModuleTree mdls  
       html = 
 	header (thetitle (toHtml doctitle) +++
 		thelink ! [href cssFile, 
 		  rel "stylesheet", thetype "text/css"]) +++
         body << vanillaTable << (
-   	    simpleHeader doctitle maybe_index_url </>
+   	    simpleHeader doctitle Nothing maybe_index_url </>
 	    ppPrologue prologue </>
 	    ppModuleTree doctitle tree </>
 	    s15 </>
@@ -218,7 +236,7 @@ mkNode ss (Node s leaf ts) =
 
 mkLeaf :: String -> [String] -> Bool -> Html
 mkLeaf s _ False = toHtml s
-mkLeaf s ss True  = anchor ! [href (moduleHtmlFile "" mdl)] << toHtml s
+mkLeaf s ss True  = ppHsModule mdl
   where mdl = foldr (++) "" (s' : map ('.':) ss')
 	(s':ss') = reverse (s:ss)
 	 -- reconstruct the module name
@@ -226,14 +244,15 @@ mkLeaf s ss True  = anchor ! [href (moduleHtmlFile "" mdl)] << toHtml s
 -- ---------------------------------------------------------------------------
 -- Generate the index
 
-ppHtmlIndex :: FilePath -> String -> [(Module,Interface)] -> IO ()
-ppHtmlIndex odir doctitle ifaces = do
+ppHtmlIndex :: FilePath -> String -> Maybe String
+   -> [(Module,Interface)] -> IO ()
+ppHtmlIndex odir doctitle maybe_contents_url ifaces = do
   let html = 
 	header (thetitle (toHtml (doctitle ++ " (Index)")) +++
 		thelink ! [href cssFile, 
 		  rel "stylesheet", thetype "text/css"]) +++
         body << vanillaTable << (
-	    simpleHeader doctitle Nothing </>
+	    simpleHeader doctitle maybe_contents_url Nothing </>
 	    index_html
 	   )
 
@@ -270,7 +289,7 @@ ppHtmlIndex odir doctitle ifaces = do
 		thelink ! [href cssFile, 
 		  rel "stylesheet", thetype "text/css"]) +++
              body << vanillaTable << (
-	        simpleHeader doctitle Nothing </>
+	        simpleHeader doctitle maybe_contents_url Nothing </>
 		indexInitialLetterLinks </>
 	        tda [theclass "section1"] << 
 	      	toHtml ("Index (" ++ c:")") </>
@@ -337,15 +356,18 @@ ppHtmlIndex odir doctitle ifaces = do
 -- ---------------------------------------------------------------------------
 -- Generate the HTML page for a module
 
-ppHtmlModule :: FilePath -> String -> Maybe String -> Maybe String ->
-	(Module,Interface) -> IO ()
-ppHtmlModule odir doctitle source_url maybe_index_url (Module mdl,iface) = do
+ppHtmlModule
+	:: FilePath -> String -> Maybe String -> Maybe String -> Maybe String
+	-> (Module,Interface) -> IO ()
+ppHtmlModule odir doctitle source_url 
+  maybe_contents_url maybe_index_url (Module mdl,iface) = do
   let html = 
 	header (thetitle (toHtml mdl) +++
 		thelink ! [href cssFile,
 		  rel "stylesheet", thetype "text/css"]) +++
         body << vanillaTable << (
-	    pageHeader mdl iface doctitle source_url maybe_index_url </> s15 </>
+	    pageHeader mdl iface doctitle source_url 
+		maybe_contents_url maybe_index_url </> s15 </>
 	    ifaceToHtml mdl iface </> s15 </>
 	    footer
          )
@@ -917,11 +939,14 @@ htmlMarkup = Markup {
   markupMonospaced    = tt . toHtml,
   markupUnorderedList = ulist . concatHtml . map (li <<),
   markupOrderedList   = olist . concatHtml . map (li <<),
+  markupDefList       = dlist . concatHtml . map markupDef,
   markupCodeBlock     = pre,
   markupURL	      = \url -> anchor ! [href url] << toHtml url,
   markupAName	      = \aname -> namedAnchor aname << toHtml ""
   }
 
+markupDef (a,b) = dterm << a +++ ddef << b
+
 -- If the doc is a single paragraph, don't surround it with <P> (this causes
 -- ugly extra whitespace with some browsers).
 docToHtml :: Doc -> Html
diff --git a/src/HaddockLex.x b/src/HaddockLex.x
index feac18ab..b4030700 100644
--- a/src/HaddockLex.x
+++ b/src/HaddockLex.x
@@ -14,7 +14,7 @@ import Char
 import HsSyn
 import HsLexer hiding (Token)
 import HsParseMonad
-import Debug.Trace
+--import Debug.Trace
 }
 
 $ws    = $white # \n
@@ -29,8 +29,9 @@ $ident    = [$alphanum \_\.\!\#\$\%\&\*\+\/\<\=\>\?\@\\\\\^\|\-\~]
 <0,para> {
  $ws* \n		;
  $ws* \>		{ begin birdtrack }
- $ws* [\*\-]		{ token TokBullet }
- $ws* \( $digit+ \) 	{ token TokNumber }
+ $ws* [\*\-]		{ token TokBullet `andBegin` string }
+ $ws* \[		{ token TokDefStart `andBegin` def }
+ $ws* \( $digit+ \) 	{ token TokNumber `andBegin` string }
  $ws*			{ begin string }		
 }
 
@@ -43,7 +44,7 @@ $ident    = [$alphanum \_\.\!\#\$\%\&\*\+\/\<\=\>\?\@\\\\\^\|\-\~]
 
 <birdtrack> .*	\n?	{ strtoken TokBirdTrack `andBegin` line }
 
-<string> {
+<string,def> {
   $special			{ strtoken $ \s -> TokSpecial (head s) }
   \<.*\>			{ strtoken $ \s -> TokURL (init (tail s)) }
   \#.*\#			{ strtoken $ \s -> TokAName (init (tail s)) }
@@ -52,8 +53,18 @@ $ident    = [$alphanum \_\.\!\#\$\%\&\*\+\/\<\=\>\?\@\\\\\^\|\-\~]
   -- allow special characters through if they don't fit one of the previous
   -- patterns.
   [\'\`\<\#\\]			{ strtoken TokString }
-  [^ $special \< \# \n \'\` \\]* \n { strtoken TokString `andBegin` line }
-  [^ $special \< \# \n \'\` \\]+    { strtoken TokString }
+  [^ $special \< \# \n \'\` \\ \]]* \n { strtoken TokString `andBegin` line }
+  [^ $special \< \# \n \'\` \\ \]]+    { strtoken TokString }
+}
+
+<def> {
+  \]				{ token TokDefEnd `andBegin` string }
+}
+
+-- ']' doesn't have any special meaning outside of the [...] at the beginning
+-- of a definition paragraph.
+<string> {
+  \]				{ strtoken TokString }
 }
 
 {
@@ -61,6 +72,8 @@ data Token
   = TokPara
   | TokNumber
   | TokBullet
+  | TokDefStart
+  | TokDefEnd
   | TokSpecial Char
   | TokIdent [HsQName]
   | TokString String
diff --git a/src/HaddockParse.y b/src/HaddockParse.y
index 29b3b70a..dbc97446 100644
--- a/src/HaddockParse.y
+++ b/src/HaddockParse.y
@@ -9,10 +9,12 @@ import HsSyn
 
 %token	'/'	{ TokSpecial '/' }
 	'@'	{ TokSpecial '@' }
+	'['     { TokDefStart }
+	']'     { TokDefEnd }
 	DQUO 	{ TokSpecial '\"' }
 	URL	{ TokURL $$ }
 	ANAME	{ TokAName $$ }
-	'*'	{ TokBullet }
+	'-'	{ TokBullet }
 	'(n)'	{ TokNumber }
 	'>..'	{ TokBirdTrack $$ }
 	IDENT   { TokIdent $$ }
@@ -35,14 +37,18 @@ doc	:: { Doc }
 apara	:: { Doc }
 	: ulpara		{ DocUnorderedList [$1] }
 	| olpara		{ DocOrderedList [$1] }
+        | defpara               { DocDefList [$1] }
 	| para			{ $1 }
 
 ulpara  :: { Doc }
-	: '*' para		{ $2 }
+	: '-' para		{ $2 }
 
 olpara  :: { Doc } 
 	: '(n)' para		{ $2 }
 
+defpara :: { (Doc,Doc) }
+	: '[' seq ']' seq	{ ($2, $4) }
+
 para    :: { Doc }
 	: seq			{ docParagraph $1 }
 	| codepara		{ DocCodeBlock $1 }
diff --git a/src/HaddockRename.hs b/src/HaddockRename.hs
index ef32ae80..ad90c1a2 100644
--- a/src/HaddockRename.hs
+++ b/src/HaddockRename.hs
@@ -213,11 +213,14 @@ markupRename = Markup {
   markupMonospaced    = liftM DocMonospaced,
   markupUnorderedList = liftM DocUnorderedList . sequence,
   markupOrderedList   = liftM DocOrderedList . sequence,
+  markupDefList       = liftM DocDefList . mapM markupDef,
   markupCodeBlock     = liftM DocCodeBlock,
   markupURL	      = return . DocURL,
   markupAName	      = return . DocAName
   }
 
+markupDef (ma,mb) = do a <- ma; b <- mb; return (a,b)
+
 renameDoc :: Doc -> RnM Doc
 renameDoc = markup markupRename
 
diff --git a/src/HsSyn.lhs b/src/HsSyn.lhs
index 139ef327..e43826a0 100644
--- a/src/HsSyn.lhs
+++ b/src/HsSyn.lhs
@@ -1,5 +1,5 @@
 % -----------------------------------------------------------------------------
-% $Id: HsSyn.lhs,v 1.18 2003/10/20 17:19:23 sof Exp $
+% $Id: HsSyn.lhs,v 1.19 2003/11/06 12:39:47 simonmar Exp $
 %
 % (c) The GHC Team, 1997-2002
 %
@@ -400,6 +400,7 @@ data GenDoc id
   | DocMonospaced (GenDoc id)
   | DocUnorderedList [GenDoc id]
   | DocOrderedList [GenDoc id]
+  | DocDefList [(GenDoc id, GenDoc id)]
   | DocCodeBlock (GenDoc id)
   | DocURL String
   | DocAName String
@@ -422,6 +423,7 @@ data DocMarkup id a = Markup {
   markupMonospaced    :: a -> a,
   markupUnorderedList :: [a] -> a,
   markupOrderedList   :: [a] -> a,
+  markupDefList       :: [(a,a)] -> a,
   markupCodeBlock     :: a -> a,
   markupURL	      :: String -> a,
   markupAName	      :: String -> a
@@ -438,10 +440,13 @@ markup m (DocEmphasis d)	= markupEmphasis m (markup m d)
 markup m (DocMonospaced d)	= markupMonospaced m (markup m d)
 markup m (DocUnorderedList ds)	= markupUnorderedList m (map (markup m) ds)
 markup m (DocOrderedList ds)	= markupOrderedList m (map (markup m) ds)
+markup m (DocDefList ds)        = markupDefList m (map (markupPair m) ds)
 markup m (DocCodeBlock d)	= markupCodeBlock m (markup m d)
 markup m (DocURL url)		= markupURL m url
 markup m (DocAName ref)		= markupAName m ref
 
+markupPair m (a,b) = (markup m a, markup m b)
+
 -- | The identity markup
 idMarkup :: DocMarkup a (GenDoc a)
 idMarkup = Markup {
@@ -455,6 +460,7 @@ idMarkup = Markup {
   markupMonospaced    = DocMonospaced,
   markupUnorderedList = DocUnorderedList,
   markupOrderedList   = DocOrderedList,
+  markupDefList       = DocDefList,
   markupCodeBlock     = DocCodeBlock,
   markupURL	      = DocURL,
   markupAName	      = DocAName
@@ -479,6 +485,10 @@ docAppend (DocOrderedList ds1) (DocOrderedList ds2)
   = DocOrderedList (ds1++ds2)
 docAppend (DocOrderedList ds1) (DocAppend (DocOrderedList ds2) d)
   = DocAppend (DocOrderedList (ds1++ds2)) d
+docAppend (DocDefList ds1) (DocDefList ds2)
+  = DocDefList (ds1++ds2)
+docAppend (DocDefList ds1) (DocAppend (DocDefList ds2) d)
+  = DocAppend (DocDefList (ds1++ds2)) d
 docAppend DocEmpty d = d
 docAppend d DocEmpty = d
 docAppend d1 d2 
diff --git a/src/Main.hs b/src/Main.hs
index 25d6cc16..3d5f97b4 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -80,6 +80,8 @@ data Flag
   | Flag_Help
   | Flag_Verbose
   | Flag_Version
+  | Flag_UseContents String
+  | Flag_GenContents
   | Flag_UseIndex String
   | Flag_GenIndex
   deriving (Eq)
@@ -119,6 +121,10 @@ options =
 	"output version information and exit",
     Option ['v']  ["verbose"]  (NoArg Flag_Verbose)
         "increase verbosity",
+    Option [] ["use-contents"] (ReqArg Flag_UseContents "URL")
+	"use a separately-generated HTML contents page",
+    Option [] ["gen-contents"] (NoArg Flag_GenContents)
+	"generate an HTML contents from specified interfaces",
     Option [] ["use-index"] (ReqArg Flag_UseIndex "URL")
 	"use a separately-generated HTML index",
     Option [] ["gen-index"] (NoArg Flag_GenIndex)
@@ -167,6 +173,11 @@ run flags files = do
       no_implicit_prelude = Flag_NoImplicitPrelude `elem` flags
       verbose = Flag_Verbose `elem` flags
 
+      maybe_contents_url = 
+	case [url | Flag_UseContents url <- flags] of
+		[] -> Nothing
+		us -> Just (last us)
+
       maybe_index_url = 
 	case [url | Flag_UseIndex url <- flags] of
 		[] -> Nothing
@@ -178,15 +189,17 @@ run flags files = do
 
   updateHTMLXRefs (map fst ifaces_to_read) read_ifaces_s
 
-  if Flag_GenIndex `elem` flags
-     then do 
-	when (not (null files)) $
-	   die ("--gen-index: expected no additional file arguments")	
-	ppHtmlIndex odir title (concat 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
+        copyHtmlBits odir libdir css_file
+
+  when (Flag_GenIndex `elem` flags) $ do
+	ppHtmlIndex odir title maybe_contents_url (concat read_ifaces_s)
         copyHtmlBits odir libdir css_file
-     else do
 
-  writeIORef saved_flags flags
   parsed_mods <- mapM parse_file files
 
   let read_ifaces = concat read_ifaces_s
@@ -225,7 +238,8 @@ run flags files = do
 
   when (Flag_Html `elem` flags) $ do
     ppHtml title source_url these_mod_ifaces odir
-	prologue (Flag_MSHtmlHelp `elem` flags) maybe_index_url
+	prologue (Flag_MSHtmlHelp `elem` flags) 
+		maybe_contents_url maybe_index_url
     copyHtmlBits odir libdir css_file
 
   -- dump an interface if requested