----------------------------------------------------------------------------- -- | -- Module : Haddock.Backends.Html.Themes -- Copyright : (c) Mark Lentczner 2010 -- License : BSD-like -- -- Maintainer : haddock@projects.haskell.org -- Stability : experimental -- Portability : portable ----------------------------------------------------------------------------- module Haddock.Backends.Xhtml.Themes ( Themes, getThemes, cssFiles, styleSheet ) where import Haddock.Options import Control.Applicative import Control.Monad (liftM) import Data.Char (toLower) import Data.Either (lefts, rights) import Data.List (nub) import Data.Maybe (isJust, listToMaybe) import System.Directory import System.FilePath import Text.XHtml hiding ( name, title, p, quote, (</>) ) import qualified Text.XHtml as XHtml -------------------------------------------------------------------------------- -- * CSS Themes -------------------------------------------------------------------------------- data Theme = Theme { themeName :: String, themeHref :: String, themeFiles :: [FilePath] } type Themes = [Theme] type PossibleTheme = Either String Theme type PossibleThemes = Either String Themes -- | Find a theme by name (case insensitive match) findTheme :: String -> Themes -> Maybe Theme findTheme s = listToMaybe . filter ((== ls).lower.themeName) where lower = map toLower ls = lower s -- | Standard theme used by default standardTheme :: FilePath -> IO PossibleThemes standardTheme libDir = liftM (liftEither (take 1)) (defaultThemes libDir) -- | Default themes that are part of Haddock; added with --default-themes -- The first theme in this list is considered the standard theme. -- Themes are "discovered" by scanning the html sub-dir of the libDir, -- and looking for directories with the extension .theme or .std-theme. -- The later is, obviously, the standard theme. defaultThemes :: FilePath -> IO PossibleThemes defaultThemes libDir = do themeDirs <- getDirectoryItems (libDir </> "html") themes <- mapM directoryTheme $ discoverThemes themeDirs return $ sequenceEither themes where discoverThemes paths = filterExt ".std-theme" paths ++ filterExt ".theme" paths filterExt ext = filter ((== ext).takeExtension) -- | Build a theme from a single .css file singleFileTheme :: FilePath -> IO PossibleTheme singleFileTheme path = if isCssFilePath path then retRight $ Theme name file [path] else errMessage "File extension isn't .css" path where name = takeBaseName path file = takeFileName path -- | Build a theme from a directory directoryTheme :: FilePath -> IO PossibleTheme directoryTheme path = do items <- getDirectoryItems path case filter isCssFilePath items of [cf] -> retRight $ Theme (takeBaseName path) (takeFileName cf) items [] -> errMessage "No .css file in theme directory" path _ -> errMessage "More than one .css file in theme directory" path -- | Check if we have a built in theme doesBuiltInExist :: IO PossibleThemes -> String -> IO Bool doesBuiltInExist pts s = fmap (either (const False) test) pts where test = isJust . findTheme s -- | Find a built in theme builtInTheme :: IO PossibleThemes -> String -> IO PossibleTheme builtInTheme pts s = either Left fetch <$> pts where fetch = maybe (Left ("Unknown theme: " ++ s)) Right . findTheme s -------------------------------------------------------------------------------- -- * CSS Theme Arguments -------------------------------------------------------------------------------- -- | Process input flags for CSS Theme arguments getThemes :: FilePath -> [Flag] -> IO PossibleThemes getThemes libDir flags = liftM concatEither (mapM themeFlag flags) >>= someTheme where themeFlag :: Flag -> IO (Either String Themes) themeFlag (Flag_CSS path) = (liftM . liftEither) (:[]) (theme path) themeFlag (Flag_BuiltInThemes) = builtIns themeFlag _ = retRight [] theme :: FilePath -> IO PossibleTheme theme path = pick path [(doesFileExist, singleFileTheme), (doesDirectoryExist, directoryTheme), (doesBuiltInExist builtIns, builtInTheme builtIns)] "Theme not found" pick :: FilePath -> [(FilePath -> IO Bool, FilePath -> IO PossibleTheme)] -> String -> IO PossibleTheme pick path [] msg = errMessage msg path pick path ((test,build):opts) msg = do pass <- test path if pass then build path else pick path opts msg someTheme :: Either String Themes -> IO (Either String Themes) someTheme (Right []) = standardTheme libDir someTheme est = return est builtIns = defaultThemes libDir errMessage :: String -> FilePath -> IO (Either String a) errMessage msg path = return (Left msg') where msg' = "Error: " ++ msg ++ ": \"" ++ path ++ "\"\n" retRight :: a -> IO (Either String a) retRight = return . Right -------------------------------------------------------------------------------- -- * File Utilities -------------------------------------------------------------------------------- getDirectoryItems :: FilePath -> IO [FilePath] getDirectoryItems path = map (combine path) . filter notDot <$> getDirectoryContents path where notDot s = s /= "." && s /= ".." 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 aRel t = thelink ! [ href (themeHref t), rel aRel, thetype "text/css", XHtml.title (themeName t) ] << noHtml -------------------------------------------------------------------------------- -- * 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