module Text.CSL.Eval.Names where
import Control.Monad.State
import Data.Char ( isLower, isUpper, isLetter )
import Data.List ( nub, intersperse )
import Data.List.Split ( wordsBy )
import Data.Maybe ( isJust )
import Text.CSL.Eval.Common
import Text.CSL.Eval.Output
import Text.CSL.Util ( headInline, lastInline, readNum, (<^>), query, toRead,
splitStrWhen, isRange )
import Text.CSL.Style
import Text.Pandoc.Definition
import Text.Pandoc.Shared ( stringify )
import qualified Text.Pandoc.Builder as B
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 . 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 d == [] then getOptionVal "names-delimiter" ops else d
resetEtal = modify (\s -> s { etal = [] })
count num x = if hasCount nl && num /= []
then [OContrib [] [] [ONum (length num) emptyFormatting] [] []]
else x
hasCount = or . query hasCount'
hasCount' n
| Name Count _ _ _ _ <- n = [True]
| otherwise = [False]
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 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 }
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 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
| (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 && not (null d)
then return . (++) [ODel d] $ output fm x
else return . (++) [OSpace] $ output fm x
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
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]
_ -> Space : x ++ [Space]
addIn x i = foldr hyphenate []
$ map (\z -> Str (headInline z) : i)
$ wordsBy (== Str "-")
$ splitStrWhen (=='-') x
sortSep g s = when_ g $ separator ++ addAffixes (g <+> s) "given" mempty
separator = if null (getOptionVal "sort-separator" ops)
then [OPan [Str ",", Space]]
else [OPan $ B.toList $ B.text $ getOptionVal "sort-separator" ops]
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 = not (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
isByzantine c = not (isLetter c) ||
c <= '\x5FF' ||
(c >= '\x1e00' && c <= '\x1fff')
shortName = oPan' (unFormatted $ nondropping <+> family) (form "family")
longName g = if isSorting m
then 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
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" -> (nondropping <+> family, dropping)
"sort-only" -> (nondropping <+> family, dropping)
_ -> (family, dropping <+> nondropping)
in oPan' (unFormatted fam) (form "family") <> sortSep g par <> suffCom
else let fam = addAffixes (dropping <+> nondropping <+> family) "family" suff
gvn = oPan' (unFormatted g) (form "given")
in if all isByzantine $ stringify $ unFormatted family
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 -> State EvalState [Output]
formatTerm f fm p s = do
t <- getTerm p f s
return $ oStr' t fm
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 (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 = return . 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