diff options
Diffstat (limited to 'src/Haddock/Backends/Xhtml/Themes.hs')
| -rw-r--r-- | src/Haddock/Backends/Xhtml/Themes.hs | 209 |
1 files changed, 0 insertions, 209 deletions
diff --git a/src/Haddock/Backends/Xhtml/Themes.hs b/src/Haddock/Backends/Xhtml/Themes.hs deleted file mode 100644 index 79b093ec..00000000 --- a/src/Haddock/Backends/Xhtml/Themes.hs +++ /dev/null @@ -1,209 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 - |