{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}
module Database.PostgreSQL.Simple.Time.Internal.Parser
(
day
, localTime
, timeOfDay
, timeZone
, UTCOffsetHMS(..)
, timeZoneHMS
, localToUTCTimeOfDayHMS
, utcTime
, zonedTime
) where
import Control.Applicative ((<$>), (<*>), (<*), (*>))
import Database.PostgreSQL.Simple.Compat (toPico)
import Data.Attoparsec.ByteString.Char8 as A
import Data.Bits ((.&.))
import Data.Char (ord)
import Data.Fixed (Pico)
import Data.Int (Int64)
import Data.Maybe (fromMaybe)
import Data.Time.Calendar (Day, fromGregorianValid, addDays)
import Data.Time.Clock (UTCTime(..))
import qualified Data.ByteString.Char8 as B8
import qualified Data.Time.LocalTime as Local
day :: Parser Day
day :: Parser Day
day = do
Integer
y <- Parser Integer
forall a. Integral a => Parser a
decimal Parser Integer -> Parser ByteString Char -> Parser Integer
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ByteString Char
char '-'
Int
m <- Parser Int
twoDigits Parser Int -> Parser ByteString Char -> Parser Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ByteString Char
char '-'
Int
d <- Parser Int
twoDigits
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
y Int
m Int
d)
twoDigits :: Parser Int
twoDigits :: Parser Int
twoDigits = do
Char
a <- Parser ByteString Char
digit
Char
b <- Parser ByteString 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 Parser Int -> Parser ByteString Char -> Parser Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ByteString Char
char ':'
Int
m <- Parser Int
twoDigits
Maybe Char
mc <- Parser (Maybe Char)
peekChar
Pico
s <- case Maybe Char
mc of
Just ':' -> Parser ByteString Char
anyChar Parser ByteString Char
-> Parser ByteString Pico -> Parser ByteString Pico
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString Pico
seconds
_ -> Pico -> Parser ByteString Pico
forall (m :: * -> *) a. Monad m => a -> m a
return 0
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
<= 60
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"
seconds :: Parser Pico
seconds :: Parser ByteString Pico
seconds = do
Int
real <- Parser Int
twoDigits
Maybe Char
mc <- Parser (Maybe Char)
peekChar
case Maybe Char
mc of
Just '.' -> do
ByteString
t <- Parser ByteString Char
anyChar Parser ByteString Char
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Parser ByteString ByteString
takeWhile1 Char -> Bool
isDigit
Pico -> Parser ByteString Pico
forall (m :: * -> *) a. Monad m => a -> m a
return (Pico -> Parser ByteString Pico) -> Pico -> Parser ByteString Pico
forall a b. (a -> b) -> a -> b
$! Int64 -> ByteString -> Pico
parsePicos (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
real) ByteString
t
_ -> Pico -> Parser ByteString Pico
forall (m :: * -> *) a. Monad m => a -> m a
return (Pico -> Parser ByteString Pico) -> Pico -> Parser ByteString Pico
forall a b. (a -> b) -> a -> b
$! Int -> Pico
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
real
where
parsePicos :: Int64 -> B8.ByteString -> Pico
parsePicos :: Int64 -> ByteString -> Pico
parsePicos a0 :: Int64
a0 t :: ByteString
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 n :: Int
n = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max 0 (12 Int -> Int -> Int
forall a. Num a => a -> a -> a
- ByteString -> Int
B8.length ByteString
t)
t' :: Int64
t' = (Int64 -> Char -> Int64) -> Int64 -> ByteString -> Int64
forall a. (a -> Char -> a) -> a -> ByteString -> a
B8.foldl' (\a :: Int64
a c :: Char
c -> 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 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. 15)) Int64
a0
(Int -> ByteString -> ByteString
B8.take 12 ByteString
t)
timeZone :: Parser (Maybe Local.TimeZone)
timeZone :: Parser (Maybe TimeZone)
timeZone = do
Char
ch <- (Char -> Bool) -> Parser ByteString Char
satisfy ((Char -> Bool) -> Parser ByteString Char)
-> (Char -> Bool) -> Parser ByteString Char
forall a b. (a -> b) -> a -> b
$ \c :: Char
c -> 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
== '-' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== 'Z'
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 ByteString Char
anyChar Parser ByteString Char -> Parser Int -> Parser Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> 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
h Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 23 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)
data UTCOffsetHMS = UTCOffsetHMS {-# UNPACK #-} !Int {-# UNPACK #-} !Int {-# UNPACK #-} !Int
timeZoneHMS :: Parser (Maybe UTCOffsetHMS)
timeZoneHMS :: Parser (Maybe UTCOffsetHMS)
timeZoneHMS = do
Char
ch <- (Char -> Bool) -> Parser ByteString Char
satisfy ((Char -> Bool) -> Parser ByteString Char)
-> (Char -> Bool) -> Parser ByteString Char
forall a b. (a -> b) -> a -> b
$ \c :: Char
c -> 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
== '-' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== 'Z'
if Char
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== 'Z'
then Maybe UTCOffsetHMS -> Parser (Maybe UTCOffsetHMS)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe UTCOffsetHMS
forall a. Maybe a
Nothing
else do
Int
h <- Parser Int
twoDigits
Int
m <- Parser Int
maybeTwoDigits
Int
s <- Parser Int
maybeTwoDigits
case Any
forall a. HasCallStack => a
undefined of
_ | Int
h Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 Bool -> Bool -> Bool
&& Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 Bool -> Bool -> Bool
&& Int
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 ->
Maybe UTCOffsetHMS -> Parser (Maybe UTCOffsetHMS)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe UTCOffsetHMS
forall a. Maybe a
Nothing
| Int
h Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 23 Bool -> Bool -> Bool
|| Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 60 Bool -> Bool -> Bool
|| Int
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 60 ->
String -> Parser (Maybe UTCOffsetHMS)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "invalid time zone offset"
| Bool
otherwise ->
if Char
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '+'
then let !tz :: UTCOffsetHMS
tz = Int -> Int -> Int -> UTCOffsetHMS
UTCOffsetHMS Int
h Int
m Int
s
in Maybe UTCOffsetHMS -> Parser (Maybe UTCOffsetHMS)
forall (m :: * -> *) a. Monad m => a -> m a
return (UTCOffsetHMS -> Maybe UTCOffsetHMS
forall a. a -> Maybe a
Just UTCOffsetHMS
tz)
else let !tz :: UTCOffsetHMS
tz = Int -> Int -> Int -> UTCOffsetHMS
UTCOffsetHMS (-Int
h) (-Int
m) (-Int
s)
in Maybe UTCOffsetHMS -> Parser (Maybe UTCOffsetHMS)
forall (m :: * -> *) a. Monad m => a -> m a
return (UTCOffsetHMS -> Maybe UTCOffsetHMS
forall a. a -> Maybe a
Just UTCOffsetHMS
tz)
where
maybeTwoDigits :: Parser Int
maybeTwoDigits = do
Maybe Char
ch <- Parser (Maybe Char)
peekChar
case Maybe Char
ch of
Just ':' -> Parser ByteString Char
anyChar Parser ByteString Char -> Parser Int -> Parser Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Int
twoDigits
_ -> Int -> Parser Int
forall (m :: * -> *) a. Monad m => a -> m a
return 0
localToUTCTimeOfDayHMS :: UTCOffsetHMS -> Local.TimeOfDay -> (Integer, Local.TimeOfDay)
localToUTCTimeOfDayHMS :: UTCOffsetHMS -> TimeOfDay -> (Integer, TimeOfDay)
localToUTCTimeOfDayHMS (UTCOffsetHMS dh :: Int
dh dm :: Int
dm ds :: Int
ds) (Local.TimeOfDay h :: Int
h m :: Int
m s :: Pico
s) =
(\ !Integer
a !TimeOfDay
b -> (Integer
a,TimeOfDay
b)) Integer
dday (Int -> Int -> Pico -> TimeOfDay
Local.TimeOfDay Int
h'' Int
m'' Pico
s'')
where
s' :: Pico
s' = Pico
s Pico -> Pico -> Pico
forall a. Num a => a -> a -> a
- Int -> Pico
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ds
(!Pico
s'', m' :: Int
m')
| Pico
s' Pico -> Pico -> Bool
forall a. Ord a => a -> a -> Bool
< 0 = (Pico
s' Pico -> Pico -> Pico
forall a. Num a => a -> a -> a
+ 60, Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
dm Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1)
| Pico
s' Pico -> Pico -> Bool
forall a. Ord a => a -> a -> Bool
>= 60 = (Pico
s' Pico -> Pico -> Pico
forall a. Num a => a -> a -> a
- 60, Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
dm Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1)
| Bool
otherwise = (Pico
s' , Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
dm )
(!Int
m'', h' :: Int
h')
| Int
m' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 0 = (Int
m' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 60, Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
dh Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1)
| Int
m' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 60 = (Int
m' Int -> Int -> Int
forall a. Num a => a -> a -> a
- 60, Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
dh Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1)
| Bool
otherwise = (Int
m' , Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
dh )
(!Int
h'', dday :: Integer
dday)
| Int
h' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 0 = (Int
h' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 24, -1)
| Int
h' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 24 = (Int
h' Int -> Int -> Int
forall a. Num a => a -> a -> a
- 24, 1)
| Bool
otherwise = (Int
h' , 0)
localTime :: Parser Local.LocalTime
localTime :: Parser LocalTime
localTime = Day -> TimeOfDay -> LocalTime
Local.LocalTime (Day -> TimeOfDay -> LocalTime)
-> Parser Day -> Parser ByteString (TimeOfDay -> LocalTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Day
day Parser ByteString (TimeOfDay -> LocalTime)
-> Parser ByteString Char
-> Parser ByteString (TimeOfDay -> LocalTime)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString Char
daySep Parser ByteString (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 ByteString Char
daySep = (Char -> Bool) -> Parser ByteString Char
satisfy (\c :: Char
c -> 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
== 'T')
utcTime :: Parser UTCTime
utcTime :: Parser UTCTime
utcTime = do
(Local.LocalTime d :: Day
d t :: TimeOfDay
t) <- Parser LocalTime
localTime
Maybe UTCOffsetHMS
mtz <- Parser (Maybe UTCOffsetHMS)
timeZoneHMS
case Maybe UTCOffsetHMS
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 :: UTCOffsetHMS
tz -> let !(dd :: Integer
dd,t' :: TimeOfDay
t') = UTCOffsetHMS -> TimeOfDay -> (Integer, TimeOfDay)
localToUTCTimeOfDayHMS UTCOffsetHMS
tz TimeOfDay
t
!d' :: Day
d' = Integer -> Day -> Day
addDays Integer
dd Day
d
!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)
zonedTime :: Parser Local.ZonedTime
zonedTime :: Parser ZonedTime
zonedTime = LocalTime -> TimeZone -> ZonedTime
Local.ZonedTime (LocalTime -> TimeZone -> ZonedTime)
-> Parser LocalTime -> Parser ByteString (TimeZone -> ZonedTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser LocalTime
localTime Parser ByteString (TimeZone -> ZonedTime)
-> Parser ByteString 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 ByteString 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 ""