aboutsummaryrefslogtreecommitdiff
path: root/src/Haddock
diff options
context:
space:
mode:
Diffstat (limited to 'src/Haddock')
-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
4 files changed, 205 insertions, 69 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"
generated by cgit v1.2.3 (git 2.39.1) at 2025-10-31 13:48:29 +0000