{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE PatternGuards       #-}
{-# LANGUAGE ScopedTypeVariables #-}
-----------------------------------------------------------------------------
-- |
-- 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
    , module Text.CSL.Eval.Common
    , module Text.CSL.Eval.Output
    ) where

import Prelude
import           Control.Arrow
import qualified Control.Exception      as E
import           Control.Monad.State
import           Data.Char              (isDigit, isLetter, toLower)
import           Data.Maybe
import           Data.Monoid            (Any (..))
import           Data.String            (fromString)
import qualified Data.Text              as T
import           Text.Pandoc.Definition (Inline (Link, Str), nullAttr)
import           Text.Pandoc.Shared     (stringify)
import           Text.Pandoc.Walk       (walk)

import           Text.CSL.Eval.Common
import           Text.CSL.Eval.Date
import           Text.CSL.Eval.Names
import           Text.CSL.Eval.Output
import           Text.CSL.Exception
import           Text.CSL.Output.Plain
import           Text.CSL.Reference
import           Text.CSL.Style         hiding (Any)
import           Text.CSL.Util          (betterThan, isRange, last', proc,
                                         proc', query, readNum, safeRead)

-- | 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] -> Abbreviations -> Maybe Reference -> [Output]
evalLayout (Layout _ _ es) em b l m o a mbr
    = cleanOutput evalOut
    where
      evalOut = case evalState job initSt of
                  x | isNothing mbr -> [noBibDataError cit]
                    | null x        -> []
                    | otherwise     -> suppTC x
      locale = case l of
                 [x] -> x
                 _   -> Locale [] [] [] [] []
      job    = evalElements es
      cit    = case em of
                 EvalCite    c -> c
                 EvalSorting c -> c
                 EvalBiblio  c -> c
      initSt = EvalState (mkRefMap mbr) (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 . unLiteral . language <$> mbr) of
                 (_,  Just "en") -> id
                 (_,  Nothing)   -> id
                 ("en", Just "") -> id
                 _               -> proc' rmTitleCase'

evalSorting :: EvalMode -> [Locale] -> [MacroMap] -> [Option] ->
               [Sort] -> Abbreviations -> Maybe Reference -> [Sorting]
evalSorting m l ms opts ss as mbr
    = map (format . sorting) ss
    where
      render       = renderPlain . formatOutputList . proc removeDelimAndLabel
      removeDelimAndLabel OLabel{} = ONull
      removeDelimAndLabel ODel{}   = ONull
      -- for sorting purposes, we need to distinguish between the space
      -- inside a last name like ben Gurion, and the space between the
      -- last name and the first.  OSpace is used for the latter.
      removeDelimAndLabel OSpace{} = OStr "," emptyFormatting
      removeDelimAndLabel x          = x
      format (s,e) = applaySort s . render $ uncurry eval e
      eval     o e = evalLayout (Layout emptyFormatting [] [e]) m False l ms o as mbr
      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 = concatMapM evalElement

evalElement :: Element -> State EvalState [Output]
evalElement el
    | Const    s   fm       <- el = return $ addSpaces s
                                           $ if fm == emptyFormatting
                                                then [OPan (readCSLString s)]
                                                else [Output [OPan (readCSLString s)] fm]
                                    -- NOTE: this conditional seems needed for
                                    -- locator_SimpleLocators.json:
    | Number   s f fm       <- el = if s == "locator"
                                       then getLocVar >>= formatRange fm . snd
                                       else formatNumber f fm s =<<
                                            getStringVar s
    | Variable s f fm d     <- el = addDelim d <$> concatMapM (getVariable f fm) s
    | Group        fm d l   <- el = outputList fm d <$> tryGroup l
    | Date{} <- el = evalDate el
    | Label    s f fm _     <- el = formatLabel f fm True s -- FIXME !!
    | Term     s f fm p     <- el = formatTerm  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 = do
                        res <- consuming $ substituteWith e
                        if null res
                           then if null els
                                   then return [ONull]
                                   else evalElement (Substitute els)
                           else return res
    -- All macros and conditionals should have been expanded
    | Choose i ei xs        <- el = do
                        res <- evalIfThen i ei xs
                        evalElements res
    | Macro    s   fm       <- el = do
                        ms <- gets (macros . env)
                        case lookup s ms of
                             Nothing  -> E.throw $ MacroNotFound (show s)
                             Just els -> do
                               res <- concat <$> mapM evalElement els
                               if null res
                                  then return []
                                  else return [Output res fm]
    | otherwise                   = return []
    where
      addSpaces strng = (if take 1 strng == " " then (OSpace:) else id) .
                        (if last' strng == " " then (++[OSpace]) else id)
      substituteWith e = head <$> gets (names . env) >>= \(Names _ ns fm d _) ->
                           case e of
                             Names rs [Name NotSet fm'' [] [] []] fm' d' []
                                 -> let nfm = mergeFM fm'' $ mergeFM fm' fm in
                                    evalElement $ Names rs ns nfm (d' `betterThan` d) []
                             _   -> evalElement e

      -- from citeproc documentation: "cs:group implicitly acts as a
      -- conditional: cs:group and its child elements are suppressed if
      -- a) at least one rendering element in cs:group calls a variable
      -- (either directly or via a macro), and b) all variables that are
      -- called are empty. This accommodates descriptive cs:text elements."

      -- TODO:  problem, this approach gives wrong results when the variable
      -- is in a conditional and the other branch is followed.  the term
      -- provided by the other branch (e.g. 'n.d.') is not printed.  we
      -- should ideally expand conditionals when we expand macros.
      tryGroup l = if getAny $ query hasVar l
                   then do
                     oldState <- get
                     res <- evalElements (rmTermConst l)
                     put oldState
                     let numVars = [s | Number s _ _ <- l]
                     nums <- mapM getStringVar numVars
                     let pluralizeTerm (Term s f fm _) = Term s f fm $
                            case numVars of
                              ["number-of-volumes"] -> "1" `notElem` nums
                              ["number-of-pages"]   -> "1" `notElem` nums
                              _ -> any isRange nums
                         pluralizeTerm x = x
                     if null res
                        then return []
                        else evalElements $ map pluralizeTerm l
                   else evalElements l
      hasVar e
          | Variable {} <- e = Any True
          | Date     {} <- e = Any True
          | Names    {} <- e = Any True
          | Number   {} <- e = Any True
          | otherwise        = Any False
      rmTermConst = proc $ filter (not . isTermConst)
      isTermConst e
          | Term  {} <- e = True
          | Const {} <- e = True
          | otherwise     = False

      ifEmpty p t e = p >>= \r -> if null 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

      getVariable f fm s
        | isTitleVar s || isTitleShortVar s =
             consumeVariable s >> formatTitle s f fm
        | otherwise =
             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 [Output [OPan [Link nullAttr [Str k] (k,"")]] fm]
               "doi"         -> do d <- getStringVar "doi"
                                   let (prefixPart, linkPart) = T.breakOn (T.pack "http") (T.pack (prefix fm))
                                   let u = if T.null linkPart
                                              then "https://doi.org/" ++ d
                                              else T.unpack linkPart ++ d
                                   if null d
                                      then return []
                                      else return [Output [OPan [Link nullAttr [Str (T.unpack linkPart ++ d)] (u, "")]]
                                            fm{ prefix = T.unpack prefixPart, suffix = suffix fm }]
               "isbn"        -> getStringVar "isbn" >>= \d ->
                                if null d
                                   then return []
                                   else return [Output [OPan [Link nullAttr [Str d] ("https://worldcat.org/isbn/" ++ d, "")]] fm]
               "pmid"        -> getStringVar "pmid" >>= \d ->
                                if null d
                                   then return []
                                   else return [Output [OPan [Link nullAttr [Str d] ("http://www.ncbi.nlm.nih.gov/pubmed/" ++ d, "")]] fm]
               "pmcid"       -> getStringVar "pmcid" >>= \d ->
                                if null d
                                   then return []
                                   else return [Output [OPan [Link nullAttr [Str d] ("http://www.ncbi.nlm.nih.gov/pmc/articles/" ++ d, "")]] fm]
               _ -> do (opts, as) <- gets (env >>> options &&& abbrevs)
                       r <- getVar []
                              (getFormattedValue opts as f fm s) s
                       consumeVariable s
                       return r

evalIfThen :: IfThen -> [IfThen] -> [Element] -> State EvalState [Element]
evalIfThen (IfThen c' m' el') ei e = whenElse (evalCond m' c') (return el') rest
  where
      rest = case ei of
                  []     -> return e
                  (x:xs) -> evalIfThen x xs 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 = case f c of
                               []  -> case m of
                                           All -> return [True]
                                           _   -> return [False]
                               xs  -> mapM a xs

      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 null (getAbbreviation as v val)
                                           then val
                                           else getAbbreviation as v val
                             return (isNumericString val')
      chkDate         v = any circa <$> getDateVar v
      chkPosition     s = if s == "near-note"
                          then gets (nearNote . cite . env)
                          else compPosition s <$> gets (citePosition . cite . env)
      chkDisambiguate s = (==) (formatVariable s) . map toLower . show <$> gets disamb
      chkLocator      v = (==) v . fst <$> getLocVar
      isIbid          s = not (s == "first" || s == "subsequent")
      compPosition a b
          | "first"             <- a = b == "first"
          | "subsequent"        <- a = b /= "first"
          | "ibid-with-locator" <- a = b == "ibid-with-locator" ||
                                       b == "ibid-with-locator-c"
          | otherwise                = isIbid b

getFormattedValue :: [Option] -> Abbreviations -> Form -> Formatting -> String -> Value -> [Output]
getFormattedValue o as f fm s val
    | Just v <- fromValue val :: Maybe Formatted =
       if v == mempty
          then []
          else let ys = unFormatted . maybe v fromString
                        $ getAbbr (stringify $ unFormatted v)
               in  if null ys
                      then []
                      else [Output [OPan $ walk value' ys] fm]
    | Just v <- fromValue val :: Maybe String    = (:[]) . flip OStr fm . Data.Maybe.fromMaybe v . getAbbr $ value v
    | Just v <- fromValue val :: Maybe Literal   = (:[]) . flip OStr fm . Data.Maybe.fromMaybe (unLiteral v) . getAbbr $ value $ unLiteral v
    | Just v <- fromValue val :: Maybe Int       = output  fm (if v == 0 then [] else show 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 CLabel    = if v == mempty then [] else [OCitLabel (unCLabel 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
      value' (Str x) = Str (value x)
      value' x       = x
      getAbbr v = if f == Short
                  then case getAbbreviation as s v of
                             [] -> Nothing
                             y  -> Just y
                  else Nothing
      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) $ (:[]) . flip OStr fm <$> getTitleShort s
    | otherwise         = getIt s
    where
      try g h = g >>= \r -> if null 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 output fm . flip process (getAbbr as n) <$> gets (terms . env)
      else return . output fm . getAbbr as $ n
    where
      getAbbr       as   = if null (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     -> maybe "" (ordinal     tm v) . safeRead
                    LongOrdinal -> maybe "" (longOrdinal tm v) . safeRead
                    Roman       -> maybe ""
                                   (\x -> if x < 6000 then roman x else show x) .
                                   safeRead
                    _           -> maybe "" show . (safeRead :: String -> Maybe Int)

      roman :: Int -> String
      roman     = foldr (++) [] . reverse . map (uncurry (!!)) . zip romanList .
                  map (readNum . return) . take 4 .
                  reverse . show
      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 == '-' || x == '\x2013'
                       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  = all (\c -> isNumber c || isSpecialChar c) $ words s

isTransNumber, isSpecialChar,isNumber :: String -> Bool
isTransNumber = all isDigit
isSpecialChar = all (`elem` "&-,.\x2013")
isNumber   cs = case [c | c <- cs
                        , not (isLetter c)
                        , c `notElem` "&-.,\x2013"] of
                     [] -> False
                     xs -> all isDigit xs

breakNumericString :: [String] -> [String]
breakNumericString [] = []
breakNumericString (x:xs)
    | isTransNumber x = x : breakNumericString xs
    | otherwise       = let (a,b) = break (`elem` "&-\x2013,") x
                            (c,d) = if null b
                                       then ("","")
                                       else span (`elem` "&-\x2013,") 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, cs]
        | cs `elem` ["-", "--", "\x2013"] = return (x,[])
      tupleRange (x:cs:y:xs)
        | cs `elem` ["-", "--", "\x2013"] = (x, y) : tupleRange xs
      tupleRange (x:      xs) = (x,[]) : tupleRange xs

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

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

-- Abbreviated page ranges are expanded to their non-abbreviated form:
-- 42–45, 321–328, 2787–2816
expandedRange :: (String, String) -> (String, String)
expandedRange (sa, []) = (sa,[])
expandedRange (sa, sb)
  | length sb < length sa =
      case (safeRead sa, safeRead sb) of
           -- check to make sure we have regular numbers
           (Just (_ :: Int), Just (_ :: Int)) ->
             (sa, take (length sa - length sb) sa ++ sb)
           _ -> (sa, sb)
  | otherwise = (sa, sb)

-- All digits repeated in the second number are left out:
-- 42–5, 321–8, 2787–816.  The minDigits parameter indicates
-- a minimum number of digits for the second number; thus, with
-- minDigits = 2, we have 328-28.
minimalRange :: Int -> (String, String) -> (String, String)
minimalRange minDigits (a:as, b:bs)
  | a == b
  , length as == length bs
  , length bs >= minDigits =
                let (_, bs') = minimalRange minDigits (as, bs)
                in  (a:as, bs')
minimalRange _ (as, bs) = (as, bs)

-- Page ranges are abbreviated according to the Chicago Manual of Style-rules:
-- First number             Second number    Examples
-- Less than 100            Use all digits   3–10; 71–72
-- 100 or multiple of 100   Use all digits   100–104; 600–613; 1100–1123
-- 101 through 109 (in multiples of 100) Use changed part only  10002-6, 505-17
-- 110 through 199          Use 2 digits or more  321-25, 415-532
-- if numbers are 4 digits long or more and 3 digits change, use all digits
--         1496-1504
chicagoRange :: (String, String) -> (String, String)
chicagoRange (sa, sb)
    = case (safeRead sa :: Maybe Int) of
          Just n | n < 100 -> expandedRange (sa, sb)
                 | n `mod` 100 == 0 -> expandedRange (sa, sb)
                 | n >= 1000 -> let (sa', sb') = minimalRange 1 (sa, sb)
                                in  if length sb' >= 3
                                       then expandedRange (sa, sb)
                                       else (sa', sb')
                  | n > 100 -> if n `mod` 100 < 10
                                 then minimalRange 1 (sa, sb)
                                 else minimalRange 2 (sa, sb)
          _ -> expandedRange (sa, sb)