-----------------------------------------------------------------------------
-- |
-- 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 {
  Theme -> String
themeName :: String,
  Theme -> String
themeHref :: String,
  Theme -> [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 :: String -> Themes -> Maybe Theme
findTheme String
s = Themes -> Maybe Theme
forall a. [a] -> Maybe a
listToMaybe (Themes -> Maybe Theme)
-> (Themes -> Themes) -> Themes -> Maybe Theme
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Theme -> Bool) -> Themes -> Themes
forall a. (a -> Bool) -> [a] -> [a]
filter ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
ls)(String -> Bool) -> (Theme -> String) -> Theme -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> String
lower(String -> String) -> (Theme -> String) -> Theme -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Theme -> String
themeName)
  where lower :: String -> String
lower = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower
        ls :: String
ls = String -> String
lower String
s


-- | Standard theme used by default
standardTheme :: FilePath -> IO PossibleThemes
standardTheme :: String -> IO PossibleThemes
standardTheme String
libDir = (PossibleThemes -> PossibleThemes)
-> IO PossibleThemes -> IO PossibleThemes
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((Themes -> Themes) -> PossibleThemes -> PossibleThemes
forall b c a. (b -> c) -> Either a b -> Either a c
liftEither (Int -> Themes -> Themes
forall a. Int -> [a] -> [a]
take Int
1)) (String -> IO PossibleThemes
defaultThemes String
libDir)


-- | Default themes that are part of Haddock; added with @--built-in-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 :: String -> IO PossibleThemes
defaultThemes String
libDir = do
  [String]
themeDirs <- String -> IO [String]
getDirectoryItems (String
libDir String -> String -> String
</> String
"html")
  [PossibleTheme]
themes <- (String -> IO PossibleTheme) -> [String] -> IO [PossibleTheme]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO PossibleTheme
directoryTheme ([String] -> IO [PossibleTheme]) -> [String] -> IO [PossibleTheme]
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
discoverThemes [String]
themeDirs
  PossibleThemes -> IO PossibleThemes
forall (m :: * -> *) a. Monad m => a -> m a
return (PossibleThemes -> IO PossibleThemes)
-> PossibleThemes -> IO PossibleThemes
forall a b. (a -> b) -> a -> b
$ [PossibleTheme] -> PossibleThemes
forall a b. [Either a b] -> Either a [b]
sequenceEither [PossibleTheme]
themes
  where
    discoverThemes :: [String] -> [String]
discoverThemes [String]
paths =
      String -> [String] -> [String]
filterExt String
".std-theme" [String]
paths [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ String -> [String] -> [String]
filterExt String
".theme" [String]
paths
    filterExt :: String -> [String] -> [String]
filterExt String
ext = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
ext)(String -> Bool) -> (String -> String) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> String
takeExtension)


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


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


-- | Check if we have a built in theme
doesBuiltInExist :: IO PossibleThemes -> String -> IO Bool
doesBuiltInExist :: IO PossibleThemes -> String -> IO Bool
doesBuiltInExist IO PossibleThemes
pts String
s = (PossibleThemes -> Bool) -> IO PossibleThemes -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((String -> Bool) -> (Themes -> Bool) -> PossibleThemes -> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Bool -> String -> Bool
forall a b. a -> b -> a
const Bool
False) Themes -> Bool
test) IO PossibleThemes
pts
  where test :: Themes -> Bool
test = Maybe Theme -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Theme -> Bool) -> (Themes -> Maybe Theme) -> Themes -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Themes -> Maybe Theme
findTheme String
s


-- | Find a built in theme
builtInTheme :: IO PossibleThemes -> String -> IO PossibleTheme
builtInTheme :: IO PossibleThemes -> String -> IO PossibleTheme
builtInTheme IO PossibleThemes
pts String
s = (String -> PossibleTheme)
-> (Themes -> PossibleTheme) -> PossibleThemes -> PossibleTheme
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> PossibleTheme
forall a b. a -> Either a b
Left Themes -> PossibleTheme
fetch (PossibleThemes -> PossibleTheme)
-> IO PossibleThemes -> IO PossibleTheme
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO PossibleThemes
pts
  where fetch :: Themes -> PossibleTheme
fetch = PossibleTheme
-> (Theme -> PossibleTheme) -> Maybe Theme -> PossibleTheme
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> PossibleTheme
forall a b. a -> Either a b
Left (String
"Unknown theme: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s)) Theme -> PossibleTheme
forall a b. b -> Either a b
Right (Maybe Theme -> PossibleTheme)
-> (Themes -> Maybe Theme) -> Themes -> PossibleTheme
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Themes -> Maybe Theme
findTheme String
s


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

-- | Process input flags for CSS Theme arguments
getThemes :: FilePath -> [Flag] -> IO PossibleThemes
getThemes :: String -> [Flag] -> IO PossibleThemes
getThemes String
libDir [Flag]
flags =
  ([PossibleThemes] -> PossibleThemes)
-> IO [PossibleThemes] -> IO PossibleThemes
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [PossibleThemes] -> PossibleThemes
forall a b. [Either a [b]] -> Either a [b]
concatEither ((Flag -> IO PossibleThemes) -> [Flag] -> IO [PossibleThemes]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Flag -> IO PossibleThemes
themeFlag [Flag]
flags) IO PossibleThemes
-> (PossibleThemes -> IO PossibleThemes) -> IO PossibleThemes
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PossibleThemes -> IO PossibleThemes
someTheme
  where
    themeFlag :: Flag -> IO (Either String Themes)
    themeFlag :: Flag -> IO PossibleThemes
themeFlag (Flag_CSS String
path) = ((PossibleTheme -> PossibleThemes)
-> IO PossibleTheme -> IO PossibleThemes
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((PossibleTheme -> PossibleThemes)
 -> IO PossibleTheme -> IO PossibleThemes)
-> ((Theme -> Themes) -> PossibleTheme -> PossibleThemes)
-> (Theme -> Themes)
-> IO PossibleTheme
-> IO PossibleThemes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Theme -> Themes) -> PossibleTheme -> PossibleThemes
forall b c a. (b -> c) -> Either a b -> Either a c
liftEither) (Theme -> Themes -> Themes
forall a. a -> [a] -> [a]
:[]) (String -> IO PossibleTheme
theme String
path)
    themeFlag (Flag
Flag_BuiltInThemes) = IO PossibleThemes
builtIns
    themeFlag Flag
_ = Themes -> IO PossibleThemes
forall a. a -> IO (Either String a)
retRight []

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

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


    someTheme :: Either String Themes -> IO (Either String Themes)
    someTheme :: PossibleThemes -> IO PossibleThemes
someTheme (Right []) = String -> IO PossibleThemes
standardTheme String
libDir
    someTheme PossibleThemes
est = PossibleThemes -> IO PossibleThemes
forall (m :: * -> *) a. Monad m => a -> m a
return PossibleThemes
est

    builtIns :: IO PossibleThemes
builtIns = String -> IO PossibleThemes
defaultThemes String
libDir


errMessage :: String -> FilePath -> IO (Either String a)
errMessage :: String -> String -> IO (Either String a)
errMessage String
msg String
path = Either String a -> IO (Either String a)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String a
forall a b. a -> Either a b
Left String
msg')
  where msg' :: String
msg' = String
"Error: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"\n"


retRight :: a -> IO (Either String a)
retRight :: a -> IO (Either String a)
retRight = Either String a -> IO (Either String a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String a -> IO (Either String a))
-> (a -> Either String a) -> a -> IO (Either String a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either String a
forall a b. b -> Either a b
Right


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


getDirectoryItems :: FilePath -> IO [FilePath]
getDirectoryItems :: String -> IO [String]
getDirectoryItems String
path =
  (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> String
combine String
path) ([String] -> [String])
-> ([String] -> [String]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
notDot ([String] -> [String]) -> IO [String] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [String]
getDirectoryContents String
path
  where notDot :: String -> Bool
notDot String
s = String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"." Bool -> Bool -> Bool
&& String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
".."


isCssFilePath :: FilePath -> Bool
isCssFilePath :: String -> Bool
isCssFilePath String
path = String -> String
takeExtension String
path String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
".css"


--------------------------------------------------------------------------------
-- * Style Sheet Utilities
--------------------------------------------------------------------------------

cssFiles :: Themes -> [String]
cssFiles :: Themes -> [String]
cssFiles Themes
ts = [String] -> [String]
forall a. Eq a => [a] -> [a]
nub ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (Theme -> [String]) -> Themes -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Theme -> [String]
themeFiles Themes
ts


styleSheet :: Themes -> Html
styleSheet :: Themes -> Html
styleSheet Themes
ts = [Html] -> Html
forall a. HTML a => a -> Html
toHtml ([Html] -> Html) -> [Html] -> Html
forall a b. (a -> b) -> a -> b
$ (String -> Theme -> Html) -> [String] -> Themes -> [Html]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith String -> Theme -> Html
mkLink [String]
rels Themes
ts
  where
    rels :: [String]
rels = String
"stylesheet" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> [String]
forall a. a -> [a]
repeat String
"alternate stylesheet"
    mkLink :: String -> Theme -> Html
mkLink String
aRel Theme
t =
      Html -> Html
thelink
        (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [ String -> HtmlAttr
href (Theme -> String
themeHref Theme
t),  String -> HtmlAttr
rel String
aRel, String -> HtmlAttr
thetype String
"text/css",
            String -> HtmlAttr
XHtml.title (Theme -> String
themeName Theme
t)
          ]
        (Html -> Html) -> Html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< Html
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 :: [Either a b] -> Either a [b]
sequenceEither [Either a b]
es = Either a [b] -> (a -> Either a [b]) -> Maybe a -> Either a [b]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([b] -> Either a [b]
forall a b. b -> Either a b
Right ([b] -> Either a [b]) -> [b] -> Either a [b]
forall a b. (a -> b) -> a -> b
$ [Either a b] -> [b]
forall a b. [Either a b] -> [b]
rights [Either a b]
es) a -> Either a [b]
forall a b. a -> Either a b
Left ([a] -> Maybe a
forall a. [a] -> Maybe a
listToMaybe ([Either a b] -> [a]
forall a b. [Either a b] -> [a]
lefts [Either a b]
es))


liftEither :: (b -> c) -> Either a b -> Either a c
liftEither :: (b -> c) -> Either a b -> Either a c
liftEither b -> c
f = (a -> Either a c) -> (b -> Either a c) -> Either a b -> Either a c
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either a -> Either a c
forall a b. a -> Either a b
Left (c -> Either a c
forall a b. b -> Either a b
Right (c -> Either a c) -> (b -> c) -> b -> Either a c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> c
f)


concatEither :: [Either a [b]] -> Either a [b]
concatEither :: [Either a [b]] -> Either a [b]
concatEither = ([[b]] -> [b]) -> Either a [[b]] -> Either a [b]
forall b c a. (b -> c) -> Either a b -> Either a c
liftEither [[b]] -> [b]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Either a [[b]] -> Either a [b])
-> ([Either a [b]] -> Either a [[b]])
-> [Either a [b]]
-> Either a [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either a [b]] -> Either a [[b]]
forall a b. [Either a b] -> Either a [b]
sequenceEither