{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Data.Time.Parsers
( day
, month
, year
, 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 = forall a b. a -> b
unsafeCoerce
year :: DateParsing m => m Integer
year :: forall (m :: * -> *). DateParsing m => m Integer
year = do
[Char]
ds <- forall (f :: * -> *) a. Alternative f => f a -> f [a]
some forall (m :: * -> *). CharParsing m => m Char
digit
if forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
ds forall a. Ord a => a -> a -> Bool
< Int
4
then forall (m :: * -> *) a. Parsing m => [Char] -> m a
unexpected [Char]
"expected year with at least 4 digits"
else forall (m :: * -> *) a. Monad m => a -> m a
return (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall {a}. Num a => a -> Char -> a
step Integer
0 [Char]
ds)
where step :: a -> Char -> a
step a
a Char
w = a
a 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 (Char -> Int
ord Char
w forall a. Num a => a -> a -> a
- Int
48)
month :: DateParsing m => m (Integer, Int)
month :: forall (m :: * -> *). DateParsing m => m (Integer, Int)
month = do
Integer -> Integer
s <- forall a. Num a => a -> a
negate forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
'-' forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. a -> a
id forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
'+' forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. a -> a
id
Integer
y <- forall (m :: * -> *). DateParsing m => m Integer
year
Char
_ <- forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
'-'
Int
m <- forall (m :: * -> *). DateParsing m => m Int
twoDigits
if Int
1 forall a. Ord a => a -> a -> Bool
<= Int
m Bool -> Bool -> Bool
&& Int
m forall a. Ord a => a -> a -> Bool
<= Int
12
then forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Integer
s Integer
y, Int
m)
else forall (m :: * -> *) a. Parsing m => [Char] -> m a
unexpected [Char]
"Invalid month"
{-# INLINE month #-}
day :: DateParsing m => m Day
day :: forall (m :: * -> *). DateParsing m => m Day
day = do
Integer -> Integer
s <- forall a. Num a => a -> a
negate forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
'-' forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. a -> a
id forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
'+' forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. a -> a
id
Integer
y <- forall (m :: * -> *). DateParsing m => m Integer
year
Char
_ <- forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
'-'
Int
m <- forall (m :: * -> *). DateParsing m => m Int
twoDigits
Char
_ <- forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
'-'
Int
d <- forall (m :: * -> *). DateParsing m => m Int
twoDigits
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Parsing m => [Char] -> m a
unexpected [Char]
"invalid date") 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 <- forall (m :: * -> *). CharParsing m => m Char
digit
Char
b <- forall (m :: * -> *). CharParsing m => m Char
digit
let c2d :: Char -> Int
c2d Char
c = Char -> Int
ord Char
c forall a. Bits a => a -> a -> a
.&. Int
15
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Char -> Int
c2d Char
a forall a. Num a => a -> a -> a
* Int
10 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 <- forall (m :: * -> *). DateParsing m => m Int
twoDigits forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
':'
Int
m <- forall (m :: * -> *). DateParsing m => m Int
twoDigits forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
':'
Pico
s <- forall (m :: * -> *). DateParsing m => m Pico
seconds
if Int
h forall a. Ord a => a -> a -> Bool
< Int
24 Bool -> Bool -> Bool
&& Int
m forall a. Ord a => a -> a -> Bool
< Int
60 Bool -> Bool -> Bool
&& Pico
s forall a. Ord a => a -> a -> Bool
< Pico
61
then forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Int -> Pico -> TimeOfDay
Local.TimeOfDay Int
h Int
m Pico
s)
else forall (m :: * -> *) a. Parsing m => [Char] -> m a
unexpected [Char]
"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 <- forall (m :: * -> *). DateParsing m => m Int
twoDigits
Maybe Char
mc <- forall (m :: * -> *). DateParsing m => m (Maybe Char)
peekChar
case Maybe Char
mc of
Just Char
'.' -> do
[Char]
t <- forall (m :: * -> *). CharParsing m => m Char
anyChar forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Alternative f => f a -> f [a]
some forall (m :: * -> *). CharParsing m => m Char
digit
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall {t :: * -> *} {p}.
(Foldable t, Integral p) =>
p -> t Char -> Pico
parsePicos Int
real [Char]
t
Maybe Char
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! 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 (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64
t' forall a. Num a => a -> a -> a
* Int64
10forall a b. (Num a, Integral b) => a -> b -> a
^Int
n))
where T Int
n Int64
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 (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 forall a. Ord a => a -> a -> Bool
<= Int
0 = T
ma
| Bool
otherwise = Int -> Int64 -> T
T (Int
mforall a. Num a => a -> a -> a
-Int
1) (Int64
10 forall a. Num a => a -> a -> a
* Int64
a forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
c) 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 <- forall (m :: * -> *). DateParsing m => m Char
peekChar'; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Char
ch forall a. Eq a => a -> a -> Bool
== Char
c) (forall (f :: * -> *) a. Functor f => f a -> f ()
void forall (m :: * -> *). CharParsing m => m Char
anyChar)
forall {m :: * -> *}.
(Monad m, CharParsing m, LookAheadParsing m) =>
Char -> m ()
maybeSkip Char
' '
Char
ch <- forall (m :: * -> *). CharParsing m => (Char -> Bool) -> m Char
satisfy forall a b. (a -> b) -> a -> b
$ \Char
c -> Char
c forall a. Eq a => a -> a -> Bool
== Char
'Z' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'+' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'-'
if Char
ch forall a. Eq a => a -> a -> Bool
== Char
'Z'
then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
else do
Int
h <- forall (m :: * -> *). DateParsing m => m Int
twoDigits
Maybe Char
mm <- forall (m :: * -> *). DateParsing m => m (Maybe Char)
peekChar
Int
m <- case Maybe Char
mm of
Just Char
':' -> forall (m :: * -> *). CharParsing m => m Char
anyChar forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *). DateParsing m => m Int
twoDigits
Just Char
d | Char -> Bool
isDigit Char
d -> forall (m :: * -> *). DateParsing m => m Int
twoDigits
Maybe Char
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
let off :: Int
off | Char
ch forall a. Eq a => a -> a -> Bool
== Char
'-' = forall a. Num a => a -> a
negate Int
off0
| Bool
otherwise = Int
off0
off0 :: Int
off0 = Int
h forall a. Num a => a -> a -> a
* Int
60 forall a. Num a => a -> a -> a
+ Int
m
case forall a. HasCallStack => a
undefined of
Any
_ | Int
off forall a. Eq a => a -> a -> Bool
== Int
0 ->
forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
| Int
off forall a. Ord a => a -> a -> Bool
< -Int
720 Bool -> Bool -> Bool
|| Int
off forall a. Ord a => a -> a -> Bool
> Int
840 Bool -> Bool -> Bool
|| Int
m forall a. Ord a => a -> a -> Bool
> Int
59 ->
forall (m :: * -> *) a. Parsing m => [Char] -> m a
unexpected [Char]
"invalid time zone offset"
| Bool
otherwise ->
let !tz :: TimeZone
tz = Int -> TimeZone
Local.minutesToTimeZone Int
off
in forall (m :: * -> *) a. Monad m => a -> m a
return (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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). DateParsing m => m Day
day forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* m Char
daySep forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *). DateParsing m => m TimeOfDay
timeOfDay
where daySep :: m Char
daySep = forall (m :: * -> *). CharParsing m => (Char -> Bool) -> m Char
satisfy (\Char
c -> Char
c forall a. Eq a => a -> a -> Bool
== Char
'T' Bool -> Bool -> Bool
|| Char
c 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). DateParsing m => m LocalTime
localTime forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). DateParsing m => m LocalTime
localTime forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall a. a -> Maybe a -> a
fromMaybe TimeZone
utc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). DateParsing m => m (Maybe TimeZone)
timeZone)
utc :: Local.TimeZone
utc :: TimeZone
utc = Int -> Bool -> [Char] -> TimeZone
Local.TimeZone Int
0 Bool
False [Char]
""
decimal :: (DateParsing m, Integral a) => m a
decimal :: forall (m :: * -> *) a. (DateParsing m, Integral a) => m a
decimal = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall {a}. Num a => a -> Char -> a
step a
0 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall (f :: * -> *) a. Alternative f => f a -> f [a]
some forall (m :: * -> *). CharParsing m => m Char
digit
where step :: a -> Char -> a
step a
a Char
w = a
a 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 (Char -> Int
ord Char
w forall a. Num a => a -> a -> a
- Int
48)
peekChar :: DateParsing m => m (Maybe Char)
peekChar :: forall (m :: * -> *). DateParsing m => m (Maybe Char)
peekChar = forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall (m :: * -> *). DateParsing m => m Char
peekChar'
peekChar' :: DateParsing m => m Char
peekChar' :: forall (m :: * -> *). DateParsing m => m Char
peekChar' = forall (m :: * -> *) a. LookAheadParsing m => m a -> m a
lookAhead forall (m :: * -> *). CharParsing m => m Char
anyChar