{-# 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
    , 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
  Integer
y <- forall a. Integral a => Parser a
decimal forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
char Char
'-'
  Int
m <- Parser ByteString Int
twoDigits forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
char Char
'-'
  Int
d <- Parser ByteString Int
twoDigits
  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
y Int
m Int
d)

-- | Parse a two-digit integer (e.g. day of month, hour).
twoDigits :: Parser Int
twoDigits :: Parser ByteString 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

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

-- | 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 ByteString Int
twoDigits
  Maybe Char
mc <- Parser (Maybe Char)
peekChar
  case Maybe Char
mc of
    Just Char
'.' -> do
      ByteString
t <- Parser Char
anyChar forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Parser ByteString ByteString
takeWhile1 Char -> Bool
isDigit
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Int64 -> ByteString -> Pico
parsePicos (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
real) ByteString
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 :: Int64 -> B8.ByteString -> Pico
  parsePicos :: Int64 -> ByteString -> Pico
parsePicos Int64
a0 ByteString
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 n :: Int
n  = forall a. Ord a => a -> a -> a
max Int
0 (Int
12 forall a. Num a => a -> a -> a
- ByteString -> Int
B8.length ByteString
t)
          t' :: Int64
t' = forall a. (a -> Char -> a) -> a -> ByteString -> a
B8.foldl' (\Int64
a Char
c -> 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
.&. 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 Char
satisfy forall a b. (a -> b) -> a -> b
$ \Char
c -> Char
c forall a. Eq a => a -> a -> Bool
== Char
'+' 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
'Z'
  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 ByteString 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 ByteString 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
h forall a. Ord a => a -> a -> Bool
> Int
23 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)

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 Char
satisfy forall a b. (a -> b) -> a -> b
$ \Char
c -> Char
c forall a. Eq a => a -> a -> Bool
== Char
'+' 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
'Z'
  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 ByteString Int
twoDigits
      Int
m <- Parser ByteString Int
maybeTwoDigits
      Int
s <- Parser ByteString Int
maybeTwoDigits
      case forall a. HasCallStack => a
undefined of
        Any
_   | Int
h forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& Int
m forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& Int
s forall a. Eq a => a -> a -> Bool
== Int
0 ->
              forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
            | Int
h forall a. Ord a => a -> a -> Bool
> Int
23 Bool -> Bool -> Bool
|| Int
m forall a. Ord a => a -> a -> Bool
>= Int
60 Bool -> Bool -> Bool
|| Int
s forall a. Ord a => a -> a -> Bool
>= Int
60 ->
              forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"invalid time zone offset"
            | Bool
otherwise ->
                if Char
ch 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 forall (m :: * -> *) a. Monad m => a -> m a
return (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 forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just UTCOffsetHMS
tz)
  where
    maybeTwoDigits :: Parser ByteString Int
maybeTwoDigits = do
        Maybe Char
ch <- Parser (Maybe Char)
peekChar
        case Maybe Char
ch of
          Just Char
':' -> Parser Char
anyChar forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString Int
twoDigits
          Maybe Char
_        -> 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 forall a. Num a => a -> a -> a
- forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ds
    (!Pico
s'', Int
m')
        | Pico
s' forall a. Ord a => a -> a -> Bool
< Pico
0    = (Pico
s' forall a. Num a => a -> a -> a
+ Pico
60, Int
m forall a. Num a => a -> a -> a
- Int
dm forall a. Num a => a -> a -> a
- Int
1)
        | Pico
s' forall a. Ord a => a -> a -> Bool
>= Pico
60  = (Pico
s' forall a. Num a => a -> a -> a
- Pico
60, Int
m forall a. Num a => a -> a -> a
- Int
dm forall a. Num a => a -> a -> a
+ Int
1)
        | Bool
otherwise = (Pico
s'     , Int
m forall a. Num a => a -> a -> a
- Int
dm    )
    (!Int
m'', Int
h')
        | Int
m' forall a. Ord a => a -> a -> Bool
< Int
0    = (Int
m' forall a. Num a => a -> a -> a
+ Int
60, Int
h forall a. Num a => a -> a -> a
- Int
dh forall a. Num a => a -> a -> a
- Int
1)
        | Int
m' forall a. Ord a => a -> a -> Bool
>= Int
60  = (Int
m' forall a. Num a => a -> a -> a
- Int
60, Int
h forall a. Num a => a -> a -> a
- Int
dh forall a. Num a => a -> a -> a
+ Int
1)
        | Bool
otherwise = (Int
m'     , Int
h forall a. Num a => a -> a -> a
- Int
dh    )
    (!Int
h'', Integer
dday)
        | Int
h' forall a. Ord a => a -> a -> Bool
< Int
0    = (Int
h' forall a. Num a => a -> a -> a
+ Int
24, -Integer
1)
        | Int
h' forall a. Ord a => a -> a -> Bool
>= Int
24  = (Int
h' 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 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
' ' Bool -> Bool -> Bool
|| Char
c 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 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 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 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
""

calendarDiffTime :: Parser CalendarDiffTime
calendarDiffTime :: Parser CalendarDiffTime
calendarDiffTime = do
  ByteString
contents <- Parser ByteString ByteString
takeByteString
  forall (m :: * -> *) t. (MonadFail m, ISO8601 t) => String -> m t
iso8601ParseM forall a b. (a -> b) -> a -> b
$ ByteString -> String
B8.unpack ByteString
contents