{-# 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
    ( evalLayout
    , evalSorting
    , last', split, trim
    , module Text.CSL.Eval.Common
    , module Text.CSL.Eval.Output
    ) where

import Control.Arrow
import Control.Applicative ( (<$>) )
import Control.Monad.State
import Data.Char ( toLower, isDigit, isLetter )
import Data.List
import Data.Maybe

import Text.CSL.Eval.Common
import Text.CSL.Eval.Output
import Text.CSL.Eval.Date
import Text.CSL.Eval.Names
import Text.CSL.Output.Plain
import Text.CSL.Reference
import Text.CSL.Style

-- | Produce the output with a 'Layout', the 'EvalMode', a 'Bool'
-- 'True' if the evaluation happens for disambiguation purposes, the
-- 'Locale', the 'MacroMap', the position of the cite and the
-- 'Reference'.
evalLayout :: Layout   -> EvalMode -> Bool -> [Locale] -> [MacroMap]
           -> [Option] -> [Abbrev] -> Reference -> [Output]
evalLayout (Layout _ _ es) em b l m o a r
    = cleanOutput evalOut
    where
      evalOut = case evalState job initSt of
                  [] -> if (isSorting $ em)
                        then []
                        else [noOutputError]
                  x | title r == citeId cit ++ " not found!" -> [noBibDataError $ cit]
                    | otherwise                              -> suppTC x
      locale = case l of
                 [x] -> x
                 _   -> Locale [] [] [] [] []
      job    = concatMapM evalElement es
      cit    = case em of
                 EvalCite    c -> c
                 EvalSorting c -> c
                 EvalBiblio  c -> c
      initSt = EvalState (mkRefMap r) (Env cit (localeTerms locale) m
                         (localeDate locale) o [] a) [] em b False [] [] False [] [] []
      suppTC = let getLang = take 2 . map toLower in
               case (getLang $ localeLang locale, getLang $ language r) of
                 (_,  "en") -> id
                 ("en", []) -> id
                 _          -> proc' rmTitleCase

evalSorting :: EvalMode -> [Locale] -> [MacroMap] -> [Option] ->
               [Sort] -> [Abbrev] -> Reference -> [Sorting]
evalSorting m l ms opts ss as r
    = map (format . sorting) ss
    where
      render       = renderPlainStrict . formatOutputList
      format (s,e) = applaySort s . render $ uncurry eval e
      eval     o e = evalLayout (Layout emptyFormatting [] [e]) m False l ms o as r
      applaySort c s
          | Ascending {} <- c = Ascending  s
          | otherwise         = Descending s

      unsetOpts ("et-al-min"                 ,_) = ("et-al-min"           ,"")
      unsetOpts ("et-al-use-first"           ,_) = ("et-al-use-first"     ,"")
      unsetOpts ("et-al-subsequent-min"      ,_) = ("et-al-subsequent-min","")
      unsetOpts ("et-al-subsequent-use-first",_) = ("et-al-subsequent-use-first","")
      unsetOpts  x                               = x
      setOpts s i = if i /= 0 then (s, show i) else ([],[])
      sorting s
          = case s of
              SortVariable str s'     -> (s', ( ("name-as-sort-order","all") : opts
                                              , Variable [str] Long emptyFormatting []))
              SortMacro  str s' a b c -> (s', ( setOpts "et-al-min"       a : ("et-al-use-last",c) :
                                                setOpts "et-al-use-first" b : proc unsetOpts opts
                                              , Macro str 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 $ rtfParser fm s
    | Number   s f fm       <- el = formatNumber f fm s =<< 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     _ _ _  _ _ _ <- el = evalDate el
    | Label    s f fm _     <- el = formatLabel f fm True s -- FIXME !!
    | Term     s f fm p     <- el = formatLabel f fm p s
    | Names    s n fm d sub <- el = modify (\st -> st { contNum = [] }) >>
                                    ifEmpty (evalNames False s n d)
                                            (withNames s el $ evalElements sub)
                                            (appendOutput fm)
    | Substitute (e:els)    <- el = ifEmpty (consuming $ substituteWith e)
                                            (getFirst els) id
    | otherwise                   = return []
    where
      substituteWith e = head <$> gets (names . env) >>= \(Names _ ns fm d _) -> do
                           case e of
                             Names rs [Name NotSet fm'' [] [] []] fm' d' []
                                 -> let nfm = mergeFM fm'' $ mergeFM fm' fm in
                                    evalElement $ Names rs ns nfm (d' `betterThen` d) []
                             _   -> evalElement e

      tryGroup l = if hasVar l
                   then get >>= \s -> evalElements (rmTermConst l) >>= \r -> put s >> return r
                   else return [ONull]
      hasVar  = not . null . query hasVarQ
      hasVarQ e
          | Variable {} <- e = [e]
          | Date     {} <- e = [e]
          | Names    {} <- e = [e]
          | Number   {} <- e = [e]
          | otherwise        = []
      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)

      withNames e n f = modify (\s -> s { authSub = e ++ authSub s
                                        , env = (env s)
                                          {names = n : names (env s)}}) >> f >>= \r ->
                         modify (\s -> s { authSub = filter (not . flip elem e) (authSub s)
                                        , env = (env s)
                                          {names = tail $ names (env s)}}) >> return r

      getFirst        [] = return []
      getFirst    (x:xs) = whenElse ((/=) []  <$> substituteWith x)
                                    (consuming $  substituteWith x)
                                    (getFirst xs)
      getMacro         s = maybe [] id . lookup s <$> gets (macros . env)
      getVariable f fm s = if isTitleVar s || isTitleShortVar s
                           then consumeVariable s >> formatTitle s f fm else
                           case (map toLower s) of
                             "year-suffix" -> getStringVar "ref-id" >>= \k  ->
                                              return . return $ OYearSuf [] k [] fm
                             "page"        -> getStringVar "page" >>= formatRange fm
                             "locator"     -> getLocVar >>= formatRange fm . snd
                             "url"         -> getStringVar "url" >>= \k ->
                                              if null k then return [] else return [OUrl (k,k) fm]
                             "doi"         -> getStringVar "doi" >>= \d ->
                                              if "doi:" `isPrefixOf` d
                                                 then let d' = drop 4 d in
                                                      return [OUrl ("http://dx.doi.org/" ++ d', d') fm]
                                                 else return [OStr d  fm]
                             _             -> gets (env >>> options &&& abbrevs) >>= \(opts,as) ->
                                              getVar [] (getFormattedValue opts as f fm s) 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         isUncertainDate 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 = do val <- getStringVar v
                             as  <- gets (abbrevs . env)
                             let val' = if getAbbreviation as v val == [] then val else getAbbreviation as v val
                             return (isNumericString val')
      chkDate         v = getDateVar v >>= return . not . null . filter ((/=) [] . circa)
      chkPosition     s = if s == "near-note"
                          then gets (nearNote . cite . env)
                          else gets (citePosition . cite . env) >>= return . compPosition s
      chkDisambiguate s = gets disamb  >>= return . (==) (formatVariable s) . map toLower . show
      chkLocator      v = getLocVar    >>= 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" ||
                                          b == "ibid-with-locator-c" then True  else False
          | otherwise                = isIbid b

getFormattedValue :: [Option] -> [Abbrev] -> Form -> Formatting -> String -> Value -> [Output]
getFormattedValue o as f fm s val
    | Just v <- fromValue val :: Maybe String    = rtfParser fm . getAbbr $ value 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 (EvalSorting emptyCite) [] [] sortDate v
    | Just v <- fromValue val :: Maybe [Agent]   = concatMap (formatName (EvalSorting emptyCite) True f
                                                              fm nameOpts []) v
    | otherwise                                  = []
    where
      value     = if stripPeriods fm then filter (/= '.') else id
      getAbbr v = if f == Short
                  then let ab = getAbbreviation as s v in
                       if null ab then v else ab
                  else v
      nameOpts = ("name-as-sort-order","all") : o
      sortDate = [ DatePart "year"  "numeric-leading-zeros" "" emptyFormatting
                 , DatePart "month" "numeric-leading-zeros" "" emptyFormatting
                 , DatePart "day"   "numeric-leading-zeros" "" emptyFormatting]

formatTitle :: String -> Form -> Formatting -> State EvalState [Output]
formatTitle s f fm
    | Short <- f
    , isTitleVar      s = try (getIt $ s ++ "-short") $ getIt s
    | isTitleShortVar s = try (getIt s) $ return . rtfParser fm =<< getTitleShort s
    | otherwise         = getIt s
    where
      try g h = g >>= \r -> if r == [] then h else return r
      getIt x = do
        o <- gets (options . env)
        a <- gets (abbrevs . env)
        getVar [] (getFormattedValue o a f fm x) x

formatNumber :: NumericForm -> Formatting -> String -> String -> State EvalState [Output]
formatNumber f fm v n
    = gets (abbrevs . env) >>= \as ->
      if isNumericString (getAbbr as n)
      then gets (terms . env) >>=
           return . output fm . flip process (getAbbr as n)
      else return . output fm . getAbbr as $ n
    where
      getAbbr       as   = if getAbbreviation as v n == [] then id else getAbbreviation as v
      checkRange'   ts   = if v == "page" then checkRange ts else id
      process       ts   = checkRange' ts . printNumStr . map (renderNumber ts) .
                           breakNumericString . words
      renderNumber  ts x = if isTransNumber x then format ts x else x

      format tm = case f of
                    Ordinal     -> ordinal     tm v
                    LongOrdinal -> longOrdinal tm v
                    Roman       -> if readNum n < 6000 then roman else id
                    _           -> id

      roman     = foldr (++) [] . reverse . map (uncurry (!!)) . zip romanList .
                  map (readNum . return) . take 4 . reverse
      romanList = [[ "", "i", "ii", "iii", "iv", "v", "vi", "vii", "viii", "ix" ]
	          ,[ "", "x", "xx", "xxx", "xl", "l", "lx", "lxx", "lxxx", "xc" ]
	          ,[ "", "c", "cc", "ccc", "cd", "d", "dc", "dcc", "dccc", "cm" ]
	          ,[ "", "m", "mm", "mmm", "mmmm", "mmmmm"]
                  ]


checkRange :: [CslTerm] -> String -> String
checkRange _ [] = []
checkRange ts (x:xs) = if x == '-'
                       then pageRange ts ++ checkRange ts xs
                       else x             : checkRange ts xs

printNumStr :: [String] -> String
printNumStr []     = []
printNumStr (x:[]) = x
printNumStr (x:"-":y:xs) = x ++ "-"  ++ y ++ printNumStr xs
printNumStr (x:",":y:xs) = x ++ ", " ++ y ++ printNumStr xs
printNumStr (x:xs)
    | x == "-"  = x ++        printNumStr xs
    | otherwise = x ++ " " ++ printNumStr xs

pageRange :: [CslTerm] -> String
pageRange = maybe "\x2013" termPlural . findTerm "page-range-delimiter" Long

isNumericString :: String -> Bool
isNumericString [] = False
isNumericString s  = null . filter (not . isNumber &&& not . isSpecialChar >>> uncurry (&&)) $
                     words s

isTransNumber, isSpecialChar,isNumber :: String -> Bool
isTransNumber = and . map isDigit
isSpecialChar = and . map (flip elem "&-,")
isNumber      = filter (not . isLetter) >>> filter (not . flip elem "&-,") >>>
                map isDigit >>> and &&& not . null >>> uncurry (&&)

breakNumericString :: [String] -> [String]
breakNumericString [] = []
breakNumericString (x:xs)
    | isTransNumber x = x : breakNumericString xs
    | otherwise       = let (a,b) = break (flip elem "&-,") x
                            (c,d) = if null b then ("","") else (head' b, tail b)
                        in filter (/= []) $  a : c : breakNumericString (d : xs)

formatRange :: Formatting -> String -> State EvalState [Output]
formatRange _ [] = return []
formatRange fm p = do
  ops <- gets (options . env)
  ts  <- gets (terms . env)
  let opt = getOptionVal "page-range-format" ops
      pages = tupleRange . breakNumericString . words $ p

      tupleRange [] = []
      tupleRange (x:"-":[]  ) = return (x,[])
      tupleRange (x:"-":y:xs) = (x, y) : tupleRange xs
      tupleRange (x:      xs) = (x,[]) : tupleRange xs

      joinRange (a, []) = a
      joinRange (a,  b) = a ++ "-" ++ b

      process = case opt of
                 "expanded" -> checkRange ts . printNumStr . map (joinRange . uncurry expandedRange)
                 "chicago"  -> checkRange ts . printNumStr . map (joinRange . uncurry chicagoRange )
                 "minimal"  -> checkRange ts . printNumStr . map (joinRange . uncurry minimalRange )
                 _          -> checkRange ts . printNumStr . map (joinRange)
  return [flip OLoc fm $ [OStr (process pages) emptyFormatting]]

expandedRange :: String -> String -> (String, String)
expandedRange sa [] = (sa,[])
expandedRange sa sb = (p ++ reverse nA', reverse nB')
    where
      (nA,pA) = reverse >>> break isLetter >>> reverse *** reverse $ sa
      (nB,pB) = reverse >>> break isLetter >>> reverse *** reverse $ sb
      zipNum x y = zipWith (\a b -> if b == '+' then (a,a) else (a,b))
                           (reverse x ++ take 10 (repeat '*'))
                   >>> unzip >>> filter (/= '*') *** filter (/= '*') $
                   (reverse y ++ repeat '+')
      checkNum a b = let a' = take (length b) a
                     in  readNum a' > readNum b
      (p,(nA',nB'))
          = case () of
              _ | pA /= []
                , checkNum nA nB       -> (,) [] $ (reverse $ pA ++ nA, reverse $ pB ++ nB)
                | pA /= pB
                , last' pA == last' pB -> (,) pA $ second (flip (++) (last' pA)) $ zipNum nA nB
                | pA == pB             -> (,) pA $ second (flip (++) (last' pA)) $ zipNum nA nB
                | pB == []             -> (,) pA $ second (flip (++) (last' pA)) $ zipNum nA nB
                | otherwise            -> (,) [] $ (reverse $ pA ++ nA, reverse $ pB ++ nB)

minimalRange :: String -> String -> (String, String)
minimalRange sa sb
    = res
    where
      (a,b) = expandedRange sa sb
      res   = if length a == length b
              then second (filter (/= '+')) $ unzip $ doit a b
              else (a,b)
      doit (x:xs) (y:ys) = if x == y
                           then (x,'+') : doit xs ys
                           else zip (x:xs) (y:ys)
      doit _      _      = []

chicagoRange :: String -> String -> (String, String)
chicagoRange sa sb
    = case () of
        _ | length sa < 3    -> expandedRange sa sb
          | '0':'0':_ <- sa' -> expandedRange sa sb
          | _  :'0':_ <- sa' -> minimalRange  sa sb
          | _  :a2:as <- sa'
          , b1 :b2:bs <- sb'
          , comp as bs       -> if a2 == b2
                                then (sa, [b2,b1])
                                else minimalRange sa sb

          | _:a2:a3:_:[] <- sa'
          , _:b2:b3:_    <- sb' -> if a3 /= b3 && a2 /= b2
                                   then expandedRange sa sb
                                   else minimalRange  sa sb
          | otherwise           -> minimalRange sa sb
      where
        sa' = reverse sa
        sb' = reverse sb
        comp a b = let b' = takeWhile isDigit b
                   in take (length b') a == b'

last' :: [a] -> [a]
last' = foldl (\_ x -> [x]) []

trim :: String -> String
trim = unwords . words

split :: (Char -> Bool) -> String -> [String]
split _ [] = []
split f s  = let (l, s') = break f s
             in  trim l : case s' of
                            []      -> []
                            (_:s'') -> split f s''