{-# OPTIONS -fno-warn-orphans #-}
module Data.Time.Format.Parse.Instances
(
) where
#if MIN_VERSION_base(4,13,0)
import Control.Applicative ((<|>))
#else
import Control.Applicative ((<$>), (<*>), (<|>))
#endif
import Data.Char
import Data.Fixed
import Data.List (elemIndex,find)
import Data.Ratio
import Data.Time.Calendar.Types
import Data.Time.Calendar.CalendarDiffDays
import Data.Time.Calendar.Days
import Data.Time.Calendar.Gregorian
import Data.Time.Calendar.OrdinalDate
import Data.Time.Calendar.Month
import Data.Time.Calendar.Private (clipValid)
import Data.Time.Calendar.WeekDate
import Data.Time.Clock.Internal.DiffTime
import Data.Time.Clock.Internal.NominalDiffTime
import Data.Time.Clock.Internal.UTCTime
import Data.Time.Clock.Internal.UniversalTime
import Data.Time.Clock.POSIX
import Data.Time.Format.Locale
import Data.Time.Format.Parse.Class
import Data.Time.LocalTime.Internal.CalendarDiffTime
import Data.Time.LocalTime.Internal.LocalTime
import Data.Time.LocalTime.Internal.TimeOfDay
import Data.Time.LocalTime.Internal.TimeZone
import Data.Time.LocalTime.Internal.ZonedTime
import Data.Traversable
import Text.Read (readMaybe)
data DayComponent
= DCCentury Integer
| DCCenturyYear Integer
| DCYearMonth MonthOfYear
| DCMonthDay DayOfMonth
| DCYearDay DayOfYear
| DCWeekDay Int
| DCYearWeek WeekType
WeekOfYear
data WeekType
= ISOWeek
| SundayWeek
| MondayWeek
makeDayComponent :: TimeLocale -> Char -> String -> Maybe [DayComponent]
makeDayComponent l c x = let
ra :: (Read a) => Maybe a
ra = readMaybe x
zeroBasedListIndex :: [String] -> Maybe Int
zeroBasedListIndex ss = elemIndex (map toUpper x) $ fmap (map toUpper) ss
oneBasedListIndex :: [String] -> Maybe Int
oneBasedListIndex ss = do
index <- zeroBasedListIndex ss
return $ 1 + index
in case c of
'C' -> do
a <- ra
return [DCCentury a]
'f' -> do
a <- ra
return [DCCentury a]
'Y' -> do
a <- ra
return [DCCentury (a `div` 100), DCCenturyYear (a `mod` 100)]
'G' -> do
a <- ra
return [DCCentury (a `div` 100), DCCenturyYear (a `mod` 100)]
'y' -> do
a <- ra
return [DCCenturyYear a]
'g' -> do
a <- ra
return [DCCenturyYear a]
'B' -> do
a <- oneBasedListIndex $ fmap fst $ months l
return [DCYearMonth a]
'b' -> do
a <- oneBasedListIndex $ fmap snd $ months l
return [DCYearMonth a]
'm' -> do
raw <- ra
a <- clipValid 1 12 raw
return [DCYearMonth a]
'd' -> do
raw <- ra
a <- clipValid 1 31 raw
return [DCMonthDay a]
'e' -> do
raw <- ra
a <- clipValid 1 31 raw
return [DCMonthDay a]
'V' -> do
raw <- ra
a <- clipValid 1 53 raw
return [DCYearWeek ISOWeek a]
'U' -> do
raw <- ra
a <- clipValid 0 53 raw
return [DCYearWeek SundayWeek a]
'W' -> do
raw <- ra
a <- clipValid 0 53 raw
return [DCYearWeek MondayWeek a]
'u' -> do
raw <- ra
a <- clipValid 1 7 raw
return [DCWeekDay a]
'a' -> do
a' <- zeroBasedListIndex $ fmap snd $ wDays l
let
a =
if a' == 0
then 7
else a'
return [DCWeekDay a]
'A' -> do
a' <- zeroBasedListIndex $ fmap fst $ wDays l
let
a =
if a' == 0
then 7
else a'
return [DCWeekDay a]
'w' -> do
raw <- ra
a' <- clipValid 0 6 raw
let
a =
if a' == 0
then 7
else a'
return [DCWeekDay a]
'j' -> do
raw <- ra
a <- clipValid 1 366 raw
return [DCYearDay a]
_ -> return []
makeDayComponents :: TimeLocale -> [(Char,String)] -> Maybe [DayComponent]
makeDayComponents l pairs = do
components <- for pairs $ \(c, x) -> makeDayComponent l c x
return $ concat components
safeLast :: a -> [a] -> a
safeLast x xs = last (x : xs)
instance ParseTime Day where
substituteTimeSpecifier _ = timeSubstituteTimeSpecifier
parseTimeSpecifier _ = timeParseTimeSpecifier
buildTime l pairs = do
cs <- makeDayComponents l pairs
let
y = let
d = safeLast 70 [x | DCCenturyYear x <- cs]
c =
safeLast
(if d >= 69
then 19
else 20)
[x | DCCentury x <- cs]
in 100 * c + d
rest (DCYearMonth m:_) = let
d = safeLast 1 [x | DCMonthDay x <- cs]
in fromGregorianValid y m d
rest (DCYearDay d:_) = fromOrdinalDateValid y d
rest (DCYearWeek wt w:_) = let
d = safeLast 4 [x | DCWeekDay x <- cs]
in case wt of
ISOWeek -> fromWeekDateValid y w d
SundayWeek -> fromSundayStartWeekValid y w (d `mod` 7)
MondayWeek -> fromMondayStartWeekValid y w d
rest (_:xs) = rest xs
rest [] = rest [DCYearMonth 1]
rest cs
instance ParseTime Month where
substituteTimeSpecifier _ = timeSubstituteTimeSpecifier
parseTimeSpecifier _ = timeParseTimeSpecifier
buildTime l pairs = do
cs <- makeDayComponents l pairs
let
y = let
d = safeLast 70 [x | DCCenturyYear x <- cs]
c =
safeLast
(if d >= 69
then 19
else 20)
[x | DCCentury x <- cs]
in 100 * c + d
rest (DCYearMonth m:_) = fromYearMonthValid y m
rest (_:xs) = rest xs
rest [] = fromYearMonthValid y 1
rest cs
mfoldl :: (Monad m) => (a -> b -> m a) -> m a -> [b] -> m a
mfoldl f = let
mf ma b = do
a <- ma
f a b
in foldl mf
instance ParseTime TimeOfDay where
substituteTimeSpecifier _ = timeSubstituteTimeSpecifier
parseTimeSpecifier _ = timeParseTimeSpecifier
buildTime l = let
f t@(TimeOfDay h m s) (c, x) = let
ra :: (Read a) => Maybe a
ra = readMaybe x
getAmPm = let
upx = map toUpper x
(amStr, pmStr) = amPm l
in if upx == amStr
then Just $ TimeOfDay (h `mod` 12) m s
else if upx == pmStr
then Just $
TimeOfDay
(if h < 12
then h + 12
else h)
m
s
else Nothing
in case c of
'P' -> getAmPm
'p' -> getAmPm
'H' -> do
raw <- ra
a <- clipValid 0 23 raw
return $ TimeOfDay a m s
'I' -> do
raw <- ra
a <- clipValid 1 12 raw
return $ TimeOfDay a m s
'k' -> do
raw <- ra
a <- clipValid 0 23 raw
return $ TimeOfDay a m s
'l' -> do
raw <- ra
a <- clipValid 1 12 raw
return $ TimeOfDay a m s
'M' -> do
raw <- ra
a <- clipValid 0 59 raw
return $ TimeOfDay h a s
'S' -> do
raw <- ra
a <- clipValid 0 60 raw
return $ TimeOfDay h m (fromInteger a)
'q' -> do
ps <- (readMaybe $ take 12 $ rpad 12 '0' x) <|> return 0
return $ TimeOfDay h m (mkPico (floor s) ps)
'Q' ->
if null x
then Just t
else do
ps <- (readMaybe $ take 12 $ rpad 12 '0' x) <|> return 0
return $ TimeOfDay h m (mkPico (floor s) ps)
_ -> Just t
in mfoldl f (Just midnight)
rpad :: Int -> a -> [a] -> [a]
rpad n c xs = xs ++ replicate (n - length xs) c
mkPico :: Integer -> Integer -> Pico
mkPico i f = fromInteger i + fromRational (f % 1000000000000)
instance ParseTime LocalTime where
substituteTimeSpecifier _ = timeSubstituteTimeSpecifier
parseTimeSpecifier _ = timeParseTimeSpecifier
buildTime l xs = LocalTime <$> (buildTime l xs) <*> (buildTime l xs)
enumDiff :: (Enum a) => a -> a -> Int
enumDiff a b = (fromEnum a) - (fromEnum b)
getMilZoneHours :: Char -> Maybe Int
getMilZoneHours c
| c < 'A' = Nothing
getMilZoneHours c
| c <= 'I' = Just $ 1 + enumDiff c 'A'
getMilZoneHours 'J' = Nothing
getMilZoneHours c
| c <= 'M' = Just $ 10 + enumDiff c 'K'
getMilZoneHours c
| c <= 'Y' = Just $ (enumDiff 'N' c) - 1
getMilZoneHours 'Z' = Just 0
getMilZoneHours _ = Nothing
getMilZone :: Char -> Maybe TimeZone
getMilZone c = let
yc = toUpper c
in do
hours <- getMilZoneHours yc
return $ TimeZone (hours * 60) False [yc]
getKnownTimeZone :: TimeLocale -> String -> Maybe TimeZone
getKnownTimeZone locale x = find (\tz -> map toUpper x == timeZoneName tz) (knownTimeZones locale)
instance ParseTime TimeZone where
substituteTimeSpecifier _ = timeSubstituteTimeSpecifier
parseTimeSpecifier _ = timeParseTimeSpecifier
buildTime l = let
f :: Char -> String -> TimeZone -> Maybe TimeZone
f 'z' str (TimeZone _ dst name)
| Just offset <- readTzOffset str = Just $ TimeZone offset dst name
f 'z' _ _ = Nothing
f 'Z' str _
| Just offset <- readTzOffset str = Just $ TimeZone offset False ""
f 'Z' str _
| Just zone <- getKnownTimeZone l str = Just zone
f 'Z' "UTC" _ = Just utc
f 'Z' [c] _
| Just zone <- getMilZone c = Just zone
f 'Z' _ _ = Nothing
f _ _ tz = Just tz
in foldl (\mt (c, s) -> mt >>= f c s) (Just $ minutesToTimeZone 0)
readTzOffset :: String -> Maybe Int
readTzOffset str = let
getSign '+' = Just 1
getSign '-' = Just (-1)
getSign _ = Nothing
calc s h1 h2 m1 m2 = do
sign <- getSign s
h <- readMaybe [h1, h2]
m <- readMaybe [m1, m2]
return $ sign * (60 * h + m)
in case str of
(s:h1:h2:':':m1:m2:[]) -> calc s h1 h2 m1 m2
(s:h1:h2:m1:m2:[]) -> calc s h1 h2 m1 m2
_ -> Nothing
instance ParseTime ZonedTime where
substituteTimeSpecifier _ = timeSubstituteTimeSpecifier
parseTimeSpecifier _ = timeParseTimeSpecifier
buildTime l xs = let
f (ZonedTime (LocalTime _ tod) z) ('s', x) = do
a <- readMaybe x
let
s = fromInteger a
(_, ps) = properFraction (todSec tod) :: (Integer, Pico)
s' = s + fromRational (toRational ps)
return $ utcToZonedTime z (posixSecondsToUTCTime s')
f t _ = Just t
in mfoldl f (ZonedTime <$> (buildTime l xs) <*> (buildTime l xs)) xs
instance ParseTime UTCTime where
substituteTimeSpecifier _ = timeSubstituteTimeSpecifier
parseTimeSpecifier _ = timeParseTimeSpecifier
buildTime l xs = zonedTimeToUTC <$> buildTime l xs
instance ParseTime UniversalTime where
substituteTimeSpecifier _ = timeSubstituteTimeSpecifier
parseTimeSpecifier _ = timeParseTimeSpecifier
buildTime l xs = localTimeToUT1 0 <$> buildTime l xs
buildTimeMonths :: [(Char, String)] -> Maybe Integer
buildTimeMonths xs = do
tt <-
for xs $ \(c, s) ->
case c of
'y' -> fmap ((*) 12) $ readMaybe s
'b' -> readMaybe s
'B' -> readMaybe s
_ -> return 0
return $ sum tt
buildTimeDays :: [(Char, String)] -> Maybe Integer
buildTimeDays xs = do
tt <-
for xs $ \(c, s) ->
case c of
'w' -> fmap ((*) 7) $ readMaybe s
'd' -> readMaybe s
'D' -> readMaybe s
_ -> return 0
return $ sum tt
buildTimeSeconds :: [(Char, String)] -> Maybe Pico
buildTimeSeconds xs = do
tt <-
for xs $ \(c, s) -> let
readInt :: Integer -> Maybe Pico
readInt t = do
i <- readMaybe s
return $ fromInteger $ i * t
in case c of
'h' -> readInt 3600
'H' -> readInt 3600
'm' -> readInt 60
'M' -> readInt 60
's' -> readMaybe s
'S' -> readMaybe s
_ -> return 0
return $ sum tt
instance ParseTime NominalDiffTime where
parseTimeSpecifier _ = durationParseTimeSpecifier
buildTime _ xs = do
dd <- buildTimeDays xs
tt <- buildTimeSeconds xs
return $ (fromInteger dd * 86400) + realToFrac tt
instance ParseTime DiffTime where
parseTimeSpecifier _ = durationParseTimeSpecifier
buildTime _ xs = do
dd <- buildTimeDays xs
tt <- buildTimeSeconds xs
return $ (fromInteger dd * 86400) + realToFrac tt
instance ParseTime CalendarDiffDays where
parseTimeSpecifier _ = durationParseTimeSpecifier
buildTime _ xs = do
mm <- buildTimeMonths xs
dd <- buildTimeDays xs
return $ CalendarDiffDays mm dd
instance ParseTime CalendarDiffTime where
parseTimeSpecifier _ = durationParseTimeSpecifier
buildTime locale xs = do
mm <- buildTimeMonths xs
tt <- buildTime locale xs
return $ CalendarDiffTime mm tt