{-# LANGUAGE OverloadedStrings #-}
module Data.IMF.DateTime
( dateTime
) where
import Control.Applicative ((<|>), optional)
import Control.Monad (guard)
import Data.Functor (($>))
import Data.Attoparsec.ByteString as A
import Data.Attoparsec.ByteString.Char8 (char8, isDigit_w8)
import qualified Data.ByteString as B
import qualified Data.Time
import Data.Time
( Day, DayOfWeek(..), LocalTime(LocalTime), TimeOfDay, TimeZone(TimeZone)
, ZonedTime(ZonedTime), fromGregorianValid, makeTimeOfDayValid
, minutesToTimeZone, hoursToTimeZone, utc
)
import Data.IMF.Syntax (fws, optionalCFWS, optionalFWS)
dateTime :: Parser ZonedTime
dateTime :: Parser ZonedTime
dateTime = do
Maybe DayOfWeek
dow <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser ByteString DayOfWeek
dayOfWeek forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Word8
char8 Char
',')
Day
theDate <- Parser Day
date
case Maybe DayOfWeek
dow of
Just DayOfWeek
dow' | Day -> DayOfWeek
Data.Time.dayOfWeek Day
theDate forall a. Eq a => a -> a -> Bool
/= DayOfWeek
dow'
-> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"day of week inconsistent with date"
Maybe DayOfWeek
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
TimeOfDay
tod <- Parser TimeOfDay
timeOfDay
TimeZone
z <- Parser TimeZone
zone
ByteString
_ <- forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s s
optionalCFWS
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ LocalTime -> TimeZone -> ZonedTime
ZonedTime (Day -> TimeOfDay -> LocalTime
LocalTime Day
theDate TimeOfDay
tod) TimeZone
z
dayOfWeek :: Parser DayOfWeek
dayOfWeek :: Parser ByteString DayOfWeek
dayOfWeek = forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s s
optionalFWS forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString DayOfWeek
dayName
dayName :: Parser DayOfWeek
dayName :: Parser ByteString DayOfWeek
dayName =
ByteString -> Parser ByteString
string ByteString
"Mon" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> DayOfWeek
Monday
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Parser ByteString
string ByteString
"Tue" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> DayOfWeek
Tuesday
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Parser ByteString
string ByteString
"Wed" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> DayOfWeek
Wednesday
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Parser ByteString
string ByteString
"Thu" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> DayOfWeek
Thursday
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Parser ByteString
string ByteString
"Fri" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> DayOfWeek
Friday
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Parser ByteString
string ByteString
"Sat" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> DayOfWeek
Saturday
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Parser ByteString
string ByteString
"Sun" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> DayOfWeek
Sunday
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"invalid day-of-week"
date :: Parser Day
date :: Parser Day
date = do
Int
d <- Parser Int
day
Int
m <- Parser Int
month
Integer
y <- Parser Integer
year
case Integer -> Int -> Int -> Maybe Day
fromGregorianValid Integer
y Int
m Int
d of
Just Day
r -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Day
r
Maybe Day
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"invalid date"
day :: Parser Int
day :: Parser Int
day = forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a, SM s) =>
f s s
optionalFWS forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Int
go forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a) =>
f s s
fws
where
go :: Parser Int
go = (Parser Int
twoDigit forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Int
digit) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. (a -> Bool) -> String -> a -> Parser a
check (\Int
n -> Int
n forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Int
n forall a. Ord a => a -> a -> Bool
<= Int
31) String
"day out of range"
month :: Parser Int
month :: Parser Int
month =
ByteString -> Parser ByteString
string ByteString
"Jan" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Int
1
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Parser ByteString
string ByteString
"Feb" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Int
2
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Parser ByteString
string ByteString
"Mar" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Int
3
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Parser ByteString
string ByteString
"Apr" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Int
4
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Parser ByteString
string ByteString
"May" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Int
5
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Parser ByteString
string ByteString
"Jun" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Int
6
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Parser ByteString
string ByteString
"Jul" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Int
7
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Parser ByteString
string ByteString
"Aug" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Int
8
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Parser ByteString
string ByteString
"Sep" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Int
9
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Parser ByteString
string ByteString
"Oct" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Int
10
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Parser ByteString
string ByteString
"Nov" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Int
11
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Parser ByteString
string ByteString
"Dec" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Int
12
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"invalid month"
year :: Parser Integer
year :: Parser Integer
year = forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a) =>
f s s
fws forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Parser Integer
go forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. (a -> Bool) -> String -> a -> Parser a
check (forall a. Ord a => a -> a -> Bool
>= Integer
1900) String
"year cannot be < 1900") forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a) =>
f s s
fws
where
go :: Parser Integer
go = Parser Integer
fourOrMoreDigit forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Integer
obsYear forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"too few digits in year"
fourOrMoreDigit :: Parser Integer
fourOrMoreDigit = do
ByteString
digits <- (Word8 -> Bool) -> Parser ByteString
A.takeWhile Word8 -> Bool
isDigit_w8
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (ByteString -> Int
B.length ByteString
digits forall a. Ord a => a -> a -> Bool
>= Int
4)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. (a -> Word8 -> a) -> a -> ByteString -> a
B.foldl' forall {a} {a}. (Integral a, Num a) => a -> a -> a
step Integer
0 ByteString
digits)
step :: a -> a -> a
step a
r a
a = a
r forall a. Num a => a -> a -> a
* a
10 forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral (a
a forall a. Num a => a -> a -> a
- a
48)
obsYear :: Parser Integer
obsYear = do
Int
yy <- Parser Int
twoDigit
forall a b. (Integral a, Num b) => a -> b
fromIntegral
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Int
yy forall a. Num a => a -> a -> a
+ if Int
yy forall a. Ord a => a -> a -> Bool
<= Int
49 then Int
2000 else Int
1900) (Int
1900 forall a. Num a => a -> a -> a
+ Int
yy forall a. Num a => a -> a -> a
* Int
10 forall a. Num a => a -> a -> a
+)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser Int
digit
timeOfDay :: Parser TimeOfDay
timeOfDay :: Parser TimeOfDay
timeOfDay = do
Int
hour <- Parser Int
twoDigit
Word8
_ <- Char -> Parser Word8
char8 Char
':'
Int
minute <- Parser Int
twoDigit
Int
second <- Char -> Parser Word8
char8 Char
':' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Int
twoDigit forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
0
case Int -> Int -> Pico -> Maybe TimeOfDay
makeTimeOfDayValid Int
hour Int
minute (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
second) of
Maybe TimeOfDay
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"invalid time-of-day"
Just TimeOfDay
tod -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TimeOfDay
tod
zone :: Parser TimeZone
zone :: Parser TimeZone
zone = forall (f :: * -> * -> *) s a.
(Alternative (f s), CharParsing f s a) =>
f s s
fws forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Parser TimeZone
go forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser TimeZone
obsZone)
where
go :: Parser TimeZone
go = do
Int -> Int
posNeg <- Char -> Parser Word8
char8 Char
'+' forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> forall a. a -> a
id forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Parser Word8
char8 Char
'-' forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> forall a. Num a => a -> a
negate
Int
h <- Parser Int
twoDigit
Int
m <- Parser Int
twoDigit
Bool -> String -> Parser ByteString ()
guardFail (Int
m forall a. Ord a => a -> a -> Bool
<= Int
59) String
"zone minutes must be in range 0..59"
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Int -> TimeZone
minutesToTimeZone (Int -> Int
posNeg (Int
h forall a. Num a => a -> a -> a
* Int
60 forall a. Num a => a -> a -> a
+ Int
m))
obsZone :: Parser TimeZone
obsZone :: Parser TimeZone
obsZone =
TimeZone
utc forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (ByteString -> Parser ByteString
string ByteString
"GMT" forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Parser ByteString
string ByteString
"UT")
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser TimeZone
usZone
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser TimeZone
milZone
where
usZone :: Parser TimeZone
usZone = do
(Int
off, Char
c1) <-
forall {a}. a -> Char -> Parser ByteString (a, Char)
charVal (-Int
5) Char
'E'
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall {a}. a -> Char -> Parser ByteString (a, Char)
charVal (-Int
6) Char
'C'
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall {a}. a -> Char -> Parser ByteString (a, Char)
charVal (-Int
7) Char
'M'
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall {a}. a -> Char -> Parser ByteString (a, Char)
charVal (-Int
8) Char
'P'
(Int
dst, Char
c2) <- forall {a}. a -> Char -> Parser ByteString (a, Char)
charVal Int
0 Char
'S' forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall {a}. a -> Char -> Parser ByteString (a, Char)
charVal Int
1 Char
'D'
Word8
_ <- Char -> Parser Word8
char8 Char
'T'
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Int -> Bool -> String -> TimeZone
TimeZone ((Int
off forall a. Num a => a -> a -> a
+ Int
dst) forall a. Num a => a -> a -> a
* Int
60) (Int
dst forall a. Eq a => a -> a -> Bool
== Int
1) (Char
c1forall a. a -> [a] -> [a]
:Char
c2forall a. a -> [a] -> [a]
:String
"T")
charVal :: a -> Char -> Parser ByteString (a, Char)
charVal a
a Char
c = (a
a, Char
c) forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Parser Word8
char8 Char
c
milZone :: Parser TimeZone
milZone =
TimeZone
utc forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Char -> Parser Word8
char8 Char
'Z' forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Parser Word8
char8 Char
'z')
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall {b}.
Num b =>
(b -> Int) -> b -> Word8 -> Word8 -> Parser TimeZone
go forall a. a -> a
id Int
0x40 Word8
0x41 Word8
0x49
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall {b}.
Num b =>
(b -> Int) -> b -> Word8 -> Word8 -> Parser TimeZone
go forall a. a -> a
id Int
0x41 Word8
0x4b Word8
0x4d
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall {b}.
Num b =>
(b -> Int) -> b -> Word8 -> Word8 -> Parser TimeZone
go forall a. Num a => a -> a
negate Int
0x4d Word8
0x4c Word8
0x59
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall {b}.
Num b =>
(b -> Int) -> b -> Word8 -> Word8 -> Parser TimeZone
go forall a. a -> a
id Int
0x60 Word8
0x61 Word8
0x69
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall {b}.
Num b =>
(b -> Int) -> b -> Word8 -> Word8 -> Parser TimeZone
go forall a. a -> a
id Int
0x61 Word8
0x6b Word8
0x6d
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall {b}.
Num b =>
(b -> Int) -> b -> Word8 -> Word8 -> Parser TimeZone
go forall a. Num a => a -> a
negate Int
0x6d Word8
0x6e Word8
0x79
go :: (b -> Int) -> b -> Word8 -> Word8 -> Parser TimeZone
go b -> Int
f b
off Word8
lo Word8
hi =
Int -> TimeZone
hoursToTimeZone forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Int
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a -> a
subtract b
off forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word8 -> Bool) -> Parser Word8
satisfy (\Word8
c -> Word8
c forall a. Ord a => a -> a -> Bool
>= Word8
lo Bool -> Bool -> Bool
&& Word8
c forall a. Ord a => a -> a -> Bool
<= Word8
hi)
guardFail :: Bool -> String -> Parser ()
guardFail :: Bool -> String -> Parser ByteString ()
guardFail Bool
True String
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
guardFail Bool
False String
s = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
s
check :: (a -> Bool) -> String -> a -> Parser a
check :: forall a. (a -> Bool) -> String -> a -> Parser a
check a -> Bool
f String
s a
a = Bool -> String -> Parser ByteString ()
guardFail (a -> Bool
f a
a) String
s forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> a
a
digit :: Parser Int
digit :: Parser Int
digit = (\Word8
c -> forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
c forall a. Num a => a -> a -> a
- Word8
48)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word8 -> Bool) -> Parser Word8
satisfy Word8 -> Bool
isDigit_w8
twoDigit :: Parser Int
twoDigit :: Parser Int
twoDigit = (\Int
hi Int
lo -> Int
hi forall a. Num a => a -> a -> a
* Int
10 forall a. Num a => a -> a -> a
+ Int
lo) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Int
digit forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Int
digit