From 54d85b9ee4c79679875dbb4b98f2eb12f46c606d Mon Sep 17 00:00:00 2001 From: Mark Lentczner Date: Mon, 26 Jul 2010 00:32:05 +0000 Subject: reorganize files in the html lib data dir --- src/Haddock/Backends/Xhtml.hs | 2 +- src/Haddock/Backends/Xhtml/Themes.hs | 89 +++++++++++++++++++----------------- src/Haddock/Backends/Xhtml/Utils.hs | 2 +- src/Haddock/Utils.hs | 6 +-- 4 files changed, 50 insertions(+), 49 deletions(-) (limited to 'src') diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs index 00f8e30b..94ee6347 100644 --- a/src/Haddock/Backends/Xhtml.hs +++ b/src/Haddock/Backends/Xhtml.hs @@ -119,7 +119,7 @@ copyHtmlBits odir libdir themes = do copyLibFile f = do copyFile (joinPath [libhtmldir, f]) (joinPath [odir, f]) mapM_ copyCssFile (cssFiles themes) - mapM_ copyLibFile [ plusFile, minusFile, jsFile, framesFile ] + mapM_ copyLibFile [ jsFile, framesFile ] headHtml :: String -> Maybe String -> Themes -> Html diff --git a/src/Haddock/Backends/Xhtml/Themes.hs b/src/Haddock/Backends/Xhtml/Themes.hs index 43339791..3274b842 100644 --- a/src/Haddock/Backends/Xhtml/Themes.hs +++ b/src/Haddock/Backends/Xhtml/Themes.hs @@ -22,12 +22,12 @@ import Haddock.Options import Control.Monad (liftM) import Data.Char (toLower) import Data.Either (lefts, rights) -import Data.List (nub) +import Data.List (nub, partition) import Data.Maybe (isJust, listToMaybe) import System.Directory import System.FilePath -import Text.XHtml hiding ( name, title, p, quote ) +import Text.XHtml hiding ( name, title, p, quote, () ) import qualified Text.XHtml as XHtml @@ -41,67 +41,57 @@ 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"] +type PossibleTheme = Either String CssTheme +type PossibleThemes = Either String Themes --- | 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"] - ] - ) +-- | Standard theme used by default +standardTheme :: FilePath -> IO PossibleThemes +standardTheme libDir = liftM (liftEither (take 1)) (defaultThemes libDir) -locateIn :: FilePath -> CssTheme -> CssTheme -locateIn libDir t = t { themeFiles = map loc (themeFiles t) } - where loc = combine libDir . combine "html" +-- | Default themes that are part of Haddock; added with --default-themes +defaultThemes :: FilePath -> IO PossibleThemes +defaultThemes libDir = do + themeDirs <- getDirectoryItems (libDir "html" "themes") + themes <- mapM directoryTheme themeDirs + return $ liftEither shuffle $ sequenceEither themes + where + shuffle ts = let (a,b) = partition isStd ts in a ++ b + isStd c = themeName c == "Ocean" -findTheme :: Themes -> String -> Maybe CssTheme -findTheme ts s = listToMaybe $ filter ((== ls).lower.themeName) ts +findTheme :: String -> Themes -> Maybe CssTheme +findTheme s = listToMaybe . filter ((== ls).lower.themeName) 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) + liftM concatEither (mapM themeFlag flags) >>= someTheme where themeFlag :: Flag -> IO (Either String Themes) themeFlag (Flag_CSS path) = (liftM . liftEither) (:[]) (theme path) - themeFlag (Flag_BuiltInThemes) = retRight builtIns + themeFlag (Flag_BuiltInThemes) = builtIns themeFlag _ = retRight [] theme :: FilePath -> IO PossibleTheme theme path = pick path [(doesFileExist, singleFileTheme), (doesDirectoryExist, directoryTheme), - (return . isThemeName builtIns, return . builtInTheme builtIns)] - "css theme path not found" + (doesBuiltInExist builtIns, builtInTheme builtIns)] + "Theme not found" pick :: FilePath -> [(FilePath -> IO Bool, FilePath -> IO PossibleTheme)] -> String @@ -111,43 +101,56 @@ getThemes libDir flags = 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 + + 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 ++ ": \"" ++ path ++ "\"")) +errMessage msg path = return (Left msg') + where msg' = "Error: " ++ msg ++ ": \"" ++ path ++ "\"\n" retRight :: a -> IO (Either String a) retRight = return . Right -singleFileTheme :: FilePath -> IO (Either String CssTheme) +singleFileTheme :: FilePath -> IO PossibleTheme singleFileTheme path = if isCssFilePath path then retRight $ CssTheme name file [path] - else errMessage "file extension isn't .css" path + else errMessage "File extension isn't .css" path where name = takeBaseName path file = takeFileName path -directoryTheme :: FilePath -> IO (Either String CssTheme) +directoryTheme :: FilePath -> IO PossibleTheme 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 + [] -> errMessage "No .css file in theme directory" path + _ -> errMessage "More than one .css file in theme directory" path + + +doesBuiltInExist :: IO PossibleThemes -> String -> IO Bool +doesBuiltInExist pts s = pts >>= return . either (const False) test + where test = isJust . findTheme s + + +builtInTheme :: IO PossibleThemes -> String -> IO PossibleTheme +builtInTheme pts s = pts >>= return . either Left fetch + where fetch = maybe (Left ("Unknown theme: " ++ s)) Right . findTheme s getDirectoryItems :: FilePath -> IO [FilePath] getDirectoryItems path = - getDirectoryContents path >>= return . map (combine path) + getDirectoryContents path >>= return . map (combine path) . filter notDot + where notDot s = s /= "." && s /= ".." isCssFilePath :: FilePath -> Bool diff --git a/src/Haddock/Backends/Xhtml/Utils.hs b/src/Haddock/Backends/Xhtml/Utils.hs index a914d2e8..61f0894d 100644 --- a/src/Haddock/Backends/Xhtml/Utils.hs +++ b/src/Haddock/Backends/Xhtml/Utils.hs @@ -184,7 +184,7 @@ linkedAnchor n = anchor ! [href ('#':n)] collapsebutton :: String -> Html collapsebutton id_ = - image ! [ src minusFile, theclass "coll", onclick ("toggle(this,'" ++ id_ ++ "')"), alt "show/hide" ] + image ! [ src "minus.gif", theclass "coll", onclick ("toggle(this,'" ++ id_ ++ "')"), alt "show/hide" ] -- A quote is a valid part of a Haskell identifier, but it would interfere with diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs index 003706cd..ed253433 100644 --- a/src/Haddock/Utils.hs +++ b/src/Haddock/Utils.hs @@ -22,7 +22,7 @@ module Haddock.Utils ( frameIndexHtmlFile, moduleIndexFrameName, mainFrameName, synopsisFrameName, subIndexHtmlFile, - jsFile, plusFile, minusFile, framesFile, + jsFile, framesFile, -- * Anchor and URL utilities moduleNameUrl, moduleUrl, @@ -257,10 +257,8 @@ makeAnchorId (f:r) = escape isAlpha f ++ concatMap (escape isLegal) r ------------------------------------------------------------------------------- -jsFile, plusFile, minusFile, framesFile :: String +jsFile, framesFile :: String jsFile = "haddock-util.js" -plusFile = "plus.gif" -minusFile = "minus.gif" framesFile = "frames.html" -- cgit v1.2.3