{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE PatternGuards #-}
module Text.CSL.Eval.Date where
import Prelude
import qualified Control.Exception as E
import Control.Monad.State
import Data.List
import Data.List.Split
import Data.Maybe (fromMaybe, isNothing)
import Text.CSL.Exception
import Text.CSL.Eval.Common
import Text.CSL.Eval.Output
import Text.CSL.Style
import Text.CSL.Reference
import Text.CSL.Util ( toRead, last' )
import Text.Pandoc.Definition ( Inline (Str) )
import Text.Printf (printf)
evalDate :: Element -> State EvalState [Output]
evalDate (Date s f fm dl dp dp') = do
tm <- gets $ terms . env
k <- getStringVar "ref-id"
em <- gets mode
let updateFM (Formatting aa ab ac ad ae af ag ah ai aj ak al am an ahl)
(Formatting _ _ bc bd be bf bg bh _ bj bk _ _ _ _) =
Formatting aa ab (updateS ac bc)
(updateS ad bd)
(updateS ae be)
(updateS af bf)
(updateS ag bg)
(updateS ah bh)
ai
(updateS aj bj)
(if bk /= ak then bk else ak)
al am an ahl
updateS a b = if b /= a && b /= [] then b else a
case f of
NoFormDate -> outputList fm dl .
concatMap (formatDate em k tm dp) <$> mapM getDateVar s
_ -> do Date _ _ lfm ldl ldp _ <- getDate f
let go dps = return . outputList (updateFM fm lfm) (if ldl /= [] then ldl else dl) .
concatMap (formatDate em k tm dps)
update l x@(DatePart a b c d) =
case filter ((==) a . dpName) l of
(DatePart _ b' c' d':_) -> DatePart a (updateS b b')
(updateS c c')
(updateFM d d')
_ -> x
updateDP = map (update dp) ldp
date = mapM getDateVar s
case dp' of
"year-month" -> go (filter ((/=) "day" . dpName) updateDP) =<< date
"year" -> go (filter ((==) "year" . dpName) updateDP) =<< date
_ -> go updateDP =<< date
evalDate _ = return []
getDate :: DateForm -> State EvalState Element
getDate f = do
x <- filter (\(Date _ df _ _ _ _) -> df == f) <$> gets (dates . env)
case x of
[x'] -> return x'
_ -> return $ Date [] NoFormDate emptyFormatting [] [] []
formatDate :: EvalMode -> String -> [CslTerm] -> [DatePart] -> [RefDate] -> [Output]
formatDate em k tm dp date
| [d] <- date = concatMap (formatDatePart d) dp
| (a:b:_) <- date = addODate . concat $ doRange a b
| otherwise = []
where
addODate [] = []
addODate xs = [ODate xs]
splitDate a b = case split (onSublist $ diff a b dp) dp of
[x,y,z] -> (x,y,z)
_ -> E.throw ErrorSplittingDate
doRange a b = let (x,y,z) = splitDate a b in
map (formatDatePart a) x ++
withDelim y
(map (formatDatePart a) (rmSuffix y))
(map (formatDatePart b) (rmPrefix y))
++
map (formatDatePart b) z
rmPrefix (dp':rest) = dp'{ dpFormatting =
(dpFormatting dp') { prefix = "" } } : rest
rmPrefix [] = []
rmSuffix (dp':rest)
| null rest = [dp'{ dpFormatting =
(dpFormatting dp') { suffix = "" } }]
| otherwise = dp':rmSuffix rest
rmSuffix [] = []
diff (RefDate ya ma sa da _ _)
(RefDate yb mb sb db _ _)
= filter (\x -> dpName x `elem` ns)
where ns =
case () of
_ | ya /= yb -> ["year","month","day"]
| ma /= mb || sa /= sb ->
if isNothing da && isNothing db
then ["month"]
else ["month","day"]
| da /= db -> ["day"]
| otherwise -> ["year","month","day"]
term f t = let f' = if f `elem` ["verb", "short", "verb-short", "symbol"]
then read $ toRead f
else Long
in maybe [] termPlural $ findTerm t f' tm
formatDatePart (RefDate y m e d o _) (DatePart n f _ fm)
| "year" <- n, Just y' <- y = return $ OYear (formatYear f y') k fm
| "month" <- n, Just m' <- m = output fm (formatMonth f fm m')
| "month" <- n, Just e' <- e =
case e' of
RawSeason s -> [OStr s fm]
_ -> output fm $ term f (printf "season-%02d"
$ fromMaybe 0 $ seasonToInt e')
| "day" <- n, Just d' <- d = output fm (formatDay f m d')
| "year" <- n, o /= mempty = output fm (unLiteral o)
| otherwise = []
withDelim xs o1 o2
| null (concat o1 ++ concat o2) = []
| otherwise = o1 ++ (case dpRangeDelim <$> last' xs of
["-"] -> [[OPan [Str "\x2013"]]]
[s] -> [[OPan [Str s]]]
_ -> []) ++ o2
formatYear f y
| "short" <- f = printf "%02d" y
| isSorting em
, y < 0 = printf "-%04d" (abs y)
| isSorting em = printf "%04d" y
| y < 0 = printf "%d" (abs y) ++ term [] "bc"
| y < 1000
, y > 0 = printf "%d" y ++ term [] "ad"
| y == 0 = ""
| otherwise = printf "%d" y
formatMonth f fm m
| "short" <- f = getMonth $ period . termPlural
| "long" <- f = getMonth termPlural
| "numeric" <- f = printf "%d" m
| otherwise = printf "%02d" m
where
period = if stripPeriods fm then filter (/= '.') else id
getMonth g = maybe (show m) g $ findTerm ("month-" ++ printf "%02d" m) (read $ toRead f) tm
formatDay f m d
| "numeric-leading-zeros" <- f = printf "%02d" d
| "ordinal" <- f = ordinal tm ("month-" ++ maybe "0" (printf "%02d") m) d
| otherwise = printf "%d" d
ordinal :: [CslTerm] -> String -> Int -> String
ordinal ts v s
| s < 10 = let a = termPlural (getWith1 (show s)) in
if a == [] then setOrd (term []) else show s ++ a
| s < 100 = let a = termPlural (getWith2 (show s))
b = getWith1 [last (show s)] in
if a /= []
then show s ++ a
else if termPlural b == [] || (termMatch b /= [] && termMatch b /= "last-digit")
then setOrd (term []) else setOrd b
| otherwise = let a = getWith2 last2
b = getWith1 [last (show s)] in
if termPlural a /= [] && termMatch a /= "whole-number"
then setOrd a
else if null (termPlural b) ||
(termMatch b /= [] &&
termMatch b /= "last-digit")
then setOrd (term [])
else setOrd b
where
setOrd = (++) (show s) . termPlural
getWith1 = term . (++) "-0"
getWith2 = term . (++) "-"
last2 = reverse . take 2 . reverse $ show s
term t = getOrdinal v ("ordinal" ++ t) ts
longOrdinal :: [CslTerm] -> String -> Int -> String
longOrdinal ts v s
| s > 10 ||
s == 0 = ordinal ts v s
| otherwise = case s `mod` 10 of
1 -> term "01"
2 -> term "02"
3 -> term "03"
4 -> term "04"
5 -> term "05"
6 -> term "06"
7 -> term "07"
8 -> term "08"
9 -> term "09"
_ -> term "10"
where
term t = termPlural $ getOrdinal v ("long-ordinal-" ++ t) ts
getOrdinal :: String -> String -> [CslTerm] -> CslTerm
getOrdinal v s ts
= fromMaybe newTerm $ findTerm' s Long gender ts `mplus`
findTerm' s Long Neuter ts
where
gender = if v `elem` numericVars || "month" `isPrefixOf` v
then maybe Neuter termGender $ findTerm v Long ts
else Neuter