{-# LANGUAGE PatternGuards #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Text.CSL.Eval
-- Copyright   :  (c) Andrea Rossato
-- License     :  BSD-style (see LICENSE)
--
-- Maintainer  :  Andrea Rossato <andrea.rossato@unitn.it>
-- Stability   :  unstable
-- Portability :  unportable
--
-- The CSL implementation
--
-----------------------------------------------------------------------------

module Text.CSL.Eval where

import Control.Arrow ( (&&&) )
import Control.Applicative ( (<$>) )
import Control.Monad.State
import Data.Char ( toLower   )
import Data.List ( elemIndex )
import Data.Maybe

import Text.CSL.Output.Plain
import Text.CSL.Parser ( toRead )
import Text.CSL.Reference
import Text.CSL.Style

data EvalState
    = EvalState
      { ref     :: ReferenceMap
      , pos     :: String
      , env     :: Environment
      , debug   :: [String]
      , disamb  :: Bool
      , consume :: Bool
      }

data Environment
    = Env
      { terms   :: [TermMap]
      , macros  :: [MacroMap]
      , options :: [Option]
      , name    :: [Name]
      } deriving ( Show )

evalLayout :: Layout   -> Bool -> [TermMap] -> [MacroMap]
           -> [Option] -> String -> Reference -> [Output]
evalLayout (Layout _ _ es) b t m o p r = evalState job initSt
    where
      job    = concatMapM evalElement es
      initSt = EvalState (mkRefMap r) p (Env t m o []) [] b False

evalSorting ::  [TermMap] -> [MacroMap] -> [Option] -> [Sort] -> Reference -> [Sorting]
evalSorting ts ms opts ss r
    = map (format . sorting) ss
    where
      render       = renderPlainStrict . map formatOutput . proc addYearSuffix
      format (s,e) = applaySort s . render $ eval e
      eval      e  = evalLayout (Layout emptyFormatting [] [e]) False ts ms opts [] r
      applaySort c s
          | Ascending {} <- c = Ascending  s
          | otherwise         = Descending s
      sorting s = case s of
                    SortVariable str o -> (o, Variable [str] Long emptyFormatting [])
                    SortMacro    str o -> (o, Macro     str  Long emptyFormatting   )

evalElements :: [Element] -> State EvalState [Output]
evalElements x = concatMapM evalElement x

evalElement :: Element -> State EvalState [Output]
evalElement el
    | Choose i ei e             <- el = evalIfThen i ei e
    | Macro        s _ fm       <- el = return . appendOutput fm =<< evalElements =<< getMacro s
    | Const        s   fm       <- el = return . output fm $ s
    | PointLocator s _ fm       <- el = return . output fm  =<< getStringVar s
    | Number       s _ fm       <- el = return . output fm  =<< getStringVar s
    | Variable     s f fm d     <- el = return . addDelim d =<< concatMapM (getVariable f fm) s
    | Group            fm d _ l <- el = when' ((/=) [] <$> tryGroup l) $
                                        return . outputList fm d =<< evalElements l
    | Date         s   fm d dp  <- el = return . outputList fm d =<< evalDate dp s
    | Label        s f fm i p   <- el = formatLabel f fm i p s
    | Term         s f fm i p   <- el = formatLabel f fm i p s
    | Names        s n fm d sub <- el = ifEmpty (evalNames s n d)
                                                (withName (getName n) $ evalElements sub)
                                                (appendOutput fm)
    | Substitute (e:els)        <- el = ifEmpty (consuming $ evalElement e)
                                                (getFirst els) id
    | ShortNames   s   fm d     <- el = head <$> gets (name . env) >>= \(Name f _ nf d') ->
                                        evalNames s [Name f fm nf d'] d
    | otherwise                       = return []
    where
      tryGroup     l = get >>= \s -> evalElements (rmTermConst l) >>= \r -> put s >> return r
      rmTermConst [] = []
      rmTermConst (e:es)
          | Term  {} <- e = rmTermConst es
          | Const {} <- e = rmTermConst es
          | otherwise = e : rmTermConst es

      ifEmpty p t e = p >>= \r -> if r == [] then t else return (e r)

      withName  n f = modify (\s -> s { env = (env s)
                                        {name =    n : name (env s)}}) >> f >>= \r ->
                       modify (\s -> s { env = (env s)
                                        {name = tail $ name (env s)}}) >> return r

      getFirst        [] = return []
      getFirst    (x:xs) = whenElse ((/=) []  <$> evalElement x)
                                    (consuming $  evalElement x)
                                    (getFirst xs)

      getMacro         s = maybe [] id . lookup s <$> gets (macros . env)
      getName            = head . filter isName
      getVariable f fm s = getStringVar "year-suffix" >>= \su ->
                           getVar [] (getFormattedValue su f fm) s >>=
                           \r -> consumeVariable s >> return r

evalIfThen :: IfThen -> [IfThen] -> [Element] -> State EvalState [Output]
evalIfThen i ei e
    | IfThen c m el <- i = ifElse c m el
    | otherwise          = evalElements e
    where
      ifElse c m el = if ei == []
                      then whenElse (evalCond m c)
                                    (evalElements el)
                                    (evalElements e )
                      else whenElse (evalCond m c)
                                    (evalElements el)
                                    (evalIfThen (head ei) (tail ei) e)
      evalCond m c = do t <- checkCond chkType         isType         c m
                        v <- checkCond isVarSet        isSet          c m
                        n <- checkCond chkNumeric      isNumeric      c m
                        d <- checkCond chkDate         isDate         c m
                        p <- checkCond chkPosition     isPosition     c m
                        a <- checkCond chkDisambiguate disambiguation c m
                        l <- checkCond chkLocator      isLocator      c m
                        return $ match m $ concat [t,v,n,d,p,a,l]

      checkCond a f c m = if f c /= [] then mapM a (f c) else checkMatch m
      checkMatch m
          | All    <- m = return [True]
          | otherwise   = return [False]

      chkType         t = let chk = (==) (formatVariable t) . show . fromMaybe NoType . fromValue
                          in  getVar False chk "ref-type"
      chkNumeric      v = isVarSet v
      chkDate         v = isVarSet v
      chkPosition     s = gets pos >>= return . compPosition s
      chkDisambiguate s = gets disamb >>= return . (==) (formatVariable s) . map toLower . show
      chkLocator      v = getLocVar v >>= return . (==) v . fst
      isIbid          s = if s == "first" || s == "subsequent" then False else True
      compPosition a b
          | "first"             <- a = if b == "first"             then True  else False
          | "subsequent"        <- a = if b == "first"             then False else True
          | "ibid-with-locator" <- a = if b == "ibid-with-locator" then True  else False
          | otherwise                = isIbid b

evalNames :: [String] -> [Name] -> String -> State EvalState [Output]
evalNames ns nl d
    | (s:xs) <- ns = do ags <- getAgents s
                        k   <- getStringVar "cite-key"
                        p   <- gets pos
                        ops <- gets (options . env)
                        let (b ,l ) = isEtAl ops p ags
                            (ea,as) = if b
                                      then (,) True  $ take l ags
                                      else (,) False $ ags
                        r   <- if s == "author" && ags /= [] && p == "subsequent" &&
                                  isOptionSet "subsequent-author-substitute" ops
                               then return $ output emptyFormatting $
                                             getOptionVal "subsequent-author-substitute" ops
                               else do res <- agents ea s as
                                       if res /= []
                                          then return . return . OContrib k res =<<
                                               mapM (rest ags ea s)  [1 + l .. length ags]
                                           else return []
                        r'  <- evalNames xs nl d
                        return $ if r /= [] && r' /= []
                                 then r ++ [ODel d] ++ r'
                                 else cleanOutput (r ++ r')
    | otherwise    = return []
    where
      agents ea s l = concatMapM (formatNames ea s l) nl
      rest l ea s n = agents (if n == length l then False else ea) s $ take n l
      etAlMin     s = read . getOptionVal s
      isEtAl o p ags
          | p /= "first"
          , isOptionSet    "et-al-subsequent-min"       o
          , isOptionSet    "et-al-subsequent-use-first" o
          , len <- etAlMin "et-al-subsequent-min"       o
          , length ags >  1
          , length ags >= len = (,) True $ etAlMin "et-al-subsequent-use-first" o
          | isOptionSet    "et-al-min"       o
          , isOptionSet    "et-al-use-first" o
          , len <- etAlMin "et-al-min"       o
          , length ags >  1
          , length ags >= len = (,) True $ etAlMin "et-al-use-first" o
          | otherwise         = (False,  0)

evalDate :: [DatePart] -> [String] -> State EvalState [Output]
evalDate dp s = do tm <- gets $ filter ((==) "month-" . take 6 . fst . fst) . terms . env
                   sf <- getStringVar "year-suffix"
                   concatMap (formatDate sf tm dp) <$> mapM getDateVar s

-- | If the first parameter is 'True' the plural form will be retrieved.
getTerm :: Bool -> Form -> String -> State EvalState String
getTerm b f s = maybe [] g . lookup (s,f) <$> gets (terms  . env) -- FIXME: vedere i fallback
    where g = if b then snd else fst

getStringVar :: String -> State EvalState String
getStringVar
    = getVar [] getStringValue

getDateVar :: String -> State EvalState [RefDate]
getDateVar
    = getVar [] getDateValue
    where
      getDateValue val
          | Just v <- fromValue val = v
          | otherwise               = []

getLocVar :: String -> State EvalState (String,String)
getLocVar s
    = (show &&& locString) <$> getVar NoneLoc getLocValue s
    where
      getLocValue val
          | Just v <- fromValue val = v
          | otherwise               = NoneLoc

getVar :: a -> (Value -> a) -> String -> State EvalState a
getVar a f s
    = withRefMap $ maybe a f . lookup (formatVariable s)

getAgents :: String -> State EvalState [Agent]
getAgents s
    = do
      mv <- withRefMap (lookup s)
      case mv of
        Just v -> case fromValue v of
                    Just x -> consumeVariable s >> return x
                    _      -> return []
        _      -> return []

getFormattedValue :: String -> Form -> Formatting -> Value -> [Output]
getFormattedValue s f fm val
    | Just v <- fromValue val :: Maybe String    = output  fm v
    | Just v <- fromValue val :: Maybe Locator   = output  fm (locString v)
    | Just v <- fromValue val :: Maybe Int       = output  fm (if v == 0 then [] else show v)
    | Just v <- fromValue val :: Maybe CNum      = if v == 0 then [] else [OCitNum (unCNum v) fm]
    | Just v <- fromValue val :: Maybe [RefDate] = formatDate s [] defaultDate v
    | Just v <- fromValue val :: Maybe [Agent]   = concatMap (formatName True f fm defaultNameFormatting) v
    | otherwise                                  = []

getStringValue :: Value -> String
getStringValue val
    | Just v <- fromValue val = v
    | otherwise               = []

getOptionVal :: String -> [Option] -> String
getOptionVal s = fromMaybe [] . lookup s

isOptionSet :: String -> [Option] -> Bool
isOptionSet s = maybe False (not . null) . lookup s

isVarSet :: String -> State EvalState Bool
isVarSet = getVar False isValueSet

withRefMap :: (ReferenceMap -> a) -> State EvalState a
withRefMap f = return . f =<< gets ref

formatNames :: Bool -> String -> [Agent] -> Name -> State EvalState [Output]
formatNames et s as n
    | Name      f fm nf d <- n = return . delim nf d =<< (++) (names f fm nf) <$> et_al fm
    | NameLabel f fm i  p <- n = when' (isVarSet s) $ formatLabel f fm i (isPlural p $ length as) s
    | otherwise                = return []
    where
      et_al fm = if not et then return [] else return . output fm =<< getTerm False Long "et-al"
      names f fm nf
          | "first" <- nameAsSortOrder nf, (a:xs) <- as = formatName True f fm nf a ++
                                                          concatMap (formatName False f fm nf) xs
          | "all"   <- nameAsSortOrder nf               = concatMap (formatName True  f fm nf) as
          | otherwise                                   = concatMap (formatName False f fm nf) as
      delim nf d x
          | True  <- et
          , length x >  1 = addDelim d x
          | "always" <- delimiterPrecedesLast nf
          , length x == 2 = addDelim d (init x) ++ ODel (d <> andStr nf) : [last x]
          | length x == 2 = addDelim d (init x) ++ ODel (     andStr nf) : [last x]
          | length x >  2 = addDelim d (init x) ++ ODel (d <> andStr nf) : [last x]
          | otherwise     = addDelim d x
      andStr nf
          | "text"   <- andConnector nf = " and "
          | "symbol" <- andConnector nf = " & "
          | otherwise                   = []
      isPlural  p = (&&) p . (<) 1

-- | Generate the 'Agent's names applying et-al options, with all
-- possible permutations to disambiguate colliding citations.
formatName :: Bool -> Form -> Formatting -> NameFormatting -> Agent -> [Output]
formatName b f fm nf n
    | Person {} <- n
    , Short     <- f = return $ OName  short        rest         fm
    | Person {} <- n = return $ OName (long given') [long given] fm
    | Entity  s <- n = output fm s
    | otherwise      = []
    where
      rest = [ family $ concatMap addPnt (givenName n)
             , long given]
      addSpace = flip (++) (if b then [] else " ")
      addPnt x = if x /= [] then head x : ". " else []
      format x = procList x initia
      initia x = if initializeWith nf /= []
                 then head x : initializeWith nf
                 else addSpace x
      long   g = if b
                 then family [] ++ sortSeparator nf ++ g
                 else family g
      short    = family []
      family x = namePrefix n <+> (x ++ articular n <+> familyName n <+> nameSuffix n)
      given'   = concatMap  format (givenName n)
      given    = addSpace $ concat (givenName n)

formatLabel :: Form -> Formatting -> Bool -> Bool -> String -> State EvalState [Output]
formatLabel f fm i p s
    | "locator" <- s = when' (isVarSet s) $ do
                       (l,v) <- getLocVar s
                       format l ('-' `elem` v)
    | "page"    <- s = when' (isVarSet s) $ do
                       v <- getStringVar s
                       format s ('-' `elem` v)
    | otherwise      = format s p
    where
      format t b = return . output fm =<< flip (++) period <$> getTerm (b && p) f t
      period     = if i then "." else []

formatDate :: String -> [TermMap] -> [DatePart] -> [RefDate] -> [Output]
formatDate s tm dp date
    | [d] <- date = concatMap (formatDatePart d) dp
    | otherwise   = []
    where
      addZero n = if length n == 1 then '0' : n else n
      formatDatePart (RefDate y m d o) (DatePart n f fm)
          | "year"  <- n, y /= 0  = return $ OYear (formatYear  f $ show y) s fm
          | "month" <- n, m /= 0  = output fm      (formatMonth f $ show m)
          | "day"   <- n, d /= 0  = output fm      (formatDay   f $ show d)
          | "other" <- n, o /= [] = output fm      o
          | otherwise             = []
      formatYear f y
          | "short"   <- f = drop 2 y
          | otherwise      = y
      formatMonth f m
          | "short"   <- f = getMonth $ flip (++) "." . fst
          | "long"    <- f = getMonth fst
          | "numeric" <- f = m
          | otherwise      = addZero m
          where
            getMonth g = maybe m g $ lookup ("month-" ++ addZero m, read $ toRead f) tm
      formatDay f d
          | "numeric-leading-zeros" <- f = addZero d
          | "ordinal"               <- f = d ++ ordinal
          | otherwise                    = d
          where
            ordinal = case last d of
                        '1' -> "st"
                        '2' -> "nd"
                        '3' -> "rd"
                        _   -> "th"

output :: Formatting -> String -> [Output]
output fm s = if s /= "" then [OStr s fm] else []

appendOutput :: Formatting -> [Output] -> [Output]
appendOutput fm xs = if xs /= [] then [Output xs fm] else []

outputList :: Formatting -> Delimiter -> [Output] -> [Output]
outputList fm d = appendOutput fm . addDelim d . cleanOutput

cleanOutput :: [Output] -> [Output]
cleanOutput = filter isNotEmpty
    where
      isNotEmpty (OStr "" _) = False
      isNotEmpty _           = True

addDelim :: String -> [Output] -> [Output]
addDelim d = foldr (\x xs -> if length xs < 1 then x : xs else x : ODel d : xs) []

consumeVariable :: String -> State EvalState ()
consumeVariable s
    = do b <- gets consume
         when b $ modify $ \st -> st { ref = f (ref st) }
      where f rm = case elemIndex (formatVariable s) (map fst rm) of
                     Just  i -> take i rm ++ [(formatVariable s,Value Empty)] ++ drop (i + 1) rm
                     Nothing -> rm

consuming :: State EvalState a -> State EvalState a
consuming f = setConsume >> f >>= \a -> unsetConsume >> return a
    where setConsume   = modify $ \s -> s {consume = True }
          unsetConsume = modify $ \s -> s {consume = False}

when' :: Monad m => m Bool -> m [a] -> m [a]
when' p f = whenElse p f (return [])

whenElse :: Monad m => m Bool -> m a -> m a -> m a
whenElse b f g = b >>= \ bool -> if bool then f else g

concatMapM :: (Monad m, Functor m, Eq b) => (a -> m [b]) -> [a] -> m [b]
concatMapM f l = concat . filter (/=[]) <$> mapM f l

formatVariable :: String -> String
formatVariable = foldr f []
    where f x xs = if x == '_' then '-' : xs else toLower x : xs

head' :: [a] -> [a]
head' = foldr (\x _ -> [x]) []

trace ::  String -> State EvalState ()
trace d = modify $ \s -> s { debug = d : debug s }