    {-# 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 }