module Text.CSL.Eval
( evalLayout
, evalSorting
, module Text.CSL.Eval.Common
, module Text.CSL.Eval.Output
) where
import Control.Arrow
import Control.Monad.State
import qualified Control.Exception as E
import Data.Monoid (Any(..))
import Data.Char ( toLower, isDigit, isLetter )
import Data.Maybe
import Data.String ( fromString )
import Text.Pandoc.Definition (Inline(Str, Link), nullAttr)
import Text.Pandoc.Walk (walk)
import Text.Pandoc.Shared (stringify)
import qualified Data.Text as T
import Text.CSL.Exception
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 hiding (Any)
import Text.CSL.Util ( readNum, last', proc, proc', query, betterThan,
safeRead, isRange )
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
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]
| 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 = return . 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
| 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
| 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 _) -> do
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
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"] -> not $ any (== "1") nums
["number-of-pages"] -> not $ any (== "1") 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 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 getAbbreviation as v val == [] then val else getAbbreviation as v val
return (isNumericString 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 = 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 = maybe (unFormatted v) (unFormatted . 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 . maybe v id . getAbbr $ value v
| Just v <- fromValue val :: Maybe Literal = (:[]) . flip OStr fm . maybe (unLiteral v) id . 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) $ return . (:[]) . flip OStr fm =<< getTitleShort s
| otherwise = getIt s
where
try g h = g >>= \r -> if 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 gets (terms . env) >>=
return . output fm . flip process (getAbbr as n)
else return . output fm . getAbbr as $ n
where
getAbbr as = if 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 -> ordinal tm v
LongOrdinal -> longOrdinal tm v
Roman -> if readNum n < 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"]
]
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)
, not (c `elem` "&-.,\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 [flip OLoc fm $ [OStr (process pages) emptyFormatting]]
expandedRange :: (String, String) -> (String, String)
expandedRange (sa, []) = (sa,[])
expandedRange (sa, sb)
| length sb < length sa =
case (safeRead sa, safeRead sb) of
(Just (_ :: Int), Just (_ :: Int)) ->
(sa, take (length sa length sb) sa ++ sb)
_ -> (sa, sb)
| otherwise = (sa, sb)
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)
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)