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

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

-- |
-- 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
  { 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 @--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 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 = fmap (either (const False) test) pts
  where
    test = isJust . findTheme s

-- | Find a built in theme
builtInTheme :: IO PossibleThemes -> String -> IO PossibleTheme
builtInTheme pts s = either Left fetch <$> pts
  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 =
  map (combine path) . filter notDot <$> getDirectoryContents path
  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 :: BaseURL -> Themes -> Html
styleSheet base_url ts = toHtml $ zipWith mkLink rels ts
  where
    rels = "stylesheet" : repeat "alternate stylesheet"
    mkLink aRel t =
      thelink
        ! [ href (withBaseURL base_url (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
