{-# 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
    , rtfParser
    , last'
    , module Text.CSL.Eval.Common
    , module Text.CSL.Eval.Output
    ) where

import Control.Arrow
import Control.Applicative ( (<$>) )
import Control.Monad.State
import Data.Char
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
import Text.Pandoc.Definition
import Text.ParserCombinators.Parsec hiding ( State (..) )

-- | Produce the output with a 'Layout', the 'EvalMode', a 'Bool'
-- 'True' if the evaluation happens for disambiguation purposes, the
-- 'Locale', the 'MacrpMap', the position of the cite and the
-- 'Reference'.
evalLayout :: Layout   -> EvalMode -> Bool -> [Locale] -> [MacroMap]
           -> [Option] -> Reference -> [Output]
evalLayout (Layout _ _ es) em b l m o 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                              -> x
      locale = case l of
                 [x] -> x
                 _   -> Locale [] [] [] [] []
      job    = concatMapM evalElement es
      cit    = case em of
                 EvalCite    c -> c
                 EvalSorting c -> c
                 EvalBiblio  s -> emptyCite { citePosition = s }
      initSt = EvalState (mkRefMap r) (Env cit (localeTermMap locale) m
                         (localeDate locale) o []) [] em b False [] [] False [] [] []

evalSorting :: EvalMode -> [Locale] -> [MacroMap] -> [Option] -> [Sort] -> Reference -> [Sorting]
evalSorting m l ms opts ss 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 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 =<< 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 $ evalElement e)
                                            (getFirst els) id
    | ShortNames   s fm d   <- el = head <$> gets (names . env) >>= \(Names _ ns fm' d' _) ->
                                    appendOutput fm' <$> evalNames False s (updateNameParts d fm ns) d'
    | otherwise                   = return []
    where
      updateNameParts d fm (Name f fm' nf d' np : xs) = Name f (mergeFM fm' fm) nf (d `betterThen` d') np : xs
      updateNameParts d fm                   (x : xs) = x : updateNameParts d fm xs
      updateNameParts _ _                         []  = []

      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)

      withNames e n f = modify (\s -> s { authSub = concat e
                                        , env = (env s)
                                          {names = n : names (env s)}}) >> f >>= \r ->
                        modify (\s -> s { authSub = []
                                        , env = (env s)
                                          {names = tail $ names (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)
      getVariable f fm s = case s of
                             "year-suffix" -> getStringVar "ref-id" >>= \k  ->
                                              return . return $ OYearSuf [] k [] fm
                             "page"        -> getStringVar "page" >>= formatRange fm
                             "title"       -> formatTitle f fm
                             "locator"     -> getLocVar >>= formatRange fm . snd
                             _             -> gets (options . env) >>= \opts ->
                                              getVar [] (getFormattedValue opts 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         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"
      numericVars       = ["edition", "volume", "number-of-volumes", "number", "issue", "citation-number"]
      chkNumeric      v = do val <- getStringVar v
                             return (v `elem` numericVars && or (map isDigit 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] -> Form -> Formatting -> Value -> [Output]
getFormattedValue o f fm val
    | Just v <- fromValue val :: Maybe String    = rtfParser fm 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
      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]

rtfTags :: [(String, (String,Formatting))]
rtfTags =
    [("b"                      , ("b"   , ef {fontWeight    = "bold"      }))
    ,("i"                      , ("i"   , ef {fontStyle     = "italic"    }))
    ,("sc"                     , ("sc"  , ef {fontVariant   = "small-caps"}))
    ,("sup"                    , ("sup" , ef {verticalAlign = "sub"       }))
    ,("sub"                    , ("sub" , ef {verticalAlign = "sub"       }))
    ,("span class=\"nocase\""  , ("span", ef {noCase        = True        }))
    ,("span class=\"nodecor\"" , ("span", ef {noDecor       = True        }))
    ]
    where
      ef = emptyFormatting

rtfParser :: Formatting -> String -> [Output]
rtfParser _ [] = []
rtfParser fm s
    = either (const [OStr s fm]) (return . flip Output fm . concat) $
      parse (manyTill parser eof) "" s
    where
      parser = parseText <|> parseMarkup

      parseText = do
        let amper = string "&" >> notFollowedBy (char '#') >>
                    return [OStr "&" emptyFormatting]
        x  <- many $ noneOf "<'\"`“‘&"
        xs <- parseQuotes <|> parseMarkup <|> amper
        r  <- manyTill anyChar eof
        return (OStr x emptyFormatting : xs ++
                [Output (rtfParser emptyFormatting r) emptyFormatting])

      parseMarkup = do
        let tillTag = many $ noneOf "<"
        m   <- string "<" >> manyTill anyChar (try $ string ">")
        res <- case lookup m rtfTags of
                 Just tf -> do let ot = "<"  ++ fst tf ++ ">"
                                   ct = "</" ++ fst tf ++ ">"
                                   parseGreedy = do a <- tillTag
                                                    _ <- string ct
                                                    return a
                               x <- manyTill anyChar $ try $ string ct
                               y <- try parseGreedy <|> (string ot >> pzero) <|> return []
                               let r = if null y then x else x ++ ct ++ y
                               return [Output (rtfParser emptyFormatting r) (snd tf)]
                 Nothing -> do r <- tillTag
                               return [OStr ("<" ++ m ++ ">" ++ r) emptyFormatting]
        return [Output res emptyFormatting]

      parseQuotes = choice [parseQ "'" "'"
                           ,parseQ "\"" "\""
                           ,parseQ "``" "''"
                           ,parseQ "`" "'"
                           ,parseQ "“" "”"
                           ,parseQ "‘" "’"
                           ,parseQ "&#39;" "&#39;"
                           ,parseQ "&#34;" "&#34;"
                           ,parseQ "&quot;" "&quot;"
                           ,parseQ "&apos;" "&apos;"
                           ]
      parseQ a b = try $ do
        q <- string a >> manyTill anyChar (try $ string b)
        return [Output (rtfParser emptyFormatting q) (emptyFormatting {quotes = True})]

formatTitle :: Form -> Formatting -> State EvalState [Output]
formatTitle f fm
    | Short <- f = getIt "short-title" "title"
    | otherwise  = getIt "title" "short-title"
    where
      getIt x fb = do
        o <- gets (options . env)
        r <- getVar [] (getFormattedValue o f fm) x
        case r of
          [] -> getVar [] (getFormattedValue o f fm) fb
          _  -> return r

formatNumber :: NumericForm -> Formatting -> String -> State EvalState [Output]
formatNumber f fm s
    | or (map isDigit s) = do tm <- gets (terms . env)
                              return . output fm . format tm . filter isDigit $ s
    | otherwise          = do return . output fm $ s
    where
      format tm = case f of
                    Ordinal     -> ordinal tm
                    LongOrdinal -> longOrdinal tm
                    Roman       -> if readNum s < 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"]
                  ]

formatRange :: Formatting -> String -> State EvalState [Output]
formatRange _ [] = return []
formatRange fm p = do
  ops <- gets (options . env)
  let opt = getOptionVal "page-range-format" ops
      splitRange = second (dropWhile (== '-')) . break (== '-')
      pages = map splitRange . split (== ',') $ p
      format a b = if b /= []
                   then flip Output emptyFormatting [ OStr a emptyFormatting, OPan [EnDash]
                                                    , OStr b emptyFormatting]
                   else flip Output emptyFormatting [ OStr a emptyFormatting]
      result = case opt of
                 "expanded" -> map (uncurry format . uncurry expandedRange) pages
                 "chicago"  -> map (uncurry format . uncurry chicagoRange ) pages
                 "minimal"  -> map (uncurry format . uncurry minimalRange ) pages
                 _          -> [OStr p emptyFormatting]
  return [flip Output fm $ addDelim ", " result]

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