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.

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
+