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