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