From c6eab25b7b9b6b8fb077014de61324416e4f2816 Mon Sep 17 00:00:00 2001 From: Mark Lentczner Date: Fri, 23 Jul 2010 06:19:35 +0000 Subject: command like processing for theme selection The bulk of the change is threadnig the selected theme set through functions in Xhtml.hs so that the selected themes can be used when generating the page output. There isn't much going on in most of these changes, just passing it along. The real work is all done in Themes.hs. --- src/Haddock/Backends/Xhtml.hs | 78 +++++++-------- src/Haddock/Backends/Xhtml/Themes.hs | 180 ++++++++++++++++++++++++++++++----- src/Haddock/Options.hs | 10 +- src/Haddock/Utils.hs | 6 +- 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 -- cgit v1.2.3