diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/HaddockDB.hs | 6 | ||||
| -rw-r--r-- | src/HaddockHtml.hs | 56 | ||||
| -rw-r--r-- | src/HaddockTypes.hs | 77 | ||||
| -rw-r--r-- | src/HaddockUtil.hs | 138 | ||||
| -rw-r--r-- | src/HaddockVersion.hs | 5 | ||||
| -rw-r--r-- | src/Main.hs | 52 | ||||
| -rw-r--r-- | src/Makefile | 48 | ||||
| -rw-r--r-- | src/haddock.sh | 10 |
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 |