From e37cef7364006392a073cc4f6601078829f2dbec Mon Sep 17 00:00:00 2001 From: Mark Lentczner Date: Fri, 23 Jul 2010 06:58:31 +0000 Subject: drop --themes support, add named theme support decided that --themes was silly - no one would do that, just use multiple --theme arguments made --theme a synonym for --css and -c made those arguments, if no file is found, look up the argument as the name of a built in theme all of this let's haddock be invoked with "--theme=classic" for example. --- src/Haddock/Backends/Xhtml/Themes.hs | 65 +++++++++++++++++++++--------------- src/Haddock/Options.hs | 7 ++-- 2 files changed, 41 insertions(+), 31 deletions(-) (limited to 'src/Haddock') diff --git a/src/Haddock/Backends/Xhtml/Themes.hs b/src/Haddock/Backends/Xhtml/Themes.hs index 5874d251..35a3986b 100644 --- a/src/Haddock/Backends/Xhtml/Themes.hs +++ b/src/Haddock/Backends/Xhtml/Themes.hs @@ -20,9 +20,10 @@ import Haddock.Backends.Xhtml.Utils (onclick) import Haddock.Options import Control.Monad (liftM) +import Data.Char (toLower) import Data.Either (lefts, rights) import Data.List (nub) -import Data.Maybe (listToMaybe) +import Data.Maybe (isJust, listToMaybe) import System.Directory import System.FilePath @@ -59,52 +60,64 @@ defaultThemes libDir = standardTheme libDir : ] ) + locateIn :: FilePath -> CssTheme -> CssTheme locateIn libDir t = t { themeFiles = map loc (themeFiles t) } where loc = combine libDir . combine "html" + +findTheme :: Themes -> String -> Maybe CssTheme +findTheme ts s = listToMaybe $ filter ((== ls).lower.themeName) ts + where lower = map toLower + ls = lower s + + +isThemeName :: Themes -> String -> Bool +isThemeName ts = isJust . findTheme ts + + +builtInTheme :: Themes -> String -> Either String CssTheme +builtInTheme ts = maybe (Left "not found") Right . findTheme ts + + -------------------------------------------------------------------------------- -- * CSS Theme Arguments -------------------------------------------------------------------------------- +type PossibleTheme = Either String CssTheme + -- | 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 (Flag_DefaultThemes) = retRight builtIns 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 + theme :: FilePath -> IO PossibleTheme + theme path = pick path + [(doesFileExist, singleFileTheme), + (doesDirectoryExist, directoryTheme), + (return . isThemeName builtIns, return . builtInTheme builtIns)] + "css theme path 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 -> Either String Themes someTheme (Right []) = Right [standardTheme libDir] someTheme est = est + builtIns = defaultThemes libDir + + errMessage :: String -> FilePath -> IO (Either String a) errMessage msg path = return (Left (msg ++ ": \"" ++ path ++ "\"")) @@ -150,7 +163,7 @@ cssFiles ts = nub $ concatMap themeFiles ts styleSheet :: Themes -> Html -styleSheet ts = toHtml $ zipWith mkLink rels ts +styleSheet ts = toHtml $ zipWith mkLink rels ts where rels = ("stylesheet" : repeat "alternate stylesheet") mkLink aRel t = diff --git a/src/Haddock/Options.hs b/src/Haddock/Options.hs index 4ea2db5e..0e2e244b 100644 --- a/src/Haddock/Options.hs +++ b/src/Haddock/Options.hs @@ -53,7 +53,6 @@ data Flag | Flag_SourceBaseURL String | Flag_SourceModuleURL String | Flag_SourceEntityURL String - | Flag_Themes String | Flag_WikiBaseURL String | Flag_WikiModuleURL String | Flag_WikiEntityURL String @@ -113,12 +112,10 @@ 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 "PATH") + Option ['c'] ["css", "theme"] (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", + "include all the built-in haddock themes", Option ['p'] ["prologue"] (ReqArg Flag_Prologue "FILE") "file containing prologue text", Option ['t'] ["title"] (ReqArg Flag_Heading "TITLE") -- cgit v1.2.3