{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Data.Time.Parsers
( day
, month
, localTime
, timeOfDay
, timeZone
, utcTime
, zonedTime
, DateParsing
) where
import Control.Applicative (optional, some, (<|>))
import Control.Monad (void, when)
import Data.Bits ((.&.))
import Data.Char (isDigit, ord)
import Data.Fixed (Pico)
import Data.Int (Int64)
import Data.List (foldl')
import Data.Maybe (fromMaybe)
import Data.Time.Calendar (Day, fromGregorianValid)
import Data.Time.Clock (UTCTime (..))
import Text.Parser.Char (CharParsing (..), digit)
import Text.Parser.Combinators (unexpected)
import Text.Parser.LookAhead (LookAheadParsing (..))
import Unsafe.Coerce (unsafeCoerce)
import qualified Data.Time.LocalTime as Local
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((*>), (<$), (<$>), (<*), (<*>))
#endif
type DateParsing m = (CharParsing m, LookAheadParsing m, Monad m)
toPico :: Integer -> Pico
toPico :: Integer -> Pico
toPico = Integer -> Pico
forall a b. a -> b
unsafeCoerce
month :: DateParsing m => m (Integer, Int)
month :: forall (m :: * -> *). DateParsing m => m (Integer, Int)
month = do
Integer -> Integer
s <- Integer -> Integer
forall a. Num a => a -> a
negate (Integer -> Integer) -> m Char -> m (Integer -> Integer)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
'-' m (Integer -> Integer)
-> m (Integer -> Integer) -> m (Integer -> Integer)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Integer -> Integer
forall a. a -> a
id (Integer -> Integer) -> m Char -> m (Integer -> Integer)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
'+' m (Integer -> Integer)
-> m (Integer -> Integer) -> m (Integer -> Integer)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Integer -> Integer) -> m (Integer -> Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return Integer -> Integer
forall a. a -> a
id
Integer
y <- m Integer
forall (m :: * -> *) a. (DateParsing m, Integral a) => m a
decimal
Char
_ <- Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
'-'
Int
m <- m Int
forall (m :: * -> *). DateParsing m => m Int
twoDigits
if (Int
1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
m Bool -> Bool -> Bool
&& Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
12)
then (Integer, Int) -> m (Integer, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Integer
s Integer
y, Int
m)
else String -> m (Integer, Int)
forall (m :: * -> *) a. Parsing m => String -> m a
unexpected String
"Invalid month"
{-# INLINE month #-}
day :: DateParsing m => m Day
day :: forall (m :: * -> *). DateParsing m => m Day
day = do
Integer -> Integer
s <- Integer -> Integer
forall a. Num a => a -> a
negate (Integer -> Integer) -> m Char -> m (Integer -> Integer)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
'-' m (Integer -> Integer)
-> m (Integer -> Integer) -> m (Integer -> Integer)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Integer -> Integer
forall a. a -> a
id (Integer -> Integer) -> m Char -> m (Integer -> Integer)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
'+' m (Integer -> Integer)
-> m (Integer -> Integer) -> m (Integer -> Integer)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Integer -> Integer) -> m (Integer -> Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return Integer -> Integer
forall a. a -> a
id
Integer
y <- m Integer
forall (m :: * -> *) a. (DateParsing m, Integral a) => m a
decimal
Char
_ <- Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
'-'
Int
m <- m Int
forall (m :: * -> *). DateParsing m => m Int
twoDigits
Char
_ <- Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
'-'
Int
d <- m Int
forall (m :: * -> *). DateParsing m => m Int
twoDigits
m Day -> (Day -> m Day) -> Maybe Day -> m Day
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> m Day
forall (m :: * -> *) a. Parsing m => String -> m a
unexpected String
"invalid date") Day -> m Day
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Int -> Int -> Maybe Day
fromGregorianValid (Integer -> Integer
s Integer
y) Int
m Int
d)
twoDigits :: DateParsing m => m Int
twoDigits :: forall (m :: * -> *). DateParsing m => m Int
twoDigits = do
Char
a <- m Char
forall (m :: * -> *). CharParsing m => m Char
digit
Char
b <- m Char
forall (m :: * -> *). CharParsing m => m Char
digit
let c2d :: Char -> Int
c2d Char
c = Char -> Int
ord Char
c Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
15
Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> m Int) -> Int -> m Int
forall a b. (a -> b) -> a -> b
$! Char -> Int
c2d Char
a Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
c2d Char
b
timeOfDay :: DateParsing m => m Local.TimeOfDay
timeOfDay :: forall (m :: * -> *). DateParsing m => m TimeOfDay
timeOfDay = do
Int
h <- m Int
forall (m :: * -> *). DateParsing m => m Int
twoDigits m Int -> m Char -> m Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
':'
Int
m <- m Int
forall (m :: * -> *). DateParsing m => m Int
twoDigits m Int -> m Char -> m Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
':'
Pico
s <- m Pico
forall (m :: * -> *). DateParsing m => m Pico
seconds
if Int
h Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
24 Bool -> Bool -> Bool
&& Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
60 Bool -> Bool -> Bool
&& Pico
s Pico -> Pico -> Bool
forall a. Ord a => a -> a -> Bool
< Pico
61
then TimeOfDay -> m TimeOfDay
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Int -> Pico -> TimeOfDay
Local.TimeOfDay Int
h Int
m Pico
s)
else String -> m TimeOfDay
forall (m :: * -> *) a. Parsing m => String -> m a
unexpected String
"invalid time"
data T = T {-# UNPACK #-} !Int {-# UNPACK #-} !Int64
seconds :: DateParsing m => m Pico
seconds :: forall (m :: * -> *). DateParsing m => m Pico
seconds = do
Int
real <- m Int
forall (m :: * -> *). DateParsing m => m Int
twoDigits
Maybe Char
mc <- m (Maybe Char)
forall (m :: * -> *). DateParsing m => m (Maybe Char)
peekChar
case Maybe Char
mc of
Just Char
'.' -> do
String
t <- m Char
forall (m :: * -> *). CharParsing m => m Char
anyChar m Char -> m String -> m String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m Char -> m String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some m Char
forall (m :: * -> *). CharParsing m => m Char
digit
Pico -> m Pico
forall (m :: * -> *) a. Monad m => a -> m a
return (Pico -> m Pico) -> Pico -> m Pico
forall a b. (a -> b) -> a -> b
$! Int -> String -> Pico
forall {t :: * -> *} {p}.
(Foldable t, Integral p) =>
p -> t Char -> Pico
parsePicos Int
real String
t
Maybe Char
_ -> Pico -> m Pico
forall (m :: * -> *) a. Monad m => a -> m a
return (Pico -> m Pico) -> Pico -> m Pico
forall a b. (a -> b) -> a -> b
$! Int -> Pico
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
real
where
parsePicos :: p -> t Char -> Pico
parsePicos p
a0 t Char
t = Integer -> Pico
toPico (Int64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64
t' Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
10Int64 -> Int -> Int64
forall a b. (Num a, Integral b) => a -> b -> a
^Int
n))
where T Int
n Int64
t' = (T -> Char -> T) -> T -> t Char -> T
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' T -> Char -> T
step (Int -> Int64 -> T
T Int
12 (p -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral p
a0)) t Char
t
step :: T -> Char -> T
step ma :: T
ma@(T Int
m Int64
a) Char
c
| Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = T
ma
| Bool
otherwise = Int -> Int64 -> T
T (Int
mInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) (Int64
10 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
a Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
c) Int64 -> Int64 -> Int64
forall a. Bits a => a -> a -> a
.&. Int64
15)
timeZone :: DateParsing m => m (Maybe Local.TimeZone)
timeZone :: forall (m :: * -> *). DateParsing m => m (Maybe TimeZone)
timeZone = do
let maybeSkip :: Char -> m ()
maybeSkip Char
c = do Char
ch <- m Char
forall (m :: * -> *). DateParsing m => m Char
peekChar'; Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Char
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c) (m Char -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void m Char
forall (m :: * -> *). CharParsing m => m Char
anyChar)
Char -> m ()
forall {m :: * -> *}.
(Monad m, CharParsing m, LookAheadParsing m) =>
Char -> m ()
maybeSkip Char
' '
Char
ch <- (Char -> Bool) -> m Char
forall (m :: * -> *). CharParsing m => (Char -> Bool) -> m Char
satisfy ((Char -> Bool) -> m Char) -> (Char -> Bool) -> m Char
forall a b. (a -> b) -> a -> b
$ \Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'Z' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'+' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-'
if Char
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'Z'
then Maybe TimeZone -> m (Maybe TimeZone)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe TimeZone
forall a. Maybe a
Nothing
else do
Int
h <- m Int
forall (m :: * -> *). DateParsing m => m Int
twoDigits
Maybe Char
mm <- m (Maybe Char)
forall (m :: * -> *). DateParsing m => m (Maybe Char)
peekChar
Int
m <- case Maybe Char
mm of
Just Char
':' -> m Char
forall (m :: * -> *). CharParsing m => m Char
anyChar m Char -> m Int -> m Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m Int
forall (m :: * -> *). DateParsing m => m Int
twoDigits
Just Char
d | Char -> Bool
isDigit Char
d -> m Int
forall (m :: * -> *). DateParsing m => m Int
twoDigits
Maybe Char
_ -> Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
let off :: Int
off | Char
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-' = Int -> Int
forall a. Num a => a -> a
negate Int
off0
| Bool
otherwise = Int
off0
off0 :: Int
off0 = Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
60 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
m
case Any
forall a. HasCallStack => a
undefined of
Any
_ | Int
off Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 ->
Maybe TimeZone -> m (Maybe TimeZone)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe TimeZone
forall a. Maybe a
Nothing
| Int
off Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< -Int
720 Bool -> Bool -> Bool
|| Int
off Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
840 Bool -> Bool -> Bool
|| Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
59 ->
String -> m (Maybe TimeZone)
forall (m :: * -> *) a. Parsing m => String -> m a
unexpected String
"invalid time zone offset"
| Bool
otherwise ->
let !tz :: TimeZone
tz = Int -> TimeZone
Local.minutesToTimeZone Int
off
in Maybe TimeZone -> m (Maybe TimeZone)
forall (m :: * -> *) a. Monad m => a -> m a
return (TimeZone -> Maybe TimeZone
forall a. a -> Maybe a
Just TimeZone
tz)
localTime :: DateParsing m => m Local.LocalTime
localTime :: forall (m :: * -> *). DateParsing m => m LocalTime
localTime = Day -> TimeOfDay -> LocalTime
Local.LocalTime (Day -> TimeOfDay -> LocalTime)
-> m Day -> m (TimeOfDay -> LocalTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Day
forall (m :: * -> *). DateParsing m => m Day
day m (TimeOfDay -> LocalTime) -> m Char -> m (TimeOfDay -> LocalTime)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* m Char
daySep m (TimeOfDay -> LocalTime) -> m TimeOfDay -> m LocalTime
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m TimeOfDay
forall (m :: * -> *). DateParsing m => m TimeOfDay
timeOfDay
where daySep :: m Char
daySep = (Char -> Bool) -> m Char
forall (m :: * -> *). CharParsing m => (Char -> Bool) -> m Char
satisfy (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'T' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ')
utcTime :: DateParsing m => m UTCTime
utcTime :: forall (m :: * -> *). DateParsing m => m UTCTime
utcTime = LocalTime -> Maybe TimeZone -> UTCTime
f (LocalTime -> Maybe TimeZone -> UTCTime)
-> m LocalTime -> m (Maybe TimeZone -> UTCTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m LocalTime
forall (m :: * -> *). DateParsing m => m LocalTime
localTime m (Maybe TimeZone -> UTCTime) -> m (Maybe TimeZone) -> m UTCTime
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m (Maybe TimeZone)
forall (m :: * -> *). DateParsing m => m (Maybe TimeZone)
timeZone
where
f :: Local.LocalTime -> Maybe Local.TimeZone -> UTCTime
f :: LocalTime -> Maybe TimeZone -> UTCTime
f (Local.LocalTime Day
d TimeOfDay
t) Maybe TimeZone
Nothing =
let !tt :: DiffTime
tt = TimeOfDay -> DiffTime
Local.timeOfDayToTime TimeOfDay
t
in Day -> DiffTime -> UTCTime
UTCTime Day
d DiffTime
tt
f LocalTime
lt (Just TimeZone
tz) = TimeZone -> LocalTime -> UTCTime
Local.localTimeToUTC TimeZone
tz LocalTime
lt
zonedTime :: DateParsing m => m Local.ZonedTime
zonedTime :: forall (m :: * -> *). DateParsing m => m ZonedTime
zonedTime = LocalTime -> TimeZone -> ZonedTime
Local.ZonedTime (LocalTime -> TimeZone -> ZonedTime)
-> m LocalTime -> m (TimeZone -> ZonedTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m LocalTime
forall (m :: * -> *). DateParsing m => m LocalTime
localTime m (TimeZone -> ZonedTime) -> m TimeZone -> m ZonedTime
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (TimeZone -> Maybe TimeZone -> TimeZone
forall a. a -> Maybe a -> a
fromMaybe TimeZone
utc (Maybe TimeZone -> TimeZone) -> m (Maybe TimeZone) -> m TimeZone
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Maybe TimeZone)
forall (m :: * -> *). DateParsing m => m (Maybe TimeZone)
timeZone)
utc :: Local.TimeZone
utc :: TimeZone
utc = Int -> Bool -> String -> TimeZone
Local.TimeZone Int
0 Bool
False String
""
decimal :: (DateParsing m, Integral a) => m a
decimal :: forall (m :: * -> *) a. (DateParsing m, Integral a) => m a
decimal = (a -> Char -> a) -> a -> String -> a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' a -> Char -> a
forall {a}. Num a => a -> Char -> a
step a
0 (String -> a) -> m String -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` m Char -> m String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some m Char
forall (m :: * -> *). CharParsing m => m Char
digit
where step :: a -> Char -> a
step a
a Char
w = a
a a -> a -> a
forall a. Num a => a -> a -> a
* a
10 a -> a -> a
forall a. Num a => a -> a -> a
+ Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
48)
peekChar :: DateParsing m => m (Maybe Char)
peekChar :: forall (m :: * -> *). DateParsing m => m (Maybe Char)
peekChar = m Char -> m (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional m Char
forall (m :: * -> *). DateParsing m => m Char
peekChar'
peekChar' :: DateParsing m => m Char
peekChar' :: forall (m :: * -> *). DateParsing m => m Char
peekChar' = m Char -> m Char
forall (m :: * -> *) a. LookAheadParsing m => m a -> m a
lookAhead m Char
forall (m :: * -> *). CharParsing m => m Char
anyChar