{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Data.Attoparsec.Time
(
day
, localTime
, timeOfDay
, timeZone
, utcTime
, zonedTime
, month
, quarter
) where
import Prelude.Compat
import Control.Applicative ((<|>))
import Control.Monad (void, when)
import Data.Attoparsec.Text (Parser, char, decimal, digit, option, anyChar, peekChar, peekChar', takeWhile1, satisfy)
import Data.Attoparsec.Time.Internal (toPico)
import Data.Bits ((.&.))
import Data.Char (isDigit, ord)
import Data.Fixed (Pico)
import Data.Int (Int64)
import Data.Maybe (fromMaybe)
import Data.Time.Calendar (Day, fromGregorianValid)
import Data.Time.Calendar.Quarter.Compat (Quarter, QuarterOfYear (..), fromYearQuarter)
import Data.Time.Calendar.Month.Compat (Month, fromYearMonthValid)
import Data.Time.Clock (UTCTime(..))
import qualified Data.Text as T
import qualified Data.Time.LocalTime as Local
day :: Parser Day
day :: Parser Day
day = do
Integer -> Integer
absOrNeg <- Integer -> Integer
forall a. Num a => a -> a
negate (Integer -> Integer)
-> Parser Text Char -> Parser Text (Integer -> Integer)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Parser Text Char
char '-' Parser Text (Integer -> Integer)
-> Parser Text (Integer -> Integer)
-> Parser Text (Integer -> Integer)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Integer -> Integer
forall a. a -> a
id (Integer -> Integer)
-> Parser Text Char -> Parser Text (Integer -> Integer)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Parser Text Char
char '+' Parser Text (Integer -> Integer)
-> Parser Text (Integer -> Integer)
-> Parser Text (Integer -> Integer)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Integer -> Integer) -> Parser Text (Integer -> Integer)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer -> Integer
forall a. a -> a
id
Integer
y <- (Parser Integer
forall a. Integral a => Parser a
decimal Parser Integer -> Parser Text Char -> Parser Integer
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Text Char
char '-') Parser Integer -> Parser Integer -> Parser Integer
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> Parser Integer
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "date must be of form [+,-]YYYY-MM-DD"
Int
m <- (Parser Int
twoDigits Parser Int -> Parser Text Char -> Parser Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Text Char
char '-') Parser Int -> Parser Int -> Parser Int
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> Parser Int
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "date must be of form [+,-]YYYY-MM-DD"
Int
d <- Parser Int
twoDigits Parser Int -> Parser Int -> Parser Int
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> Parser Int
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "date must be of form [+,-]YYYY-MM-DD"
Parser Day -> (Day -> Parser Day) -> Maybe Day -> Parser Day
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Parser Day
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "invalid date") Day -> Parser Day
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Int -> Int -> Maybe Day
fromGregorianValid (Integer -> Integer
absOrNeg Integer
y) Int
m Int
d)
month :: Parser Month
month :: Parser Month
month = do
Integer -> Integer
absOrNeg <- Integer -> Integer
forall a. Num a => a -> a
negate (Integer -> Integer)
-> Parser Text Char -> Parser Text (Integer -> Integer)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Parser Text Char
char '-' Parser Text (Integer -> Integer)
-> Parser Text (Integer -> Integer)
-> Parser Text (Integer -> Integer)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Integer -> Integer
forall a. a -> a
id (Integer -> Integer)
-> Parser Text Char -> Parser Text (Integer -> Integer)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Parser Text Char
char '+' Parser Text (Integer -> Integer)
-> Parser Text (Integer -> Integer)
-> Parser Text (Integer -> Integer)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Integer -> Integer) -> Parser Text (Integer -> Integer)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer -> Integer
forall a. a -> a
id
Integer
y <- (Parser Integer
forall a. Integral a => Parser a
decimal Parser Integer -> Parser Text Char -> Parser Integer
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Text Char
char '-') Parser Integer -> Parser Integer -> Parser Integer
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> Parser Integer
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "month must be of form [+,-]YYYY-MM"
Int
m <- Parser Int
twoDigits Parser Int -> Parser Int -> Parser Int
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> Parser Int
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "month must be of form [+,-]YYYY-MM"
Parser Month
-> (Month -> Parser Month) -> Maybe Month -> Parser Month
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Parser Month
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "invalid month") Month -> Parser Month
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Int -> Maybe Month
fromYearMonthValid (Integer -> Integer
absOrNeg Integer
y) Int
m)
quarter :: Parser Quarter
quarter :: Parser Quarter
quarter = do
Integer -> Integer
absOrNeg <- Integer -> Integer
forall a. Num a => a -> a
negate (Integer -> Integer)
-> Parser Text Char -> Parser Text (Integer -> Integer)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Parser Text Char
char '-' Parser Text (Integer -> Integer)
-> Parser Text (Integer -> Integer)
-> Parser Text (Integer -> Integer)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Integer -> Integer
forall a. a -> a
id (Integer -> Integer)
-> Parser Text Char -> Parser Text (Integer -> Integer)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Parser Text Char
char '+' Parser Text (Integer -> Integer)
-> Parser Text (Integer -> Integer)
-> Parser Text (Integer -> Integer)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Integer -> Integer) -> Parser Text (Integer -> Integer)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer -> Integer
forall a. a -> a
id
Integer
y <- (Parser Integer
forall a. Integral a => Parser a
decimal Parser Integer -> Parser Text Char -> Parser Integer
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Text Char
char '-') Parser Integer -> Parser Integer -> Parser Integer
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> Parser Integer
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "month must be of form [+,-]YYYY-MM"
Char
_ <- Char -> Parser Text Char
char 'q' Parser Text Char -> Parser Text Char -> Parser Text Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Parser Text Char
char 'Q'
QuarterOfYear
q <- Parser Text QuarterOfYear
parseQ
Quarter -> Parser Quarter
forall (m :: * -> *) a. Monad m => a -> m a
return (Quarter -> Parser Quarter) -> Quarter -> Parser Quarter
forall a b. (a -> b) -> a -> b
$! Integer -> QuarterOfYear -> Quarter
fromYearQuarter (Integer -> Integer
absOrNeg Integer
y) QuarterOfYear
q
where
parseQ :: Parser Text QuarterOfYear
parseQ = QuarterOfYear
Q1 QuarterOfYear -> Parser Text Char -> Parser Text QuarterOfYear
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Parser Text Char
char '1'
Parser Text QuarterOfYear
-> Parser Text QuarterOfYear -> Parser Text QuarterOfYear
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> QuarterOfYear
Q2 QuarterOfYear -> Parser Text Char -> Parser Text QuarterOfYear
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Parser Text Char
char '2'
Parser Text QuarterOfYear
-> Parser Text QuarterOfYear -> Parser Text QuarterOfYear
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> QuarterOfYear
Q3 QuarterOfYear -> Parser Text Char -> Parser Text QuarterOfYear
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Parser Text Char
char '3'
Parser Text QuarterOfYear
-> Parser Text QuarterOfYear -> Parser Text QuarterOfYear
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> QuarterOfYear
Q4 QuarterOfYear -> Parser Text Char -> Parser Text QuarterOfYear
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Parser Text Char
char '4'
twoDigits :: Parser Int
twoDigits :: Parser Int
twoDigits = do
Char
a <- Parser Text Char
digit
Char
b <- Parser Text Char
digit
let c2d :: Char -> Int
c2d c :: Char
c = Char -> Int
ord Char
c Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. 15
Int -> Parser Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Parser Int) -> Int -> Parser Int
forall a b. (a -> b) -> a -> b
$! Char -> Int
c2d Char
a Int -> Int -> Int
forall a. Num a => a -> a -> a
* 10 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
c2d Char
b
timeOfDay :: Parser Local.TimeOfDay
timeOfDay :: Parser TimeOfDay
timeOfDay = do
Int
h <- Parser Int
twoDigits
Int
m <- Char -> Parser Text Char
char ':' Parser Text Char -> Parser Int -> Parser Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Int
twoDigits
Pico
s <- Pico -> Parser Text Pico -> Parser Text Pico
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option 0 (Char -> Parser Text Char
char ':' Parser Text Char -> Parser Text Pico -> Parser Text Pico
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text Pico
seconds)
if Int
h Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 24 Bool -> Bool -> Bool
&& Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 60 Bool -> Bool -> Bool
&& Pico
s Pico -> Pico -> Bool
forall a. Ord a => a -> a -> Bool
< 61
then TimeOfDay -> Parser TimeOfDay
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Int -> Pico -> TimeOfDay
Local.TimeOfDay Int
h Int
m Pico
s)
else String -> Parser TimeOfDay
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "invalid time"
data T = T {-# UNPACK #-} !Int {-# UNPACK #-} !Int64
seconds :: Parser Pico
seconds :: Parser Text Pico
seconds = do
Int
real <- Parser Int
twoDigits
Maybe Char
mc <- Parser (Maybe Char)
peekChar
case Maybe Char
mc of
Just '.' -> do
Text
t <- Parser Text Char
anyChar Parser Text Char -> Parser Text Text -> Parser Text Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Parser Text Text
takeWhile1 Char -> Bool
isDigit
Pico -> Parser Text Pico
forall (m :: * -> *) a. Monad m => a -> m a
return (Pico -> Parser Text Pico) -> Pico -> Parser Text Pico
forall a b. (a -> b) -> a -> b
$! Int -> Text -> Pico
forall a. Integral a => a -> Text -> Pico
parsePicos Int
real Text
t
_ -> Pico -> Parser Text Pico
forall (m :: * -> *) a. Monad m => a -> m a
return (Pico -> Parser Text Pico) -> Pico -> Parser Text Pico
forall a b. (a -> b) -> a -> b
$! Int -> Pico
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
real
where
parsePicos :: a -> Text -> Pico
parsePicos a0 :: a
a0 t :: Text
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
* 10Int64 -> Int -> Int64
forall a b. (Num a, Integral b) => a -> b -> a
^Int
n))
where T n :: Int
n t' :: Int64
t' = (T -> Char -> T) -> T -> Text -> T
forall a. (a -> Char -> a) -> a -> Text -> a
T.foldl' T -> Char -> T
step (Int -> Int64 -> T
T 12 (a -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
a0)) Text
t
step :: T -> Char -> T
step ma :: T
ma@(T m :: Int
m a :: Int64
a) c :: Char
c
| Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 0 = T
ma
| Bool
otherwise = Int -> Int64 -> T
T (Int
mInt -> Int -> Int
forall a. Num a => a -> a -> a
-1) (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
.&. 15)
timeZone :: Parser (Maybe Local.TimeZone)
timeZone :: Parser (Maybe TimeZone)
timeZone = do
let maybeSkip :: Char -> Parser Text ()
maybeSkip c :: Char
c = do Char
ch <- Parser Text Char
peekChar'; Bool -> Parser Text () -> Parser Text ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Char
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c) (Parser Text Char -> Parser Text ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Parser Text Char
anyChar)
Char -> Parser Text ()
maybeSkip ' '
Char
ch <- (Char -> Bool) -> Parser Text Char
satisfy ((Char -> Bool) -> Parser Text Char)
-> (Char -> Bool) -> Parser Text Char
forall a b. (a -> b) -> a -> b
$ \c :: Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== 'Z' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '+' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '-'
if Char
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== 'Z'
then Maybe TimeZone -> Parser (Maybe TimeZone)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe TimeZone
forall a. Maybe a
Nothing
else do
Int
h <- Parser Int
twoDigits
Maybe Char
mm <- Parser (Maybe Char)
peekChar
Int
m <- case Maybe Char
mm of
Just ':' -> Parser Text Char
anyChar Parser Text Char -> Parser Int -> Parser Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Int
twoDigits
Just d :: Char
d | Char -> Bool
isDigit Char
d -> Parser Int
twoDigits
_ -> Int -> Parser Int
forall (m :: * -> *) a. Monad m => a -> m a
return 0
let off :: Int
off | Char
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '-' = 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
* 60 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
m
case Any
forall a. HasCallStack => a
undefined of
_ | Int
off Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 ->
Maybe TimeZone -> Parser (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
< -720 Bool -> Bool -> Bool
|| Int
off Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 840 Bool -> Bool -> Bool
|| Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 59 ->
String -> Parser (Maybe TimeZone)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "invalid time zone offset"
| Bool
otherwise ->
let !tz :: TimeZone
tz = Int -> TimeZone
Local.minutesToTimeZone Int
off
in Maybe TimeZone -> Parser (Maybe TimeZone)
forall (m :: * -> *) a. Monad m => a -> m a
return (TimeZone -> Maybe TimeZone
forall a. a -> Maybe a
Just TimeZone
tz)
localTime :: Parser Local.LocalTime
localTime :: Parser LocalTime
localTime = Day -> TimeOfDay -> LocalTime
Local.LocalTime (Day -> TimeOfDay -> LocalTime)
-> Parser Day -> Parser Text (TimeOfDay -> LocalTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Day
day Parser Text (TimeOfDay -> LocalTime)
-> Parser Text Char -> Parser Text (TimeOfDay -> LocalTime)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text Char
daySep Parser Text (TimeOfDay -> LocalTime)
-> Parser TimeOfDay -> Parser LocalTime
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser TimeOfDay
timeOfDay
where daySep :: Parser Text Char
daySep = (Char -> Bool) -> Parser Text Char
satisfy (\c :: Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== 'T' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ' ')
utcTime :: Parser UTCTime
utcTime :: Parser UTCTime
utcTime = do
lt :: LocalTime
lt@(Local.LocalTime d :: Day
d t :: TimeOfDay
t) <- Parser LocalTime
localTime
Maybe TimeZone
mtz <- Parser (Maybe TimeZone)
timeZone
case Maybe TimeZone
mtz of
Nothing -> let !tt :: DiffTime
tt = TimeOfDay -> DiffTime
Local.timeOfDayToTime TimeOfDay
t
in UTCTime -> Parser UTCTime
forall (m :: * -> *) a. Monad m => a -> m a
return (Day -> DiffTime -> UTCTime
UTCTime Day
d DiffTime
tt)
Just tz :: TimeZone
tz -> UTCTime -> Parser UTCTime
forall (m :: * -> *) a. Monad m => a -> m a
return (UTCTime -> Parser UTCTime) -> UTCTime -> Parser UTCTime
forall a b. (a -> b) -> a -> b
$! TimeZone -> LocalTime -> UTCTime
Local.localTimeToUTC TimeZone
tz LocalTime
lt
zonedTime :: Parser Local.ZonedTime
zonedTime :: Parser ZonedTime
zonedTime = LocalTime -> TimeZone -> ZonedTime
Local.ZonedTime (LocalTime -> TimeZone -> ZonedTime)
-> Parser LocalTime -> Parser Text (TimeZone -> ZonedTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser LocalTime
localTime Parser Text (TimeZone -> ZonedTime)
-> Parser Text TimeZone -> Parser 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)
-> Parser (Maybe TimeZone) -> Parser Text TimeZone
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Maybe TimeZone)
timeZone)
utc :: Local.TimeZone
utc :: TimeZone
utc = Int -> Bool -> String -> TimeZone
Local.TimeZone 0 Bool
False ""