From 248b76b4dc77dbbdbb0f7a2081188c81ee35ca77 Mon Sep 17 00:00:00 2001
From: Mark Lentczner <markl@glyphic.com>
Date: Tue, 20 Jul 2010 17:25:52 +0000
Subject: [PATCH] move CSS Theme functions into Themes.hs
---
src/Haddock/Backends/Xhtml.hs | 3 +-
src/Haddock/Backends/Xhtml/Themes.hs | 66 ++++++++++++++++++++++++++++
src/Haddock/Backends/Xhtml/Utils.hs | 12 ++---
3 files changed, 72 insertions(+), 9 deletions(-)
create mode 100644 src/Haddock/Backends/Xhtml/Themes.hs
diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs
index 18204a2bce..b249ddf37f 100644
--- a/src/Haddock/Backends/Xhtml.hs
+++ b/src/Haddock/Backends/Xhtml.hs
@@ -26,6 +26,7 @@ import Haddock.Backends.Xhtml.Decl
import Haddock.Backends.Xhtml.DocMarkup
import Haddock.Backends.Xhtml.Layout
import Haddock.Backends.Xhtml.Names
+import Haddock.Backends.Xhtml.Themes
import Haddock.Backends.Xhtml.Types
import Haddock.Backends.Xhtml.Utils
import Haddock.ModuleTree
@@ -154,7 +155,7 @@ copyHtmlBits odir libdir _maybe_css = do
copyFile (joinPath [libhtmldir, f]) (joinPath [odir, f])
--copyFile css_file css_destination
mapM_ copyLibFile cssFiles
- mapM_ copyLibFile [ iconFile, plusFile, minusFile, jsFile, framesFile ]
+ mapM_ copyLibFile [ plusFile, minusFile, jsFile, framesFile ]
headHtml :: String -> Maybe String -> Html
diff --git a/src/Haddock/Backends/Xhtml/Themes.hs b/src/Haddock/Backends/Xhtml/Themes.hs
new file mode 100644
index 0000000000..c02a826539
--- /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 443cb45917..92b4afe3cc 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
--
GitLab