diff options
-rw-r--r-- | src/Haddock/Backends/Xhtml.hs | 78 | ||||
-rw-r--r-- | src/Haddock/Backends/Xhtml/Themes.hs | 180 | ||||
-rw-r--r-- | src/Haddock/Options.hs | 10 | ||||
-rw-r--r-- | src/Haddock/Utils.hs | 6 | ||||
-rw-r--r-- | src/Main.hs | 15 |
5 files changed, 213 insertions, 76 deletions
diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs index 2befd9bd..00f8e30b 100644 --- a/src/Haddock/Backends/Xhtml.hs +++ b/src/Haddock/Backends/Xhtml.hs @@ -63,6 +63,7 @@ ppHtml :: String -> [Interface] -> FilePath -- destination directory -> Maybe (Doc GHC.RdrName) -- prologue text, maybe + -> Themes -- themes -> SourceURLs -- the source URL (--source) -> WikiURLs -- the wiki URL (--wiki) -> Maybe String -- the contents URL (--use-contents) @@ -71,24 +72,24 @@ ppHtml :: String -> IO () ppHtml doctitle maybe_package ifaces odir prologue - maybe_source_url maybe_wiki_url + themes maybe_source_url maybe_wiki_url maybe_contents_url maybe_index_url unicode = do let visible_ifaces = filter visible ifaces visible i = OptHide `notElem` ifaceOptions i when (not (isJust maybe_contents_url)) $ ppHtmlContents odir doctitle maybe_package - maybe_index_url maybe_source_url maybe_wiki_url + themes maybe_index_url maybe_source_url maybe_wiki_url (map toInstalledIface visible_ifaces) False -- we don't want to display the packages in a single-package contents prologue when (not (isJust maybe_index_url)) $ ppHtmlIndex odir doctitle maybe_package - maybe_contents_url maybe_source_url maybe_wiki_url + themes maybe_contents_url maybe_source_url maybe_wiki_url (map toInstalledIface visible_ifaces) - mapM_ (ppHtmlModule odir doctitle + mapM_ (ppHtmlModule odir doctitle themes maybe_source_url maybe_wiki_url maybe_contents_url maybe_index_url unicode) visible_ifaces @@ -109,29 +110,24 @@ copyFile fromFPath toFPath = copyContents hFrom hTo buffer -copyHtmlBits :: FilePath -> FilePath -> Maybe FilePath -> IO () -copyHtmlBits odir libdir _maybe_css = do +copyHtmlBits :: FilePath -> FilePath -> Themes -> IO () +copyHtmlBits odir libdir themes = do let libhtmldir = joinPath [libdir, "html"] - {- - css_file = case maybe_css of - Nothing -> joinPath [libhtmldir, 'x':cssFile] - Just f -> f - css_destination = joinPath [odir, cssFile] - -} + copyCssFile f = do + copyFile f (combine odir (takeFileName f)) copyLibFile f = do copyFile (joinPath [libhtmldir, f]) (joinPath [odir, f]) - --copyFile css_file css_destination - mapM_ copyLibFile cssFiles + mapM_ copyCssFile (cssFiles themes) mapM_ copyLibFile [ plusFile, minusFile, jsFile, framesFile ] -headHtml :: String -> Maybe String -> Html -headHtml docTitle miniPage = +headHtml :: String -> Maybe String -> Themes -> Html +headHtml docTitle miniPage themes = header << [ meta ! [httpequiv "Content-Type", content "text/html; charset=UTF-8"], thetitle << docTitle, - styleSheet, + styleSheet themes, script ! [src jsFile, thetype "text/javascript"] << noHtml, script ! [thetype "text/javascript"] -- NB: Within XHTML, the content of script tags needs to be @@ -180,11 +176,11 @@ indexButton maybe_index_url where url = maybe indexHtmlFile id maybe_index_url -bodyHtml :: String -> Maybe Interface +bodyHtml :: String -> Maybe Interface -> Themes -> SourceURLs -> WikiURLs -> Maybe String -> Maybe String -> Html -> Html -bodyHtml doctitle iface +bodyHtml doctitle iface themes maybe_source_url maybe_wiki_url maybe_contents_url maybe_index_url pageContent = @@ -196,7 +192,7 @@ bodyHtml doctitle iface wikiButton maybe_wiki_url (ifaceMod `fmap` iface), contentsButton maybe_contents_url, indexButton maybe_index_url - ] ++ [styleMenu]) ! [theclass "links"] + ] ++ [styleMenu themes]) ! [theclass "links"] ], divContent << pageContent, divFooter << paragraph << ( @@ -236,19 +232,20 @@ ppHtmlContents :: FilePath -> String -> Maybe String + -> Themes -> Maybe String -> SourceURLs -> WikiURLs -> [InstalledInterface] -> Bool -> Maybe (Doc GHC.RdrName) -> IO () -ppHtmlContents odir doctitle - _maybe_package maybe_index_url +ppHtmlContents odir doctitle _maybe_package + themes maybe_index_url maybe_source_url maybe_wiki_url ifaces showPkgs prologue = do let tree = mkModuleTree showPkgs [(instMod iface, toInstalledDescription iface) | iface <- ifaces] html = - headHtml doctitle Nothing +++ - bodyHtml doctitle Nothing + headHtml doctitle Nothing themes +++ + bodyHtml doctitle Nothing themes maybe_source_url maybe_wiki_url Nothing maybe_index_url << [ ppPrologue doctitle prologue, @@ -258,7 +255,7 @@ ppHtmlContents odir doctitle writeFile (joinPath [odir, contentsHtmlFile]) (renderToString html) -- XXX: think of a better place for this? - ppHtmlContentsFrame odir doctitle ifaces + ppHtmlContentsFrame odir doctitle themes ifaces ppPrologue :: String -> Maybe (Doc GHC.RdrName) -> Html @@ -324,11 +321,12 @@ flatModuleTree ifaces = << toHtml txt -ppHtmlContentsFrame :: FilePath -> String -> [InstalledInterface] -> IO () -ppHtmlContentsFrame odir doctitle ifaces = do +ppHtmlContentsFrame :: FilePath -> String -> Themes + -> [InstalledInterface] -> IO () +ppHtmlContentsFrame odir doctitle themes ifaces = do let mods = flatModuleTree ifaces html = - headHtml doctitle Nothing +++ + headHtml doctitle Nothing themes +++ miniBody << divModuleList << (sectionName << "Modules" +++ ulist << [ li ! [theclass "module"] << m | m <- mods ]) @@ -344,12 +342,13 @@ ppHtmlContentsFrame odir doctitle ifaces = do ppHtmlIndex :: FilePath -> String -> Maybe String + -> Themes -> Maybe String -> SourceURLs -> WikiURLs -> [InstalledInterface] -> IO () -ppHtmlIndex odir doctitle _maybe_package +ppHtmlIndex odir doctitle _maybe_package themes maybe_contents_url maybe_source_url maybe_wiki_url ifaces = do let html = indexPage split_indices Nothing (if split_indices then [] else index) @@ -363,8 +362,8 @@ ppHtmlIndex odir doctitle _maybe_package where indexPage showLetters ch items = - headHtml (doctitle ++ " (" ++ indexName ch ++ ")") Nothing +++ - bodyHtml doctitle Nothing + headHtml (doctitle ++ " (" ++ indexName ch ++ ")") Nothing themes +++ + bodyHtml doctitle Nothing themes maybe_source_url maybe_wiki_url maybe_contents_url Nothing << [ if showLetters then indexInitialLetterLinks else noHtml, @@ -458,19 +457,19 @@ ppHtmlIndex odir doctitle _maybe_package ppHtmlModule - :: FilePath -> String + :: FilePath -> String -> Themes -> SourceURLs -> WikiURLs -> Maybe String -> Maybe String -> Bool -> Interface -> IO () -ppHtmlModule odir doctitle +ppHtmlModule odir doctitle themes maybe_source_url maybe_wiki_url maybe_contents_url maybe_index_url unicode iface = do let mdl = ifaceMod iface mdl_str = moduleString mdl html = - headHtml mdl_str (Just $ "mini_" ++ moduleHtmlFile mdl) +++ - bodyHtml doctitle (Just iface) + headHtml mdl_str (Just $ "mini_" ++ moduleHtmlFile mdl) themes +++ + bodyHtml doctitle (Just iface) themes maybe_source_url maybe_wiki_url maybe_contents_url maybe_index_url << [ divModuleHeader << (sectionName << mdl_str +++ moduleInfo iface), @@ -479,14 +478,15 @@ ppHtmlModule odir doctitle createDirectoryIfMissing True odir writeFile (joinPath [odir, moduleHtmlFile mdl]) (renderToString html) - ppHtmlModuleMiniSynopsis odir doctitle iface unicode + ppHtmlModuleMiniSynopsis odir doctitle themes iface unicode -ppHtmlModuleMiniSynopsis :: FilePath -> String -> Interface -> Bool -> IO () -ppHtmlModuleMiniSynopsis odir _doctitle iface unicode = do +ppHtmlModuleMiniSynopsis :: FilePath -> String -> Themes + -> Interface -> Bool -> IO () +ppHtmlModuleMiniSynopsis odir _doctitle themes iface unicode = do let mdl = ifaceMod iface html = - headHtml (moduleString mdl) Nothing +++ + headHtml (moduleString mdl) Nothing themes +++ miniBody << (divModuleHeader << sectionName << moduleString mdl +++ miniSynopsis mdl iface unicode) diff --git a/src/Haddock/Backends/Xhtml/Themes.hs b/src/Haddock/Backends/Xhtml/Themes.hs index 0e398532..5874d251 100644 --- a/src/Haddock/Backends/Xhtml/Themes.hs +++ b/src/Haddock/Backends/Xhtml/Themes.hs @@ -9,22 +9,30 @@ -- Portability : portable ----------------------------------------------------------------------------- module Haddock.Backends.Xhtml.Themes ( - CssTheme(..), - + Themes, + getThemes, + cssFiles, styleSheet, stylePickers, styleMenu ) where import Haddock.Backends.Xhtml.Utils (onclick) -import Haddock.Utils (iconFile) +import Haddock.Options +import Control.Monad (liftM) +import Data.Either (lefts, rights) import Data.List (nub) +import Data.Maybe (listToMaybe) +import System.Directory +import System.FilePath import Text.XHtml hiding ( name, title, p, quote ) import qualified Text.XHtml as XHtml --- Standard set of style sheets, first is the preferred +-------------------------------------------------------------------------------- +-- * CSS Themes +-------------------------------------------------------------------------------- data CssTheme = CssTheme { themeName :: String, @@ -32,36 +40,160 @@ data CssTheme = CssTheme { themeFiles :: [FilePath] } +type Themes = [CssTheme] + + +-- | Standard theme used by default +standardTheme :: FilePath -> CssTheme +standardTheme libDir = locateIn libDir $ + CssTheme "Ocean" "nhaddock.css" ["nhaddock.css", "hslogo-16.png"] -themes :: [CssTheme] -themes = [ - CssTheme "Classic" "xhaddock.css" ["xhaddock.css", iconFile], - CssTheme "Tibbe" "thaddock.css" ["thaddock.css", iconFile], - CssTheme "Snappy" "shaddock.css" ["shaddock.css", "s_haskell_icon.gif"], - CssTheme "Nomi" "nhaddock.css" ["nhaddock.css", "hslogo-16.png"] + +-- | Default themes that are part of Haddock; added with --default-themes +defaultThemes :: FilePath -> Themes +defaultThemes libDir = standardTheme libDir : + (map (locateIn libDir) $ [ + CssTheme "Classic" "xhaddock.css" ["xhaddock.css", "haskell_icon.gif"], + CssTheme "Tibbe" "thaddock.css" ["thaddock.css", "haskell_icon.gif"], + CssTheme "Snappy" "shaddock.css" ["shaddock.css", "s_haskell_icon.gif"] ] + ) + +locateIn :: FilePath -> CssTheme -> CssTheme +locateIn libDir t = t { themeFiles = map loc (themeFiles t) } + where loc = combine libDir . combine "html" -cssFiles :: [String] -cssFiles = nub (concatMap themeFiles themes) +-------------------------------------------------------------------------------- +-- * CSS Theme Arguments +-------------------------------------------------------------------------------- -styleSheet :: Html -styleSheet = toHtml $ zipWith mkLink themes rels +-- | Process input flags for CSS Theme arguments +getThemes :: FilePath -> [Flag] -> IO (Either String Themes) +getThemes libDir flags = + liftM (someTheme . concatEither) (mapM themeFlag flags) + where + themeFlag :: Flag -> IO (Either String Themes) + + themeFlag (Flag_CSS path) = (liftM . liftEither) (:[]) (theme path) + + themeFlag (Flag_Themes path) = do + itsADirectory <- doesDirectoryExist path + if itsADirectory + then do + items <- getDirectoryItems path + themes <- mapM theme items + case rights themes of + [] -> errMessage "no themes found in" path + ts -> retRight ts + else errMessage "not a valid theme directory" path + + themeFlag (Flag_DefaultThemes) = retRight (defaultThemes libDir) + themeFlag _ = retRight [] + + theme :: FilePath -> IO (Either String CssTheme) + theme path = do + itsAFile <- doesFileExist path + if itsAFile + then singleFileTheme path + else do + itsADirectory <- doesDirectoryExist path + if itsADirectory + then directoryTheme path + else errMessage "css path doesn't exist" path + + someTheme :: Either String Themes -> Either String Themes + someTheme (Right []) = Right [standardTheme libDir] + someTheme est = est + +errMessage :: String -> FilePath -> IO (Either String a) +errMessage msg path = return (Left (msg ++ ": \"" ++ path ++ "\"")) + + +retRight :: a -> IO (Either String a) +retRight = return . Right + + +singleFileTheme :: FilePath -> IO (Either String CssTheme) +singleFileTheme path = + if isCssFilePath path + then retRight $ CssTheme name file [path] + else errMessage "file extension isn't .css" path + where + name = takeBaseName path + file = takeFileName path + + +directoryTheme :: FilePath -> IO (Either String CssTheme) +directoryTheme path = do + items <- getDirectoryItems path + case filter isCssFilePath items of + [] -> errMessage "no .css file in theme directory" path + [cf] -> retRight $ CssTheme (takeBaseName path) (takeFileName cf) items + _ -> errMessage "more than one .css file in theme directory" path + + +getDirectoryItems :: FilePath -> IO [FilePath] +getDirectoryItems path = + getDirectoryContents path >>= return . map (combine path) + + +isCssFilePath :: FilePath -> Bool +isCssFilePath path = takeExtension path == ".css" + + +-------------------------------------------------------------------------------- +-- * Style Sheet Utilities +-------------------------------------------------------------------------------- + +cssFiles :: Themes -> [String] +cssFiles ts = nub $ concatMap themeFiles ts + + +styleSheet :: Themes -> Html +styleSheet ts = toHtml $ zipWith mkLink rels ts where rels = ("stylesheet" : repeat "alternate stylesheet") - mkLink (CssTheme aTitle aRef _) aRel = - (thelink ! [href aRef, rel aRel, thetype "text/css", XHtml.title aTitle]) noHtml + mkLink aRel t = + thelink + ! [ href (themeHref t), rel aRel, thetype "text/css", + XHtml.title (themeName t) + ] + << noHtml -stylePickers :: [Html] -stylePickers = map mkPicker themes + +stylePickers :: Themes -> [Html] +stylePickers ts = map mkPicker ts where - mkPicker (CssTheme aTitle aRef _) = - let js = "setActiveStyleSheet('" ++ aRef ++ "'); return false;" in - anchor ! [href "#", onclick js] << aTitle + mkPicker t = + let js = "setActiveStyleSheet('" ++ themeHref t ++ "'); return false;" in + anchor ! [href "#", onclick js] << themeName t + -styleMenu :: Html -styleMenu = thediv ! [identifier "style-menu-holder"] << [ +styleMenu :: Themes -> Html +styleMenu [] = noHtml +styleMenu [_] = noHtml +styleMenu ts = thediv ! [identifier "style-menu-holder"] << [ anchor ! [ href "#", onclick js ] << "Style \9662", - unordList stylePickers ! [ identifier "style-menu", theclass "hide" ] + unordList (stylePickers ts) ! [ identifier "style-menu", theclass "hide" ] ] where js = "styleMenu(); return false;" + + +-------------------------------------------------------------------------------- +-- * Either Utilities +-------------------------------------------------------------------------------- + +-- These three routines are here because Haddock does not have access to the +-- Control.Monad.Error module which supplies the Functor and Monad instances +-- for Either String. + +sequenceEither :: [Either a b] -> Either a [b] +sequenceEither es = maybe (Right $ rights es) Left (listToMaybe (lefts es)) + +liftEither :: (b -> c) -> Either a b -> Either a c +liftEither f = either Left (Right . f) + +concatEither :: [Either a [b]] -> Either a [b] +concatEither = liftEither concat . sequenceEither + diff --git a/src/Haddock/Options.hs b/src/Haddock/Options.hs index 132a5e52..4ea2db5e 100644 --- a/src/Haddock/Options.hs +++ b/src/Haddock/Options.hs @@ -42,6 +42,7 @@ data Flag | Flag_Debug -- | Flag_DocBook | Flag_ReadInterface String + | Flag_DefaultThemes | Flag_DumpInterface String | Flag_Heading String | Flag_Html @@ -52,6 +53,7 @@ data Flag | Flag_SourceBaseURL String | Flag_SourceModuleURL String | Flag_SourceEntityURL String + | Flag_Themes String | Flag_WikiBaseURL String | Flag_WikiModuleURL String | Flag_WikiEntityURL String @@ -111,8 +113,12 @@ options backwardsCompat = "URL for a comments link for each module\n(using the %{MODULE} var)", Option [] ["comments-entity"] (ReqArg Flag_WikiEntityURL "URL") "URL for a comments link for each entity\n(using the %{FILE}, %{MODULE}, %{NAME},\n%{KIND} or %{LINE} vars)", - Option ['c'] ["css"] (ReqArg Flag_CSS "FILE") - "the CSS file to use for HTML output", + Option ['c'] ["css"] (ReqArg Flag_CSS "PATH") + "the CSS file or theme directory to use for HTML output", + Option [] ["themes"] (ReqArg Flag_Themes "DIR") + "a directory of CSS files or themes to use for HTML output", + Option [] ["default-themes"] (NoArg Flag_DefaultThemes) + "include all the available haddock themes", Option ['p'] ["prologue"] (ReqArg Flag_Prologue "FILE") "file containing prologue text", Option ['t'] ["title"] (ReqArg Flag_Heading "TITLE") diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs index b5ef2f71..003706cd 100644 --- a/src/Haddock/Utils.hs +++ b/src/Haddock/Utils.hs @@ -22,7 +22,7 @@ module Haddock.Utils ( frameIndexHtmlFile, moduleIndexFrameName, mainFrameName, synopsisFrameName, subIndexHtmlFile, - cssFile, iconFile, jsFile, plusFile, minusFile, framesFile, + jsFile, plusFile, minusFile, framesFile, -- * Anchor and URL utilities moduleNameUrl, moduleUrl, @@ -257,9 +257,7 @@ makeAnchorId (f:r) = escape isAlpha f ++ concatMap (escape isLegal) r ------------------------------------------------------------------------------- -cssFile, iconFile, jsFile, plusFile, minusFile, framesFile :: String -cssFile = "haddock.css" -iconFile = "haskell_icon.gif" +jsFile, plusFile, minusFile, framesFile :: String jsFile = "haddock-util.js" plusFile = "plus.gif" minusFile = "minus.gif" diff --git a/src/Main.hs b/src/Main.hs index 40b1d42a..b21f5a8b 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -19,6 +19,7 @@ module Main (main) where import Haddock.Backends.Xhtml +import Haddock.Backends.Xhtml.Themes (getThemes) import Haddock.Backends.LaTeX import Haddock.Backends.Hoogle import Haddock.Interface @@ -179,7 +180,6 @@ render flags ifaces installedIfaces = do opt_wiki_urls = optWikiUrls flags opt_contents_url = optContentsUrl flags opt_index_url = optIndexUrl flags - css_file = optCssFile flags odir = outputDir flags opt_latex_style = optLaTeXStyle flags @@ -195,25 +195,26 @@ render flags ifaces installedIfaces = do libDir <- getHaddockLibDir flags prologue <- getPrologue flags + themes <- getThemes libDir flags >>= either bye return when (Flag_GenIndex `elem` flags) $ do ppHtmlIndex odir title packageStr - opt_contents_url opt_source_urls opt_wiki_urls + themes opt_contents_url opt_source_urls opt_wiki_urls allVisibleIfaces - copyHtmlBits odir libDir css_file + copyHtmlBits odir libDir themes when (Flag_GenContents `elem` flags) $ do ppHtmlContents odir title packageStr - opt_index_url opt_source_urls opt_wiki_urls + themes opt_index_url opt_source_urls opt_wiki_urls allVisibleIfaces True prologue - copyHtmlBits odir libDir css_file + copyHtmlBits odir libDir themes when (Flag_Html `elem` flags) $ do ppHtml title packageStr visibleIfaces odir prologue - opt_source_urls opt_wiki_urls + themes opt_source_urls opt_wiki_urls opt_contents_url opt_index_url unicode - copyHtmlBits odir libDir css_file + copyHtmlBits odir libDir themes when (Flag_Hoogle `elem` flags) $ do let pkgName2 = if pkgName == "main" && title /= [] then title else pkgName |