From b67678234917d61b8393fa9b75092bfa2c399ab4 Mon Sep 17 00:00:00 2001
From: Mark Lentczner <markl@glyphic.com>
Date: Thu, 15 Jul 2010 23:53:01 +0000
Subject: added two new themes and rough css switcher

---
 src/Haddock/Backends/Xhtml.hs      | 11 +++++++----
 src/Haddock/Backends/Xhtml/Util.hs | 30 +++++++++++++++++++++++++++---
 2 files changed, 34 insertions(+), 7 deletions(-)

(limited to 'src/Haddock')

diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs
index dc24acbd..c24dec6a 100644
--- a/src/Haddock/Backends/Xhtml.hs
+++ b/src/Haddock/Backends/Xhtml.hs
@@ -138,16 +138,19 @@ copyFile fromFPath toFPath =
 
 
 copyHtmlBits :: FilePath -> FilePath -> Maybe FilePath -> IO ()
-copyHtmlBits odir libdir maybe_css = do
+copyHtmlBits odir libdir _maybe_css = 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]
+        -}
         copyLibFile f = do
            copyFile (joinPath [libhtmldir, f]) (joinPath [odir, f])
-  copyFile css_file css_destination
+  --copyFile css_file css_destination
+  mapM_ copyLibFile cssFiles
   mapM_ copyLibFile [ iconFile, plusFile, minusFile, jsFile, framesFile ]
 
 footer :: Html
@@ -201,7 +204,7 @@ simpleHeader doctitle maybe_contents_url maybe_index_url
       wikiButton maybe_wiki_url Nothing,
       contentsButton maybe_contents_url,
       indexButton maybe_index_url
-      ]) ! [theclass "links"]
+      ] ++ stylePickers) ! [theclass "links"]
   )
 
 pageHeader :: String -> Interface -> String
@@ -217,7 +220,7 @@ pageHeader mdl iface doctitle
         wikiButton maybe_wiki_url (Just $ ifaceMod iface),
         contentsButton maybe_contents_url,
         indexButton maybe_index_url
-        ]) ! [theclass "links"]
+        ] ++ stylePickers) ! [theclass "links"]
    ) +++
   divModuleHeader << (
     sectionName << mdl +++
diff --git a/src/Haddock/Backends/Xhtml/Util.hs b/src/Haddock/Backends/Xhtml/Util.hs
index f2527b06..de5f8180 100644
--- a/src/Haddock/Backends/Xhtml/Util.hs
+++ b/src/Haddock/Backends/Xhtml/Util.hs
@@ -26,7 +26,9 @@ module Haddock.Backends.Xhtml.Util (
   abovesSep, hsep,
   
   collapsebutton, collapseId, collapsed,
-  documentCharacterEncoding, styleSheet
+  documentCharacterEncoding,
+  
+  cssFiles, styleSheet, stylePickers
 ) where
 
 import Haddock.GhcUtils
@@ -217,6 +219,28 @@ documentCharacterEncoding :: Html
 documentCharacterEncoding =
    meta ! [httpequiv "Content-Type", content "text/html; charset=UTF-8"]
 
+-- Standard set of style sheets, first is the preferred
+cssThemes :: [(String, String)]
+cssThemes = [
+    ("Classic", "xhaddock.css"),
+    ("Tibbe", "thaddock.css"),
+    ("Snappy", "shaddock.css")
+    ]
+
+cssFiles :: [String]
+cssFiles = map snd cssThemes
+
 styleSheet :: Html
-styleSheet =
-   (thelink ! [href cssFile, rel "stylesheet", thetype "text/css"]) noHtml
+styleSheet = toHtml $ zipWith mkLink cssThemes rels
+  where
+    rels = ("stylesheet" : repeat "alternate stylesheet")
+    mkLink (aTitle, aFile) aRel =
+       (thelink ! [href aFile, rel aRel, thetype "text/css", Html.title aTitle]) noHtml
+
+stylePickers :: [Html]
+stylePickers = map mkPicker cssThemes
+  where
+    mkPicker (aTitle, aFile) = 
+      let js = "setActiveStyleSheet('" ++ aFile ++ "'); return false;" in
+      anchor ! [href "#", onclick js] << aTitle
+    
\ No newline at end of file
-- 
cgit v1.2.3