2 files changed, 70 insertions, 8 deletions

diff --git a/src/Haddock/Backends/Xhtml/Themes.hs b/src/Haddock/Backends/Xhtml/Themes.hs
new file mode 100644
index 00000000..c02a8265
--- /dev/null
+++ b/src/Haddock/Backends/Xhtml/Themes.hs
@@ -0,0 +1,66 @@
+-----------------------------------------------------------------------------
+-- |
+-- 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 (
+    CssTheme(..),
+    
+    cssFiles, styleSheet, stylePickers, styleMenu
+    )
+    where
+
+import Haddock.Backends.Xhtml.Utils (onclick)
+import Haddock.Utils (iconFile)
+
+import Data.List (nub)
+
+import Text.XHtml hiding ( name, title, p, quote )
+import qualified Text.XHtml as XHtml
+
+
+-- Standard set of style sheets, first is the preferred
+
+data CssTheme = CssTheme {
+  themeName :: String,
+  themeHref :: String,
+  themeFiles :: [FilePath]
+  }
+
+
+themes :: [CssTheme]
+themes = [
+    CssTheme "Classic" "xhaddock.css" ["xhaddock.css", iconFile],
+    CssTheme "Tibbe"   "thaddock.css" ["thaddock.css", iconFile],
+    CssTheme "Snappy"  "shaddock.css" ["shaddock.css", iconFile]
+    ]
+
+cssFiles :: [String]
+cssFiles = nub (concatMap themeFiles themes)
+
+styleSheet :: Html
+styleSheet = toHtml $ zipWith mkLink themes rels
+  where
+    rels = ("stylesheet" : repeat "alternate stylesheet")
+    mkLink (CssTheme aTitle aRef _) aRel =
+       (thelink ! [href aRef, rel aRel, thetype "text/css", XHtml.title aTitle]) noHtml
+
+stylePickers :: [Html]
+stylePickers = map mkPicker themes
+  where
+    mkPicker (CssTheme aTitle aRef _) = 
+      let js = "setActiveStyleSheet('" ++ aRef ++ "'); return false;" in
+      anchor ! [href "#", onclick js] << aTitle
+
+styleMenu :: Html
+styleMenu = thediv ! [identifier "style-menu-holder"] << [
+    anchor ! [ href "#", onclick js ] << "Style\9662",
+    unordList stylePickers ! [ identifier "style-menu", theclass "hide" ]
+  ]
+  where
+    js = "styleMenu(); return false;"
diff --git a/src/Haddock/Backends/Xhtml/Utils.hs b/src/Haddock/Backends/Xhtml/Utils.hs
index 443cb459..92b4afe3 100644
--- a/src/Haddock/Backends/Xhtml/Utils.hs
+++ b/src/Haddock/Backends/Xhtml/Utils.hs
@@ -23,9 +23,9 @@ module Haddock.Backends.Xhtml.Utils (
   arrow, comma, dcolon, dot, darrow, equals, forallSymbol, quote,
 
   hsep,
-
+  
   collapsebutton, collapseId,
-
+  
   cssFiles, styleSheet, stylePickers, styleMenu
 ) where
 
@@ -202,11 +202,9 @@ cssThemes = [
     ("Snappy", "shaddock.css")
     ]
 
-
 cssFiles :: [String]
 cssFiles = map snd cssThemes
 
-
 styleSheet :: Html
 styleSheet = toHtml $ zipWith mkLink cssThemes rels
   where
@@ -214,15 +212,13 @@ styleSheet = toHtml $ zipWith mkLink cssThemes rels
     mkLink (aTitle, aFile) aRel =
        (thelink ! [href aFile, rel aRel, thetype "text/css", XHtml.title aTitle]) noHtml
 
-
 stylePickers :: [Html]
 stylePickers = map mkPicker cssThemes
   where
-    mkPicker (aTitle, aFile) =
+    mkPicker (aTitle, aFile) = 
       let js = "setActiveStyleSheet('" ++ aFile ++ "'); return false;" in
       anchor ! [href "#", onclick js] << aTitle
 
-
 styleMenu :: Html
 styleMenu = thediv ! [identifier "style-menu-holder"] << [
     anchor ! [ href "#", onclick js ] << "Style\9662",
@@ -230,4 +226,4 @@ styleMenu = thediv ! [identifier "style-menu-holder"] << [
   ]
   where
     js = "styleMenu(); return false;"
-
+        
\ No newline at end of file