aboutsummaryrefslogtreecommitdiff
path: root/src/Haddock/Backends/Xhtml
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/Haddock/Backends/Xhtml
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/Haddock/Backends/Xhtml')
-rw-r--r--src/Haddock/Backends/Xhtml/Themes.hs180
1 files changed, 156 insertions, 24 deletions
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
+