-----------------------------------------------------------------------------

-----------------------------------------------------------------------------

-- |
-- 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 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, p, quote, title, (</>))
import qualified Text.XHtml as XHtml

import Haddock.Backends.Xhtml.Types (BaseURL, withBaseURL)
import Haddock.Options

--------------------------------------------------------------------------------

-- * 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 :: Type -> Type) 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
  themeDirs <- String -> IO [String]
getDirectoryItems (String
libDir String -> String -> String
</> String
"html")
  themes <- mapM directoryTheme $ discoverThemes themeDirs
  return $ sequenceEither 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
  items <- String -> IO [String]
getDirectoryItems String
path
  case filter isCssFilePath 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 a b. (a -> b) -> IO a -> IO b
forall (f :: Type -> Type) 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 :: Type -> Type) 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 :: Type -> Type) 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 :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM Flag -> IO PossibleThemes
themeFlag [Flag]
flags) IO PossibleThemes
-> (PossibleThemes -> IO PossibleThemes) -> IO PossibleThemes
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: Type -> Type) 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 :: Type -> Type) 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
      pass <- String -> IO Bool
test String
path
      if pass then build path else pick path opts 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 a. a -> IO a
forall (m :: Type -> Type) 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 :: forall a. String -> String -> IO (Either String a)
errMessage String
msg String
path = Either String a -> IO (Either String a)
forall a. a -> IO a
forall (m :: Type -> Type) 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 :: forall a. a -> IO (Either String a)
retRight = Either String a -> IO (Either String a)
forall a. a -> IO a
forall (m :: Type -> Type) 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 :: Type -> Type) 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 :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap Theme -> [String]
themeFiles Themes
ts

styleSheet :: BaseURL -> Themes -> Html
styleSheet :: BaseURL -> Themes -> Html
styleSheet BaseURL
base_url 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 (BaseURL -> String -> String
withBaseURL BaseURL
base_url (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 :: forall a b. [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 :: forall b c a. (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 :: forall a b. [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 :: Type -> Type) 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