{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}

-- |
-- Module:      Database.PostgreSQL.Simple.Time.Internal.Parser
-- Copyright:   (c) 2012-2015 Leon P Smith
--              (c) 2015 Bryan O'Sullivan
-- License:     BSD3
-- Maintainer:  Leon P Smith <[email protected]>
-- Stability:   experimental
--
-- Parsers for parsing dates and times.

module Database.PostgreSQL.Simple.Time.Internal.Parser
    (
      day
    , localTime
    , timeOfDay
    , timeZone
    , UTCOffsetHMS(..)
    , timeZoneHMS
    , localToUTCTimeOfDayHMS
    , utcTime
    , zonedTime
    , calendarDiffTime
    ) where

import Control.Applicative ((<$>), (<*>), (<*), (*>))
import Database.PostgreSQL.Simple.Compat (toPico)
import Data.Attoparsec.ByteString.Char8 as A
import Data.Bits ((.&.))
import Data.ByteString (ByteString)
import Data.Char (ord)
import Data.Fixed (Pico)
import Data.Int (Int64)
import Data.Maybe (fromMaybe)
import Data.Time.Calendar.Compat (Day, fromGregorianValid, addDays)
import Data.Time.Clock.Compat (UTCTime(..))
import Data.Time.Format.ISO8601.Compat (iso8601ParseM)
import Data.Time.LocalTime.Compat (CalendarDiffTime)
import qualified Data.ByteString.Char8 as B8
import qualified Data.Time.LocalTime.Compat as Local

-- | Parse a date of the form @YYYY-MM-DD@.
day :: Parser Day
day :: Parser Day
day = do
  y <- Parser Integer
forall a. Integral a => Parser a
decimal Parser Integer -> Parser ByteString Char -> Parser Integer
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ByteString Char
char Char
'-'
  m <- twoDigits <* char '-'
  d <- twoDigits
  maybe (fail "invalid date") return (fromGregorianValid y m d)

-- | Parse a two-digit integer (e.g. day of month, hour).
twoDigits :: Parser Int
twoDigits :: Parser Int
twoDigits = do
  a <- Parser ByteString Char
digit
  b <- digit
  let c2d Char
c = Char -> Int
ord Char
c Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
15
  return $! c2d a * 10 + c2d b

-- | Parse a time of the form @HH:MM[:SS[.SSS]]@.
timeOfDay :: Parser Local.TimeOfDay
timeOfDay :: Parser TimeOfDay
timeOfDay = do
  h <- Parser Int
twoDigits Parser Int -> Parser ByteString Char -> Parser Int
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ByteString Char
char Char
':'
  m <- twoDigits
  mc <- peekChar
  s <- case mc of
         Just Char
':' -> Parser ByteString Char
anyChar Parser ByteString Char
-> Parser ByteString Pico -> Parser ByteString Pico
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString Pico
seconds
         Maybe Char
_   -> Pico -> Parser ByteString Pico
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return Pico
0
  if h < 24 && m < 60 && s <= 60
    then return (Local.TimeOfDay h m s)
    else fail "invalid time"

-- | Parse a count of seconds, with the integer part being two digits
-- long.
seconds :: Parser Pico
seconds :: Parser ByteString Pico
seconds = do
  real <- Parser Int
twoDigits
  mc <- peekChar
  case mc of
    Just Char
'.' -> do
      t <- Parser ByteString Char
anyChar Parser ByteString Char
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Parser ByteString ByteString
takeWhile1 Char -> Bool
isDigit
      return $! parsePicos (fromIntegral real) t
    Maybe Char
_ -> Pico -> Parser ByteString Pico
forall a. a -> Parser ByteString a
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 Int64
a0 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
* Int64
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 Int
0 (Int
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' (\Int64
a Char
c -> Int64
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
.&. Int
15)) Int64
a0
                         (Int -> ByteString -> ByteString
B8.take Int
12 ByteString
t)

-- | Parse a time zone, and return 'Nothing' if the offset from UTC is
-- zero. (This makes some speedups possible.)
timeZone :: Parser (Maybe Local.TimeZone)
timeZone :: Parser (Maybe TimeZone)
timeZone = do
  ch <- (Char -> Bool) -> Parser ByteString Char
satisfy ((Char -> Bool) -> Parser ByteString Char)
-> (Char -> Bool) -> Parser ByteString Char
forall a b. (a -> b) -> a -> b
$ \Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'+' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'Z'
  if ch == 'Z'
    then return Nothing
    else do
      h <- twoDigits
      mm <- peekChar
      m <- case mm of
             Just Char
':'           -> Parser ByteString Char
anyChar Parser ByteString Char -> Parser Int -> Parser Int
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Int
twoDigits
             Maybe Char
_                  -> Int -> Parser Int
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
      let off | Char
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-' = Int -> Int
forall a. Num a => a -> a
negate Int
off0
              | Bool
otherwise = Int
off0
          off0 = Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
60 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
m
      case undefined of
        ZonkAny 0
_   | Int
off Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 ->
              Maybe TimeZone -> Parser (Maybe TimeZone)
forall a. a -> Parser ByteString a
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
> Int
23 Bool -> Bool -> Bool
|| Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
59 ->
              String -> Parser (Maybe TimeZone)
forall a. String -> Parser ByteString a
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 Maybe TimeZone -> Parser (Maybe TimeZone)
forall a. a -> Parser ByteString a
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

-- | Parse a time zone, and return 'Nothing' if the offset from UTC is
-- zero. (This makes some speedups possible.)
timeZoneHMS :: Parser (Maybe UTCOffsetHMS)
timeZoneHMS :: Parser (Maybe UTCOffsetHMS)
timeZoneHMS = do
  ch <- (Char -> Bool) -> Parser ByteString Char
satisfy ((Char -> Bool) -> Parser ByteString Char)
-> (Char -> Bool) -> Parser ByteString Char
forall a b. (a -> b) -> a -> b
$ \Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'+' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'Z'
  if ch == 'Z'
    then return Nothing
    else do
      h <- twoDigits
      m <- maybeTwoDigits
      s <- maybeTwoDigits
      case undefined of
        ZonkAny 1
_   | Int
h Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& Int
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 ->
              Maybe UTCOffsetHMS -> Parser (Maybe UTCOffsetHMS)
forall a. a -> Parser ByteString a
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
> Int
23 Bool -> Bool -> Bool
|| Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
60 Bool -> Bool -> Bool
|| Int
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
60 ->
              String -> Parser (Maybe UTCOffsetHMS)
forall a. String -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"invalid time zone offset"
            | Bool
otherwise ->
                if Char
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'+'
                then let !tz :: UTCOffsetHMS
tz = Int -> Int -> Int -> UTCOffsetHMS
UTCOffsetHMS Int
h Int
m Int
s
                      in Maybe UTCOffsetHMS -> Parser (Maybe UTCOffsetHMS)
forall a. a -> Parser ByteString a
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 a. a -> Parser ByteString a
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
        ch <- Parser (Maybe Char)
peekChar
        case ch of
          Just Char
':' -> Parser ByteString Char
anyChar Parser ByteString Char -> Parser Int -> Parser Int
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Int
twoDigits
          Maybe Char
_        -> Int -> Parser Int
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0

localToUTCTimeOfDayHMS :: UTCOffsetHMS -> Local.TimeOfDay -> (Integer, Local.TimeOfDay)
localToUTCTimeOfDayHMS :: UTCOffsetHMS -> TimeOfDay -> (Integer, TimeOfDay)
localToUTCTimeOfDayHMS (UTCOffsetHMS Int
dh Int
dm Int
ds) (Local.TimeOfDay Int
h Int
m 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'', Int
m')
        | Pico
s' Pico -> Pico -> Bool
forall a. Ord a => a -> a -> Bool
< Pico
0    = (Pico
s' Pico -> Pico -> Pico
forall a. Num a => a -> a -> a
+ Pico
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
- Int
1)
        | Pico
s' Pico -> Pico -> Bool
forall a. Ord a => a -> a -> Bool
>= Pico
60  = (Pico
s' Pico -> Pico -> Pico
forall a. Num a => a -> a -> a
- Pico
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
+ Int
1)
        | Bool
otherwise = (Pico
s'     , Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
dm    )
    (!Int
m'', Int
h')
        | Int
m' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0    = (Int
m' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
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
- Int
1)
        | Int
m' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
60  = (Int
m' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
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
+ Int
1)
        | Bool
otherwise = (Int
m'     , Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
dh    )
    (!Int
h'', Integer
dday)
        | Int
h' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0    = (Int
h' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
24, -Integer
1)
        | Int
h' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
24  = (Int
h' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
24,  Integer
1)
        | Bool
otherwise = (Int
h'     ,  Integer
0)


-- | Parse a date and time, of the form @YYYY-MM-DD HH:MM:SS@.
-- The space may be replaced with a @T@.  The number of seconds may be
-- followed by a fractional component.
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 a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
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 a b.
Parser ByteString (a -> b)
-> Parser ByteString a -> Parser ByteString b
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 (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'T')

-- | Behaves as 'zonedTime', but converts any time zone offset into a
-- UTC time.
utcTime :: Parser UTCTime
utcTime :: Parser UTCTime
utcTime = do
  (Local.LocalTime d t) <- Parser LocalTime
localTime
  mtz <- timeZoneHMS
  case mtz of
    Maybe UTCOffsetHMS
Nothing -> let !tt :: DiffTime
tt = TimeOfDay -> DiffTime
Local.timeOfDayToTime TimeOfDay
t
               in UTCTime -> Parser UTCTime
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return (Day -> DiffTime -> UTCTime
UTCTime Day
d DiffTime
tt)
    Just UTCOffsetHMS
tz -> let !(Integer
dd,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 a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return (Day -> DiffTime -> UTCTime
UTCTime Day
d' DiffTime
tt)

-- | Parse a date with time zone info. Acceptable formats:
--
-- @YYYY-MM-DD HH:MM:SS Z@
--
-- The first space may instead be a @T@, and the second space is
-- optional.  The @Z@ represents UTC.  The @Z@ may be replaced with a
-- time zone offset of the form @+0000@ or @-08:00@, where the first
-- two digits are hours, the @:@ is optional and the second two digits
-- (also optional) are minutes.
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 a b.
Parser ByteString (a -> b)
-> Parser ByteString a -> Parser ByteString b
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 Int
0 Bool
False String
""

calendarDiffTime :: Parser CalendarDiffTime
calendarDiffTime :: Parser CalendarDiffTime
calendarDiffTime = do
  contents <- Parser ByteString ByteString
takeByteString
  iso8601ParseM $ B8.unpack contents