{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Data.Attoparsec.Time
(
day
, localTime
, timeOfDay
, timeZone
, utcTime
, zonedTime
, year
, month
, quarter
) where
import Prelude.Compat
import Control.Applicative ((<|>))
import Control.Monad (void, when)
import Data.Attoparsec.Text (Parser, char, 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.Compat (Year)
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 <- forall a. Num a => a -> a
negate forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Parser 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
<$ Char -> Parser Char
char Char
'+' forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. a -> a
id
Integer
y <- (Parser Text Integer
year forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
char Char
'-') forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"date must be of form [+,-]YYYY-MM-DD"
Int
m <- (Parser Text Int
twoDigits forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
char Char
'-') forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"date must be of form [+,-]YYYY-MM-DD"
Int
d <- Parser Text Int
twoDigits forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"date must be of form [+,-]YYYY-MM-DD"
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"invalid date") 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 <- forall a. Num a => a -> a
negate forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Parser 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
<$ Char -> Parser Char
char Char
'+' forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. a -> a
id
Integer
y <- (Parser Text Integer
year forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
char Char
'-') forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"month must be of form [+,-]YYYY-MM"
Int
m <- Parser Text Int
twoDigits forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"month must be of form [+,-]YYYY-MM"
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"invalid 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 <- forall a. Num a => a -> a
negate forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Parser 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
<$ Char -> Parser Char
char Char
'+' forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. a -> a
id
Integer
y <- (Parser Text Integer
year forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
char Char
'-') forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"month must be of form [+,-]YYYY-MM"
Char
_ <- Char -> Parser Char
char Char
'q' forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Parser Char
char Char
'Q'
QuarterOfYear
q <- Parser Text QuarterOfYear
parseQ
forall (m :: * -> *) a. Monad m => a -> m a
return 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 forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Parser Char
char Char
'1'
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> QuarterOfYear
Q2 forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Parser Char
char Char
'2'
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> QuarterOfYear
Q3 forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Parser Char
char Char
'3'
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> QuarterOfYear
Q4 forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Parser Char
char Char
'4'
year :: Parser Year
year :: Parser Text Integer
year = do
Text
ds <- (Char -> Bool) -> Parser Text
takeWhile1 Char -> Bool
isDigit
if Text -> Int
T.length Text
ds forall a. Ord a => a -> a -> Bool
< Int
4 then
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"expected year with at least 4 digits"
else
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Integer
txtToInteger Text
ds)
twoDigits :: Parser Int
twoDigits :: Parser Text Int
twoDigits = do
Char
a <- Parser Char
digit
Char
b <- Parser 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 :: Parser Local.TimeOfDay
timeOfDay :: Parser TimeOfDay
timeOfDay = do
Int
h <- Parser Text Int
twoDigits
Int
m <- Char -> Parser Char
char Char
':' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text Int
twoDigits
Pico
s <- forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option Pico
0 (Char -> Parser Char
char Char
':' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text 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. MonadFail m => String -> m a
fail String
"invalid time"
data T = T {-# UNPACK #-} !Int {-# UNPACK #-} !Int64
seconds :: Parser Pico
seconds :: Parser Text Pico
seconds = do
Int
real <- Parser Text Int
twoDigits
Maybe Char
mc <- Parser (Maybe Char)
peekChar
case Maybe Char
mc of
Just Char
'.' -> do
Text
t <- Parser Char
anyChar forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Parser Text
takeWhile1 Char -> Bool
isDigit
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall {p}. Integral p => p -> Text -> Pico
parsePicos Int
real Text
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 -> Text -> Pico
parsePicos p
a0 Text
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 a. (a -> Char -> a) -> a -> Text -> a
T.foldl' T -> Char -> T
step (Int -> Int64 -> T
T Int
12 (forall a b. (Integral a, Num b) => a -> b
fromIntegral p
a0)) Text
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 :: Parser (Maybe Local.TimeZone)
timeZone :: Parser (Maybe TimeZone)
timeZone = do
let maybeSkip :: Char -> Parser Text ()
maybeSkip Char
c = do Char
ch <- Parser 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 Parser Char
anyChar)
Char -> Parser Text ()
maybeSkip Char
' '
Char
ch <- (Char -> Bool) -> Parser 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 <- Parser Text Int
twoDigits
Maybe Char
mm <- Parser (Maybe Char)
peekChar
Int
m <- case Maybe Char
mm of
Just Char
':' -> Parser Char
anyChar forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text Int
twoDigits
Just Char
d | Char -> Bool
isDigit Char
d -> Parser Text 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. MonadFail m => String -> m a
fail String
"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 :: Parser Local.LocalTime
localTime :: Parser LocalTime
localTime = Day -> TimeOfDay -> LocalTime
Local.LocalTime forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Day
day forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Char
daySep forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser TimeOfDay
timeOfDay
where daySep :: Parser Char
daySep = (Char -> Bool) -> Parser 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 :: Parser UTCTime
utcTime :: Parser UTCTime
utcTime = do
lt :: LocalTime
lt@(Local.LocalTime Day
d TimeOfDay
t) <- Parser LocalTime
localTime
Maybe TimeZone
mtz <- Parser (Maybe TimeZone)
timeZone
case Maybe TimeZone
mtz of
Maybe TimeZone
Nothing -> let !tt :: DiffTime
tt = TimeOfDay -> DiffTime
Local.timeOfDayToTime TimeOfDay
t
in forall (m :: * -> *) a. Monad m => a -> m a
return (Day -> DiffTime -> UTCTime
UTCTime Day
d DiffTime
tt)
Just TimeZone
tz -> forall (m :: * -> *) a. Monad m => a -> m a
return 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser 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
<$> Parser (Maybe TimeZone)
timeZone)
utc :: Local.TimeZone
utc :: TimeZone
utc = Int -> Bool -> String -> TimeZone
Local.TimeZone Int
0 Bool
False String
""
txtToInteger :: T.Text -> Integer
txtToInteger :: Text -> Integer
txtToInteger Text
bs
| Int
l forall a. Ord a => a -> a -> Bool
> Int
40 = Integer -> Int -> [Integer] -> Integer
valInteger Integer
10 Int
l [ forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
w forall a. Num a => a -> a -> a
- Int
48) | Char
w <- Text -> String
T.unpack Text
bs ]
| Bool
otherwise = Text -> Integer
txtToIntegerSimple Text
bs
where
l :: Int
l = Text -> Int
T.length Text
bs
txtToIntegerSimple :: T.Text -> Integer
txtToIntegerSimple :: Text -> Integer
txtToIntegerSimple = forall a. (a -> Char -> a) -> a -> Text -> a
T.foldl' forall {a}. Num a => a -> Char -> a
step Integer
0 where
step :: a -> Char -> a
step a
a Char
b = 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
b forall a. Num a => a -> a -> a
- Int
48)
valInteger :: Integer -> Int -> [Integer] -> Integer
valInteger :: Integer -> Int -> [Integer] -> Integer
valInteger = Integer -> Int -> [Integer] -> Integer
go
where
go :: Integer -> Int -> [Integer] -> Integer
go :: Integer -> Int -> [Integer] -> Integer
go Integer
_ Int
_ [] = Integer
0
go Integer
_ Int
_ [Integer
d] = Integer
d
go Integer
b Int
l [Integer]
ds
| Int
l forall a. Ord a => a -> a -> Bool
> Int
40 = Integer
b' seq :: forall a b. a -> b -> b
`seq` Integer -> Int -> [Integer] -> Integer
go Integer
b' Int
l' (forall {t}. Num t => t -> [t] -> [t]
combine Integer
b [Integer]
ds')
| Bool
otherwise = Integer -> [Integer] -> Integer
valSimple Integer
b [Integer]
ds
where
ds' :: [Integer]
ds' = if forall a. Integral a => a -> Bool
even Int
l then [Integer]
ds else Integer
0 forall a. a -> [a] -> [a]
: [Integer]
ds
b' :: Integer
b' = Integer
b forall a. Num a => a -> a -> a
* Integer
b
l' :: Int
l' = (Int
l forall a. Num a => a -> a -> a
+ Int
1) forall a. Integral a => a -> a -> a
`quot` Int
2
combine :: t -> [t] -> [t]
combine t
b (t
d1 : t
d2 : [t]
ds) = t
d seq :: forall a b. a -> b -> b
`seq` (t
d forall a. a -> [a] -> [a]
: t -> [t] -> [t]
combine t
b [t]
ds)
where
d :: t
d = t
d1 forall a. Num a => a -> a -> a
* t
b forall a. Num a => a -> a -> a
+ t
d2
combine t
_ [] = []
combine t
_ [t
_] = forall a. String -> a
errorWithoutStackTrace String
"this should not happen"
valSimple :: Integer -> [Integer] -> Integer
valSimple :: Integer -> [Integer] -> Integer
valSimple Integer
base = forall {a}. Integral a => Integer -> [a] -> Integer
go Integer
0
where
go :: Integer -> [a] -> Integer
go Integer
r [] = Integer
r
go Integer
r (a
d : [a]
ds) = Integer
r' seq :: forall a b. a -> b -> b
`seq` Integer -> [a] -> Integer
go Integer
r' [a]
ds
where
r' :: Integer
r' = Integer
r forall a. Num a => a -> a -> a
* Integer
base forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral a
d