{-# LANGUAGE PatternGuards #-} ----------------------------------------------------------------------------- -- | -- Module : Text.CSL.Eval.Date -- Copyright : (c) Andrea Rossato -- License : BSD-style (see LICENSE) -- -- Maintainer : Andrea Rossato -- Stability : unstable -- Portability : unportable -- -- The CSL implementation -- ----------------------------------------------------------------------------- module Text.CSL.Eval.Date where 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 -- the point of rmPrefix is to remove the blank space that otherwise -- gets added after the delimiter in a range: 24- 26. 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