-----------------------------------------------------------------------------
-- |
-- 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.Applicative
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 = 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 :: 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