[haddock @ 2002-04-11 13:40:30 by simonmar]

- copy haddock.css into the same place as the generated HTML

- new option: --css <file>  specifies the style sheet to use

- new option:  -o <dir>  specifies the directory in which to
  generate the output.

- because Haddock now needs to know where to find its default stylesheet,
  we have to have a wrapper script and do the haddock-inplace thing
  (Makefile code copied largely from fptools/happy).

8 files changed, 275 insertions, 117 deletions

diff --git a/src/HaddockDB.hs b/src/HaddockDB.hs
index 1edd90fd..446bce1d 100644
--- a/src/HaddockDB.hs
+++ b/src/HaddockDB.hs
@@ -7,6 +7,8 @@
 module HaddockDB (ppDocBook) where
 
 import HaddockTypes hiding (Doc)
+import HaddockUtil
+
 import HsSyn
 import Pretty
 import FiniteMap
@@ -14,8 +16,8 @@ import FiniteMap
 -----------------------------------------------------------------------------
 -- Printing the results in DocBook format
 
-ppDocBook :: [(Module, Interface)] -> String
-ppDocBook mods = render (ppIfaces mods)
+ppDocBook :: FilePath -> [(Module, Interface)] -> String
+ppDocBook odir mods = render (ppIfaces mods)
 
 ppIfaces mods
   =  text "<!DOCTYPE BOOK PUBLIC \"-//OASIS//DTD DocBook V3.1//EN\" ["
diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs
index daf9732c..8e02e535 100644
--- a/src/HaddockHtml.hs
+++ b/src/HaddockHtml.hs
@@ -9,6 +9,7 @@ module HaddockHtml (ppHtml) where
 import Prelude hiding (div)
 import HaddockVersion
 import HaddockTypes
+import HaddockUtil
 import HsSyn
 
 import Maybe	( fromJust, isNothing, isJust )
@@ -23,18 +24,30 @@ import qualified Html
 -- -----------------------------------------------------------------------------
 -- Generating HTML documentation
 
-ppHtml :: String -> Maybe String -> [(Module, Interface)] -> IO ()
-ppHtml title source_url ifaces =  do
-  ppHtmlContents title source_url (map fst ifaces)
-  ppHtmlIndex title ifaces
-  mapM_ (ppHtmlModule title source_url) ifaces
+ppHtml	:: String
+	-> Maybe String
+	-> [(Module, Interface)]
+	-> FilePath			-- destination directory
+	-> String			-- CSS file
+	-> IO ()
+ppHtml title source_url ifaces odir css_file =  do
+  let 
+	(_css_dir, css_basename, css_suff) = splitFilename3 css_file
+	css_filename = css_basename ++ '.':css_suff
+	css_destination = odir ++ pathSeparator:css_filename
+
+  css_contents <- readFile css_file
+  writeFile css_destination css_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
 
 moduleHtmlFile :: String -> FilePath
 moduleHtmlFile mod = mod ++ ".html" -- ToDo: Z-encode filename?
 
 contentsHtmlFile = "index.html"
 indexHtmlFile    = "doc-index.html"
-styleSheetFile   = "haddock.css"
 subIndexHtmlFile k a = "doc-index-" ++ k:a:".html"
 
 footer = 
@@ -116,12 +129,13 @@ pageHeader mod iface title source_url =
 -- ---------------------------------------------------------------------------
 -- Generate the module contents
 
-ppHtmlContents :: String -> Maybe String -> [Module] -> IO ()
-ppHtmlContents title source_url mods = do
+ppHtmlContents :: FilePath -> String -> String -> Maybe String -> [Module]
+   -> IO ()
+ppHtmlContents odir css_filename title source_url mods = do
   let tree = mkModuleTree mods  
       html = 
 	header (thetitle (toHtml title) +++
-		thelink ! [href styleSheetFile, 
+		thelink ! [href css_filename, 
 		  rel "stylesheet", thetype "text/css"]) +++
         body <<  
 	  table ! [width "100%", cellpadding 0, cellspacing 1] << (
@@ -129,7 +143,7 @@ ppHtmlContents title source_url mods = do
 	    ppModuleTree title tree </>
 	    footer
 	  )
-  writeFile contentsHtmlFile (renderHtml html)
+  writeFile (odir ++ pathSeparator:contentsHtmlFile) (renderHtml html)
 
 ppModuleTree :: String -> [ModuleTree] -> HtmlTable
 ppModuleTree title ts = 
@@ -176,11 +190,11 @@ splitModule (Module mod) = split mod
 -- ---------------------------------------------------------------------------
 -- Generate the index
 
-ppHtmlIndex :: String -> [(Module,Interface)] -> IO ()
-ppHtmlIndex title ifaces = do
+ppHtmlIndex :: FilePath -> String -> String -> [(Module,Interface)] -> IO ()
+ppHtmlIndex odir css_filename title ifaces = do
   let html = 
 	header (thetitle (toHtml (title ++ " (Index)")) +++
-		thelink ! [href styleSheetFile, 
+		thelink ! [href css_filename, 
 		  rel "stylesheet", thetype "text/css"]) +++
         body <<  
 	  table ! [width "100%", cellpadding 0, cellspacing 1] << (
@@ -196,7 +210,7 @@ ppHtmlIndex title ifaces = do
         mapM_ (do_sub_index "Function/Constructor" var_index 'v') ['A'..'Z'] 
     )
 
-  writeFile indexHtmlFile (renderHtml html)
+  writeFile (odir ++ pathSeparator:indexHtmlFile) (renderHtml html)
 
  where
   split_indices = length tycls_index > 50 || length var_index > 50
@@ -212,10 +226,11 @@ ppHtmlIndex title ifaces = do
 	  aboves (map indexElt this_ix) 
  	
   do_sub_index descr this_ix kind c
-    = writeFile (subIndexHtmlFile kind c) (renderHtml html)
+    = writeFile (odir ++ pathSeparator:subIndexHtmlFile kind c)
+	(renderHtml html)
     where 
       html = header (thetitle (toHtml (title ++ " (" ++ descr ++ "Index)")) +++
-		thelink ! [href styleSheetFile, 
+		thelink ! [href css_filename, 
 		  rel "stylesheet", thetype "text/css"]) +++
              body <<  
 	      table ! [width "100%", cellpadding 0, cellspacing 1] << (
@@ -265,11 +280,12 @@ idBeginsWith (HsSpecial s) c = head s `elem` [toLower c, toUpper c]
 -- ---------------------------------------------------------------------------
 -- Generate the HTML page for a module
 
-ppHtmlModule :: String -> Maybe String -> (Module,Interface) -> IO ()
-ppHtmlModule title source_url (Module mod,iface) = do
+ppHtmlModule :: FilePath -> String -> String -> Maybe String
+	-> (Module,Interface) -> IO ()
+ppHtmlModule odir css_filename title source_url (Module mod,iface) = do
   let html = 
 	header (thetitle (toHtml mod) +++
-		thelink ! [href styleSheetFile, 
+		thelink ! [href css_filename,
 		  rel "stylesheet", thetype "text/css"]) +++
         body <<  
 	  table ! [width "100%", cellpadding 0, cellspacing 1] << (
@@ -277,7 +293,7 @@ ppHtmlModule title source_url (Module mod,iface) = do
 	    ifaceToHtml mod iface </>
 	    footer
          )
-  writeFile (moduleHtmlFile mod) (renderHtml html)
+  writeFile (odir ++ pathSeparator:moduleHtmlFile mod) (renderHtml html)
 
 ifaceToHtml :: String -> Interface -> HtmlTable
 ifaceToHtml mod iface
diff --git a/src/HaddockTypes.hs b/src/HaddockTypes.hs
index e29d5dae..c157a753 100644
--- a/src/HaddockTypes.hs
+++ b/src/HaddockTypes.hs
@@ -12,16 +12,11 @@ module HaddockTypes (
   DocString, GenDoc(..), Doc, ParsedDoc, DocMarkup(..),
   markup, mapIdent, 
   docAppend, docParagraph,
-
-  -- * Misc utilities
-  nameOfQName, collectNames, declBinders, declMainBinder, splitTyConApp,
-  restrictTo,
  ) where
 
 import FiniteMap
 import HsSyn
 
-import List (intersect)
 import Char (isSpace)
 
 -- ---------------------------------------------------------------------------
@@ -77,78 +72,6 @@ data ExportItem
 type ModuleMap = FiniteMap Module Interface
 
 -- -----------------------------------------------------------------------------
--- Some Utilities
-
-nameOfQName (Qual _ n) = n
-nameOfQName (UnQual n) = n
-
-collectNames :: [HsDecl] -> [HsName]
-collectNames ds = concat (map declBinders ds)
-
-declMainBinder :: HsDecl -> Maybe HsName
-declMainBinder d = 
-   case d of
-     HsTypeDecl _ n _ _          -> Just n
-     HsDataDecl _ _ n _ cons _   -> Just n
-     HsNewTypeDecl _ _ n _ _ _   -> Just n
-     HsClassDecl _ qt decls      -> Just (exQtNm qt)
-     HsTypeSig _ [n] _           -> Just n
-     HsTypeSig _ ns _            -> error "declMainBinder"
-     HsForeignImport _ _ _ _ n _ -> Just n
-     _                           -> Nothing
-
-declBinders :: HsDecl -> [HsName]
-declBinders d =
-   case d of
-     HsTypeDecl _ n _ _          -> [n]
-     HsDataDecl _ _ n _ cons _   -> n : concat (map conDeclBinders cons)
-     HsNewTypeDecl _ _ n _ _ _   -> [n]
-     HsClassDecl _ qt decls      -> exQtNm qt : collectNames decls
-     HsTypeSig _ ns _            -> ns
-     HsForeignImport _ _ _ _ n _ -> [n]
-     _                           -> []
-
-conDeclBinders (HsConDecl _ n _ _) = [n]
-conDeclBinders (HsRecDecl _ n fields _) = n : concat (map fieldDeclBinders fields)
-
-fieldDeclBinders (HsFieldDecl ns _ _) = ns
-
-exQtNm (HsForAllType _ _ t) = nameOfQName (fst (splitTyConApp t))
-exQtNm t = nameOfQName (fst (splitTyConApp t))
-
-splitTyConApp :: HsType -> (HsQName,[HsType])
-splitTyConApp t = split t []
- where
-	split :: HsType -> [HsType] -> (HsQName,[HsType])
-	split (HsTyApp t u) ts = split t (u:ts)
-	split (HsTyCon t)   ts = (t,ts)
-	split _ _ = error "splitTyConApp"
-
--- ---------------------------------------------------------------------------
--- Making abstract declarations
-
-restrictTo :: [HsName] -> HsDecl -> HsDecl
-restrictTo names decl = case decl of
-     HsDataDecl loc ctxt n xs cons drv -> 
-	HsDataDecl loc ctxt n xs (restrictCons names cons) drv
-     HsNewTypeDecl loc ctxt n xs con drv ->
-	HsDataDecl loc ctxt n xs (restrictCons names [con]) drv	
-     HsClassDecl loc qt decls  ->
-	HsClassDecl loc qt (restrictDecls names decls)
-     _ -> decl
-   
-restrictCons :: [HsName] -> [HsConDecl] -> [HsConDecl]
-restrictCons names decls = filter keep decls
-  where keep (HsConDecl _ n _ _) = n `elem` names
-	keep (HsRecDecl _ n _ _) = n `elem` names
-	-- ToDo: records not right
-
-restrictDecls :: [HsName] -> [HsDecl] -> [HsDecl]
-restrictDecls names decls = filter keep decls
-  where keep d = not (null (declBinders d `intersect` names))
-	-- ToDo: not really correct
-
--- -----------------------------------------------------------------------------
 -- Doc strings and formatting
 
 data GenDoc id
diff --git a/src/HaddockUtil.hs b/src/HaddockUtil.hs
new file mode 100644
index 00000000..51c31438
--- /dev/null
+++ b/src/HaddockUtil.hs
@@ -0,0 +1,138 @@
+--
+-- Haddock - A Haskell Documentation Tool
+--
+-- (c) The University of Glasgow 2001-2002
+-- (c) Simon Marlow 2002
+--
+
+module HaddockUtil (
+
+  -- * Misc utilities
+  nameOfQName, collectNames, declBinders, declMainBinder, splitTyConApp,
+  restrictTo,
+
+  -- * Filename utilities
+  basename, dirname, splitFilename3, 
+  isPathSeparator, pathSeparator
+
+ ) where
+
+import HsSyn
+import List (intersect)
+
+-- -----------------------------------------------------------------------------
+-- Some Utilities
+
+nameOfQName (Qual _ n) = n
+nameOfQName (UnQual n) = n
+
+collectNames :: [HsDecl] -> [HsName]
+collectNames ds = concat (map declBinders ds)
+
+declMainBinder :: HsDecl -> Maybe HsName
+declMainBinder d = 
+   case d of
+     HsTypeDecl _ n _ _          -> Just n
+     HsDataDecl _ _ n _ cons _   -> Just n
+     HsNewTypeDecl _ _ n _ _ _   -> Just n
+     HsClassDecl _ qt decls      -> Just (exQtNm qt)
+     HsTypeSig _ [n] _           -> Just n
+     HsTypeSig _ ns _            -> error "declMainBinder"
+     HsForeignImport _ _ _ _ n _ -> Just n
+     _                           -> Nothing
+
+declBinders :: HsDecl -> [HsName]
+declBinders d =
+   case d of
+     HsTypeDecl _ n _ _          -> [n]
+     HsDataDecl _ _ n _ cons _   -> n : concat (map conDeclBinders cons)
+     HsNewTypeDecl _ _ n _ _ _   -> [n]
+     HsClassDecl _ qt decls      -> exQtNm qt : collectNames decls
+     HsTypeSig _ ns _            -> ns
+     HsForeignImport _ _ _ _ n _ -> [n]
+     _                           -> []
+
+conDeclBinders (HsConDecl _ n _ _) = [n]
+conDeclBinders (HsRecDecl _ n fields _) = n : concat (map fieldDeclBinders fields)
+
+fieldDeclBinders (HsFieldDecl ns _ _) = ns
+
+exQtNm (HsForAllType _ _ t) = nameOfQName (fst (splitTyConApp t))
+exQtNm t = nameOfQName (fst (splitTyConApp t))
+
+splitTyConApp :: HsType -> (HsQName,[HsType])
+splitTyConApp t = split t []
+ where
+	split :: HsType -> [HsType] -> (HsQName,[HsType])
+	split (HsTyApp t u) ts = split t (u:ts)
+	split (HsTyCon t)   ts = (t,ts)
+	split _ _ = error "splitTyConApp"
+
+-- ---------------------------------------------------------------------------
+-- Making abstract declarations
+
+restrictTo :: [HsName] -> HsDecl -> HsDecl
+restrictTo names decl = case decl of
+     HsDataDecl loc ctxt n xs cons drv -> 
+	HsDataDecl loc ctxt n xs (restrictCons names cons) drv
+     HsNewTypeDecl loc ctxt n xs con drv ->
+	HsDataDecl loc ctxt n xs (restrictCons names [con]) drv	
+     HsClassDecl loc qt decls  ->
+	HsClassDecl loc qt (restrictDecls names decls)
+     _ -> decl
+   
+restrictCons :: [HsName] -> [HsConDecl] -> [HsConDecl]
+restrictCons names decls = filter keep decls
+  where keep (HsConDecl _ n _ _) = n `elem` names
+	keep (HsRecDecl _ n _ _) = n `elem` names
+	-- ToDo: records not right
+
+restrictDecls :: [HsName] -> [HsDecl] -> [HsDecl]
+restrictDecls names decls = filter keep decls
+  where keep d = not (null (declBinders d `intersect` names))
+	-- ToDo: not really correct
+
+-- -----------------------------------------------------------------------------
+-- Filename mangling functions stolen from GHC's main/DriverUtil.lhs.
+
+type Suffix = String
+
+splitFilename :: String -> (String,Suffix)
+splitFilename f = split_longest_prefix f (=='.')
+
+basename :: String -> String
+basename f = base where (_dir, base, _suff) = splitFilename3 f
+
+dirname :: String -> String
+dirname f = dir where (dir, _base, _suff) = splitFilename3 f
+
+-- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext")
+splitFilename3 :: String -> (String,String,Suffix)
+splitFilename3 str
+   = let (dir, rest) = split_longest_prefix str isPathSeparator
+	 (name, ext) = splitFilename rest
+	 real_dir | null dir  = "."
+		  | otherwise = dir
+     in  (real_dir, name, ext)
+
+split_longest_prefix :: String -> (Char -> Bool) -> (String,String)
+split_longest_prefix s pred
+  = case pre of
+	[]      -> ([], reverse suf)
+	(_:pre) -> (reverse pre, reverse suf)
+  where (suf,pre) = break pred (reverse s)
+
+pathSeparator :: Char
+#ifdef __WIN32__
+pathSeparator = '\\'
+#else
+pathSeparator = '/'
+#endif
+
+isPathSeparator :: Char -> Bool
+isPathSeparator ch =
+#ifdef mingw32_TARGET_OS
+  ch == '/' || ch == '\\'
+#else
+  ch == '/'
+#endif
diff --git a/src/HaddockVersion.hs b/src/HaddockVersion.hs
index 0442761f..6617203c 100644
--- a/src/HaddockVersion.hs
+++ b/src/HaddockVersion.hs
@@ -7,5 +7,8 @@
 module HaddockVersion ( projectName, projectVersion, projectUrl ) where
 
 projectName = "Haddock"
-projectVersion = "0.0"
 projectUrl = "http://www.haskell.org/haddock"
+
+-- The version comes in via CPP from mk/version.mk
+projectVersion = tail "\ 
+  \ HADDOCK_VERSION"
diff --git a/src/Main.hs b/src/Main.hs
index 19941ed1..7be91b9a 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -12,6 +12,7 @@ import HaddockLex
 import HaddockDB
 import HaddockHtml
 import HaddockTypes
+import HaddockUtil
 
 import HsLexer hiding (Token)
 import HsParser
@@ -47,27 +48,48 @@ data Flag
   | Flag_Html
   | Flag_Heading String
   | Flag_SourceURL String
+  | Flag_CSS String
+  | Flag_OutputDir FilePath
   deriving (Eq)
 
 options =
   [ 
-    Option ['t']  ["heading"]  (ReqArg Flag_Heading "HEADING")
-	"page heading",
-    Option ['v']  ["verbose"]  (NoArg Flag_Verbose)
-	"be verbose",
     Option ['d']  ["docbook"]  (NoArg Flag_DocBook)
 	"output in docbook (SGML)",
     Option ['h']  ["html"]     (NoArg Flag_Html)
 	"output in HTML",
+    Option ['o']  ["odir"]     (ReqArg Flag_OutputDir "DIR")
+	"directory in which to put the output files",
     Option ['s']  ["source"]   (ReqArg Flag_SourceURL "URL") 
-	"base URL for links to source code"
+	"base URL for links to source code",
+    Option ['t']  ["heading"]  (ReqArg Flag_Heading "HEADING")
+	"page heading",
+    Option ['v']  ["verbose"]  (NoArg Flag_Verbose)
+	"be verbose",
+    Option []  ["css"]         (ReqArg Flag_CSS "FILE") 
+	"The CSS file to use for HTML output"
   ]
 
 saved_flags :: IORef [Flag]
 saved_flags = unsafePerformIO (newIORef (error "no flags yet"))
 
 run flags files = do
-  seq stderr $ do
+  let title = case [str | Flag_Heading str <- flags] of
+		[] -> ""
+		(t:ts) -> t
+
+      source_url = case [str | Flag_SourceURL str <- flags] of
+			[] -> Nothing
+			(t:ts) -> Just t
+
+  css_file <- case [str | Flag_CSS str <- flags] of
+		[] -> dieMsg "no --css option"
+		fs -> return (last fs)
+
+  odir <- case [str | Flag_OutputDir str <- flags] of
+		[] -> return "."
+		fs -> return (last fs)
+
   writeIORef saved_flags flags
   parsed_mods <- sequence (map parse_file files)
 
@@ -77,22 +99,14 @@ run flags files = do
       mod_ifaces = [ (m,i) | (m,i,_,_) <- ifaces ]
       module_map = listToFM mod_ifaces
 
-  let title = case [str | Flag_Heading str <- flags] of
-		[] -> ""
-		(t:ts) -> t
-
-      source_url = case [str | Flag_SourceURL str <- flags] of
-			[] -> Nothing
-			(t:ts) -> Just t
-
   sequence [ reportMissingNames m ns_docs ns_decls 
 	   | (m, _, ns_docs, ns_decls) <- ifaces ]
 
   when (Flag_DocBook `elem` flags) $
-    putStr (ppDocBook mod_ifaces)
+    putStr (ppDocBook odir mod_ifaces)
 
   when (Flag_Html `elem` flags) $
-    ppHtml title source_url mod_ifaces
+    ppHtml title source_url mod_ifaces odir css_file
 
 
 parse_file file = do
@@ -513,6 +527,12 @@ strToHsQNames str
 -----------------------------------------------------------------------------
 -- 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
 
diff --git a/src/Makefile b/src/Makefile
index 66c0b0b5..238009e0 100644
--- a/src/Makefile
+++ b/src/Makefile
@@ -1,9 +1,55 @@
 TOP = ..
 include $(TOP)/mk/boilerplate.mk
 
+INSTALLING=1
+
 SRC_HC_OPTS += -package data -package text -fglasgow-exts -cpp
-HS_PROG = haddock
+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)
+HADDOCKBIN=$$\"\"libexecdir/$(HS_PROG)
+else
+HADDOCKCSS=$(libdir)/haddock/$(CSS_FILE)
+HADDOCKBIN=$(libexecdir)/$(HS_PROG)
+endif # BIN_DIST
+else
+HADDOCKCSS=$(FPTOOLS_TOP_ABS)/haddock/html/$(CSS_FILE)
+HADDOCKBIN=$(FPTOOLS_TOP_ABS)/haddock/src/$(HS_PROG)
+endif
+
+INSTALLED_SCRIPT_PROG  = haddock-$(ProjectVersion)
+INPLACE_SCRIPT_PROG    = haddock-inplace
+
+ifeq "$(INSTALLING)" "1"
+TOP_PWD 	:= $(prefix)
+SCRIPT_PROG 	=  $(INSTALLED_SCRIPT_PROG)
+LINK	 	=  haddock
+else
+TOP_PWD 	:= $(FPTOOLS_TOP_ABS)
+SCRIPT_PROG 	=  $(INPLACE_SCRIPT_PROG)
+endif
+
+SCRIPT_OBJS=haddock.sh
+
+INTERP=$(SHELL)
+
+SCRIPT_SUBST_VARS = HADDOCKCSS HADDOCKBIN
+
+INSTALL_SCRIPTS += $(SCRIPT_PROG)
+INSTALL_LIBEXECS = $(HS_PROG)
+
+# don't recurse on 'make install'
+#
+ifeq "$(INSTALLING)" "1"
+all clean distclean maintainer-clean ::
+	$(MAKE) INSTALLING=0 BIN_DIST=0 $(MFLAGS) $@
+endif
 
 include $(TOP)/mk/target.mk
diff --git a/src/haddock.sh b/src/haddock.sh
new file mode 100644
index 00000000..b0b534f0
--- /dev/null
+++ b/src/haddock.sh
@@ -0,0 +1,10 @@
+# Mini-driver for Haddock
+
+# needs the following variables:
+#	HADDOCKCSS
+#	HADDOCKBIN
+
+case $* in
+*--css*) $HADDOCKBIN ${1+"$@"};;
+*)       $HADDOCKBIN --css $HADDOCKCSS ${1+"$@"};;
+esac