module Text.CSL.Eval where
import Control.Arrow ( (&&&) )
import Control.Applicative ( (<$>) )
import Control.Monad.State
import Data.Char ( toLower )
import Data.List ( elemIndex )
import Data.Maybe
import Text.CSL.Output.Plain
import Text.CSL.Parser ( toRead )
import Text.CSL.Reference
import Text.CSL.Style
data EvalState
= EvalState
{ ref :: ReferenceMap
, pos :: String
, env :: Environment
, debug :: [String]
, disamb :: Bool
, consume :: Bool
}
data Environment
= Env
{ terms :: [TermMap]
, macros :: [MacroMap]
, options :: [Option]
, name :: [Name]
} deriving ( Show )
evalLayout :: Layout -> Bool -> [TermMap] -> [MacroMap]
-> [Option] -> String -> Reference -> [Output]
evalLayout (Layout _ _ es) b t m o p r = evalState job initSt
where
job = concatMapM evalElement es
initSt = EvalState (mkRefMap r) p (Env t m o []) [] b False
evalSorting :: [TermMap] -> [MacroMap] -> [Option] -> [Sort] -> Reference -> [Sorting]
evalSorting ts ms opts ss r
= map (format . sorting) ss
where
render = renderPlainStrict . map formatOutput . proc addYearSuffix
format (s,e) = applaySort s . render $ eval e
eval e = evalLayout (Layout emptyFormatting [] [e]) False ts ms opts [] r
applaySort c s
| Ascending {} <- c = Ascending s
| otherwise = Descending s
sorting s = case s of
SortVariable str o -> (o, Variable [str] Long emptyFormatting [])
SortMacro str o -> (o, Macro str Long 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 . output fm $ s
| PointLocator s _ fm <- el = return . output fm =<< getStringVar s
| Number s _ fm <- el = return . output 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 s fm d dp <- el = return . outputList fm d =<< evalDate dp s
| Label s f fm i p <- el = formatLabel f fm i p s
| Term s f fm i p <- el = formatLabel f fm i p s
| Names s n fm d sub <- el = ifEmpty (evalNames s n d)
(withName (getName n) $ evalElements sub)
(appendOutput fm)
| Substitute (e:els) <- el = ifEmpty (consuming $ evalElement e)
(getFirst els) id
| ShortNames s fm d <- el = head <$> gets (name . env) >>= \(Name f _ nf d') ->
evalNames s [Name f fm nf d'] d
| otherwise = return []
where
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)
withName n f = modify (\s -> s { env = (env s)
{name = n : name (env s)}}) >> f >>= \r ->
modify (\s -> s { env = (env s)
{name = tail $ name (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)
getName = head . filter isName
getVariable f fm s = getStringVar "year-suffix" >>= \su ->
getVar [] (getFormattedValue su f fm) 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 isDate 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 = isVarSet v
chkDate v = isVarSet v
chkPosition s = gets pos >>= return . compPosition s
chkDisambiguate s = gets disamb >>= return . (==) (formatVariable s) . map toLower . show
chkLocator v = getLocVar v >>= 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" then True else False
| otherwise = isIbid b
evalNames :: [String] -> [Name] -> String -> State EvalState [Output]
evalNames ns nl d
| (s:xs) <- ns = do ags <- getAgents s
k <- getStringVar "cite-key"
p <- gets pos
ops <- gets (options . env)
let (b ,l ) = isEtAl ops p ags
(ea,as) = if b
then (,) True $ take l ags
else (,) False $ ags
r <- if s == "author" && ags /= [] && p == "subsequent" &&
isOptionSet "subsequent-author-substitute" ops
then return $ output emptyFormatting $
getOptionVal "subsequent-author-substitute" ops
else do res <- agents ea s as
if res /= []
then return . return . OContrib k res =<<
mapM (rest ags ea s) [1 + l .. length ags]
else return []
r' <- evalNames xs nl d
return $ if r /= [] && r' /= []
then r ++ [ODel d] ++ r'
else cleanOutput (r ++ r')
| otherwise = return []
where
agents ea s l = concatMapM (formatNames ea s l) nl
rest l ea s n = agents (if n == length l then False else ea) s $ take n l
etAlMin s = read . getOptionVal s
isEtAl o p ags
| p /= "first"
, isOptionSet "et-al-subsequent-min" o
, isOptionSet "et-al-subsequent-use-first" o
, len <- etAlMin "et-al-subsequent-min" o
, length ags > 1
, length ags >= len = (,) True $ etAlMin "et-al-subsequent-use-first" o
| isOptionSet "et-al-min" o
, isOptionSet "et-al-use-first" o
, len <- etAlMin "et-al-min" o
, length ags > 1
, length ags >= len = (,) True $ etAlMin "et-al-use-first" o
| otherwise = (False, 0)
evalDate :: [DatePart] -> [String] -> State EvalState [Output]
evalDate dp s = do tm <- gets $ filter ((==) "month-" . take 6 . fst . fst) . terms . env
sf <- getStringVar "year-suffix"
concatMap (formatDate sf tm dp) <$> mapM getDateVar s
getTerm :: Bool -> Form -> String -> State EvalState String
getTerm b f s = maybe [] g . lookup (s,f) <$> gets (terms . env)
where g = if b then snd else fst
getStringVar :: String -> State EvalState String
getStringVar
= getVar [] getStringValue
getDateVar :: String -> State EvalState [RefDate]
getDateVar
= getVar [] getDateValue
where
getDateValue val
| Just v <- fromValue val = v
| otherwise = []
getLocVar :: String -> State EvalState (String,String)
getLocVar s
= (show &&& locString) <$> getVar NoneLoc getLocValue s
where
getLocValue val
| Just v <- fromValue val = v
| otherwise = NoneLoc
getVar :: a -> (Value -> a) -> String -> State EvalState a
getVar a f s
= withRefMap $ maybe a f . lookup (formatVariable s)
getAgents :: String -> State EvalState [Agent]
getAgents s
= do
mv <- withRefMap (lookup s)
case mv of
Just v -> case fromValue v of
Just x -> consumeVariable s >> return x
_ -> return []
_ -> return []
getFormattedValue :: String -> Form -> Formatting -> Value -> [Output]
getFormattedValue s f fm val
| Just v <- fromValue val :: Maybe String = output fm v
| Just v <- fromValue val :: Maybe Locator = output fm (locString 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 s [] defaultDate v
| Just v <- fromValue val :: Maybe [Agent] = concatMap (formatName True f fm defaultNameFormatting) v
| otherwise = []
getStringValue :: Value -> String
getStringValue val
| Just v <- fromValue val = v
| otherwise = []
getOptionVal :: String -> [Option] -> String
getOptionVal s = fromMaybe [] . lookup s
isOptionSet :: String -> [Option] -> Bool
isOptionSet s = maybe False (not . null) . lookup s
isVarSet :: String -> State EvalState Bool
isVarSet = getVar False isValueSet
withRefMap :: (ReferenceMap -> a) -> State EvalState a
withRefMap f = return . f =<< gets ref
formatNames :: Bool -> String -> [Agent] -> Name -> State EvalState [Output]
formatNames et s as n
| Name f fm nf d <- n = return . delim nf d =<< (++) (names f fm nf) <$> et_al fm
| NameLabel f fm i p <- n = when' (isVarSet s) $ formatLabel f fm i (isPlural p $ length as) s
| otherwise = return []
where
et_al fm = if not et then return [] else return . output fm =<< getTerm False Long "et-al"
names f fm nf
| "first" <- nameAsSortOrder nf, (a:xs) <- as = formatName True f fm nf a ++
concatMap (formatName False f fm nf) xs
| "all" <- nameAsSortOrder nf = concatMap (formatName True f fm nf) as
| otherwise = concatMap (formatName False f fm nf) as
delim nf d x
| True <- et
, length x > 1 = addDelim d x
| "always" <- delimiterPrecedesLast nf
, length x == 2 = addDelim d (init x) ++ ODel (d <> andStr nf) : [last x]
| length x == 2 = addDelim d (init x) ++ ODel ( andStr nf) : [last x]
| length x > 2 = addDelim d (init x) ++ ODel (d <> andStr nf) : [last x]
| otherwise = addDelim d x
andStr nf
| "text" <- andConnector nf = " and "
| "symbol" <- andConnector nf = " & "
| otherwise = []
isPlural p = (&&) p . (<) 1
formatName :: Bool -> Form -> Formatting -> NameFormatting -> Agent -> [Output]
formatName b f fm nf n
| Person {} <- n
, Short <- f = return $ OName short rest fm
| Person {} <- n = return $ OName (long given') [long given] fm
| Entity s <- n = output fm s
| otherwise = []
where
rest = [ family $ concatMap addPnt (givenName n)
, long given]
addSpace = flip (++) (if b then [] else " ")
addPnt x = if x /= [] then head x : ". " else []
format x = procList x initia
initia x = if initializeWith nf /= []
then head x : initializeWith nf
else addSpace x
long g = if b
then family [] ++ sortSeparator nf ++ g
else family g
short = family []
family x = namePrefix n <+> (x ++ articular n <+> familyName n <+> nameSuffix n)
given' = concatMap format (givenName n)
given = addSpace $ concat (givenName n)
formatLabel :: Form -> Formatting -> Bool -> Bool -> String -> State EvalState [Output]
formatLabel f fm i p s
| "locator" <- s = when' (isVarSet s) $ do
(l,v) <- getLocVar s
format l ('-' `elem` v)
| "page" <- s = when' (isVarSet s) $ do
v <- getStringVar s
format s ('-' `elem` v)
| otherwise = format s p
where
format t b = return . output fm =<< flip (++) period <$> getTerm (b && p) f t
period = if i then "." else []
formatDate :: String -> [TermMap] -> [DatePart] -> [RefDate] -> [Output]
formatDate s tm dp date
| [d] <- date = concatMap (formatDatePart d) dp
| otherwise = []
where
addZero n = if length n == 1 then '0' : n else n
formatDatePart (RefDate y m d o) (DatePart n f fm)
| "year" <- n, y /= 0 = return $ OYear (formatYear f $ show y) s fm
| "month" <- n, m /= 0 = output fm (formatMonth f $ show m)
| "day" <- n, d /= 0 = output fm (formatDay f $ show d)
| "other" <- n, o /= [] = output fm o
| otherwise = []
formatYear f y
| "short" <- f = drop 2 y
| otherwise = y
formatMonth f m
| "short" <- f = getMonth $ flip (++) "." . fst
| "long" <- f = getMonth fst
| "numeric" <- f = m
| otherwise = addZero m
where
getMonth g = maybe m g $ lookup ("month-" ++ addZero m, read $ toRead f) tm
formatDay f d
| "numeric-leading-zeros" <- f = addZero d
| "ordinal" <- f = d ++ ordinal
| otherwise = d
where
ordinal = case last d of
'1' -> "st"
'2' -> "nd"
'3' -> "rd"
_ -> "th"
output :: Formatting -> String -> [Output]
output fm s = if s /= "" then [OStr s fm] else []
appendOutput :: Formatting -> [Output] -> [Output]
appendOutput fm xs = if xs /= [] then [Output xs fm] else []
outputList :: Formatting -> Delimiter -> [Output] -> [Output]
outputList fm d = appendOutput fm . addDelim d . cleanOutput
cleanOutput :: [Output] -> [Output]
cleanOutput = filter isNotEmpty
where
isNotEmpty (OStr "" _) = False
isNotEmpty _ = True
addDelim :: String -> [Output] -> [Output]
addDelim d = foldr (\x xs -> if length xs < 1 then x : xs else x : ODel d : xs) []
consumeVariable :: String -> State EvalState ()
consumeVariable s
= do b <- gets consume
when b $ modify $ \st -> st { ref = f (ref st) }
where f rm = case elemIndex (formatVariable s) (map fst rm) of
Just i -> take i rm ++ [(formatVariable s,Value Empty)] ++ drop (i + 1) rm
Nothing -> rm
consuming :: State EvalState a -> State EvalState a
consuming f = setConsume >> f >>= \a -> unsetConsume >> return a
where setConsume = modify $ \s -> s {consume = True }
unsetConsume = modify $ \s -> s {consume = False}
when' :: Monad m => m Bool -> m [a] -> m [a]
when' p f = whenElse p f (return [])
whenElse :: Monad m => m Bool -> m a -> m a -> m a
whenElse b f g = b >>= \ bool -> if bool then f else g
concatMapM :: (Monad m, Functor m, Eq b) => (a -> m [b]) -> [a] -> m [b]
concatMapM f l = concat . filter (/=[]) <$> mapM f l
formatVariable :: String -> String
formatVariable = foldr f []
where f x xs = if x == '_' then '-' : xs else toLower x : xs
head' :: [a] -> [a]
head' = foldr (\x _ -> [x]) []
trace :: String -> State EvalState ()
trace d = modify $ \s -> s { debug = d : debug s }