-----------------------------------------------------------------------------
-- |
-- 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, stylePickers, styleMenu
    )
    where

import Haddock.Backends.Xhtml.Utils (onclick)
import Haddock.Options

import Control.Monad (liftM)
import Data.Char (toLower)
import Data.Either (lefts, rights)
import Data.List (nub, partition)
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 CssTheme = CssTheme {
  themeName :: String,
  themeHref :: String,
  themeFiles :: [FilePath]
  }


type Themes = [CssTheme]


type PossibleTheme = Either String CssTheme
type PossibleThemes = Either String Themes


-- | 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
defaultThemes :: FilePath -> IO PossibleThemes
defaultThemes libDir = do
  themeDirs <- getDirectoryItems (libDir </> "html" </> "themes")
  themes <- mapM directoryTheme themeDirs
  return $ liftEither shuffle $ sequenceEither themes
  where
    shuffle ts = let (a,b) = partition isStd ts in a ++ b
    isStd c = themeName c == "Ocean"


findTheme :: String -> Themes -> Maybe CssTheme
findTheme s = listToMaybe . filter ((== ls).lower.themeName)
  where lower = map toLower
        ls = lower s


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


-- | Process input flags for CSS Theme arguments
getThemes :: FilePath -> [Flag] -> IO (Either String Themes)
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


singleFileTheme :: FilePath -> IO PossibleTheme
singleFileTheme path =
  if isCssFilePath path
      then retRight $ CssTheme name file [path]
      else errMessage "File extension isn't .css" path
  where
    name = takeBaseName path
    file = takeFileName path


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


doesBuiltInExist :: IO PossibleThemes -> String -> IO Bool
doesBuiltInExist pts s = pts >>= return . either (const False) test
  where test = isJust . findTheme s


builtInTheme :: IO PossibleThemes -> String -> IO PossibleTheme
builtInTheme pts s = pts >>= return . either Left fetch
  where fetch = maybe (Left ("Unknown theme: " ++ s)) Right . findTheme s


getDirectoryItems :: FilePath -> IO [FilePath]
getDirectoryItems path =
  getDirectoryContents path >>= return . map (combine path) . filter notDot
  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


stylePickers :: Themes -> [Html]
stylePickers ts = map mkPicker ts
  where
    mkPicker t =
      let js = "setActiveStyleSheet('" ++ themeHref t ++ "'); return false;" in
      anchor ! [href "#", onclick js] << themeName t


styleMenu :: Themes -> Html
styleMenu [] = noHtml
styleMenu [_] = noHtml
styleMenu ts = thediv ! [identifier "style-menu-holder"] << [
    anchor ! [ href "#", onclick js ] << "Style \9662",
    unordList (stylePickers ts) ! [ identifier "style-menu", theclass "hide" ]
  ]
  where
    js = "styleMenu(); return false;"


--------------------------------------------------------------------------------
-- * 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