{-# 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 '-'
  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)

-- | 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 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

-- | 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 ':'
  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"

-- | 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 '.' -> 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)

-- | 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
$ \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

-- | 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
$ \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)


-- | 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 (\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')

-- | Behaves as 'zonedTime', but converts any time zone offset into a
-- UTC time.
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)

-- | 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 0 Bool
False ""