{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
module Text.CSL.Eval.Date where
import Prelude
import qualified Control.Exception as E
import Control.Monad.State
import Data.List.Split
import Data.Maybe (fromMaybe, isNothing)
import Data.Text (Text)
import qualified Data.Text as T
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 res <- getDate f
case res of
Date _ _ lfm ldl ldp _ -> do
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
_ -> return []
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 -> Text -> [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 . T.unpack $ 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 . T.pack $
(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 = T.pack $ printf "%02d" y
| isSorting em
, y < 0 = T.pack $ printf "-%04d" (abs y)
| isSorting em = T.pack $ printf "%04d" y
| y < 0 = (T.pack $ printf "%d" (abs y)) <> term "" "bc"
| y < 1000
, y > 0 = (T.pack $ printf "%d" y) <> term "" "ad"
| y == 0 = ""
| otherwise = T.pack $ printf "%d" y
formatMonth f fm m
| "short" <- f = getMonth $ period . termPlural
| "long" <- f = getMonth termPlural
| "numeric" <- f = T.pack $ printf "%d" m
| otherwise = T.pack $ printf "%02d" m
where
period = if stripPeriods fm then T.filter (/= '.') else id
getMonth g = case findTerm ("month-" <> T.pack (printf "%02d" m))
(read . T.unpack $ toRead f) tm of
Nothing -> T.pack (show m)
Just x -> g x
formatDay f m d
| "numeric-leading-zeros" <- f = T.pack $ printf "%02d" d
| "ordinal" <- f = ordinal tm ("month-" <> maybe "0" (T.pack . printf "%02d") m) d
| otherwise = T.pack $ printf "%d" d
ordinal :: [CslTerm] -> Text -> Int -> Text
ordinal ts v s
| s < 10 = let a = termPlural (getWith1 (show s)) in
if T.null a
then setOrd (term "")
else T.pack (show s) <> a
| s < 100 = let a = termPlural (getWith2 (show s))
b = getWith1 [last (show s)] in
if not (T.null a)
then T.pack (show s) <> a
else if T.null (termPlural b) ||
(not (T.null (termMatch b)) &&
termMatch b /= "last-digit")
then setOrd (term "")
else setOrd b
| otherwise = let a = getWith2 last2
b = getWith1 [last (show s)] in
if not (T.null (termPlural a)) &&
termMatch a /= "whole-number"
then setOrd a
else if T.null (termPlural b) ||
(not (T.null (termMatch b)) &&
termMatch b /= "last-digit")
then setOrd (term "")
else setOrd b
where
setOrd = T.append (T.pack $ show s) . termPlural
getWith1 = term . T.append "-0" . T.pack
getWith2 = term . T.append "-" . T.pack
last2 = reverse . take 2 . reverse $ show s
term t = getOrdinal v ("ordinal" <> t) ts
longOrdinal :: [CslTerm] -> Text -> Int -> Text
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 :: Text -> Text -> [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" `T.isPrefixOf` v
then maybe Neuter termGender $ findTerm v Long ts
else Neuter