aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorMark Lentczner <markl@glyphic.com>2010-07-23 06:19:35 +0000
committerMark Lentczner <markl@glyphic.com>2010-07-23 06:19:35 +0000
commitc6eab25b7b9b6b8fb077014de61324416e4f2816 (patch)
treebe0efc955ea8bb9fa5548cfb3cd70f2c8bc9ca07 /src
parentb4f6adb415fdef827e5c48fa2e9ba618ee62ab6d (diff)
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.
Diffstat (limited to 'src')
-rw-r--r--src/Haddock/Backends/Xhtml.hs78
-rw-r--r--src/Haddock/Backends/Xhtml/Themes.hs180
-rw-r--r--src/Haddock/Options.hs10
-rw-r--r--src/Haddock/Utils.hs6
-rw-r--r--src/Main.hs15
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