{-# OPTIONS -fno-warn-orphans #-}
module Data.Time.Format.Parse.Instances() where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>),(<*>))
#endif
import Data.Char
import Data.Fixed
import Data.List
import Data.Ratio
import Data.Traversable
import Text.Read(readMaybe)
import Data.Time.Clock.Internal.DiffTime
import Data.Time.Clock.Internal.NominalDiffTime
import Data.Time.Clock.Internal.UniversalTime
import Data.Time.Clock.POSIX
import Data.Time.Clock.Internal.UTCTime
import Data.Time.Calendar.Days
import Data.Time.Calendar.Gregorian
import Data.Time.Calendar.CalendarDiffDays
import Data.Time.Calendar.OrdinalDate
import Data.Time.Calendar.WeekDate
import Data.Time.Calendar.Private(clipValid)
import Data.Time.LocalTime.Internal.CalendarDiffTime
import Data.Time.LocalTime.Internal.TimeZone
import Data.Time.LocalTime.Internal.TimeOfDay
import Data.Time.LocalTime.Internal.LocalTime
import Data.Time.LocalTime.Internal.ZonedTime
import Data.Time.Format.Locale
import Data.Time.Format.Parse.Class
data DayComponent = Century Integer
| CenturyYear Integer
| YearMonth Int
| MonthDay Int
| YearDay Int
| WeekDay Int
| YearWeek WeekType Int
data WeekType = ISOWeek | SundayWeek | MondayWeek
instance ParseTime Day where
substituteTimeSpecifier _ = timeSubstituteTimeSpecifier
parseTimeSpecifier _ = timeParseTimeSpecifier
buildTime l = let
f :: Char -> String -> Maybe [DayComponent]
f 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 [Century a]
'f' -> do
a <- ra
return [Century a]
'Y' -> do
a <- ra
return [Century (a `div` 100), CenturyYear (a `mod` 100)]
'G' -> do
a <- ra
return [Century (a `div` 100), CenturyYear (a `mod` 100)]
'y' -> do
a <- ra
return [CenturyYear a]
'g' -> do
a <- ra
return [CenturyYear a]
'B' -> do
a <- oneBasedListIndex $ fmap fst $ months l
return [YearMonth a]
'b' -> do
a <- oneBasedListIndex $ fmap snd $ months l
return [YearMonth a]
'm' -> do
raw <- ra
a <- clipValid 1 12 raw
return [YearMonth a]
'd' -> do
raw <- ra
a <- clipValid 1 31 raw
return [MonthDay a]
'e' -> do
raw <- ra
a <- clipValid 1 31 raw
return [MonthDay a]
'V' -> do
raw <- ra
a <- clipValid 1 53 raw
return [YearWeek ISOWeek a]
'U' -> do
raw <- ra
a <- clipValid 0 53 raw
return [YearWeek SundayWeek a]
'W' -> do
raw <- ra
a <- clipValid 0 53 raw
return [YearWeek MondayWeek a]
'u' -> do
raw <- ra
a <- clipValid 1 7 raw
return [WeekDay a]
'a' -> do
a' <- zeroBasedListIndex $ fmap snd $ wDays l
let a = if a' == 0 then 7 else a'
return [WeekDay a]
'A' -> do
a' <- zeroBasedListIndex $ fmap fst $ wDays l
let a = if a' == 0 then 7 else a'
return [WeekDay a]
'w' -> do
raw <- ra
a' <- clipValid 0 6 raw
let a = if a' == 0 then 7 else a'
return [WeekDay a]
'j' -> do
raw <- ra
a <- clipValid 1 366 raw
return [YearDay a]
_ -> return []
buildDay :: [DayComponent] -> Maybe Day
buildDay cs = let
safeLast x xs = last (x:xs)
y = let
d = safeLast 70 [x | CenturyYear x <- cs]
c = safeLast (if d >= 69 then 19 else 20) [x | Century x <- cs]
in 100 * c + d
rest (YearMonth m:_) = let
d = safeLast 1 [x | MonthDay x <- cs]
in fromGregorianValid y m d
rest (YearDay d:_) = fromOrdinalDateValid y d
rest (YearWeek wt w:_) = let
d = safeLast 4 [x | WeekDay 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 [YearMonth 1]
in rest cs
in \pairs -> do
components <- for pairs $ \(c,x) -> f c x
buildDay $ concat components
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
a <- ra
return $ TimeOfDay h m (mkPico (floor s) a)
'Q' -> if null x then Just t else do
ps <- readMaybe $ take 12 $ rpad 12 '0' $ drop 1 x
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