{-# 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 <leon@melding-monads.com>
-- Stability:   experimental
--
-- Parsers for parsing dates and times.

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

-- | Parse a date of the form @YYYY-MM-DD@.
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 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 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 String
"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)

-- | Parse a two-digit integer (e.g. day of month, hour).
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 Char
c = Char -> Int
ord Char
c Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
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
* Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
c2d Char
b

-- | Parse a time of the form @HH:MM[:SS[.SSS]]@.
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 Char
':'
  Int
m <- Parser Int
twoDigits
  Maybe Char
mc <- Parser (Maybe Char)
peekChar
  Pico
s <- case Maybe Char
mc of
         Just Char
':' -> 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
         Maybe Char
_   -> Pico -> Parser ByteString Pico
forall (m :: * -> *) a. Monad m => a -> m a
return Pico
0
  if Int
h Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
24 Bool -> Bool -> Bool
&& Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
60 Bool -> Bool -> Bool
&& Pico
s Pico -> Pico -> Bool
forall a. Ord a => a -> a -> Bool
<= Pico
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 String
"invalid time"

-- | Parse a count of seconds, with the integer part being two digits
-- long.
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 Char
'.' -> 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
    Maybe Char
_ -> 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 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
  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
$ \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 Char
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'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 Char
':'           -> 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
             Maybe Char
_                  -> Int -> Parser Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
      let off :: Int
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
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 Any
forall a. HasCallStack => a
undefined of
        Any
_   | Int
off Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
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
> Int
23 Bool -> Bool -> Bool
|| Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
59 ->
              String -> Parser (Maybe TimeZone)
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 (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
  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
$ \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 Char
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'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
        Any
_   | 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 (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 (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 (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 Char
':' -> 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
          Maybe Char
_        -> Int -> Parser Int
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 (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 (\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 Day
d TimeOfDay
t) <- Parser LocalTime
localTime
  Maybe UTCOffsetHMS
mtz <- Parser (Maybe UTCOffsetHMS)
timeZoneHMS
  case Maybe UTCOffsetHMS
mtz of
    Maybe UTCOffsetHMS
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 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 (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 (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
""