{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor      #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE FlexibleInstances  #-}

------------------------------------------------------------------------------
-- |
-- Module:      Database.PostgreSQL.Simple.Range
-- Copyright:   (c) 2014-2015 Leonid Onokhov
--              (c) 2014-2015 Leon P Smith
-- License:     BSD3
-- Maintainer:  Leon P Smith <leon@melding-monads.com>
--
------------------------------------------------------------------------------

module Database.PostgreSQL.Simple.Range
      ( RangeBound(..)
      , PGRange(..)
      , empty
      , isEmpty, isEmptyBy
      , contains, containsBy
      , fromFieldRange
      ) where

import           Control.Applicative hiding (empty)
import           Data.Attoparsec.ByteString.Char8     (Parser, parseOnly)
import qualified Data.Attoparsec.ByteString.Char8     as A
import qualified Data.ByteString                      as B
import           Data.ByteString.Builder
                   ( Builder, byteString, lazyByteString, char8
                   , intDec, int8Dec, int16Dec, int32Dec, int64Dec, integerDec
                   , wordDec, word8Dec, word16Dec, word32Dec, word64Dec
                   , doubleDec, floatDec )
import           Data.Int                             (Int16, Int32, Int64,
                                                       Int8)
import           Data.Function (on)
import           Data.Monoid                          (mempty)
import           Data.Scientific                      (Scientific)
import qualified Data.Text.Lazy.Builder               as LT
import qualified Data.Text.Lazy.Encoding              as LT
import           Data.Time.Compat                     (Day, LocalTime,
                                                       NominalDiffTime,
                                                       TimeOfDay, UTCTime,
                                                       ZonedTime,
                                                       zonedTimeToUTC)
import           Data.Typeable                        (Typeable)
import           Data.Word                            (Word, Word16, Word32,
                                                       Word64, Word8)

import           Database.PostgreSQL.Simple.Compat    (scientificBuilder, (<>), toByteString)
import           Database.PostgreSQL.Simple.FromField
import           Database.PostgreSQL.Simple.Time
                   hiding (PosInfinity, NegInfinity)
-- import qualified Database.PostgreSQL.Simple.Time as Time
import           Database.PostgreSQL.Simple.ToField

-- | Represents boundary of a range
data RangeBound a = NegInfinity
                  | Inclusive !a
                  | Exclusive !a
                  | PosInfinity
     deriving (Int -> RangeBound a -> ShowS
[RangeBound a] -> ShowS
RangeBound a -> String
(Int -> RangeBound a -> ShowS)
-> (RangeBound a -> String)
-> ([RangeBound a] -> ShowS)
-> Show (RangeBound a)
forall a. Show a => Int -> RangeBound a -> ShowS
forall a. Show a => [RangeBound a] -> ShowS
forall a. Show a => RangeBound a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RangeBound a] -> ShowS
$cshowList :: forall a. Show a => [RangeBound a] -> ShowS
show :: RangeBound a -> String
$cshow :: forall a. Show a => RangeBound a -> String
showsPrec :: Int -> RangeBound a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> RangeBound a -> ShowS
Show, Typeable, RangeBound a -> RangeBound a -> Bool
(RangeBound a -> RangeBound a -> Bool)
-> (RangeBound a -> RangeBound a -> Bool) -> Eq (RangeBound a)
forall a. Eq a => RangeBound a -> RangeBound a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RangeBound a -> RangeBound a -> Bool
$c/= :: forall a. Eq a => RangeBound a -> RangeBound a -> Bool
== :: RangeBound a -> RangeBound a -> Bool
$c== :: forall a. Eq a => RangeBound a -> RangeBound a -> Bool
Eq, a -> RangeBound b -> RangeBound a
(a -> b) -> RangeBound a -> RangeBound b
(forall a b. (a -> b) -> RangeBound a -> RangeBound b)
-> (forall a b. a -> RangeBound b -> RangeBound a)
-> Functor RangeBound
forall a b. a -> RangeBound b -> RangeBound a
forall a b. (a -> b) -> RangeBound a -> RangeBound b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> RangeBound b -> RangeBound a
$c<$ :: forall a b. a -> RangeBound b -> RangeBound a
fmap :: (a -> b) -> RangeBound a -> RangeBound b
$cfmap :: forall a b. (a -> b) -> RangeBound a -> RangeBound b
Functor)

-- | Generic range type
data PGRange a = PGRange !(RangeBound a) !(RangeBound a)
     deriving (Int -> PGRange a -> ShowS
[PGRange a] -> ShowS
PGRange a -> String
(Int -> PGRange a -> ShowS)
-> (PGRange a -> String)
-> ([PGRange a] -> ShowS)
-> Show (PGRange a)
forall a. Show a => Int -> PGRange a -> ShowS
forall a. Show a => [PGRange a] -> ShowS
forall a. Show a => PGRange a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PGRange a] -> ShowS
$cshowList :: forall a. Show a => [PGRange a] -> ShowS
show :: PGRange a -> String
$cshow :: forall a. Show a => PGRange a -> String
showsPrec :: Int -> PGRange a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> PGRange a -> ShowS
Show, Typeable, a -> PGRange b -> PGRange a
(a -> b) -> PGRange a -> PGRange b
(forall a b. (a -> b) -> PGRange a -> PGRange b)
-> (forall a b. a -> PGRange b -> PGRange a) -> Functor PGRange
forall a b. a -> PGRange b -> PGRange a
forall a b. (a -> b) -> PGRange a -> PGRange b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> PGRange b -> PGRange a
$c<$ :: forall a b. a -> PGRange b -> PGRange a
fmap :: (a -> b) -> PGRange a -> PGRange b
$cfmap :: forall a b. (a -> b) -> PGRange a -> PGRange b
Functor)

empty :: PGRange a
empty :: PGRange a
empty = RangeBound a -> RangeBound a -> PGRange a
forall a. RangeBound a -> RangeBound a -> PGRange a
PGRange RangeBound a
forall a. RangeBound a
PosInfinity RangeBound a
forall a. RangeBound a
NegInfinity

instance Ord a => Eq (PGRange a) where
  PGRange a
x == :: PGRange a -> PGRange a -> Bool
== PGRange a
y = PGRange a -> PGRange a -> Bool
forall a. Eq a => PGRange a -> PGRange a -> Bool
eq PGRange a
x PGRange a
y Bool -> Bool -> Bool
|| (PGRange a -> Bool
forall a. Ord a => PGRange a -> Bool
isEmpty PGRange a
x Bool -> Bool -> Bool
&& PGRange a -> Bool
forall a. Ord a => PGRange a -> Bool
isEmpty PGRange a
y)
   where eq :: PGRange a -> PGRange a -> Bool
eq (PGRange RangeBound a
a RangeBound a
m) (PGRange RangeBound a
b RangeBound a
n) = RangeBound a
a RangeBound a -> RangeBound a -> Bool
forall a. Eq a => a -> a -> Bool
== RangeBound a
b Bool -> Bool -> Bool
&& RangeBound a
m RangeBound a -> RangeBound a -> Bool
forall a. Eq a => a -> a -> Bool
== RangeBound a
n

isEmptyBy :: (a -> a -> Ordering) -> PGRange a -> Bool
isEmptyBy :: (a -> a -> Ordering) -> PGRange a -> Bool
isEmptyBy a -> a -> Ordering
cmp PGRange a
v =
    case PGRange a
v of
      (PGRange RangeBound a
PosInfinity RangeBound a
_) -> Bool
True
      (PGRange RangeBound a
_ RangeBound a
NegInfinity) -> Bool
True
      (PGRange RangeBound a
NegInfinity RangeBound a
_) -> Bool
False
      (PGRange RangeBound a
_ RangeBound a
PosInfinity) -> Bool
False
      (PGRange (Inclusive a
x) (Inclusive a
y)) -> a -> a -> Ordering
cmp a
x a
y Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
GT
      (PGRange (Inclusive a
x) (Exclusive a
y)) -> a -> a -> Ordering
cmp a
x a
y Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
/= Ordering
LT
      (PGRange (Exclusive a
x) (Inclusive a
y)) -> a -> a -> Ordering
cmp a
x a
y Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
/= Ordering
LT
      (PGRange (Exclusive a
x) (Exclusive a
y)) -> a -> a -> Ordering
cmp a
x a
y Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
/= Ordering
LT

-- | Is a range empty?   If this returns 'True',  then the 'contains'
--   predicate will always return 'False'.   However,  if this returns
--   'False', it is not necessarily true that there exists a point for
--   which 'contains' returns 'True'.
--   Consider @'PGRange' ('Excludes' 2) ('Excludes' 3) :: PGRange Int@,
--   for example.
isEmpty :: Ord a => PGRange a -> Bool
isEmpty :: PGRange a -> Bool
isEmpty = (a -> a -> Ordering) -> PGRange a -> Bool
forall a. (a -> a -> Ordering) -> PGRange a -> Bool
isEmptyBy a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare


-- | Does a range contain a given point?   Note that in some cases, this may
-- not correspond exactly with a server-side computation.   Consider @UTCTime@
-- for example, which has a resolution of a picosecond,  whereas postgresql's
-- @timestamptz@ types have a resolution of a microsecond.  Putting such
-- Haskell values into the database will result in them being rounded, which
-- can change the value of the containment predicate.

contains :: Ord a => PGRange a -> (a -> Bool)
contains :: PGRange a -> a -> Bool
contains = (a -> a -> Ordering) -> PGRange a -> a -> Bool
forall a. (a -> a -> Ordering) -> PGRange a -> a -> Bool
containsBy a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare

containsBy :: (a -> a -> Ordering) -> PGRange a -> (a -> Bool)
containsBy :: (a -> a -> Ordering) -> PGRange a -> a -> Bool
containsBy a -> a -> Ordering
cmp PGRange a
rng a
x =
    case PGRange a
rng of
      PGRange RangeBound a
_lb         RangeBound a
NegInfinity -> Bool
False
      PGRange RangeBound a
lb          RangeBound a
ub          -> RangeBound a -> a -> Bool
checkLB RangeBound a
lb a
x Bool -> Bool -> Bool
&& RangeBound a -> a -> Bool
checkUB RangeBound a
ub a
x
  where
    checkLB :: RangeBound a -> a -> Bool
checkLB RangeBound a
lb a
y =
        case RangeBound a
lb of
          RangeBound a
NegInfinity -> Bool
True
          RangeBound a
PosInfinity -> Bool
False
          Inclusive a
a -> a -> a -> Ordering
cmp a
a a
y Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
/= Ordering
GT
          Exclusive a
a -> a -> a -> Ordering
cmp a
a a
y Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
LT

    checkUB :: RangeBound a -> a -> Bool
checkUB RangeBound a
ub a
y =
        case RangeBound a
ub of
          RangeBound a
NegInfinity -> Bool
False
          RangeBound a
PosInfinity -> Bool
True
          Inclusive a
z -> a -> a -> Ordering
cmp a
y a
z Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
/= Ordering
GT
          Exclusive a
z -> a -> a -> Ordering
cmp a
y a
z Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
LT

lowerBound :: Parser (a -> RangeBound a)
lowerBound :: Parser (a -> RangeBound a)
lowerBound = (Char -> Parser Char
A.char Char
'(' Parser Char
-> Parser (a -> RangeBound a) -> Parser (a -> RangeBound a)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (a -> RangeBound a) -> Parser (a -> RangeBound a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure a -> RangeBound a
forall a. a -> RangeBound a
Exclusive) Parser (a -> RangeBound a)
-> Parser (a -> RangeBound a) -> Parser (a -> RangeBound a)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Char -> Parser Char
A.char Char
'[' Parser Char
-> Parser (a -> RangeBound a) -> Parser (a -> RangeBound a)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (a -> RangeBound a) -> Parser (a -> RangeBound a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure a -> RangeBound a
forall a. a -> RangeBound a
Inclusive)
{-# INLINE lowerBound #-}

upperBound :: Parser (a -> RangeBound a)
upperBound :: Parser (a -> RangeBound a)
upperBound = (Char -> Parser Char
A.char Char
')' Parser Char
-> Parser (a -> RangeBound a) -> Parser (a -> RangeBound a)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (a -> RangeBound a) -> Parser (a -> RangeBound a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure a -> RangeBound a
forall a. a -> RangeBound a
Exclusive) Parser (a -> RangeBound a)
-> Parser (a -> RangeBound a) -> Parser (a -> RangeBound a)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Char -> Parser Char
A.char Char
']' Parser Char
-> Parser (a -> RangeBound a) -> Parser (a -> RangeBound a)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (a -> RangeBound a) -> Parser (a -> RangeBound a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure a -> RangeBound a
forall a. a -> RangeBound a
Inclusive)
{-# INLINE upperBound #-}

-- | Generic range parser
pgrange :: Parser (RangeBound B.ByteString, RangeBound B.ByteString)
pgrange :: Parser (RangeBound ByteString, RangeBound ByteString)
pgrange = do
  ByteString -> RangeBound ByteString
lb <- Parser (ByteString -> RangeBound ByteString)
forall a. Parser (a -> RangeBound a)
lowerBound
  ByteString
v1 <- (Char -> Parser Char
A.char Char
',' Parser Char
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString ByteString
"") Parser ByteString ByteString
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((Char -> Bool) -> Parser ByteString ByteString
rangeElem (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
',') Parser ByteString ByteString
-> Parser Char -> Parser ByteString ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
A.char Char
',')
  ByteString
v2 <- (Char -> Bool) -> Parser ByteString ByteString
rangeElem ((Char -> Bool) -> Parser ByteString ByteString)
-> (Char -> Bool) -> Parser ByteString ByteString
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
']'
  ByteString -> RangeBound ByteString
ub <- Parser (ByteString -> RangeBound ByteString)
forall a. Parser (a -> RangeBound a)
upperBound
  Parser ByteString ()
forall t. Chunk t => Parser t ()
A.endOfInput
  let low :: RangeBound ByteString
low = if ByteString -> Bool
B.null ByteString
v1 then RangeBound ByteString
forall a. RangeBound a
NegInfinity else ByteString -> RangeBound ByteString
lb ByteString
v1
      up :: RangeBound ByteString
up  = if ByteString -> Bool
B.null ByteString
v2 then RangeBound ByteString
forall a. RangeBound a
PosInfinity else ByteString -> RangeBound ByteString
ub ByteString
v2
  (RangeBound ByteString, RangeBound ByteString)
-> Parser (RangeBound ByteString, RangeBound ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (RangeBound ByteString
low, RangeBound ByteString
up)

rangeElem :: (Char -> Bool) -> Parser B.ByteString
rangeElem :: (Char -> Bool) -> Parser ByteString ByteString
rangeElem Char -> Bool
end = (Char -> Parser Char
A.char Char
'"' Parser Char
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString ByteString
doubleQuoted)
            Parser ByteString ByteString
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Char -> Bool) -> Parser ByteString ByteString
A.takeTill Char -> Bool
end
{-# INLINE rangeElem #-}

-- | Simple double quoted value parser
doubleQuoted :: Parser B.ByteString
doubleQuoted :: Parser ByteString ByteString
doubleQuoted = Builder -> ByteString
toByteString (Builder -> ByteString)
-> Parser ByteString Builder -> Parser ByteString ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Builder -> Parser ByteString Builder
go Builder
forall a. Monoid a => a
mempty
  where
    go :: Builder -> Parser ByteString Builder
go Builder
acc = do
      Builder
h <- ByteString -> Builder
byteString (ByteString -> Builder)
-> Parser ByteString ByteString -> Parser ByteString Builder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser ByteString ByteString
A.takeTill (\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
'"')
      let rest :: Parser ByteString Builder
rest = do
           Char
start <- Parser Char
A.anyChar
           case Char
start of
             Char
'\\' -> do
               Char
c <- Parser Char
A.anyChar
               Builder -> Parser ByteString Builder
go (Builder
acc Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
h Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
char8 Char
c)
             Char
'"' -> (Char -> Parser Char
A.char Char
'"' Parser Char
-> Parser ByteString Builder -> Parser ByteString Builder
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Builder -> Parser ByteString Builder
go (Builder
acc Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
h Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
char8 Char
'"'))
                    Parser ByteString Builder
-> Parser ByteString Builder -> Parser ByteString Builder
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Builder -> Parser ByteString Builder
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Builder
acc Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
h)
             Char
_ -> String -> Parser ByteString Builder
forall a. HasCallStack => String -> a
error String
"impossible in doubleQuoted"
      Parser ByteString Builder
rest

rangeToBuilder :: Ord a => (a -> Builder) -> PGRange a -> Builder
rangeToBuilder :: (a -> Builder) -> PGRange a -> Builder
rangeToBuilder = (a -> a -> Ordering) -> (a -> Builder) -> PGRange a -> Builder
forall a.
(a -> a -> Ordering) -> (a -> Builder) -> PGRange a -> Builder
rangeToBuilderBy a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare

-- | Generic range to builder for plain values
rangeToBuilderBy :: (a -> a -> Ordering) -> (a -> Builder) -> PGRange a -> Builder
rangeToBuilderBy :: (a -> a -> Ordering) -> (a -> Builder) -> PGRange a -> Builder
rangeToBuilderBy a -> a -> Ordering
cmp a -> Builder
f PGRange a
x =
    if (a -> a -> Ordering) -> PGRange a -> Bool
forall a. (a -> a -> Ordering) -> PGRange a -> Bool
isEmptyBy a -> a -> Ordering
cmp PGRange a
x
    then ByteString -> Builder
byteString ByteString
"'empty'"
    else let (PGRange RangeBound a
a RangeBound a
b) = PGRange a
x
          in RangeBound a -> Builder
buildLB RangeBound a
a Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> RangeBound a -> Builder
buildUB RangeBound a
b
  where
    buildLB :: RangeBound a -> Builder
buildLB RangeBound a
NegInfinity   = ByteString -> Builder
byteString ByteString
"'[,"
    buildLB (Inclusive a
v) = ByteString -> Builder
byteString ByteString
"'[\"" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> a -> Builder
f a
v Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
byteString ByteString
"\","
    buildLB (Exclusive a
v) = ByteString -> Builder
byteString ByteString
"'(\"" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> a -> Builder
f a
v Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
byteString ByteString
"\","
    buildLB RangeBound a
PosInfinity   = String -> Builder
forall a. HasCallStack => String -> a
error String
"impossible in rangeToBuilder"

    buildUB :: RangeBound a -> Builder
buildUB RangeBound a
NegInfinity   = String -> Builder
forall a. HasCallStack => String -> a
error String
"impossible in rangeToBuilder"
    buildUB (Inclusive a
v) = Char -> Builder
char8 Char
'"' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> a -> Builder
f a
v Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
byteString ByteString
"\"]'"
    buildUB (Exclusive a
v) = Char -> Builder
char8 Char
'"' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> a -> Builder
f a
v Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
byteString ByteString
"\")'"
    buildUB RangeBound a
PosInfinity   = ByteString -> Builder
byteString ByteString
"]'"
{-# INLINE rangeToBuilder #-}


instance (FromField a, Typeable a) => FromField (PGRange a) where
  fromField :: FieldParser (PGRange a)
fromField = FieldParser a -> FieldParser (PGRange a)
forall a. Typeable a => FieldParser a -> FieldParser (PGRange a)
fromFieldRange FieldParser a
forall a. FromField a => FieldParser a
fromField

fromFieldRange :: Typeable a => FieldParser a -> FieldParser (PGRange a)
fromFieldRange :: FieldParser a -> FieldParser (PGRange a)
fromFieldRange FieldParser a
fromField' Field
f Maybe ByteString
mdat = do
    TypeInfo
info <- Field -> Conversion TypeInfo
typeInfo Field
f
    case TypeInfo
info of
      Range{} ->
        let f' :: Field
f' = Field
f { typeOid :: Oid
typeOid = TypeInfo -> Oid
typoid (TypeInfo -> TypeInfo
rngsubtype TypeInfo
info) }
        in case Maybe ByteString
mdat of
          Maybe ByteString
Nothing -> (String -> Maybe Oid -> String -> String -> String -> ResultError)
-> Field -> String -> Conversion (PGRange a)
forall a err.
(Typeable a, Exception err) =>
(String -> Maybe Oid -> String -> String -> String -> err)
-> Field -> String -> Conversion a
returnError String -> Maybe Oid -> String -> String -> String -> ResultError
UnexpectedNull Field
f String
""
          Just ByteString
"empty" -> PGRange a -> Conversion (PGRange a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PGRange a -> Conversion (PGRange a))
-> PGRange a -> Conversion (PGRange a)
forall a b. (a -> b) -> a -> b
$ PGRange a
forall a. PGRange a
empty
          Just ByteString
bs ->
            let parseIt :: RangeBound ByteString -> Conversion (RangeBound a)
parseIt RangeBound ByteString
NegInfinity   = RangeBound a -> Conversion (RangeBound a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure RangeBound a
forall a. RangeBound a
NegInfinity
                parseIt (Inclusive ByteString
v) = a -> RangeBound a
forall a. a -> RangeBound a
Inclusive (a -> RangeBound a) -> Conversion a -> Conversion (RangeBound a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldParser a
fromField' Field
f' (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
v)
                parseIt (Exclusive ByteString
v) = a -> RangeBound a
forall a. a -> RangeBound a
Exclusive (a -> RangeBound a) -> Conversion a -> Conversion (RangeBound a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldParser a
fromField' Field
f' (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
v)
                parseIt RangeBound ByteString
PosInfinity   = RangeBound a -> Conversion (RangeBound a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure RangeBound a
forall a. RangeBound a
PosInfinity
            in case Parser (RangeBound ByteString, RangeBound ByteString)
-> ByteString
-> Either String (RangeBound ByteString, RangeBound ByteString)
forall a. Parser a -> ByteString -> Either String a
parseOnly Parser (RangeBound ByteString, RangeBound ByteString)
pgrange ByteString
bs of
                Left String
e -> (String -> Maybe Oid -> String -> String -> String -> ResultError)
-> Field -> String -> Conversion (PGRange a)
forall a err.
(Typeable a, Exception err) =>
(String -> Maybe Oid -> String -> String -> String -> err)
-> Field -> String -> Conversion a
returnError String -> Maybe Oid -> String -> String -> String -> ResultError
ConversionFailed Field
f String
e
                Right (RangeBound ByteString
lb,RangeBound ByteString
ub) -> RangeBound a -> RangeBound a -> PGRange a
forall a. RangeBound a -> RangeBound a -> PGRange a
PGRange (RangeBound a -> RangeBound a -> PGRange a)
-> Conversion (RangeBound a)
-> Conversion (RangeBound a -> PGRange a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RangeBound ByteString -> Conversion (RangeBound a)
parseIt RangeBound ByteString
lb Conversion (RangeBound a -> PGRange a)
-> Conversion (RangeBound a) -> Conversion (PGRange a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RangeBound ByteString -> Conversion (RangeBound a)
parseIt RangeBound ByteString
ub
      TypeInfo
_ -> (String -> Maybe Oid -> String -> String -> String -> ResultError)
-> Field -> String -> Conversion (PGRange a)
forall a err.
(Typeable a, Exception err) =>
(String -> Maybe Oid -> String -> String -> String -> err)
-> Field -> String -> Conversion a
returnError String -> Maybe Oid -> String -> String -> String -> ResultError
Incompatible Field
f String
""


instance ToField (PGRange Int8) where
    toField :: PGRange Int8 -> Action
toField = Builder -> Action
Plain (Builder -> Action)
-> (PGRange Int8 -> Builder) -> PGRange Int8 -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int8 -> Builder) -> PGRange Int8 -> Builder
forall a. Ord a => (a -> Builder) -> PGRange a -> Builder
rangeToBuilder Int8 -> Builder
int8Dec
    {-# INLINE toField #-}

instance ToField (PGRange Int16) where
    toField :: PGRange Int16 -> Action
toField = Builder -> Action
Plain (Builder -> Action)
-> (PGRange Int16 -> Builder) -> PGRange Int16 -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int16 -> Builder) -> PGRange Int16 -> Builder
forall a. Ord a => (a -> Builder) -> PGRange a -> Builder
rangeToBuilder Int16 -> Builder
int16Dec
    {-# INLINE toField #-}

instance ToField (PGRange Int32) where
    toField :: PGRange Int32 -> Action
toField = Builder -> Action
Plain (Builder -> Action)
-> (PGRange Int32 -> Builder) -> PGRange Int32 -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int32 -> Builder) -> PGRange Int32 -> Builder
forall a. Ord a => (a -> Builder) -> PGRange a -> Builder
rangeToBuilder Int32 -> Builder
int32Dec
    {-# INLINE toField #-}

instance ToField (PGRange Int) where
    toField :: PGRange Int -> Action
toField = Builder -> Action
Plain (Builder -> Action)
-> (PGRange Int -> Builder) -> PGRange Int -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Builder) -> PGRange Int -> Builder
forall a. Ord a => (a -> Builder) -> PGRange a -> Builder
rangeToBuilder Int -> Builder
intDec
    {-# INLINE toField #-}

instance ToField (PGRange Int64) where
    toField :: PGRange Int64 -> Action
toField = Builder -> Action
Plain (Builder -> Action)
-> (PGRange Int64 -> Builder) -> PGRange Int64 -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int64 -> Builder) -> PGRange Int64 -> Builder
forall a. Ord a => (a -> Builder) -> PGRange a -> Builder
rangeToBuilder Int64 -> Builder
int64Dec
    {-# INLINE toField #-}

instance ToField (PGRange Integer) where
    toField :: PGRange Integer -> Action
toField = Builder -> Action
Plain (Builder -> Action)
-> (PGRange Integer -> Builder) -> PGRange Integer -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer -> Builder) -> PGRange Integer -> Builder
forall a. Ord a => (a -> Builder) -> PGRange a -> Builder
rangeToBuilder Integer -> Builder
integerDec
    {-# INLINE toField #-}

instance ToField (PGRange Word8) where
    toField :: PGRange Word8 -> Action
toField = Builder -> Action
Plain (Builder -> Action)
-> (PGRange Word8 -> Builder) -> PGRange Word8 -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Builder) -> PGRange Word8 -> Builder
forall a. Ord a => (a -> Builder) -> PGRange a -> Builder
rangeToBuilder Word8 -> Builder
word8Dec
    {-# INLINE toField #-}

instance ToField (PGRange Word16) where
    toField :: PGRange Word16 -> Action
toField = Builder -> Action
Plain (Builder -> Action)
-> (PGRange Word16 -> Builder) -> PGRange Word16 -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word16 -> Builder) -> PGRange Word16 -> Builder
forall a. Ord a => (a -> Builder) -> PGRange a -> Builder
rangeToBuilder Word16 -> Builder
word16Dec
    {-# INLINE toField #-}

instance ToField (PGRange Word32) where
    toField :: PGRange Word32 -> Action
toField = Builder -> Action
Plain (Builder -> Action)
-> (PGRange Word32 -> Builder) -> PGRange Word32 -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word32 -> Builder) -> PGRange Word32 -> Builder
forall a. Ord a => (a -> Builder) -> PGRange a -> Builder
rangeToBuilder Word32 -> Builder
word32Dec
    {-# INLINE toField #-}

instance ToField (PGRange Word) where
    toField :: PGRange Word -> Action
toField = Builder -> Action
Plain (Builder -> Action)
-> (PGRange Word -> Builder) -> PGRange Word -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word -> Builder) -> PGRange Word -> Builder
forall a. Ord a => (a -> Builder) -> PGRange a -> Builder
rangeToBuilder Word -> Builder
wordDec
    {-# INLINE toField #-}

instance ToField (PGRange Word64) where
    toField :: PGRange Word64 -> Action
toField = Builder -> Action
Plain (Builder -> Action)
-> (PGRange Word64 -> Builder) -> PGRange Word64 -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word64 -> Builder) -> PGRange Word64 -> Builder
forall a. Ord a => (a -> Builder) -> PGRange a -> Builder
rangeToBuilder Word64 -> Builder
word64Dec
    {-# INLINE toField #-}

instance ToField (PGRange Float) where
    toField :: PGRange Float -> Action
toField = Builder -> Action
Plain (Builder -> Action)
-> (PGRange Float -> Builder) -> PGRange Float -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Float -> Builder) -> PGRange Float -> Builder
forall a. Ord a => (a -> Builder) -> PGRange a -> Builder
rangeToBuilder Float -> Builder
floatDec
    {-# INLINE toField #-}

instance ToField (PGRange Double) where
    toField :: PGRange Double -> Action
toField = Builder -> Action
Plain (Builder -> Action)
-> (PGRange Double -> Builder) -> PGRange Double -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Builder) -> PGRange Double -> Builder
forall a. Ord a => (a -> Builder) -> PGRange a -> Builder
rangeToBuilder Double -> Builder
doubleDec
    {-# INLINE toField #-}

instance ToField (PGRange Scientific) where
    toField :: PGRange Scientific -> Action
toField = Builder -> Action
Plain (Builder -> Action)
-> (PGRange Scientific -> Builder) -> PGRange Scientific -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Scientific -> Builder) -> PGRange Scientific -> Builder
forall a. Ord a => (a -> Builder) -> PGRange a -> Builder
rangeToBuilder Scientific -> Builder
f
      where
        f :: Scientific -> Builder
f = ByteString -> Builder
lazyByteString (ByteString -> Builder)
-> (Scientific -> ByteString) -> Scientific -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
LT.encodeUtf8 (Text -> ByteString)
-> (Scientific -> Text) -> Scientific -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
LT.toLazyText (Builder -> Text) -> (Scientific -> Builder) -> Scientific -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scientific -> Builder
scientificBuilder
    {-# INLINE toField #-}

instance ToField (PGRange UTCTime) where
    toField :: PGRange UTCTime -> Action
toField = Builder -> Action
Plain (Builder -> Action)
-> (PGRange UTCTime -> Builder) -> PGRange UTCTime -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UTCTime -> Builder) -> PGRange UTCTime -> Builder
forall a. Ord a => (a -> Builder) -> PGRange a -> Builder
rangeToBuilder UTCTime -> Builder
utcTimeToBuilder
    {-# INLINE toField #-}

instance ToField (PGRange ZonedTime) where
    toField :: PGRange ZonedTime -> Action
toField = Builder -> Action
Plain (Builder -> Action)
-> (PGRange ZonedTime -> Builder) -> PGRange ZonedTime -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ZonedTime -> ZonedTime -> Ordering)
-> (ZonedTime -> Builder) -> PGRange ZonedTime -> Builder
forall a.
(a -> a -> Ordering) -> (a -> Builder) -> PGRange a -> Builder
rangeToBuilderBy ZonedTime -> ZonedTime -> Ordering
cmpZonedTime ZonedTime -> Builder
zonedTimeToBuilder
    {-# INLINE toField #-}

cmpZonedTime :: ZonedTime -> ZonedTime -> Ordering
cmpZonedTime :: ZonedTime -> ZonedTime -> Ordering
cmpZonedTime = UTCTime -> UTCTime -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (UTCTime -> UTCTime -> Ordering)
-> (ZonedTime -> UTCTime) -> ZonedTime -> ZonedTime -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ZonedTime -> UTCTime
zonedTimeToUTC   -- FIXME:  optimize

instance ToField (PGRange LocalTime) where
    toField :: PGRange LocalTime -> Action
toField = Builder -> Action
Plain (Builder -> Action)
-> (PGRange LocalTime -> Builder) -> PGRange LocalTime -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LocalTime -> Builder) -> PGRange LocalTime -> Builder
forall a. Ord a => (a -> Builder) -> PGRange a -> Builder
rangeToBuilder LocalTime -> Builder
localTimeToBuilder
    {-# INLINE toField #-}

instance ToField (PGRange Day) where
    toField :: PGRange Day -> Action
toField = Builder -> Action
Plain (Builder -> Action)
-> (PGRange Day -> Builder) -> PGRange Day -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Day -> Builder) -> PGRange Day -> Builder
forall a. Ord a => (a -> Builder) -> PGRange a -> Builder
rangeToBuilder Day -> Builder
dayToBuilder
    {-# INLINE toField #-}

instance ToField (PGRange TimeOfDay) where
    toField :: PGRange TimeOfDay -> Action
toField = Builder -> Action
Plain (Builder -> Action)
-> (PGRange TimeOfDay -> Builder) -> PGRange TimeOfDay -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TimeOfDay -> Builder) -> PGRange TimeOfDay -> Builder
forall a. Ord a => (a -> Builder) -> PGRange a -> Builder
rangeToBuilder TimeOfDay -> Builder
timeOfDayToBuilder
    {-# INLINE toField #-}

instance ToField (PGRange UTCTimestamp) where
    toField :: PGRange UTCTimestamp -> Action
toField = Builder -> Action
Plain (Builder -> Action)
-> (PGRange UTCTimestamp -> Builder)
-> PGRange UTCTimestamp
-> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UTCTimestamp -> Builder) -> PGRange UTCTimestamp -> Builder
forall a. Ord a => (a -> Builder) -> PGRange a -> Builder
rangeToBuilder UTCTimestamp -> Builder
utcTimestampToBuilder
    {-# INLINE toField #-}

instance ToField (PGRange ZonedTimestamp) where
    toField :: PGRange ZonedTimestamp -> Action
toField = Builder -> Action
Plain (Builder -> Action)
-> (PGRange ZonedTimestamp -> Builder)
-> PGRange ZonedTimestamp
-> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ZonedTimestamp -> ZonedTimestamp -> Ordering)
-> (ZonedTimestamp -> Builder) -> PGRange ZonedTimestamp -> Builder
forall a.
(a -> a -> Ordering) -> (a -> Builder) -> PGRange a -> Builder
rangeToBuilderBy ZonedTimestamp -> ZonedTimestamp -> Ordering
cmpZonedTimestamp ZonedTimestamp -> Builder
zonedTimestampToBuilder
    {-# INLINE toField #-}

cmpZonedTimestamp :: ZonedTimestamp -> ZonedTimestamp -> Ordering
cmpZonedTimestamp :: ZonedTimestamp -> ZonedTimestamp -> Ordering
cmpZonedTimestamp = UTCTimestamp -> UTCTimestamp -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (UTCTimestamp -> UTCTimestamp -> Ordering)
-> (ZonedTimestamp -> UTCTimestamp)
-> ZonedTimestamp
-> ZonedTimestamp
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (ZonedTime -> UTCTime
zonedTimeToUTC (ZonedTime -> UTCTime) -> ZonedTimestamp -> UTCTimestamp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)

instance ToField (PGRange LocalTimestamp) where
    toField :: PGRange LocalTimestamp -> Action
toField = Builder -> Action
Plain (Builder -> Action)
-> (PGRange LocalTimestamp -> Builder)
-> PGRange LocalTimestamp
-> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LocalTimestamp -> Builder) -> PGRange LocalTimestamp -> Builder
forall a. Ord a => (a -> Builder) -> PGRange a -> Builder
rangeToBuilder LocalTimestamp -> Builder
localTimestampToBuilder
    {-# INLINE toField #-}

instance ToField (PGRange Date) where
    toField :: PGRange Date -> Action
toField = Builder -> Action
Plain (Builder -> Action)
-> (PGRange Date -> Builder) -> PGRange Date -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Date -> Builder) -> PGRange Date -> Builder
forall a. Ord a => (a -> Builder) -> PGRange a -> Builder
rangeToBuilder Date -> Builder
dateToBuilder
    {-# INLINE toField #-}

instance ToField (PGRange NominalDiffTime) where
    toField :: PGRange NominalDiffTime -> Action
toField = Builder -> Action
Plain (Builder -> Action)
-> (PGRange NominalDiffTime -> Builder)
-> PGRange NominalDiffTime
-> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NominalDiffTime -> Builder) -> PGRange NominalDiffTime -> Builder
forall a. Ord a => (a -> Builder) -> PGRange a -> Builder
rangeToBuilder NominalDiffTime -> Builder
nominalDiffTimeToBuilder
    {-# INLINE toField #-}