[haddock @ 2002-04-25 14:40:05 by simonmar]

- Add support for named chunks of documentation which can be
  referenced from the export list.

- Copy the icon from $libdir to the destination in HTML mode.

10 files changed, 103 insertions, 38 deletions

diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs
index 2b2c4f3e..994b17e1 100644
--- a/src/HaddockHtml.hs
+++ b/src/HaddockHtml.hs
@@ -22,26 +22,39 @@ import Html
 import qualified Html
 
 -- -----------------------------------------------------------------------------
+-- Files we need to copy from our $libdir
+
+cssFile  = "haddock.css"
+iconFile = "haskell_icon.gif"
+
+-- -----------------------------------------------------------------------------
 -- Generating HTML documentation
 
 ppHtml	:: String
 	-> Maybe String
 	-> [(Module, Interface)]
 	-> FilePath			-- destination directory
-	-> String			-- CSS file
+	-> Maybe String			-- CSS file
+	-> String			-- $libdir
 	-> IO ()
-ppHtml title source_url ifaces odir css_file =  do
+ppHtml title source_url ifaces odir maybe_css libdir =  do
   let 
-	(_css_dir, css_basename, css_suff) = splitFilename3 css_file
-	css_filename = css_basename ++ '.':css_suff
-	css_destination = odir ++ pathSeparator:css_filename
+	css_file = case maybe_css of
+			Nothing -> libdir ++ pathSeparator:cssFile
+			Just f  -> f
+	css_destination = odir ++ pathSeparator:cssFile
+
+	icon_file        = libdir ++ pathSeparator:iconFile
+	icon_destination = odir   ++ pathSeparator:iconFile
 
   css_contents <- readFile css_file
   writeFile css_destination css_contents
+  icon_contents <- readFile icon_file
+  writeFile icon_destination icon_contents
 
-  ppHtmlContents odir css_filename title source_url (map fst ifaces)
-  ppHtmlIndex odir css_filename title ifaces
-  mapM_ (ppHtmlModule odir css_filename title source_url) ifaces
+  ppHtmlContents odir title source_url (map fst ifaces)
+  ppHtmlIndex odir title ifaces
+  mapM_ (ppHtmlModule odir title source_url) ifaces
 
 moduleHtmlFile :: String -> FilePath
 moduleHtmlFile mod = mod ++ ".html" -- ToDo: Z-encode filename?
@@ -134,13 +147,13 @@ moduleInfo iface
 -- ---------------------------------------------------------------------------
 -- Generate the module contents
 
-ppHtmlContents :: FilePath -> String -> String -> Maybe String -> [Module]
+ppHtmlContents :: FilePath -> String -> Maybe String -> [Module]
    -> IO ()
-ppHtmlContents odir css_filename title source_url mods = do
+ppHtmlContents odir title source_url mods = do
   let tree = mkModuleTree mods  
       html = 
 	header (thetitle (toHtml title) +++
-		thelink ! [href css_filename, 
+		thelink ! [href cssFile, 
 		  rel "stylesheet", thetype "text/css"]) +++
         body <<  
 	  table ! [width "100%", cellpadding 0, cellspacing 1] << (
@@ -195,11 +208,11 @@ splitModule (Module mod) = split mod
 -- ---------------------------------------------------------------------------
 -- Generate the index
 
-ppHtmlIndex :: FilePath -> String -> String -> [(Module,Interface)] -> IO ()
-ppHtmlIndex odir css_filename title ifaces = do
+ppHtmlIndex :: FilePath -> String -> [(Module,Interface)] -> IO ()
+ppHtmlIndex odir title ifaces = do
   let html = 
 	header (thetitle (toHtml (title ++ " (Index)")) +++
-		thelink ! [href css_filename, 
+		thelink ! [href cssFile, 
 		  rel "stylesheet", thetype "text/css"]) +++
         body <<  
 	  table ! [width "100%", cellpadding 0, cellspacing 1] << (
@@ -235,7 +248,7 @@ ppHtmlIndex odir css_filename title ifaces = do
 	(renderHtml html)
     where 
       html = header (thetitle (toHtml (title ++ " (" ++ descr ++ "Index)")) +++
-		thelink ! [href css_filename, 
+		thelink ! [href cssFile, 
 		  rel "stylesheet", thetype "text/css"]) +++
              body <<  
 	      table ! [width "100%", cellpadding 0, cellspacing 1] << (
@@ -285,12 +298,12 @@ idBeginsWith (HsSpecial s) c = head s `elem` [toLower c, toUpper c]
 -- ---------------------------------------------------------------------------
 -- Generate the HTML page for a module
 
-ppHtmlModule :: FilePath -> String -> String -> Maybe String
+ppHtmlModule :: FilePath -> String -> Maybe String
 	-> (Module,Interface) -> IO ()
-ppHtmlModule odir css_filename title source_url (Module mod,iface) = do
+ppHtmlModule odir title source_url (Module mod,iface) = do
   let html = 
 	header (thetitle (toHtml mod) +++
-		thelink ! [href css_filename,
+		thelink ! [href cssFile,
 		  rel "stylesheet", thetype "text/css"]) +++
         body <<  
 	  table ! [width "100%", cellpadding 0, cellspacing 1] << (
@@ -352,6 +365,7 @@ ppModuleContents exports
   process :: Int -> [ExportItem] -> ([Html],[ExportItem])
   process n [] = ([], [])
   process n (ExportDecl _ : rest) = process n rest
+  process n (ExportDoc _ : rest) = process n rest
   process n items@(ExportGroup lev id doc : rest) 
     | lev <= n  = ( [], items )
     | otherwise = ( html:sections, rest2 )
@@ -380,6 +394,9 @@ processExport doc_map summary (ExportGroup lev id doc)
   | otherwise = ppDocGroup lev (anchor ! [name id] << markup htmlMarkup doc)
 processExport doc_map summary (ExportDecl decl)
   = doDecl doc_map summary decl
+processExport doc_map summary (ExportDoc doc)
+  | summary = Html.emptyTable
+  | otherwise = docBox (markup htmlMarkup doc)
 
 ppDocGroup lev doc
   | lev == 1  = tda [ theclass "section1" ] << doc
diff --git a/src/HaddockRename.hs b/src/HaddockRename.hs
index d43fb959..9dfa7147 100644
--- a/src/HaddockRename.hs
+++ b/src/HaddockRename.hs
@@ -69,6 +69,9 @@ renameExportList spec = mapM renameExport spec
 	     lookupRn (\x' -> HsEThingWith x' cs') x
     renameExport (HsEModuleContents m) = return (HsEModuleContents m)
     renameExport (HsEGroup lev str) = return (HsEGroup lev str)
+    renameExport (HsEDoc str) = return (HsEDoc str)
+    renameExport (HsEDocNamed str) = return (HsEDocNamed str)
+
 
 renameDecl :: HsDecl -> RnM HsDecl
 renameDecl decl
@@ -197,3 +200,6 @@ renameExportItems items = mapM rn items
 	rn (ExportDecl decl)
 	   = do decl <- renameDecl decl
 		return (ExportDecl decl)
+	rn (ExportDoc doc)
+	   = do doc <- renameDoc doc
+		return (ExportDoc doc)
diff --git a/src/HaddockTypes.hs b/src/HaddockTypes.hs
index 21ee513c..c5010fa4 100644
--- a/src/HaddockTypes.hs
+++ b/src/HaddockTypes.hs
@@ -72,6 +72,9 @@ data ExportItem
 	String		-- section "id" (for hyperlinks)
 	Doc		-- section heading text
 
+  | ExportDoc		-- some documentation
+	Doc
+
 type ModuleMap = FiniteMap Module Interface
 
 -- -----------------------------------------------------------------------------
diff --git a/src/HaddockVersion.hs b/src/HaddockVersion.hs
index 6617203c..5048d899 100644
--- a/src/HaddockVersion.hs
+++ b/src/HaddockVersion.hs
@@ -4,7 +4,9 @@
 -- (c) Simon Marlow 2002
 --
 
-module HaddockVersion ( projectName, projectVersion, projectUrl ) where
+module HaddockVersion ( 
+	projectName, projectVersion, projectUrl
+   ) where
 
 projectName = "Haddock"
 projectUrl = "http://www.haskell.org/haddock"
diff --git a/src/HsLexer.lhs b/src/HsLexer.lhs
index ac5fa9ae..8f5c0174 100644
--- a/src/HsLexer.lhs
+++ b/src/HsLexer.lhs
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------------
--- $Id: HsLexer.lhs,v 1.3 2002/04/24 15:12:41 simonmar Exp $
+-- $Id: HsLexer.lhs,v 1.4 2002/04/25 14:40:05 simonmar Exp $
 --
 -- (c) The GHC Team, 1997-2000
 --
@@ -66,7 +66,7 @@ data Token
 
 	| DocCommentNext String		-- something beginning '-- |'
 	| DocCommentPrev String		-- something beginning '-- ^'
-	| DocCommentNamed String	-- something beginning '-- @'
+	| DocCommentNamed String	-- something beginning '-- $'
 	| DocSection Int String		-- a section heading
 
 -- Reserved operators
@@ -222,6 +222,7 @@ lexer cont input (SrcLoc _ x) y col =
 	doc (' ':'/':_) = True
 	doc (' ':'^':_) = True
 	doc (' ':'*':_) = True
+	doc (' ':'$':_) = True
 	doc _ = False
 
 nextTab x = x + (tAB_LENGTH - (x-1) `mod` tAB_LENGTH)
@@ -280,6 +281,7 @@ lexToken cont s loc y x =
 	'-':'-':' ':'|':s -> docComment DocCommentNext cont s loc y x
 	'-':'-':' ':'/':s -> docComment DocCommentNext cont s loc y x
 	'-':'-':' ':'^':s -> docComment DocCommentPrev cont s loc y x
+	'-':'-':' ':'$':s -> docComment DocCommentNamed cont s loc y x
 	'-':'-':' ':'*':s -> docSection cont ('*':s) loc y x
 
         '\'':s -> lexChar cont s loc y (x+1)
diff --git a/src/HsParser.ly b/src/HsParser.ly
index 26829cd9..c7833bf2 100644
--- a/src/HsParser.ly
+++ b/src/HsParser.ly
@@ -1,5 +1,5 @@
 q-----------------------------------------------------------------------------
-$Id: HsParser.ly,v 1.3 2002/04/24 15:57:47 simonmar Exp $
+$Id: HsParser.ly,v 1.4 2002/04/25 14:40:05 simonmar Exp $
 
 (c) Simon Marlow, Sven Panne 1997-2000
 
@@ -69,6 +69,7 @@ Docs
 
 >	DOCNEXT    { DocCommentNext $$ }
 >	DOCPREV    { DocCommentPrev $$ }
+>	DOCNAMED   { DocCommentNamed $$ }
 >	DOCGROUP   { DocSection _ _ }
 
 Symbols
@@ -185,6 +186,8 @@ The Export List
 > exportlist :: { [HsExportSpec] }
 >	:  export ',' exportlist		{ $1 : $3 }
 >	|  docgroup exportlist			{ $1 : $2 }
+>	|  DOCNAMED exportlist			{ HsEDocNamed $1 : $2 }
+>	|  DOCNEXT  exportlist			{ HsEDoc $1 : $2 }
 > 	|  ',' exportlist			{ $2 }
 >	|  export				{ [$1] }
 > 	|  {- empty -}				{ [] }
@@ -324,6 +327,7 @@ shift/reduce-conflict, so we don't handle this case here, but in bodyaux.
 >	| valdef			{ $1 }
 >	| DOCNEXT			{ HsDocCommentNext $1 }
 >	| DOCPREV			{ HsDocCommentPrev $1 }
+>	| DOCNAMED			{ HsDocCommentNamed $1 }
 >	| DOCGROUP			{ case $1 of { DocSection i s -> 
 >							HsDocGroup i s } }
 
diff --git a/src/HsSyn.lhs b/src/HsSyn.lhs
index ae55402e..7abf4454 100644
--- a/src/HsSyn.lhs
+++ b/src/HsSyn.lhs
@@ -1,5 +1,5 @@
 % -----------------------------------------------------------------------------
-% $Id: HsSyn.lhs,v 1.3 2002/04/24 15:57:48 simonmar Exp $
+% $Id: HsSyn.lhs,v 1.4 2002/04/25 14:40:05 simonmar Exp $
 %
 % (c) The GHC Team, 1997-2002
 %
@@ -80,6 +80,8 @@ data HsExportSpec
 	 | HsEThingWith HsQName [HsQName]	-- T(C_1,...,C_n)
 	 | HsEModuleContents Module		-- module M   (not for imports)
 	 | HsEGroup Int String			-- a doc section heading
+	 | HsEDoc String			-- some documentation
+	 | HsEDocNamed String			-- a reference to named doc
   deriving (Eq,Show)
 
 data HsImportDecl
@@ -127,6 +129,7 @@ data HsDecl
 	 | HsForeignExport SrcLoc HsCallConv String HsName HsType
 	 | HsDocCommentNext String	-- a documentation annotation
 	 | HsDocCommentPrev String	-- a documentation annotation
+	 | HsDocCommentNamed String	-- a documentation annotation
 	 | HsDocGroup    Int String	-- a documentation group
   deriving (Eq,Show)
 
diff --git a/src/Main.hs b/src/Main.hs
index ee6c0d3b..0b8ac7d0 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -50,6 +50,7 @@ data Flag
   | Flag_Heading String
   | Flag_SourceURL String
   | Flag_CSS String
+  | Flag_Lib String
   | Flag_OutputDir FilePath
   deriving (Eq)
 
@@ -68,7 +69,9 @@ options =
     Option ['v']  ["verbose"]  (NoArg Flag_Verbose)
 	"be verbose",
     Option []  ["css"]         (ReqArg Flag_CSS "FILE") 
-	"The CSS file to use for HTML output"
+	"The CSS file to use for HTML output",
+    Option []  ["lib"]         (ReqArg Flag_Lib "DIR") 
+	"Directory containing Haddock's auxiliary files"
   ]
 
 saved_flags :: IORef [Flag]
@@ -83,10 +86,14 @@ run flags files = do
 			[] -> Nothing
 			(t:ts) -> Just t
 
-  css_file <- case [str | Flag_CSS str <- flags] of
-		[] -> dieMsg "no --css option"
+  libdir <- case [str | Flag_Lib str <- flags] of
+		[] -> dieMsg "no --lib option"
 		fs -> return (last fs)
 
+  let css_file = case [str | Flag_CSS str <- flags] of
+			[] -> Nothing
+			fs -> Just (last fs)
+
   odir <- case [str | Flag_OutputDir str <- flags] of
 		[] -> return "."
 		fs -> return (last fs)
@@ -107,7 +114,7 @@ run flags files = do
     putStr (ppDocBook odir mod_ifaces)
 
   when (Flag_Html `elem` flags) $
-    ppHtml title source_url mod_ifaces odir css_file
+    ppHtml title source_url mod_ifaces odir css_file libdir
 
 
 parse_file file = do
@@ -292,6 +299,15 @@ mkExportItems mod_map mod env decl_map decls (Just specs)
 	= [ ExportGroup lev "" doc ]
 	where (doc, _names) = formatDocHeading (lookupForDoc env) str
 	-- ToDo: report the unresolved names
+    lookupExport (HsEDoc str)
+	= [ ExportDoc doc ]
+	where (doc, _names) = formatDocString (lookupForDoc env) str
+	-- ToDo: report the unresolved names
+    lookupExport (HsEDocNamed str)
+	| Just found <- findNamedDoc str decls
+	= let (doc, _names) = formatDocString (lookupForDoc env) found in
+	  [ ExportDoc doc ]
+	
     lookupExport _ = [] -- didn't find it?
 
     fullContentsOf m
@@ -552,3 +568,20 @@ moduleHeaderRE = mkRegexWithOpts
 	-- 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?).
+
+-- -----------------------------------------------------------------------------
+-- Named documentation
+
+findNamedDoc :: String -> [HsDecl] -> Maybe String
+findNamedDoc str decls = 
+  case matchRegex docNameRE str of
+     Just (name:_) -> search decls
+	where search [] = Nothing
+	      search (HsDocCommentNamed str : rest) = 
+		case matchRegexAll docNameRE str of
+		   Nothing -> search rest
+		   Just (_, _, after, _, _) -> Just after
+	      search (_other_decl : rest) = search rest
+     _other -> Nothing
+
+docNameRE = mkRegex "[ \t]*([A-Za-z0-9_]*)"
diff --git a/src/Makefile b/src/Makefile
index 238009e0..fe2beb1e 100644
--- a/src/Makefile
+++ b/src/Makefile
@@ -9,18 +9,16 @@ HS_PROG = haddock.bin
 HsParser_HC_OPTS += -Onot
 HaddockVersion_HC_OPTS = -DHADDOCK_VERSION=$(ProjectVersion)
 
-CSS_FILE = haddock.css
-
 ifeq "$(INSTALLING)" "1"
 ifeq "$(BIN_DIST)"   "1"
-HADDOCKCSS=$$\"\"libdir/haddock/$(CSS_FILE)
+HADDOCKLIB=$$\"\"libdir/haddock
 HADDOCKBIN=$$\"\"libexecdir/$(HS_PROG)
 else
-HADDOCKCSS=$(libdir)/haddock/$(CSS_FILE)
+HADDOCKLIB=$(libdir)/haddock
 HADDOCKBIN=$(libexecdir)/$(HS_PROG)
 endif # BIN_DIST
 else
-HADDOCKCSS=$(FPTOOLS_TOP_ABS)/haddock/html/$(CSS_FILE)
+HADDOCKLIB=$(FPTOOLS_TOP_ABS)/haddock/html
 HADDOCKBIN=$(FPTOOLS_TOP_ABS)/haddock/src/$(HS_PROG)
 endif
 
@@ -40,7 +38,7 @@ SCRIPT_OBJS=haddock.sh
 
 INTERP=$(SHELL)
 
-SCRIPT_SUBST_VARS = HADDOCKCSS HADDOCKBIN
+SCRIPT_SUBST_VARS = HADDOCKLIB HADDOCKBIN
 
 INSTALL_SCRIPTS += $(SCRIPT_PROG)
 INSTALL_LIBEXECS = $(HS_PROG)
diff --git a/src/haddock.sh b/src/haddock.sh
index b0b534f0..f1ad0191 100644
--- a/src/haddock.sh
+++ b/src/haddock.sh
@@ -1,10 +1,7 @@
 # Mini-driver for Haddock
 
 # needs the following variables:
-#	HADDOCKCSS
+#	HADDOCKLIB
 #	HADDOCKBIN
 
-case $* in
-*--css*) $HADDOCKBIN ${1+"$@"};;
-*)       $HADDOCKBIN --css $HADDOCKCSS ${1+"$@"};;
-esac
+$HADDOCKBIN --lib $HADDOCKLIB ${1+"$@"}