{-# LANGUAGE CPP, BangPatterns, ScopedTypeVariables #-}
module Database.PostgreSQL.Simple.Time.Internal.Parser
(
day
, localTime
, timeOfDay
, timeZone
, UTCOffsetHMS(..)
, timeZoneHMS
, localToUTCTimeOfDayHMS
, utcTime
, zonedTime
, diffTime
) where
import Data.Attoparsec.ByteString.Char8 (Parser, peekChar, anyChar, satisfy, option, digit, isDigit, char, takeWhile1, decimal)
import Data.Bits ((.&.))
import Data.Char (ord)
import Data.Fixed (Fixed (MkFixed), Pico)
import Data.Int (Int64)
import Data.Maybe (fromMaybe)
import Data.Time.Calendar (Day, fromGregorianValid, addDays)
import Data.Time.Clock (UTCTime(UTCTime), DiffTime, picosecondsToDiffTime)
import qualified Data.ByteString.Char8 as B8
import qualified Data.Time.LocalTime as Local
#if !MIN_VERSION_base(4,13,0)
import Control.Applicative ((<$>), (<*>), (<*), (*>))
#endif
day :: Parser Day
day = do
y <- decimal <* char '-'
m <- twoDigits <* char '-'
d <- twoDigits
maybe (fail "invalid date") return (fromGregorianValid y m d)
twoDigits :: Parser Int
twoDigits = do
a <- digit
b <- digit
return $! c2d a * 10 + c2d b
timeOfDay :: Parser Local.TimeOfDay
timeOfDay = do
h <- twoDigits <* char ':'
m <- twoDigits
mc <- peekChar
s <- case mc of
Just ':' -> anyChar *> seconds
_ -> return 0
if h < 24 && m < 60 && s <= 60
then return (Local.TimeOfDay h m s)
else fail "invalid time"
seconds :: Parser Pico
seconds = do
real <- twoDigits
mc <- peekChar
case mc of
Just '.' -> do
t <- anyChar *> takeWhile1 isDigit
return $! parsePicos (fromIntegral real) t
_ -> return $! fromIntegral real
where
parsePicos :: Int64 -> B8.ByteString -> Pico
parsePicos a0 t = toPico (fromIntegral (t' * 10^n))
where n = max 0 (12 - B8.length t)
t' = B8.foldl' (\a c -> 10 * a + fromIntegral (ord c .&. 15)) a0
(B8.take 12 t)
diffTime :: Parser DiffTime
diffTime = do
h <- digits <* char ':'
m <- toInteger <$> twoDigits <* char ':'
MkFixed ps <- seconds
return $ picosecondsToDiffTime $ (h * 60 + m) * 60 * 10 ^ (12 :: Int) + ps
where
digits =
go 0
where
go acc = do
md <- option Nothing $ Just . toInteger . c2d <$> digit
case md of
Just d -> go $ d + acc * 10
Nothing -> return acc
timeZone :: Parser (Maybe Local.TimeZone)
timeZone = do
ch <- satisfy $ \c -> c == '+' || c == '-' || c == 'Z'
if ch == 'Z'
then return Nothing
else do
h <- twoDigits
mm <- peekChar
m <- case mm of
Just ':' -> anyChar *> twoDigits
_ -> return 0
let off | ch == '-' = negate off0
| otherwise = off0
off0 = h * 60 + m
case () of
_ | off == 0 ->
return Nothing
| h > 23 || m > 59 ->
fail "invalid time zone offset"
| otherwise ->
let !tz = Local.minutesToTimeZone off
in return (Just tz)
data UTCOffsetHMS = UTCOffsetHMS {-# UNPACK #-} !Int {-# UNPACK #-} !Int {-# UNPACK #-} !Int
timeZoneHMS :: Parser (Maybe UTCOffsetHMS)
timeZoneHMS = do
ch <- satisfy $ \c -> c == '+' || c == '-' || c == 'Z'
if ch == 'Z'
then return Nothing
else do
h <- twoDigits
m <- maybeTwoDigits
s <- maybeTwoDigits
case () of
_ | h == 0 && m == 0 && s == 0 ->
return Nothing
| h > 23 || m >= 60 || s >= 60 ->
fail "invalid time zone offset"
| otherwise ->
if ch == '+'
then let !tz = UTCOffsetHMS h m s
in return (Just tz)
else let !tz = UTCOffsetHMS (-h) (-m) (-s)
in return (Just tz)
where
maybeTwoDigits = do
ch <- peekChar
case ch of
Just ':' -> anyChar *> twoDigits
_ -> return 0
localToUTCTimeOfDayHMS :: UTCOffsetHMS -> Local.TimeOfDay -> (Integer, Local.TimeOfDay)
localToUTCTimeOfDayHMS (UTCOffsetHMS dh dm ds) (Local.TimeOfDay h m s) =
(\ !a !b -> (a,b)) dday (Local.TimeOfDay h'' m'' s'')
where
s' = s - fromIntegral ds
(!s'', m')
| s' < 0 = (s' + 60, m - dm - 1)
| s' >= 60 = (s' - 60, m - dm + 1)
| otherwise = (s' , m - dm )
(!m'', h')
| m' < 0 = (m' + 60, h - dh - 1)
| m' >= 60 = (m' - 60, h - dh + 1)
| otherwise = (m' , h - dh )
h'' :: Int
dday :: Integer
(!h'', dday)
| h' < 0 = (h' + 24, -1)
| h' >= 24 = (h' - 24, 1)
| otherwise = (h' , 0)
localTime :: Parser Local.LocalTime
localTime = Local.LocalTime <$> day <* daySep <*> timeOfDay
where daySep = satisfy (\c -> c == ' ' || c == 'T')
utcTime :: Parser UTCTime
utcTime = do
(Local.LocalTime d t) <- localTime
mtz <- timeZoneHMS
case mtz of
Nothing -> let !tt = Local.timeOfDayToTime t
in return (UTCTime d tt)
Just tz -> let !(dd,t') = localToUTCTimeOfDayHMS tz t
!d' = addDays dd d
!tt = Local.timeOfDayToTime t'
in return (UTCTime d' tt)
zonedTime :: Parser Local.ZonedTime
zonedTime = Local.ZonedTime <$> localTime <*> (fromMaybe utc <$> timeZone)
c2d :: Char -> Int
c2d c = ord c .&. 15
utc :: Local.TimeZone
utc = Local.TimeZone 0 False ""
toPico :: Integer -> Pico
toPico = MkFixed