aboutsummaryrefslogtreecommitdiff
path: root/src/Haddock/Backends/Xhtml/Themes.hs
blob: cbcf10a4d0b8483580bd9133b399cf0458bed6b7 (plain) (blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
-----------------------------------------------------------------------------
-- |
-- 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 (
    Themes,
    getThemes,

    cssFiles, styleSheet
    )
    where

import Haddock.Options

import Control.Monad (liftM)
import Data.Char (toLower)
import Data.Either (lefts, rights)
import Data.List (nub)
import Data.Maybe (isJust, listToMaybe)

import System.Directory
import System.FilePath
import Text.XHtml hiding ( name, title, p, quote, (</>) )
import qualified Text.XHtml as XHtml


--------------------------------------------------------------------------------
-- * CSS Themes
--------------------------------------------------------------------------------

data Theme = Theme {
  themeName :: String,
  themeHref :: String,
  themeFiles :: [FilePath]
  }

type Themes = [Theme]

type PossibleTheme = Either String Theme
type PossibleThemes = Either String Themes


-- | Find a theme by name (case insensitive match)
findTheme :: String -> Themes -> Maybe Theme
findTheme s = listToMaybe . filter ((== ls).lower.themeName)
  where lower = map toLower
        ls = lower s


-- | Standard theme used by default
standardTheme :: FilePath -> IO PossibleThemes
standardTheme libDir = liftM (liftEither (take 1)) (defaultThemes libDir)


-- | Default themes that are part of Haddock; added with --default-themes
-- The first theme in this list is considered the standard theme.
-- Themes are "discovered" by scanning the html sub-dir of the libDir,
-- and looking for directories with the extension .theme or .std-theme.
-- The later is, obviously, the standard theme.
defaultThemes :: FilePath -> IO PossibleThemes
defaultThemes libDir = do
  themeDirs <- getDirectoryItems (libDir </> "html")
  themes <- mapM directoryTheme $ discoverThemes themeDirs
  return $ sequenceEither themes
  where
    discoverThemes paths =
      filterExt ".std-theme" paths ++ filterExt ".theme" paths
    filterExt ext = filter ((== ext).takeExtension)


-- | Build a theme from a single .css file
singleFileTheme :: FilePath -> IO PossibleTheme
singleFileTheme path =
  if isCssFilePath path
      then retRight $ Theme name file [path]
      else errMessage "File extension isn't .css" path
  where
    name = takeBaseName path
    file = takeFileName path


-- | Build a theme from a directory
directoryTheme :: FilePath -> IO PossibleTheme
directoryTheme path = do
  items <- getDirectoryItems path
  case filter isCssFilePath items of
    [cf] -> retRight $ Theme (takeBaseName path) (takeFileName cf) items
    [] -> errMessage "No .css file in theme directory" path
    _ -> errMessage "More than one .css file in theme directory" path


-- | Check if we have a built in theme
doesBuiltInExist :: IO PossibleThemes -> String -> IO Bool
doesBuiltInExist pts s = pts >>= return . either (const False) test 
  where test = isJust . findTheme s


-- | Find a built in theme
builtInTheme :: IO PossibleThemes -> String -> IO PossibleTheme
builtInTheme pts s = pts >>= return . either Left fetch
  where fetch = maybe (Left ("Unknown theme: " ++ s)) Right . findTheme s


--------------------------------------------------------------------------------
-- * CSS Theme Arguments
--------------------------------------------------------------------------------

-- | Process input flags for CSS Theme arguments
getThemes :: FilePath -> [Flag] -> IO PossibleThemes
getThemes libDir flags =
  liftM concatEither (mapM themeFlag flags) >>= someTheme
  where
    themeFlag :: Flag -> IO (Either String Themes)
    themeFlag (Flag_CSS path) = (liftM . liftEither) (:[]) (theme path)
    themeFlag (Flag_BuiltInThemes) = builtIns
    themeFlag _ = retRight []

    theme :: FilePath -> IO PossibleTheme
    theme path = pick path
      [(doesFileExist,              singleFileTheme),
       (doesDirectoryExist,         directoryTheme),
       (doesBuiltInExist builtIns,  builtInTheme builtIns)]
      "Theme not found"

    pick :: FilePath
      -> [(FilePath -> IO Bool, FilePath -> IO PossibleTheme)] -> String
      -> IO PossibleTheme
    pick path [] msg = errMessage msg path
    pick path ((test,build):opts) msg = do
      pass <- test path
      if pass then build path else pick path opts msg


    someTheme :: Either String Themes -> IO (Either String Themes)
    someTheme (Right []) = standardTheme libDir
    someTheme est = return est

    builtIns = defaultThemes libDir


errMessage :: String -> FilePath -> IO (Either String a)
errMessage msg path = return (Left msg')
  where msg' = "Error: " ++ msg ++ ": \"" ++ path ++ "\"\n"


retRight :: a -> IO (Either String a)
retRight = return . Right


--------------------------------------------------------------------------------
-- * File Utilities
--------------------------------------------------------------------------------

getDirectoryItems :: FilePath -> IO [FilePath]
getDirectoryItems path =
  getDirectoryContents path >>= return . map (combine path) . filter notDot
  where notDot s = s /= "." && s /= ".."


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 aRel t =
      thelink
        ! [ href (themeHref t),  rel aRel, thetype "text/css",
            XHtml.title (themeName t)
          ]
        << noHtml

--------------------------------------------------------------------------------
-- * 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