module Text.CSL.Eval
( evalLayout
, evalSorting
, last', split, trim
, 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 qualified Data.Map as M
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
evalLayout :: Layout -> EvalMode -> Bool -> [Locale] -> [MacroMap]
-> [Option] -> [Abbrev] -> Reference -> [Output]
evalLayout (Layout _ _ es) em b l m o a 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 [] a) [] em b False [] [] False [] [] []
evalSorting :: EvalMode -> [Locale] -> [MacroMap] -> [Option] ->
[Sort] -> [Abbrev] -> Reference -> [Sorting]
evalSorting m l ms opts ss as 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 as 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
| 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 $ substituteWith 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
substituteWith e = head <$> gets (names . env) >>= \(Names _ ns fm d _) -> do
case e of
Names rs [Name NotSet _ [] [] []] fm' d' []
-> evalElement $ Names rs ns (mergeFM fm' fm) (d' `betterThen` d) []
_ -> evalElement e
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 (map toLower 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
"url" -> getStringVar "url" >>= \k ->
if null k then return [] else return [OUrl k fm]
_ -> gets (env >>> options &&& abbrevs) >>= \(opts,as) ->
getVar [] (getFormattedValue opts as f fm s) 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"
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] -> [Abbrev] -> Form -> Formatting -> String -> Value -> [Output]
getFormattedValue o as f fm s val
| Just v <- fromValue val :: Maybe String = rtfParser fm . getAbbr $ value 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
value = if stripPeriods fm then filter (/= '.') else id
getAbbr v = if f /= Short then v else
case lookup "default" as of
Nothing -> v
Just x -> case lookup s x of
Nothing -> v
Just x' -> case M.lookup v x' of
Nothing -> v
Just x'' -> x''
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 :: Form -> Formatting -> State EvalState [Output]
formatTitle f fm
| Short <- f = getIt "title-short" "title"
| otherwise = getIt "title" "title-short"
where
getIt x fb = do
o <- gets (options . env)
a <- gets (abbrevs . env)
r <- getVar [] (getFormattedValue o a f fm x) x
case r of
[] -> getVar [] (getFormattedValue o a f fm x) 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 = break (== '-') >>> trim *** trim . dropWhile (== '-')
pages = map splitRange . split (== ',') $ p
format a b = if b /= []
then flip Output emptyFormatting [ OStr a emptyFormatting, OPan [Str "\x2013"]
, 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
_ -> map (uncurry format ) pages
return [flip OLoc 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''