------------------------------------------------------------------------------
-- |
-- Module:      Database.PostgreSQL.Simple.Time.Implementation
-- Copyright:   (c) 2012-2015 Leon P Smith
-- License:     BSD3
-- Maintainer:  Leon P Smith <leon@melding-monads.com>
-- Stability:   experimental
--
------------------------------------------------------------------------------

{-# LANGUAGE DeriveDataTypeable, DeriveFunctor #-}

module Database.PostgreSQL.Simple.Time.Implementation where

import Prelude hiding (take)
import Data.ByteString.Builder(Builder, byteString)
import Data.ByteString.Builder.Prim(primBounded)
import Control.Arrow((***))
import Control.Applicative
import qualified Data.ByteString as B
import Data.Time.Compat (LocalTime, UTCTime, ZonedTime, Day, TimeOfDay, TimeZone, NominalDiffTime, utc)
import Data.Time.LocalTime.Compat (CalendarDiffTime)
import Data.Typeable
import Data.Maybe (fromMaybe)
import qualified Data.Attoparsec.ByteString.Char8 as A
import Database.PostgreSQL.Simple.Compat ((<>))
import qualified Database.PostgreSQL.Simple.Time.Internal.Parser  as TP
import qualified Database.PostgreSQL.Simple.Time.Internal.Printer as TPP

data Unbounded a
   = NegInfinity
   | Finite !a
   | PosInfinity
     deriving (Unbounded a -> Unbounded a -> Bool
(Unbounded a -> Unbounded a -> Bool)
-> (Unbounded a -> Unbounded a -> Bool) -> Eq (Unbounded a)
forall a. Eq a => Unbounded a -> Unbounded a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Unbounded a -> Unbounded a -> Bool
$c/= :: forall a. Eq a => Unbounded a -> Unbounded a -> Bool
== :: Unbounded a -> Unbounded a -> Bool
$c== :: forall a. Eq a => Unbounded a -> Unbounded a -> Bool
Eq, Eq (Unbounded a)
Eq (Unbounded a)
-> (Unbounded a -> Unbounded a -> Ordering)
-> (Unbounded a -> Unbounded a -> Bool)
-> (Unbounded a -> Unbounded a -> Bool)
-> (Unbounded a -> Unbounded a -> Bool)
-> (Unbounded a -> Unbounded a -> Bool)
-> (Unbounded a -> Unbounded a -> Unbounded a)
-> (Unbounded a -> Unbounded a -> Unbounded a)
-> Ord (Unbounded a)
Unbounded a -> Unbounded a -> Bool
Unbounded a -> Unbounded a -> Ordering
Unbounded a -> Unbounded a -> Unbounded a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (Unbounded a)
forall a. Ord a => Unbounded a -> Unbounded a -> Bool
forall a. Ord a => Unbounded a -> Unbounded a -> Ordering
forall a. Ord a => Unbounded a -> Unbounded a -> Unbounded a
min :: Unbounded a -> Unbounded a -> Unbounded a
$cmin :: forall a. Ord a => Unbounded a -> Unbounded a -> Unbounded a
max :: Unbounded a -> Unbounded a -> Unbounded a
$cmax :: forall a. Ord a => Unbounded a -> Unbounded a -> Unbounded a
>= :: Unbounded a -> Unbounded a -> Bool
$c>= :: forall a. Ord a => Unbounded a -> Unbounded a -> Bool
> :: Unbounded a -> Unbounded a -> Bool
$c> :: forall a. Ord a => Unbounded a -> Unbounded a -> Bool
<= :: Unbounded a -> Unbounded a -> Bool
$c<= :: forall a. Ord a => Unbounded a -> Unbounded a -> Bool
< :: Unbounded a -> Unbounded a -> Bool
$c< :: forall a. Ord a => Unbounded a -> Unbounded a -> Bool
compare :: Unbounded a -> Unbounded a -> Ordering
$ccompare :: forall a. Ord a => Unbounded a -> Unbounded a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (Unbounded a)
Ord, Typeable, a -> Unbounded b -> Unbounded a
(a -> b) -> Unbounded a -> Unbounded b
(forall a b. (a -> b) -> Unbounded a -> Unbounded b)
-> (forall a b. a -> Unbounded b -> Unbounded a)
-> Functor Unbounded
forall a b. a -> Unbounded b -> Unbounded a
forall a b. (a -> b) -> Unbounded a -> Unbounded b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Unbounded b -> Unbounded a
$c<$ :: forall a b. a -> Unbounded b -> Unbounded a
fmap :: (a -> b) -> Unbounded a -> Unbounded b
$cfmap :: forall a b. (a -> b) -> Unbounded a -> Unbounded b
Functor)

instance Show a => Show (Unbounded a) where
  showsPrec :: Int -> Unbounded a -> ShowS
showsPrec Int
prec Unbounded a
x String
rest
    = case Unbounded a
x of
        Unbounded a
NegInfinity -> String
"-infinity" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
rest
        Finite a
time -> Int -> a -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
prec a
time String
rest
        Unbounded a
PosInfinity ->  String
"infinity" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
rest

instance Read a => Read (Unbounded a) where
  readsPrec :: Int -> ReadS (Unbounded a)
readsPrec Int
prec = Bool -> ReadS (Unbounded a) -> ReadS (Unbounded a)
forall a. Bool -> ReadS a -> ReadS a
readParen Bool
False (ReadS (Unbounded a) -> ReadS (Unbounded a))
-> ReadS (Unbounded a) -> ReadS (Unbounded a)
forall a b. (a -> b) -> a -> b
$ \String
str -> case String
str of
    (Char
'-':Char
'i':Char
'n':Char
'f':Char
'i':Char
'n':Char
'i':Char
't':Char
'y':String
xs)  -> [(Unbounded a
forall a. Unbounded a
NegInfinity,String
xs)]
    (    Char
'i':Char
'n':Char
'f':Char
'i':Char
'n':Char
'i':Char
't':Char
'y':String
xs)  -> [(Unbounded a
forall a. Unbounded a
PosInfinity,String
xs)]
    String
xs -> ((a, String) -> (Unbounded a, String))
-> [(a, String)] -> [(Unbounded a, String)]
forall a b. (a -> b) -> [a] -> [b]
map (a -> Unbounded a
forall a. a -> Unbounded a
Finite (a -> Unbounded a) -> ShowS -> (a, String) -> (Unbounded a, String)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** ShowS
forall a. a -> a
id) (Int -> ReadS a
forall a. Read a => Int -> ReadS a
readsPrec Int
prec String
xs)

type LocalTimestamp = Unbounded LocalTime
type UTCTimestamp   = Unbounded UTCTime
type ZonedTimestamp = Unbounded ZonedTime
type Date           = Unbounded Day

parseUTCTime   :: B.ByteString -> Either String UTCTime
parseUTCTime :: ByteString -> Either String UTCTime
parseUTCTime   = Parser UTCTime -> ByteString -> Either String UTCTime
forall a. Parser a -> ByteString -> Either String a
A.parseOnly (Parser UTCTime
getUTCTime Parser UTCTime -> Parser ByteString () -> Parser UTCTime
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
forall t. Chunk t => Parser t ()
A.endOfInput)

parseZonedTime :: B.ByteString -> Either String ZonedTime
parseZonedTime :: ByteString -> Either String ZonedTime
parseZonedTime = Parser ZonedTime -> ByteString -> Either String ZonedTime
forall a. Parser a -> ByteString -> Either String a
A.parseOnly (Parser ZonedTime
getZonedTime Parser ZonedTime -> Parser ByteString () -> Parser ZonedTime
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
forall t. Chunk t => Parser t ()
A.endOfInput)

parseLocalTime :: B.ByteString -> Either String LocalTime
parseLocalTime :: ByteString -> Either String LocalTime
parseLocalTime = Parser LocalTime -> ByteString -> Either String LocalTime
forall a. Parser a -> ByteString -> Either String a
A.parseOnly (Parser LocalTime
getLocalTime Parser LocalTime -> Parser ByteString () -> Parser LocalTime
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
forall t. Chunk t => Parser t ()
A.endOfInput)

parseDay :: B.ByteString -> Either String Day
parseDay :: ByteString -> Either String Day
parseDay = Parser Day -> ByteString -> Either String Day
forall a. Parser a -> ByteString -> Either String a
A.parseOnly (Parser Day
getDay Parser Day -> Parser ByteString () -> Parser Day
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
forall t. Chunk t => Parser t ()
A.endOfInput)

parseTimeOfDay :: B.ByteString -> Either String TimeOfDay
parseTimeOfDay :: ByteString -> Either String TimeOfDay
parseTimeOfDay = Parser TimeOfDay -> ByteString -> Either String TimeOfDay
forall a. Parser a -> ByteString -> Either String a
A.parseOnly (Parser TimeOfDay
getTimeOfDay Parser TimeOfDay -> Parser ByteString () -> Parser TimeOfDay
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
forall t. Chunk t => Parser t ()
A.endOfInput)

parseUTCTimestamp   :: B.ByteString -> Either String UTCTimestamp
parseUTCTimestamp :: ByteString -> Either String UTCTimestamp
parseUTCTimestamp   = Parser UTCTimestamp -> ByteString -> Either String UTCTimestamp
forall a. Parser a -> ByteString -> Either String a
A.parseOnly (Parser UTCTimestamp
getUTCTimestamp Parser UTCTimestamp -> Parser ByteString () -> Parser UTCTimestamp
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
forall t. Chunk t => Parser t ()
A.endOfInput)

parseZonedTimestamp :: B.ByteString -> Either String ZonedTimestamp
parseZonedTimestamp :: ByteString -> Either String ZonedTimestamp
parseZonedTimestamp = Parser ZonedTimestamp -> ByteString -> Either String ZonedTimestamp
forall a. Parser a -> ByteString -> Either String a
A.parseOnly (Parser ZonedTimestamp
getZonedTimestamp Parser ZonedTimestamp
-> Parser ByteString () -> Parser ZonedTimestamp
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
forall t. Chunk t => Parser t ()
A.endOfInput)

parseLocalTimestamp :: B.ByteString -> Either String LocalTimestamp
parseLocalTimestamp :: ByteString -> Either String LocalTimestamp
parseLocalTimestamp = Parser LocalTimestamp -> ByteString -> Either String LocalTimestamp
forall a. Parser a -> ByteString -> Either String a
A.parseOnly (Parser LocalTimestamp
getLocalTimestamp Parser LocalTimestamp
-> Parser ByteString () -> Parser LocalTimestamp
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
forall t. Chunk t => Parser t ()
A.endOfInput)

parseDate :: B.ByteString -> Either String Date
parseDate :: ByteString -> Either String Date
parseDate = Parser Date -> ByteString -> Either String Date
forall a. Parser a -> ByteString -> Either String a
A.parseOnly (Parser Date
getDate Parser Date -> Parser ByteString () -> Parser Date
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
forall t. Chunk t => Parser t ()
A.endOfInput)

parseCalendarDiffTime :: B.ByteString -> Either String CalendarDiffTime
parseCalendarDiffTime :: ByteString -> Either String CalendarDiffTime
parseCalendarDiffTime = Parser CalendarDiffTime
-> ByteString -> Either String CalendarDiffTime
forall a. Parser a -> ByteString -> Either String a
A.parseOnly (Parser CalendarDiffTime
getCalendarDiffTime Parser CalendarDiffTime
-> Parser ByteString () -> Parser CalendarDiffTime
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
forall t. Chunk t => Parser t ()
A.endOfInput)

getUnbounded :: A.Parser a -> A.Parser (Unbounded a)
getUnbounded :: Parser a -> Parser (Unbounded a)
getUnbounded Parser a
getFinite
    =     (Unbounded a -> Parser (Unbounded a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Unbounded a
forall a. Unbounded a
NegInfinity Parser (Unbounded a)
-> Parser ByteString ByteString -> Parser (Unbounded a)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ByteString -> Parser ByteString ByteString
A.string ByteString
"-infinity")
      Parser (Unbounded a)
-> Parser (Unbounded a) -> Parser (Unbounded a)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Unbounded a -> Parser (Unbounded a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Unbounded a
forall a. Unbounded a
PosInfinity Parser (Unbounded a)
-> Parser ByteString ByteString -> Parser (Unbounded a)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ByteString -> Parser ByteString ByteString
A.string  ByteString
"infinity")
      Parser (Unbounded a)
-> Parser (Unbounded a) -> Parser (Unbounded a)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (a -> Unbounded a
forall a. a -> Unbounded a
Finite (a -> Unbounded a) -> Parser a -> Parser (Unbounded a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser a
getFinite)

getDay :: A.Parser Day
getDay :: Parser Day
getDay = Parser Day
TP.day

getDate :: A.Parser Date
getDate :: Parser Date
getDate = Parser Day -> Parser Date
forall a. Parser a -> Parser (Unbounded a)
getUnbounded Parser Day
getDay

getTimeOfDay :: A.Parser TimeOfDay
getTimeOfDay :: Parser TimeOfDay
getTimeOfDay = Parser TimeOfDay
TP.timeOfDay

getLocalTime :: A.Parser LocalTime
getLocalTime :: Parser LocalTime
getLocalTime = Parser LocalTime
TP.localTime

getLocalTimestamp :: A.Parser LocalTimestamp
getLocalTimestamp :: Parser LocalTimestamp
getLocalTimestamp = Parser LocalTime -> Parser LocalTimestamp
forall a. Parser a -> Parser (Unbounded a)
getUnbounded Parser LocalTime
getLocalTime

getTimeZone :: A.Parser TimeZone
getTimeZone :: Parser TimeZone
getTimeZone = TimeZone -> Maybe TimeZone -> TimeZone
forall a. a -> Maybe a -> a
fromMaybe TimeZone
utc (Maybe TimeZone -> TimeZone)
-> Parser ByteString (Maybe TimeZone) -> Parser TimeZone
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString (Maybe TimeZone)
TP.timeZone

type TimeZoneHMS = (Int,Int,Int)

getTimeZoneHMS :: A.Parser TimeZoneHMS
getTimeZoneHMS :: Parser TimeZoneHMS
getTimeZoneHMS = Maybe UTCOffsetHMS -> TimeZoneHMS
munge (Maybe UTCOffsetHMS -> TimeZoneHMS)
-> Parser ByteString (Maybe UTCOffsetHMS) -> Parser TimeZoneHMS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString (Maybe UTCOffsetHMS)
TP.timeZoneHMS
  where
    munge :: Maybe UTCOffsetHMS -> TimeZoneHMS
munge Maybe UTCOffsetHMS
Nothing = (Int
0,Int
0,Int
0)
    munge (Just (TP.UTCOffsetHMS Int
h Int
m Int
s)) = (Int
h,Int
m,Int
s)

localToUTCTimeOfDayHMS :: TimeZoneHMS -> TimeOfDay -> (Integer, TimeOfDay)
localToUTCTimeOfDayHMS :: TimeZoneHMS -> TimeOfDay -> (Integer, TimeOfDay)
localToUTCTimeOfDayHMS (Int
dh, Int
dm, Int
ds) TimeOfDay
tod =
    UTCOffsetHMS -> TimeOfDay -> (Integer, TimeOfDay)
TP.localToUTCTimeOfDayHMS (Int -> Int -> Int -> UTCOffsetHMS
TP.UTCOffsetHMS Int
dh Int
dm Int
ds) TimeOfDay
tod

getZonedTime :: A.Parser ZonedTime
getZonedTime :: Parser ZonedTime
getZonedTime = Parser ZonedTime
TP.zonedTime

getZonedTimestamp :: A.Parser ZonedTimestamp
getZonedTimestamp :: Parser ZonedTimestamp
getZonedTimestamp = Parser ZonedTime -> Parser ZonedTimestamp
forall a. Parser a -> Parser (Unbounded a)
getUnbounded Parser ZonedTime
getZonedTime

getUTCTime :: A.Parser UTCTime
getUTCTime :: Parser UTCTime
getUTCTime = Parser UTCTime
TP.utcTime

getUTCTimestamp :: A.Parser UTCTimestamp
getUTCTimestamp :: Parser UTCTimestamp
getUTCTimestamp = Parser UTCTime -> Parser UTCTimestamp
forall a. Parser a -> Parser (Unbounded a)
getUnbounded Parser UTCTime
getUTCTime

getCalendarDiffTime :: A.Parser CalendarDiffTime
getCalendarDiffTime :: Parser CalendarDiffTime
getCalendarDiffTime = Parser CalendarDiffTime
TP.calendarDiffTime

dayToBuilder :: Day -> Builder
dayToBuilder :: Day -> Builder
dayToBuilder = BoundedPrim Day -> Day -> Builder
forall a. BoundedPrim a -> a -> Builder
primBounded BoundedPrim Day
TPP.day

timeOfDayToBuilder :: TimeOfDay -> Builder
timeOfDayToBuilder :: TimeOfDay -> Builder
timeOfDayToBuilder = BoundedPrim TimeOfDay -> TimeOfDay -> Builder
forall a. BoundedPrim a -> a -> Builder
primBounded BoundedPrim TimeOfDay
TPP.timeOfDay

timeZoneToBuilder :: TimeZone -> Builder
timeZoneToBuilder :: TimeZone -> Builder
timeZoneToBuilder = BoundedPrim TimeZone -> TimeZone -> Builder
forall a. BoundedPrim a -> a -> Builder
primBounded BoundedPrim TimeZone
TPP.timeZone

utcTimeToBuilder :: UTCTime -> Builder
utcTimeToBuilder :: UTCTime -> Builder
utcTimeToBuilder = BoundedPrim UTCTime -> UTCTime -> Builder
forall a. BoundedPrim a -> a -> Builder
primBounded BoundedPrim UTCTime
TPP.utcTime

zonedTimeToBuilder :: ZonedTime -> Builder
zonedTimeToBuilder :: ZonedTime -> Builder
zonedTimeToBuilder = BoundedPrim ZonedTime -> ZonedTime -> Builder
forall a. BoundedPrim a -> a -> Builder
primBounded BoundedPrim ZonedTime
TPP.zonedTime

localTimeToBuilder :: LocalTime -> Builder
localTimeToBuilder :: LocalTime -> Builder
localTimeToBuilder = BoundedPrim LocalTime -> LocalTime -> Builder
forall a. BoundedPrim a -> a -> Builder
primBounded BoundedPrim LocalTime
TPP.localTime

unboundedToBuilder :: (a -> Builder) -> (Unbounded a -> Builder)
unboundedToBuilder :: (a -> Builder) -> Unbounded a -> Builder
unboundedToBuilder a -> Builder
finiteToBuilder Unbounded a
unbounded
    = case Unbounded a
unbounded of
        Unbounded a
NegInfinity -> ByteString -> Builder
byteString ByteString
"-infinity"
        Finite a
a    -> a -> Builder
finiteToBuilder a
a
        Unbounded a
PosInfinity -> ByteString -> Builder
byteString  ByteString
"infinity"

utcTimestampToBuilder :: UTCTimestamp -> Builder
utcTimestampToBuilder :: UTCTimestamp -> Builder
utcTimestampToBuilder = (UTCTime -> Builder) -> UTCTimestamp -> Builder
forall a. (a -> Builder) -> Unbounded a -> Builder
unboundedToBuilder UTCTime -> Builder
utcTimeToBuilder

zonedTimestampToBuilder :: ZonedTimestamp -> Builder
zonedTimestampToBuilder :: ZonedTimestamp -> Builder
zonedTimestampToBuilder = (ZonedTime -> Builder) -> ZonedTimestamp -> Builder
forall a. (a -> Builder) -> Unbounded a -> Builder
unboundedToBuilder ZonedTime -> Builder
zonedTimeToBuilder

localTimestampToBuilder :: LocalTimestamp -> Builder
localTimestampToBuilder :: LocalTimestamp -> Builder
localTimestampToBuilder = (LocalTime -> Builder) -> LocalTimestamp -> Builder
forall a. (a -> Builder) -> Unbounded a -> Builder
unboundedToBuilder LocalTime -> Builder
localTimeToBuilder

dateToBuilder  :: Date -> Builder
dateToBuilder :: Date -> Builder
dateToBuilder  = (Day -> Builder) -> Date -> Builder
forall a. (a -> Builder) -> Unbounded a -> Builder
unboundedToBuilder Day -> Builder
dayToBuilder

nominalDiffTimeToBuilder :: NominalDiffTime -> Builder
nominalDiffTimeToBuilder :: NominalDiffTime -> Builder
nominalDiffTimeToBuilder = NominalDiffTime -> Builder
TPP.nominalDiffTime

calendarDiffTimeToBuilder :: CalendarDiffTime -> Builder
calendarDiffTimeToBuilder :: CalendarDiffTime -> Builder
calendarDiffTimeToBuilder = CalendarDiffTime -> Builder
TPP.calendarDiffTime