module Text.CSL.Eval.Date where
import Control.Applicative ( (<$>) )
import Control.Monad.State
import Text.CSL.Eval.Common
import Text.CSL.Eval.Output
import Text.CSL.Parser ( toRead )
import Text.CSL.Reference
import Text.CSL.Style
import Text.Pandoc.Definition ( Inline (Str,EnDash) )
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)
(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
updateS a b = if b /= a && b /= [] then b else a
case f of
NoFormDate -> return . 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 -> [TermMap] -> [DatePart] -> [RefDate] -> [Output]
formatDate em k tm dp date
| [d] <- date = concatMap (formatDatePart False d) dp
| (a:b:_) <- date = concat $ (start a b ++ end a b ++ coda b)
| otherwise = []
where
start a b = map (formatDatePart False a) . init . diff a b $ dp
end a b = map (formatDatePart True a) . return . last . diff a b $ dp
coda b = map (formatDatePart False b) dp
diff a b = filter (flip elem (diffDate a b) . dpName)
diffDate (RefDate ya ma _ da _ _)
(RefDate yb mb _ db _ _) = case () of
_ | ya /= yb -> ["year","month","day"]
| ma /= mb -> ["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 [] fst $ lookup (t, f') tm
addZero n = if length n == 1 then '0' : n else n
addZeros = reverse . take 5 . flip (++) (repeat '0') . reverse
formatDatePart False (RefDate y m e d _ _) (DatePart n f _ fm)
| "year" <- n, y /= [] = return $ OYear (formatYear f y) k fm
| "month" <- n, m /= [] = output fm (formatMonth f m)
| "day" <- n, d /= [] = output fm (formatDay f d)
| "month" <- n, m == []
, e /= [] = output fm $ term f ("season-0" ++ e)
formatDatePart True (RefDate y m e d _ _) (DatePart n f rd fm)
| "year" <- n, y /= [] = OYear (formatYear f y) k (fm {suffix = []}) : formatDelim
| "month" <- n, m /= [] = output (fm {suffix = []}) (formatMonth f m) ++ formatDelim
| "day" <- n, d /= [] = output (fm {suffix = []}) (formatDay f d) ++ formatDelim
| "month" <- n, m == []
, e /= [] = output (fm {suffix = []}) $ term f ("season-0" ++ e)
where
formatDelim = if rd == "-" then [OPan [EnDash]] else [OPan [Str rd]]
formatDatePart _ (RefDate _ _ _ _ o _) (DatePart n _ _ fm)
| "year" <- n, o /= [] = output fm o
| otherwise = []
formatYear f y
| "short" <- f = drop 2 y
| isSorting em
, iy < 0 = '-' : addZeros (tail y)
| isSorting em = addZeros y
| iy < 0 = show (abs iy) ++ term [] "bc"
| length y < 4
, iy /= 0 = y ++ term [] "ad"
| iy == 0 = []
| otherwise = y
where
iy = readNum y
formatMonth f m
| "short" <- f = getMonth 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 = ordinal tm d
| otherwise = d
ordinal :: [TermMap] -> String -> String
ordinal _ [] = []
ordinal tm s
= case last s of
'1' -> s ++ term "1"
'2' -> s ++ term "2"
'3' -> s ++ term "3"
_ -> s ++ term "4"
where
term t = maybe [] fst $ lookup ("ordinal-0" ++ t, Long) tm
longOrdinal :: [TermMap] -> String -> String
longOrdinal _ [] = []
longOrdinal tm s
| num > 10 ||
num == 0 = ordinal tm s
| otherwise = case last s 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
num = readNum s
term t = maybe [] fst $ lookup ("long-ordinal-" ++ t, Long) tm