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

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

-- |
-- 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 qualified Data.Text.Lazy as LText

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

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

-- * CSS Themes

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

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

-- | Standard theme used by default
standardTheme :: FilePath -> IO PossibleThemes
standardTheme :: FilePath -> IO PossibleThemes
standardTheme FilePath
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)) (FilePath -> IO PossibleThemes
defaultThemes FilePath
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 :: FilePath -> IO PossibleThemes
defaultThemes FilePath
libDir = do
  themeDirs <- FilePath -> IO [FilePath]
getDirectoryItems (FilePath
libDir FilePath -> FilePath -> FilePath
</> FilePath
"html")
  themes <- mapM directoryTheme $ discoverThemes themeDirs
  return $ sequenceEither themes
  where
    discoverThemes :: [FilePath] -> [FilePath]
discoverThemes [FilePath]
paths =
      FilePath -> [FilePath] -> [FilePath]
filterExt FilePath
".std-theme" [FilePath]
paths [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ FilePath -> [FilePath] -> [FilePath]
filterExt FilePath
".theme" [FilePath]
paths
    filterExt :: FilePath -> [FilePath] -> [FilePath]
filterExt FilePath
ext = (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter ((FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
ext) (FilePath -> Bool) -> (FilePath -> FilePath) -> FilePath -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
takeExtension)

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

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

-- | Check if we have a built in theme
doesBuiltInExist :: IO PossibleThemes -> String -> IO Bool
doesBuiltInExist :: IO PossibleThemes -> FilePath -> IO Bool
doesBuiltInExist IO PossibleThemes
pts FilePath
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 ((FilePath -> Bool) -> (Themes -> Bool) -> PossibleThemes -> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Bool -> FilePath -> 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
. FilePath -> Themes -> Maybe Theme
findTheme FilePath
s

-- | Find a built in theme
builtInTheme :: IO PossibleThemes -> String -> IO PossibleTheme
builtInTheme :: IO PossibleThemes -> FilePath -> IO PossibleTheme
builtInTheme IO PossibleThemes
pts FilePath
s = (FilePath -> PossibleTheme)
-> (Themes -> PossibleTheme) -> PossibleThemes -> PossibleTheme
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either FilePath -> PossibleTheme
FilePath -> 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 (FilePath -> PossibleTheme
forall a b. a -> Either a b
Left (FilePath
"Unknown theme: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
s)) Theme -> PossibleTheme
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
. FilePath -> Themes -> Maybe Theme
findTheme FilePath
s

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

-- * CSS Theme Arguments

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

-- | Process input flags for CSS Theme arguments
getThemes :: FilePath -> [Flag] -> IO PossibleThemes
getThemes :: FilePath -> [Flag] -> IO PossibleThemes
getThemes FilePath
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 FilePath
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
Theme -> Themes -> Themes
forall a. a -> [a] -> [a]
: []) (FilePath -> IO PossibleTheme
theme FilePath
path)
    themeFlag (Flag
Flag_BuiltInThemes) = IO PossibleThemes
builtIns
    themeFlag Flag
_ = Themes -> IO PossibleThemes
forall a. a -> IO (Either FilePath a)
retRight []

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

    pick
      :: FilePath
      -> [(FilePath -> IO Bool, FilePath -> IO PossibleTheme)]
      -> String
      -> IO PossibleTheme
    pick :: FilePath
-> [(FilePath -> IO Bool, FilePath -> IO PossibleTheme)]
-> FilePath
-> IO PossibleTheme
pick FilePath
path [] FilePath
msg = FilePath -> FilePath -> IO PossibleTheme
forall a. FilePath -> FilePath -> IO (Either FilePath a)
errMessage FilePath
msg FilePath
path
    pick FilePath
path ((FilePath -> IO Bool
test, FilePath -> IO PossibleTheme
build) : [(FilePath -> IO Bool, FilePath -> IO PossibleTheme)]
opts) FilePath
msg = do
      pass <- FilePath -> IO Bool
test FilePath
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 []) = FilePath -> IO PossibleThemes
standardTheme FilePath
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 = FilePath -> IO PossibleThemes
defaultThemes FilePath
libDir

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

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

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

-- * File Utilities

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

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

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

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

-- * Style Sheet Utilities

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

cssFiles :: Themes -> [String]
cssFiles :: Themes -> [FilePath]
cssFiles Themes
ts = [FilePath] -> [FilePath]
forall a. Eq a => [a] -> [a]
nub ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ (Theme -> [FilePath]) -> Themes -> [FilePath]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap Theme -> [FilePath]
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
$ (Text -> Theme -> Html) -> [Text] -> Themes -> [Html]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Text -> Theme -> Html
mkLink [Text]
rels Themes
ts
  where
    rels :: [Text]
rels = Text
"stylesheet" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Text -> [Text]
forall a. a -> [a]
repeat Text
"alternate stylesheet"
    mkLink :: Text -> Theme -> Html
mkLink Text
aRel Theme
t =
      Html -> Html
thelink
        (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [ Text -> HtmlAttr
href (FilePath -> Text
LText.pack (BaseURL -> FilePath -> FilePath
withBaseURL BaseURL
base_url (Theme -> FilePath
themeHref Theme
t)))
          , Text -> HtmlAttr
rel Text
aRel
          , Text -> HtmlAttr
thetype Text
"text/css"
          , Text -> HtmlAttr
XHtml.title (FilePath -> Text
LText.pack (Theme -> FilePath
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]
[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]
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
a -> Either a c
forall a b. a -> Either a b
Left (c -> Either a c
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