{-# 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 Control.Applicative ( (<$>) )
import Control.Monad.State
import Data.Char  ( toUpper, isLower, isUpper, isSpace )
import Data.List  ( nub )
import Data.Maybe ( isJust )

import Text.CSL.Eval.Common
import Text.CSL.Eval.Output
import Text.CSL.Output.Plain ( (<>) )
import Text.CSL.Parser ( toRead )
import Text.CSL.Reference
import Text.CSL.Style
import Text.Pandoc.Definition

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 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 res /= []
                    then let role = if aus == ["author"] then concat aus ++ "sub" else s
                         in  return . return . OContrib k role res fb =<< gets etal
                    else     return []
        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 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 <- gets (options . env) >>= return . mergeOptions ns
        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 <- gets (options . env) >>= return . mergeOptions ns
        m <- gets mode
        let odel  = if del /= [] then del else getOptionVal "name-delimiter" o
            del'  = if d   /= [] then d   else if odel == [] then ", " else 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 etal' == []
                              then do t <- getTerm False Long "and"
                                      return $ delim t o del' $ format m o form fm np x
                              else do 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 }
        updateEtal [res]
        return res

    | EtAl fm t <- n = do
        o <- gets (options . env)
        if (getOptionVal "et-al-min" o == [])
           then return []
           else do
             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 = if etal st /= []
                                    then map (uncurry (++)) . zip (etal st) $ x'
                                    else 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 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' (gets mode >>= return . not . isSorting) $
            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
                                        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 /= [] = return $ OName (show n)  institution     []         fm
    | Short      <- f = return $ OName (show n)  shortName       disambdata fm
    | otherwise       = return $ OName (show n) (longName given) disambdata fm
    where
      institution = [OStr (literal n) $ form "family"]
      when_ c o = if c /= [] then o else []
      addAffixes s sf ns = [Output ((oStr' s (form sf) { prefix = [], suffix = [] }) ++ ns) $
                                   emptyFormatting { prefix = prefix (form sf)
                                                   , suffix = suffix (form sf)}]

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

      hasHyphen = not . null . filter (== '-')
      hyphen    = if getOptionVal "initialize-with-hyphen" ops == "false"
                  then getOptionVal "initialize-with" ops
                  else filter (not . isSpace) $ getOptionVal "initialize-with" ops  ++ "-"
      isInit  x = length x == 1 && or (map isUpper x)
      initial x = if isJust (lookup "initialize-with" ops) &&
                     getOptionVal "initialize" ops /= "false"
                  then if not . and . map isLower $ x
                       then addIn x $ getOptionVal "initialize-with" ops
                       else " " ++ case x of
                                     _:'\'':[] -> x
                                     _         -> x ++ " "
                  else " " ++ if isJust (lookup "initialize-with" ops) && isInit x
                              then addIn x $ getOptionVal "initialize-with" ops
                              else x
      addIn x i = if hasHyphen x
                  then head (       takeWhile (/= '-') x) : hyphen ++
                       head (tail $ dropWhile (/= '-') x) : i
                  else head x : i

      sortSep g s = when_ g $ separator ++ addAffixes (g <+> s) "given" []
      separator   = if getOptionVal "sort-separator" ops == []
                    then oStr "," ++ [OSpace]
                    else oStr (getOptionVal "sort-separator" ops)

      suff      = if commaSuffix n && nameSuffix n /= []
                  then suffCom
                  else suffNoCom
      suffCom   = when_ (nameSuffix n) $ separator ++ [        OStr (nameSuffix n) fm]
      suffNoCom = when_ (nameSuffix n) $              [OSpace, OStr (nameSuffix n) fm]

      given     = when_ (givenName  n) . unwords . words . concatMap initial $ givenName n
      givenLong = when_ (givenName  n) . unwords' $ givenName n
      family    = familyName n

      shortName = oStr' (nonDroppingPart n <+> family) (form "family")
      longName g = if isSorting m
                   then let firstPart = case getOptionVal "demote-non-dropping-particle" ops of
                                           "never" -> nonDroppingPart n <+> family  <+> droppingPart n
                                           _       -> family  <+> droppingPart n <+> nonDroppingPart n
                        in [OStr firstPart (form "family")] <++> oStr' g (form "given") ++ suffCom
                   else if (b && getOptionVal "name-as-sort-order" ops == "first") ||
                           getOptionVal "name-as-sort-order" ops == "all"
                        then let (fam,par) = case getOptionVal "demote-non-dropping-particle" ops of
                                               "never"     -> (nonDroppingPart n <+> family, droppingPart n)
                                               "sort-only" -> (nonDroppingPart n <+> family, droppingPart n)
                                               _           -> (family, droppingPart n <+> nonDroppingPart n)
                             in oStr' fam (form "family") ++ sortSep g par ++ suffCom
                          else oStr' g (form "given") <++>
                               addAffixes (droppingPart n <+> nonDroppingPart n <+> family) "family" suff

      disWithGiven = getOptionVal "disambiguate-add-givenname" ops == "true"
      initialize   = isJust . lookup "initialize-with" $ ops
      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                   -> []

unwords' :: [String] -> String
unwords' = unwords . words . foldr concatWord []
    where
      concatWord w ws = if w /= [] && last w == '.'
                        then w ++     ws
                        else w ++ ' ':ws

formatLabel :: Form -> Formatting -> Bool -> String -> State EvalState [Output]
formatLabel f fm p s
    | "locator" <- s = when' (gets (citeLocator . cite . env) >>= return . (/=) []) $ do
                       (l,v) <- getLocVar
                       form (\fm' -> return . flip OLoc emptyFormatting . output fm') id l ('-' `elem` v)
    | "page"    <- s = checkPlural
    | "volume"  <- s = checkPlural
    | "ibid"    <- s = format' s p
    | otherwise      = if isRole s then form (\fm' x -> [OLabel x fm']) id s p else 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 ('-' `elem` v)
      format      = form output id
      format' t b = gets (citePosition . cite . env) >>= \po ->
                    if po == "ibid-with-locator-c" || po == "ibid-c"
                    then form output capital t b
                    else format t b
      form o g t b = return . o fm =<< g . period <$> getTerm (b && p) f t
      period      = if stripPeriods fm then filter (/= '.') else id
      capital   x = toUpper (head x) : (tail x)

(<+>) :: String -> String -> String
[] <+> ss = ss
s  <+> [] = s
s  <+> ss = if last s == '\''
            then init s ++ "’" ++ ss
            else      s ++ " " ++ ss