{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE PatternGuards    #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Text.CSL.Eval.Names
-- 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.Names where

import Prelude
import           Control.Monad.State
import           Data.Char              (isLower, isUpper)
import           Data.List              (intersperse, nub)
import           Data.List.Split        (wordsBy)
import           Data.Maybe             (isJust)

import           Text.CSL.Eval.Common
import           Text.CSL.Eval.Output
import           Text.CSL.Style
import           Text.CSL.Util          (headInline, isRange, lastInline, query,
                                         readNum, splitStrWhen, toRead, (<^>))
import qualified Text.Pandoc.Builder    as B
import           Text.Pandoc.Definition
import           Text.Pandoc.Shared     (stringify)

evalNames :: Bool -> [String] -> [Name] -> String -> State EvalState [Output]
evalNames skipEdTrans ns nl d
    | [sa,sb] <- ns, not skipEdTrans
    , (sa == "editor" && sb == "translator") ||
      (sb == "editor" && sa == "translator") = do
        aa <- getAgents' sa
        ab <- getAgents' sb
        if not (null aa) && aa == ab
           then modify (\s -> s { edtrans = True }) >>
                evalNames True [sa] nl d
           else evalNames True  ns  nl d
    | (s:xs) <- ns = do
        resetEtal
        ags <- getAgents s
        k   <- getStringVar "ref-id"
        p   <- gets (citePosition . cite . env)
        ops <- gets (options . env)
        aus <- gets authSub
        r   <- do res <- agents p            s ags
                  st  <- get
                  fb  <- agents "subsequent" s ags
                  put st
                  if null res
                    then     return []
                    else let role = if aus == ["author"] then "authorsub" else s
                         in return . OContrib k role res fb <$> gets etal
        r'  <- evalNames skipEdTrans xs nl d
        num <- gets contNum
        return $ if r /= [] && r' /= []
                 then count num (r ++ [ODel $ delim ops] ++ r')
                 else count num $ cleanOutput (r ++ r')
    | otherwise = return []
    where
      agents p s a = concatMapM (formatNames (hasEtAl nl) d p s a) nl
      delim    ops = if null d then getOptionVal "names-delimiter" ops else d
      resetEtal    = modify (\s -> s { etal = [] })
      count  num x = if hasCount nl && num /= [] -- FIXME!! le zero!!
                     then [OContrib [] [] [ONum (length num) emptyFormatting] [] []]
                     else x
      hasCount     = or . query hasCount'
      hasCount' n
          | Name Count _ _ _ _  <- n = [True]
          | otherwise                = [False]

-- | The 'Bool' is 'True' when formatting a name with a final "et-al".
-- The first 'String' represents the position and the second the role
-- (e.i. editor, translator, etc.).
formatNames :: Bool -> Delimiter -> String -> String -> [Agent] -> Name -> State EvalState [Output]
formatNames ea del p s as n
    | Name f _ ns _ _ <- n, Count <- f = do
        b <- isBib <$> gets mode
        o <- mergeOptions ns <$> gets (options . env)
        modify $ \st -> st { contNum = nub $ (++) (take (snd $ isEtAl b o p as) as) $ contNum st }
        return []

    | Name f fm ns d np <- n = do
        b <- isBib <$> gets mode
        o <- mergeOptions ns <$> gets (options . env)
        m <- gets mode
        let odel  = if del /= [] then del else getOptionVal "name-delimiter" o
            del'
              | d   /= [] = d
              | null odel = ", "
              | otherwise = odel
            (_,i) = isEtAl b o p as
            form  = case f of
                      NotSet -> case getOptionVal "name-form" o of
                                  [] -> Long
                                  x  -> read $ toRead x
                      _      -> f
            genName x = do etal' <- formatEtAl o ea "et-al" fm del' x
                           if null etal'
                              then do t <- getTerm False Long "and"
                                      return $ delim t o del'
                                             $ format m o form fm np x
                              else return $
                                    addDelim del' (format m o form fm np x)
                                    ++ etal'
        setLastName o $ formatName m False f fm o np (last as)
        updateEtal =<< mapM genName [1 + i .. length as]
        genName i

    | NameLabel f fm pl <- n = when' (isVarSet s) $ do
        b <- gets edtrans
        res <- formatLabel f fm (isPlural pl $ length as) $
               if b then "editortranslator" else s
        modify $ \st -> st { edtrans = False }
        -- Note: the following line was here previously.
        -- It produces spurious 'et al's and seems to have no function,
        -- so I have commented it out:
        -- updateEtal [tr' "res" res]
        return res

    | EtAl fm t <- n = do
        o <- gets (options . env)
        et <- gets etal
        let i = length as - length et
            t' = if null t then "et-al" else t
        r <- mapM (et_al o False t' fm del) [i .. length as]
        let (r',r'') = case r of
                         (x:xs) -> (x, xs)
                         []     -> ([],[])
        updateEtal r''
        return r'

    | otherwise = return []
    where
      isBib (EvalBiblio _) = True
      isBib  _             = False
      updateEtal x = modify $ \st ->
                     let x' = if length x == 1 then repeat $ head x else x
                     in st { etal = case etal st of
                                         [] -> x
                                         ys -> zipWith (++) ys x'
                           }
      isWithLastName os
          | "true" <-       getOptionVal "et-al-use-last"  os
          , em <- readNum $ getOptionVal "et-al-min"       os
          , uf <- readNum $ getOptionVal "et-al-use-first" os
          , em - uf > 1 = True
          | otherwise   = False
      setLastName os x
          | as /= []
          , isWithLastName os = modify $ \st -> st { lastName = x}
          | otherwise         = return ()

      format m os f fm np i
          | (a:xs) <- take i as  = formatName m True  f fm os np  a ++
                        concatMap (formatName m False f fm os np) xs
          | otherwise = concatMap (formatName m True  f fm os np) . take i $ as
      delim t os d x
          | "always" <- getOptionVal "delimiter-precedes-last" os
          , length x == 2 = addDelim d (init x) ++ ODel (d <^> andStr t os) : [last x]
          | length x == 2 = addDelim d (init x) ++ ODel (andStr'   t d os) : [last x]
          | "never" <- getOptionVal "delimiter-precedes-last" os
          , length x >  2 = addDelim d (init x) ++ ODel (andStr'   t d os) : [last x]
          | length x >  2 = addDelim d (init x) ++ ODel (d <^> andStr t os) : [last x]
          | otherwise     = addDelim d x
      andStr t os
          | "text"   <- getOptionVal "and" os = " " ++ t ++ " "
          | "symbol" <- getOptionVal "and" os = " & "
          | otherwise                          = []
      andStr' t d os = if null (andStr t os) then d else andStr t os

      formatEtAl o b t fm d i = do
        ln <- gets lastName
        if isWithLastName o
           then case () of
                  _ | (length as - i) == 1 -> et_al o b t fm d i -- is that correct? FIXME later
                    | (length as - i) >  1 -> return $ [ODel d, OPan [Str "\x2026"], OSpace] ++ ln
                    | otherwise            -> return []
           else et_al o b t fm d i
      et_al o b t fm d i
          = when' ( not . isSorting <$> gets mode) $
            if b || length as <= i
            then return []
            else do x <- getTerm False Long t
                    when' (return $ x /= []) $
                          case getOptionVal "delimiter-precedes-et-al" o of
                            "never"  -> return . (++) [OSpace] $ output fm x
                            "always" -> return . (++) [ODel d] $ output fm x
                            _        -> if i > 1 && not (null d)
                                        then return . (++) [ODel d] $ output fm x
                                        else return . (++) [OSpace] $ output fm x

-- | The first 'Bool' is 'True' if we are evaluating the bibliography.
-- The 'String' is the cite position. The function also returns the
-- number of contributors to be displayed.
isEtAl :: Bool -> [Option] -> String -> [Agent] -> (Bool, Int)
isEtAl b os p as
    | p /= "first"
    , isOptionSet    "et-al-subsequent-min"       os
    , isOptionSet    "et-al-subsequent-use-first" os
    , le  <- etAlMin "et-al-subsequent-min"
    , le' <- etAlMin "et-al-subsequent-use-first"
    , length as >= le
    , length as >  le' = (,) True le'
    | isOptionSet'    "et-al-min"       "et-al-subsequent-min"
    , isOptionSet'    "et-al-use-first" "et-al-subsequent-use-first"
    , le  <- etAlMin' "et-al-min"       "et-al-subsequent-min"
    , le' <- etAlMin' "et-al-use-first" "et-al-subsequent-use-first"
    , length as >= le
    , length as >  le' = (,) True le'
    | isOptionSet'    "et-al-min"       "et-al-subsequent-min"
    , le  <- etAlMin' "et-al-min"       "et-al-subsequent-min"
    , length as >= le
    , length as >    1 = (,) True getUseFirst
    | otherwise        = (,) False $ length as
    where
      etAlMin  x   = read $ getOptionVal x os
      etAlMin' x y = if b then etAlMin x else read $ getOptionVal' x y
      isOptionSet'  s1 s2 = if b
                            then isOptionSet s1 os
                            else or $ isOptionSet s1 os : [isOptionSet s2 os]
      getOptionVal' s1 s2 = if null (getOptionVal s1 os)
                            then getOptionVal s2 os
                            else getOptionVal s1 os
      getUseFirst = let u = if b
                            then getOptionVal  "et-al-use-first" os
                            else getOptionVal' "et-al-use-first" "et-al-subsequent-min"
                    in if null u then 1 else read u

-- | Generate the 'Agent's names applying et-al options, with all
-- possible permutations to disambiguate colliding citations. The
-- 'Bool' indicate whether we are formatting the first name or not.
formatName :: EvalMode -> Bool -> Form -> Formatting -> [Option] -> [NamePart] -> Agent -> [Output]
formatName m b f fm ops np n
    | literal n /= mempty = return $ OName n  institution []         fm
    | Short      <- f = return $ OName n  shortName       disambdata fm
    | otherwise       = return $ OName n (longName given) disambdata fm
    where
      institution = oPan' (unFormatted $ literal n) (form "family")
      when_ c o = if c /= mempty then o else mempty
      addAffixes (Formatted []) _ [] = []
      addAffixes s sf ns  = [Output (Output [OPan (unFormatted s)]
                            (form sf){ prefix = mempty, suffix = mempty} : ns)
                                   emptyFormatting { prefix = prefix (form sf)
                                                   , suffix = suffix (form sf)}]

      form    s = case filter (\(NamePart n' _) -> n' == s) np of
                    NamePart _ fm':_ -> fm'
                    _                -> emptyFormatting

      hyphenate new []    = new
      hyphenate new accum =
                  if getOptionVal "initialize-with-hyphen" ops == "false"
                  then new ++ accum
                  else trimsp new ++ [Str "-"] ++ accum
      isInit [Str [c]] = isUpper c
      isInit _         = False
      initial (Formatted x) =
                  case lookup "initialize-with" ops of
                       Just iw
                         | getOptionVal "initialize" ops == "false"
                         , isInit x  -> addIn x $ B.toList $ B.text iw
                         | getOptionVal "initialize" ops /= "false"
                         , not (all isLower $ query (:[]) x) -> addIn x $ B.toList $ B.text iw
                       Nothing
                         | isInit x  -> addIn x [Space] -- default
                       _ -> Space : x ++ [Space]
      addIn x i = foldr (hyphenate . (\z -> Str (headInline z) : i)) []
                     $ wordsBy (== Str "-")
                     $ splitStrWhen (=='-') x

      sortSep g s = when_ g $ separator ++ addAffixes (g <+> s) "given" mempty
      separator   = if isByzantineFamily
                       then [OPan (B.toList (B.text
                              (getOptionValWithDefault "sort-separator" ", " ops)))]
                       else []
      suff      = if commaSuffix n && nameSuffix n /= mempty
                  then suffCom
                  else suffNoCom
      suffCom   = when_ (nameSuffix n) $ separator ++
                        oPan' (unFormatted $ nameSuffix n) fm
      suffNoCom = when_ (nameSuffix n) $ OSpace : oPan' (unFormatted $ nameSuffix n) fm

      onlyGiven = givenName n /= mempty && family == mempty
      given     = if onlyGiven
                     then givenLong
                     else when_ (givenName  n) . Formatted . trimsp . fixsp . concatMap initial $ givenName n
      fixsp     (Space:Space:xs) = fixsp (Space:xs)
      fixsp     (x:xs)           = x : fixsp xs
      fixsp     []               = []
      trimsp = reverse . dropWhile (==Space) . reverse . dropWhile (==Space)
      givenLong = when_ (givenName  n) . mconcat . intersperse (Formatted [Space]) $ givenName n
      family    = familyName n
      dropping  = droppingPart n
      nondropping  = nonDroppingPart n
      -- see src/load.js ROMANESQUE_REGEX in citeproc-js:
      -- /[-0-9a-zA-Z\u0e01-\u0e5b\u00c0-\u017f\u0370-\u03ff\u0400-\u052f\u0590-\u05d4\u05d6-\u05ff\u1f00-\u1fff\u0600-\u06ff\u200c\u200d\u200e\u0218\u0219\u021a\u021b\u202a-\u202e]/
      isByzantine c = c == '-' ||
                      (c >= '0' && c <= '9') ||
                      (c >= 'a' && c <= 'z') ||
                      (c >= 'A' && c <= 'Z') ||
                      (c >= '\x0e01' && c <= '\x0e5b') ||
                      (c >= '\x00c0' && c <= '\x017f') ||
                      (c >= '\x0370' && c <= '\x03ff') ||
                      (c >= '\x0400' && c <= '\x052f') ||
                      (c >= '\x0590' && c <= '\x05d4') ||
                      (c >= '\x05d6' && c <= '\x05ff') ||
                      (c >= '\x1f00' && c <= '\x1fff') ||
                      (c >= '\x0600' && c <= '\x06ff') ||
                      (c >= '\x200c' && c <= '\x200e') ||
                      (c >= '\x2018' && c <= '\x2019') ||
                      (c >= '\x021a' && c <= '\x021b') ||
                      (c >= '\x202a' && c <= '\x202e')

      isByzantineFamily = any isByzantine (stringify family)
      shortName = oPan' (unFormatted $ nondropping <+> family) (form "family")

      longName g
        | isSorting m = let firstPart = case getOptionVal "demote-non-dropping-particle" ops of
                                           "never" -> nondropping <+> family  <+> dropping
                                           _       -> family  <+> dropping <+> nondropping
                        in oPan' (unFormatted firstPart) (form "family") <++> oPan' (unFormatted g) (form "given") <> suffCom
        | (b && getOptionVal "name-as-sort-order" ops == "first") ||
         getOptionVal "name-as-sort-order" ops == "all" = let (fam,par) = case getOptionVal "demote-non-dropping-particle" ops of
                                                                            "never"     -> (nondropping <+> family, dropping)
                                                                            "sort-only" -> (nondropping <+> family, dropping)
                                                                            _           -> (family, dropping <+> nondropping)
                                                          in oPan' (unFormatted fam) (form "family") <> sortSep g par <> suffCom
        | otherwise = let fam = addAffixes (dropping <+> nondropping <+> family) "family" suff
                          gvn = oPan' (unFormatted g) (form "given")
                      in  if isByzantineFamily
                          then gvn <++> fam
                          else fam <> gvn

      disWithGiven = getOptionVal "disambiguate-add-givenname" ops == "true"
      initialize   = isJust (lookup "initialize-with" ops) && not onlyGiven
      isLong       = f /= Short && initialize
      givenRule    = let gr = getOptionVal "givenname-disambiguation-rule" ops
                     in if null gr then "by-cite" else gr
      disambdata   = case () of
                       _ | "all-names-with-initials"    <- givenRule
                         , disWithGiven, Short <- f, initialize    -> [longName given]
                         | "primary-name-with-initials" <- givenRule
                         , disWithGiven, Short <- f, initialize, b -> [longName given]
                         | disWithGiven, Short <- f, b
                         , "primary-name" <- givenRule -> [longName given, longName givenLong]
                         | disWithGiven, Short <- f
                         , "all-names"    <- givenRule -> [longName given, longName givenLong]
                         | disWithGiven, Short <- f
                         , "by-cite"      <- givenRule -> [longName given, longName givenLong]
                         | disWithGiven, isLong        -> [longName givenLong]
                         | otherwise                   -> []

formatTerm :: Form -> Formatting -> Bool -> String -> String
           -> State EvalState [Output]
formatTerm f fm p refid s = do
  plural <- if s `elem` ["page", "volume", "issue"]
               then do
                 varset <- isVarSet s
                 if varset
                    then isRange <$> getStringVar s
                    else return p
               else return p
  t <- getTerm plural f s
  return $
     if s == "no date"
        then [OYear t refid fm]
        else oStr' t fm

formatLabel :: Form -> Formatting -> Bool -> String -> State EvalState [Output]
formatLabel f fm p s
    | "locator" <- s = when' ( (/=) [] <$> gets (citeLocator . cite . env)) $ do
                       (l,v) <- getLocVar
                       form (\fm' -> return . flip OLoc emptyFormatting . output fm') id l (isRange v)
    | "page"    <- s = checkPlural
    | "volume"  <- s = checkPlural
    | "issue"   <- s = checkPlural
    | "ibid"    <- s = format s p
    | isRole       s = do a <- getAgents' (if s == "editortranslator"
                                              then "editor"
                                              else s)
                          if null a
                             then return []
                             else form (\fm' x -> [OLabel x fm']) id s p
    | otherwise      = format s p
    where
      isRole = flip elem ["author", "collection-editor", "composer", "container-author"
                         ,"director", "editor", "editorial-director", "editortranslator"
                         ,"illustrator", "interviewer", "original-author", "recipient"
                         ,"reviewed-author", "translator"]
      checkPlural = when' (isVarSet s) $ do
                      v <- getStringVar s
                      format  s (isRange v)
      format      = form output id
      form o g t b = o fm . g . period <$> getTerm (b && p) f t
      period      = if stripPeriods fm then filter (/= '.') else id

(<+>) :: Formatted -> Formatted -> Formatted
Formatted [] <+> ss = ss
s  <+> Formatted [] = s
Formatted xs <+> Formatted ys =
  case lastInline xs of
       "’" -> Formatted (xs ++ ys)
       "-" -> Formatted (xs ++ ys)
       _   -> Formatted (xs ++ [Space] ++ ys)

(<++>) :: [Output] -> [Output] -> [Output]
[] <++> o  = o
o  <++> [] = o
o1 <++> o2 = o1 ++ [OSpace] ++ o2