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.

2 files changed, 195 insertions, 63 deletions

diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs
index 2befd9bd..00f8e30b 100644
--- a/src/Haddock/Backends/Xhtml.hs
+++ b/src/Haddock/Backends/Xhtml.hs
@@ -63,6 +63,7 @@ ppHtml :: String
        -> [Interface]
        -> FilePath                     -- destination directory
        -> Maybe (Doc GHC.RdrName)      -- prologue text, maybe
+       -> Themes                       -- themes
        -> SourceURLs                   -- the source URL (--source)
        -> WikiURLs                     -- the wiki URL (--wiki)
        -> Maybe String                 -- the contents URL (--use-contents)
@@ -71,24 +72,24 @@ ppHtml :: String
        -> IO ()
 
 ppHtml doctitle maybe_package ifaces odir prologue
-        maybe_source_url maybe_wiki_url
+        themes maybe_source_url maybe_wiki_url
         maybe_contents_url maybe_index_url unicode =  do
   let
         visible_ifaces = filter visible ifaces
         visible i = OptHide `notElem` ifaceOptions i
   when (not (isJust maybe_contents_url)) $
     ppHtmlContents odir doctitle maybe_package
-        maybe_index_url maybe_source_url maybe_wiki_url
+        themes maybe_index_url maybe_source_url maybe_wiki_url
         (map toInstalledIface visible_ifaces)
         False -- we don't want to display the packages in a single-package contents
         prologue
 
   when (not (isJust maybe_index_url)) $
     ppHtmlIndex odir doctitle maybe_package
-      maybe_contents_url maybe_source_url maybe_wiki_url
+      themes maybe_contents_url maybe_source_url maybe_wiki_url
       (map toInstalledIface visible_ifaces)
 
-  mapM_ (ppHtmlModule odir doctitle
+  mapM_ (ppHtmlModule odir doctitle themes
            maybe_source_url maybe_wiki_url
            maybe_contents_url maybe_index_url unicode) visible_ifaces
 
@@ -109,29 +110,24 @@ copyFile fromFPath toFPath =
                                 copyContents hFrom hTo buffer
 
 
-copyHtmlBits :: FilePath -> FilePath -> Maybe FilePath -> IO ()
-copyHtmlBits odir libdir _maybe_css = do
+copyHtmlBits :: FilePath -> FilePath -> Themes -> IO ()
+copyHtmlBits odir libdir themes = do
   let
         libhtmldir = joinPath [libdir, "html"]
-        {-
-        css_file = case maybe_css of
-                        Nothing -> joinPath [libhtmldir, 'x':cssFile]
-                        Just f  -> f
-        css_destination = joinPath [odir, cssFile]
-        -}
+        copyCssFile f = do
+           copyFile f (combine odir (takeFileName f))
         copyLibFile f = do
            copyFile (joinPath [libhtmldir, f]) (joinPath [odir, f])
-  --copyFile css_file css_destination
-  mapM_ copyLibFile cssFiles
+  mapM_ copyCssFile (cssFiles themes)
   mapM_ copyLibFile [ plusFile, minusFile, jsFile, framesFile ]
 
 
-headHtml :: String -> Maybe String -> Html
-headHtml docTitle miniPage =
+headHtml :: String -> Maybe String -> Themes -> Html
+headHtml docTitle miniPage themes =
   header << [
     meta ! [httpequiv "Content-Type", content "text/html; charset=UTF-8"],
     thetitle << docTitle,
-    styleSheet,
+    styleSheet themes,
     script ! [src jsFile, thetype "text/javascript"] << noHtml,
     script ! [thetype "text/javascript"]
         -- NB: Within XHTML, the content of script tags needs to be
@@ -180,11 +176,11 @@ indexButton maybe_index_url
   where url = maybe indexHtmlFile id maybe_index_url
 
 
-bodyHtml :: String -> Maybe Interface
+bodyHtml :: String -> Maybe Interface -> Themes
     -> SourceURLs -> WikiURLs
     -> Maybe String -> Maybe String
     -> Html -> Html
-bodyHtml doctitle iface
+bodyHtml doctitle iface themes
            maybe_source_url maybe_wiki_url
            maybe_contents_url maybe_index_url
            pageContent =
@@ -196,7 +192,7 @@ bodyHtml doctitle iface
         wikiButton maybe_wiki_url (ifaceMod `fmap` iface),
         contentsButton maybe_contents_url,
         indexButton maybe_index_url
-        ] ++ [styleMenu]) ! [theclass "links"]
+        ] ++ [styleMenu themes]) ! [theclass "links"]
       ],
     divContent << pageContent,
     divFooter << paragraph << (
@@ -236,19 +232,20 @@ ppHtmlContents
    :: FilePath
    -> String
    -> Maybe String
+   -> Themes
    -> Maybe String
    -> SourceURLs
    -> WikiURLs
    -> [InstalledInterface] -> Bool -> Maybe (Doc GHC.RdrName)
    -> IO ()
-ppHtmlContents odir doctitle
-  _maybe_package maybe_index_url
+ppHtmlContents odir doctitle _maybe_package
+  themes maybe_index_url
   maybe_source_url maybe_wiki_url ifaces showPkgs prologue = do
   let tree = mkModuleTree showPkgs
          [(instMod iface, toInstalledDescription iface) | iface <- ifaces]
       html =
-        headHtml doctitle Nothing +++
-        bodyHtml doctitle Nothing
+        headHtml doctitle Nothing themes +++
+        bodyHtml doctitle Nothing themes
           maybe_source_url maybe_wiki_url
           Nothing maybe_index_url << [
             ppPrologue doctitle prologue,
@@ -258,7 +255,7 @@ ppHtmlContents odir doctitle
   writeFile (joinPath [odir, contentsHtmlFile]) (renderToString html)
 
   -- XXX: think of a better place for this?
-  ppHtmlContentsFrame odir doctitle ifaces
+  ppHtmlContentsFrame odir doctitle themes ifaces
 
 
 ppPrologue :: String -> Maybe (Doc GHC.RdrName) -> Html
@@ -324,11 +321,12 @@ flatModuleTree ifaces =
         << toHtml txt
 
 
-ppHtmlContentsFrame :: FilePath -> String -> [InstalledInterface] -> IO ()
-ppHtmlContentsFrame odir doctitle ifaces = do
+ppHtmlContentsFrame :: FilePath -> String -> Themes
+  -> [InstalledInterface] -> IO ()
+ppHtmlContentsFrame odir doctitle themes ifaces = do
   let mods = flatModuleTree ifaces
       html =
-        headHtml doctitle Nothing +++
+        headHtml doctitle Nothing themes +++
         miniBody << divModuleList <<
           (sectionName << "Modules" +++
            ulist << [ li ! [theclass "module"] << m | m <- mods ])
@@ -344,12 +342,13 @@ ppHtmlContentsFrame odir doctitle ifaces = do
 ppHtmlIndex :: FilePath
             -> String
             -> Maybe String
+            -> Themes
             -> Maybe String
             -> SourceURLs
             -> WikiURLs
             -> [InstalledInterface]
             -> IO ()
-ppHtmlIndex odir doctitle _maybe_package
+ppHtmlIndex odir doctitle _maybe_package themes
   maybe_contents_url maybe_source_url maybe_wiki_url ifaces = do
   let html = indexPage split_indices Nothing
               (if split_indices then [] else index)
@@ -363,8 +362,8 @@ ppHtmlIndex odir doctitle _maybe_package
 
   where
     indexPage showLetters ch items =
-      headHtml (doctitle ++ " (" ++ indexName ch ++ ")") Nothing +++
-      bodyHtml doctitle Nothing
+      headHtml (doctitle ++ " (" ++ indexName ch ++ ")") Nothing themes +++
+      bodyHtml doctitle Nothing themes
         maybe_source_url maybe_wiki_url
         maybe_contents_url Nothing << [
           if showLetters then indexInitialLetterLinks else noHtml,
@@ -458,19 +457,19 @@ ppHtmlIndex odir doctitle _maybe_package
 
 
 ppHtmlModule
-        :: FilePath -> String
+        :: FilePath -> String -> Themes
         -> SourceURLs -> WikiURLs
         -> Maybe String -> Maybe String -> Bool
         -> Interface -> IO ()
-ppHtmlModule odir doctitle
+ppHtmlModule odir doctitle themes
   maybe_source_url maybe_wiki_url
   maybe_contents_url maybe_index_url unicode iface = do
   let
       mdl = ifaceMod iface
       mdl_str = moduleString mdl
       html =
-        headHtml mdl_str (Just $ "mini_" ++ moduleHtmlFile mdl) +++
-        bodyHtml doctitle (Just iface)
+        headHtml mdl_str (Just $ "mini_" ++ moduleHtmlFile mdl) themes +++
+        bodyHtml doctitle (Just iface) themes
           maybe_source_url maybe_wiki_url
           maybe_contents_url maybe_index_url << [
             divModuleHeader << (sectionName << mdl_str +++ moduleInfo iface),
@@ -479,14 +478,15 @@ ppHtmlModule odir doctitle
 
   createDirectoryIfMissing True odir
   writeFile (joinPath [odir, moduleHtmlFile mdl]) (renderToString html)
-  ppHtmlModuleMiniSynopsis odir doctitle iface unicode
+  ppHtmlModuleMiniSynopsis odir doctitle themes iface unicode
 
 
-ppHtmlModuleMiniSynopsis :: FilePath -> String -> Interface -> Bool -> IO ()
-ppHtmlModuleMiniSynopsis odir _doctitle iface unicode = do
+ppHtmlModuleMiniSynopsis :: FilePath -> String -> Themes
+  -> Interface -> Bool -> IO ()
+ppHtmlModuleMiniSynopsis odir _doctitle themes iface unicode = do
   let mdl = ifaceMod iface
       html =
-        headHtml (moduleString mdl) Nothing +++
+        headHtml (moduleString mdl) Nothing themes +++
         miniBody <<
           (divModuleHeader << sectionName << moduleString mdl +++
            miniSynopsis mdl iface unicode)
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
+