{-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, UndecidableInstances, DataKinds, GeneralizedNewtypeDeriving, PatternGuards, OverloadedStrings, TypeFamilies #-}
#if __GLASGOW_HASKELL__ >= 800
{-# LANGUAGE UndecidableSuperClasses #-}
#endif
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- |
-- Module: Database.PostgreSQL.Typed.Range
-- Copyright: 2015 Dylan Simon
-- 
-- Representaion of PostgreSQL's range type.
-- There are a number of existing range data types, but PostgreSQL's is rather particular.
-- This tries to provide a one-to-one mapping.

module Database.PostgreSQL.Typed.Range where

#if !MIN_VERSION_base(4,8,0)
import           Control.Applicative ((<$>), (<$))
#endif
import           Control.Monad (guard)
import qualified Data.Attoparsec.ByteString.Char8 as P
import qualified Data.ByteString.Builder as BSB
import qualified Data.ByteString.Char8 as BSC
#if MIN_VERSION_base(4,9,0)
import           Data.Semigroup (Semigroup(..))
#else
import           Data.Monoid ((<>))
#if !MIN_VERSION_base(4,8,0)
import           Data.Monoid (Monoid(..))
#endif
#endif
import           GHC.TypeLits (Symbol)

import Database.PostgreSQL.Typed.Types

-- |A end-point for a range, which may be nothing (infinity, NULL in PostgreSQL), open (inclusive), or closed (exclusive)
data Bound a
  = Unbounded -- ^ Equivalent to @Bounded False ±Infinity@
  | Bounded
    { forall a. Bound a -> Bool
_boundClosed :: Bool -- ^ @True@ if the range includes this bound
    , forall a. Bound a -> a
_bound :: a
    }
  deriving (Bound a -> Bound a -> Bool
forall a. Eq a => Bound a -> Bound a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Bound a -> Bound a -> Bool
$c/= :: forall a. Eq a => Bound a -> Bound a -> Bool
== :: Bound a -> Bound a -> Bool
$c== :: forall a. Eq a => Bound a -> Bound a -> Bool
Eq)

instance Functor Bound where
  fmap :: forall a b. (a -> b) -> Bound a -> Bound b
fmap a -> b
_ Bound a
Unbounded = forall a. Bound a
Unbounded
  fmap a -> b
f (Bounded Bool
c a
a) = forall a. Bool -> a -> Bound a
Bounded Bool
c (a -> b
f a
a)

newtype LowerBound a = Lower { forall a. LowerBound a -> Bound a
boundLower :: Bound a } deriving (LowerBound a -> LowerBound a -> Bool
forall a. Eq a => LowerBound a -> LowerBound a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LowerBound a -> LowerBound a -> Bool
$c/= :: forall a. Eq a => LowerBound a -> LowerBound a -> Bool
== :: LowerBound a -> LowerBound a -> Bool
$c== :: forall a. Eq a => LowerBound a -> LowerBound a -> Bool
Eq, forall a b. a -> LowerBound b -> LowerBound a
forall a b. (a -> b) -> LowerBound a -> LowerBound b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> LowerBound b -> LowerBound a
$c<$ :: forall a b. a -> LowerBound b -> LowerBound a
fmap :: forall a b. (a -> b) -> LowerBound a -> LowerBound b
$cfmap :: forall a b. (a -> b) -> LowerBound a -> LowerBound b
Functor)

-- |Takes into account open vs. closed (but does not understand equivalent discrete bounds)
instance Ord a => Ord (LowerBound a) where
  compare :: LowerBound a -> LowerBound a -> Ordering
compare (Lower Bound a
Unbounded) (Lower Bound a
Unbounded) = Ordering
EQ
  compare (Lower Bound a
Unbounded) LowerBound a
_ = Ordering
LT
  compare LowerBound a
_ (Lower Bound a
Unbounded) = Ordering
GT
  compare (Lower (Bounded Bool
ac a
a)) (Lower (Bounded Bool
bc a
b)) = forall a. Ord a => a -> a -> Ordering
compare a
a a
b forall a. Semigroup a => a -> a -> a
<> forall a. Ord a => a -> a -> Ordering
compare Bool
bc Bool
ac

-- |The constraint is only necessary for @maxBound@, unfortunately
instance Bounded a => Bounded (LowerBound a) where
  minBound :: LowerBound a
minBound = forall a. Bound a -> LowerBound a
Lower forall a. Bound a
Unbounded
  maxBound :: LowerBound a
maxBound = forall a. Bound a -> LowerBound a
Lower (forall a. Bool -> a -> Bound a
Bounded Bool
False forall a. Bounded a => a
maxBound)

newtype UpperBound a = Upper { forall a. UpperBound a -> Bound a
boundUpper :: Bound a } deriving (UpperBound a -> UpperBound a -> Bool
forall a. Eq a => UpperBound a -> UpperBound a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UpperBound a -> UpperBound a -> Bool
$c/= :: forall a. Eq a => UpperBound a -> UpperBound a -> Bool
== :: UpperBound a -> UpperBound a -> Bool
$c== :: forall a. Eq a => UpperBound a -> UpperBound a -> Bool
Eq, forall a b. a -> UpperBound b -> UpperBound a
forall a b. (a -> b) -> UpperBound a -> UpperBound b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> UpperBound b -> UpperBound a
$c<$ :: forall a b. a -> UpperBound b -> UpperBound a
fmap :: forall a b. (a -> b) -> UpperBound a -> UpperBound b
$cfmap :: forall a b. (a -> b) -> UpperBound a -> UpperBound b
Functor)

-- |Takes into account open vs. closed (but does not understand equivalent discrete bounds)
instance Ord a => Ord (UpperBound a) where
  compare :: UpperBound a -> UpperBound a -> Ordering
compare (Upper Bound a
Unbounded) (Upper Bound a
Unbounded) = Ordering
EQ
  compare (Upper Bound a
Unbounded) UpperBound a
_ = Ordering
GT
  compare UpperBound a
_ (Upper Bound a
Unbounded) = Ordering
LT
  compare (Upper (Bounded Bool
ac a
a)) (Upper (Bounded Bool
bc a
b)) = forall a. Ord a => a -> a -> Ordering
compare a
a a
b forall a. Semigroup a => a -> a -> a
<> forall a. Ord a => a -> a -> Ordering
compare Bool
ac Bool
bc

-- |The constraint is only necessary for @minBound@, unfortunately
instance Bounded a => Bounded (UpperBound a) where
  minBound :: UpperBound a
minBound = forall a. Bound a -> UpperBound a
Upper (forall a. Bool -> a -> Bound a
Bounded Bool
False forall a. Bounded a => a
minBound)
  maxBound :: UpperBound a
maxBound = forall a. Bound a -> UpperBound a
Upper forall a. Bound a
Unbounded

compareBounds :: Ord a => LowerBound a -> UpperBound a -> Bound Bool
compareBounds :: forall a. Ord a => LowerBound a -> UpperBound a -> Bound Bool
compareBounds (Lower (Bounded Bool
lc a
l)) (Upper (Bounded Bool
uc a
u)) =
  case forall a. Ord a => a -> a -> Ordering
compare a
l a
u of
    Ordering
LT -> forall a. Bool -> a -> Bound a
Bounded Bool
True Bool
True
    Ordering
EQ -> forall a. Bool -> a -> Bound a
Bounded (Bool
lc forall a. Eq a => a -> a -> Bool
/= Bool
uc) (Bool
lc Bool -> Bool -> Bool
&& Bool
uc)
    Ordering
GT -> forall a. Bool -> a -> Bound a
Bounded Bool
False Bool
False
compareBounds LowerBound a
_ UpperBound a
_ = forall a. Bound a
Unbounded

data Range a
  = Empty
  | Range
    { forall a. Range a -> LowerBound a
lower :: LowerBound a
    , forall a. Range a -> UpperBound a
upper :: UpperBound a
    }
  deriving (Range a -> Range a -> Bool
forall a. Eq a => Range a -> Range a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Range a -> Range a -> Bool
$c/= :: forall a. Eq a => Range a -> Range a -> Bool
== :: Range a -> Range a -> Bool
$c== :: forall a. Eq a => Range a -> Range a -> Bool
Eq, Range a -> Range a -> Bool
Range a -> Range a -> Ordering
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 (Range a)
forall a. Ord a => Range a -> Range a -> Bool
forall a. Ord a => Range a -> Range a -> Ordering
forall a. Ord a => Range a -> Range a -> Range a
min :: Range a -> Range a -> Range a
$cmin :: forall a. Ord a => Range a -> Range a -> Range a
max :: Range a -> Range a -> Range a
$cmax :: forall a. Ord a => Range a -> Range a -> Range a
>= :: Range a -> Range a -> Bool
$c>= :: forall a. Ord a => Range a -> Range a -> Bool
> :: Range a -> Range a -> Bool
$c> :: forall a. Ord a => Range a -> Range a -> Bool
<= :: Range a -> Range a -> Bool
$c<= :: forall a. Ord a => Range a -> Range a -> Bool
< :: Range a -> Range a -> Bool
$c< :: forall a. Ord a => Range a -> Range a -> Bool
compare :: Range a -> Range a -> Ordering
$ccompare :: forall a. Ord a => Range a -> Range a -> Ordering
Ord)

instance Functor Range where
  fmap :: forall a b. (a -> b) -> Range a -> Range b
fmap a -> b
_ Range a
Empty = forall a. Range a
Empty
  fmap a -> b
f (Range LowerBound a
l UpperBound a
u) = forall a. LowerBound a -> UpperBound a -> Range a
Range (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f LowerBound a
l) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f UpperBound a
u)

instance Show a => Show (Range a) where
  showsPrec :: Int -> Range a -> ShowS
showsPrec Int
_ Range a
Empty = String -> ShowS
showString String
"empty"
  showsPrec Int
_ (Range (Lower Bound a
l) (Upper Bound a
u)) =
    forall {a}. Char -> Char -> Bound a -> ShowS
sc Char
'[' Char
'(' Bound a
l forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bound a -> ShowS
sb Bound a
l forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
',' forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bound a -> ShowS
sb Bound a
u forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Char -> Char -> Bound a -> ShowS
sc Char
']' Char
')' Bound a
u where
    sc :: Char -> Char -> Bound a -> ShowS
sc Char
c Char
o Bound a
b = Char -> ShowS
showChar forall a b. (a -> b) -> a -> b
$ if forall a. Bound a -> Bool
boundClosed Bound a
b then Char
c else Char
o
    sb :: Bound a -> ShowS
sb = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (forall a. Show a => Int -> a -> ShowS
showsPrec Int
10) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Bound a -> Maybe a
bound

bound :: Bound a -> Maybe a
bound :: forall a. Bound a -> Maybe a
bound Bound a
Unbounded = forall a. Maybe a
Nothing
bound (Bounded Bool
_ a
b) = forall a. a -> Maybe a
Just a
b

-- |Unbounded endpoints are always open.
boundClosed :: Bound a -> Bool
boundClosed :: forall a. Bound a -> Bool
boundClosed Bound a
Unbounded = Bool
False
boundClosed (Bounded Bool
c a
_) = Bool
c

-- |Construct from parts: @makeBound (boundClosed b) (bound b) == b@
makeBound :: Bool -> Maybe a -> Bound a
makeBound :: forall a. Bool -> Maybe a -> Bound a
makeBound Bool
c (Just a
a) = forall a. Bool -> a -> Bound a
Bounded Bool
c a
a
makeBound Bool
False Maybe a
Nothing = forall a. Bound a
Unbounded
makeBound Bool
True Maybe a
Nothing = forall a. HasCallStack => String -> a
error String
"makeBound: unbounded may not be closed"

-- |Empty ranges treated as 'Unbounded'
lowerBound :: Range a -> Bound a
lowerBound :: forall a. Range a -> Bound a
lowerBound Range a
Empty = forall a. Bound a
Unbounded
lowerBound (Range (Lower Bound a
b) UpperBound a
_) = Bound a
b

-- |Empty ranges treated as 'Unbounded'
upperBound :: Range a -> Bound a
upperBound :: forall a. Range a -> Bound a
upperBound Range a
Empty = forall a. Bound a
Unbounded
upperBound (Range LowerBound a
_ (Upper Bound a
b)) = Bound a
b

-- |Equivalent to @boundClosed . lowerBound@
lowerClosed :: Range a -> Bool
lowerClosed :: forall a. Range a -> Bool
lowerClosed Range a
Empty = Bool
False
lowerClosed (Range (Lower Bound a
b) UpperBound a
_) = forall a. Bound a -> Bool
boundClosed Bound a
b

-- |Equivalent to @boundClosed . upperBound@
upperClosed :: Range a -> Bool
upperClosed :: forall a. Range a -> Bool
upperClosed Range a
Empty = Bool
False
upperClosed (Range LowerBound a
_ (Upper Bound a
b)) = forall a. Bound a -> Bool
boundClosed Bound a
b

empty :: Range a
empty :: forall a. Range a
empty = forall a. Range a
Empty

isEmpty :: Ord a => Range a -> Bool
isEmpty :: forall a. Ord a => Range a -> Bool
isEmpty Range a
Empty = Bool
True
isEmpty (Range LowerBound a
l UpperBound a
u)
  | Bounded Bool
_ Bool
n <- forall a. Ord a => LowerBound a -> UpperBound a -> Bound Bool
compareBounds LowerBound a
l UpperBound a
u = Bool -> Bool
not Bool
n
  | Bool
otherwise = Bool
False

full :: Range a
full :: forall a. Range a
full = forall a. LowerBound a -> UpperBound a -> Range a
Range (forall a. Bound a -> LowerBound a
Lower forall a. Bound a
Unbounded) (forall a. Bound a -> UpperBound a
Upper forall a. Bound a
Unbounded)

isFull :: Range a -> Bool
isFull :: forall a. Range a -> Bool
isFull (Range (Lower Bound a
Unbounded) (Upper Bound a
Unbounded)) = Bool
True
isFull Range a
_ = Bool
False

-- |Create a point range @[x,x]@
point :: a -> Range a
point :: forall a. a -> Range a
point a
a = forall a. LowerBound a -> UpperBound a -> Range a
Range (forall a. Bound a -> LowerBound a
Lower (forall a. Bool -> a -> Bound a
Bounded Bool
True a
a)) (forall a. Bound a -> UpperBound a
Upper (forall a. Bool -> a -> Bound a
Bounded Bool
True a
a))

-- |Extract a point: @getPoint (point x) == Just x@
getPoint :: Eq a => Range a -> Maybe a
getPoint :: forall a. Eq a => Range a -> Maybe a
getPoint (Range (Lower (Bounded Bool
True a
l)) (Upper (Bounded Bool
True a
u))) = a
u forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (f :: * -> *). Alternative f => Bool -> f ()
guard (a
u forall a. Eq a => a -> a -> Bool
== a
l)
getPoint Range a
_ = forall a. Maybe a
Nothing

-- Construct a range from endpoints and normalize it.
range :: Ord a => Bound a -> Bound a -> Range a
range :: forall a. Ord a => Bound a -> Bound a -> Range a
range Bound a
l Bound a
u = forall a. Ord a => Range a -> Range a
normalize forall a b. (a -> b) -> a -> b
$ forall a. LowerBound a -> UpperBound a -> Range a
Range (forall a. Bound a -> LowerBound a
Lower Bound a
l) (forall a. Bound a -> UpperBound a
Upper Bound a
u)

-- Construct a standard range (@[l,u)@ or 'point') from bounds (like 'bound') and normalize it.
normal :: Ord a => Maybe a -> Maybe a -> Range a
normal :: forall a. Ord a => Maybe a -> Maybe a -> Range a
normal Maybe a
l Maybe a
u = forall a. Ord a => Bound a -> Bound a -> Range a
range (forall a. Bool -> Maybe a -> Bound a
mb Bool
True Maybe a
l) (forall a. Bool -> Maybe a -> Bound a
mb (Maybe a
l forall a. Eq a => a -> a -> Bool
== Maybe a
u) Maybe a
u) where
  mb :: Bool -> Maybe a -> Bound a
mb = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Bound a
Unbounded forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Bool -> a -> Bound a
Bounded

-- Construct a bounded range like 'normal'.
bounded :: Ord a => a -> a -> Range a
bounded :: forall a. Ord a => a -> a -> Range a
bounded a
l a
u = forall a. Ord a => Maybe a -> Maybe a -> Range a
normal (forall a. a -> Maybe a
Just a
l) (forall a. a -> Maybe a
Just a
u)

-- Fold empty ranges to 'Empty'.
normalize :: Ord a => Range a -> Range a
normalize :: forall a. Ord a => Range a -> Range a
normalize Range a
r
  | forall a. Ord a => Range a -> Bool
isEmpty Range a
r = forall a. Range a
Empty
  | Bool
otherwise = Range a
r

-- |'normalize' for discrete (non-continuous) range types, using the 'Enum' instance
normalize' :: (Ord a, Enum a) => Range a -> Range a
normalize' :: forall a. (Ord a, Enum a) => Range a -> Range a
normalize' Range a
Empty = forall a. Range a
Empty
normalize' (Range (Lower Bound a
l) (Upper Bound a
u)) = forall a. Ord a => Range a -> Range a
normalize forall a b. (a -> b) -> a -> b
$ forall a. Ord a => Bound a -> Bound a -> Range a
range Bound a
l' Bound a
u'
  where
  l' :: Bound a
l' = case Bound a
l of
    Bounded Bool
False a
b -> forall a. Bool -> a -> Bound a
Bounded Bool
True (forall a. Enum a => a -> a
succ a
b)
    Bound a
_ -> Bound a
l
  u' :: Bound a
u' = case Bound a
u of
    Bounded Bool
True a
b -> forall a. Bool -> a -> Bound a
Bounded Bool
False (forall a. Enum a => a -> a
succ a
b)
    Bound a
_ -> Bound a
u

-- |Contains range
(@>), (<@) :: Ord a => Range a -> Range a -> Bool
Range a
_ @> :: forall a. Ord a => Range a -> Range a -> Bool
@> Range a
Empty = Bool
True
Range a
Empty @> Range a
r = forall a. Ord a => Range a -> Bool
isEmpty Range a
r
Range LowerBound a
la UpperBound a
ua @> Range LowerBound a
lb UpperBound a
ub = LowerBound a
la forall a. Ord a => a -> a -> Bool
<= LowerBound a
lb Bool -> Bool -> Bool
&& UpperBound a
ua forall a. Ord a => a -> a -> Bool
>= UpperBound a
ub
Range a
a <@ :: forall a. Ord a => Range a -> Range a -> Bool
<@ Range a
b = Range a
b forall a. Ord a => Range a -> Range a -> Bool
@> Range a
a

-- |Contains element
(@>.) :: Ord a => Range a -> a -> Bool
Range a
r @>. :: forall a. Ord a => Range a -> a -> Bool
@>. a
a = Range a
r forall a. Ord a => Range a -> Range a -> Bool
@> forall a. a -> Range a
point a
a

overlaps :: Ord a => Range a -> Range a -> Bool
overlaps :: forall a. Ord a => Range a -> Range a -> Bool
overlaps Range a
a Range a
b = forall a. Ord a => Range a -> Range a -> Range a
intersect Range a
a Range a
b forall a. Eq a => a -> a -> Bool
/= forall a. Range a
Empty

intersect :: Ord a => Range a -> Range a -> Range a
intersect :: forall a. Ord a => Range a -> Range a -> Range a
intersect (Range LowerBound a
la UpperBound a
ua) (Range LowerBound a
lb UpperBound a
ub) = forall a. Ord a => Range a -> Range a
normalize forall a b. (a -> b) -> a -> b
$ forall a. LowerBound a -> UpperBound a -> Range a
Range (forall a. Ord a => a -> a -> a
max LowerBound a
la LowerBound a
lb) (forall a. Ord a => a -> a -> a
min UpperBound a
ua UpperBound a
ub)
intersect Range a
_ Range a
_ = forall a. Range a
Empty

-- |Union ranges.  Fails if ranges are disjoint.
union :: Ord a => Range a -> Range a -> Range a
union :: forall a. Ord a => Range a -> Range a -> Range a
union Range a
Empty Range a
r = Range a
r
union Range a
r Range a
Empty = Range a
r
union _ra :: Range a
_ra@(Range LowerBound a
la UpperBound a
ua) _rb :: Range a
_rb@(Range LowerBound a
lb UpperBound a
ub)
  -- isEmpty _ra = _rb
  -- isEmpty _rb = _ra
  | Bounded Bool
False Bool
False <- forall a. Ord a => LowerBound a -> UpperBound a -> Bound Bool
compareBounds LowerBound a
lb UpperBound a
ua = forall a. HasCallStack => String -> a
error String
"union: disjoint Ranges"
  | Bounded Bool
False Bool
False <- forall a. Ord a => LowerBound a -> UpperBound a -> Bound Bool
compareBounds LowerBound a
la UpperBound a
ub = forall a. HasCallStack => String -> a
error String
"union: disjoint Ranges"
  | Bool
otherwise = forall a. LowerBound a -> UpperBound a -> Range a
Range (forall a. Ord a => a -> a -> a
min LowerBound a
la LowerBound a
lb) (forall a. Ord a => a -> a -> a
max UpperBound a
ua UpperBound a
ub)

#if MIN_VERSION_base(4,9,0)
instance Ord a => Semigroup (Range a) where
  <> :: Range a -> Range a -> Range a
(<>) = forall a. Ord a => Range a -> Range a -> Range a
union
#endif

instance Ord a => Monoid (Range a) where
  mempty :: Range a
mempty = forall a. Range a
Empty
  mappend :: Range a -> Range a -> Range a
mappend = forall a. Ord a => Range a -> Range a -> Range a
union

-- |Class indicating that the first PostgreSQL type is a range of the second.
-- This implies 'PGParameter' and 'PGColumn' instances that will work for any type.
class (PGType t, PGType (PGSubType t)) => PGRangeType t where
  type PGSubType t :: Symbol
  pgRangeElementType :: PGTypeID t -> PGTypeID (PGSubType t)
  pgRangeElementType PGTypeID t
PGTypeProxy = forall (t :: Symbol). PGTypeID t
PGTypeProxy

instance (PGRangeType t, PGParameter (PGSubType t) a) => PGParameter t (Range a) where
  pgEncode :: PGTypeID t -> Range a -> PGTextValue
pgEncode PGTypeID t
_ Range a
Empty = String -> PGTextValue
BSC.pack String
"empty"
  pgEncode PGTypeID t
tr (Range (Lower Bound a
l) (Upper Bound a
u)) = Builder -> PGTextValue
buildPGValue forall a b. (a -> b) -> a -> b
$
    forall {a}. Char -> Char -> Bound a -> Builder
pc Char
'[' Char
'(' Bound a
l
      forall a. Semigroup a => a -> a -> a
<> Maybe a -> Builder
pb (forall a. Bound a -> Maybe a
bound Bound a
l)
      forall a. Semigroup a => a -> a -> a
<> Char -> Builder
BSB.char7 Char
','
      forall a. Semigroup a => a -> a -> a
<> Maybe a -> Builder
pb (forall a. Bound a -> Maybe a
bound Bound a
u)
      forall a. Semigroup a => a -> a -> a
<> forall {a}. Char -> Char -> Bound a -> Builder
pc Char
']' Char
')' Bound a
u
    where
    pb :: Maybe a -> Builder
pb Maybe a
Nothing = forall a. Monoid a => a
mempty
    pb (Just a
b) = String -> PGTextValue -> Builder
pgDQuoteFrom String
"(),[]" forall a b. (a -> b) -> a -> b
$ forall (t :: Symbol) a.
PGParameter t a =>
PGTypeID t -> a -> PGTextValue
pgEncode (forall (t :: Symbol).
PGRangeType t =>
PGTypeID t -> PGTypeID (PGSubType t)
pgRangeElementType PGTypeID t
tr) a
b
    pc :: Char -> Char -> Bound a -> Builder
pc Char
c Char
o Bound a
b = Char -> Builder
BSB.char7 forall a b. (a -> b) -> a -> b
$ if forall a. Bound a -> Bool
boundClosed Bound a
b then Char
c else Char
o
instance (PGRangeType t, PGColumn (PGSubType t) a) => PGColumn t (Range a) where
  pgDecode :: PGTypeID t -> PGTextValue -> Range a
pgDecode PGTypeID t
tr PGTextValue
a = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. HasCallStack => String -> a
error forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"pgDecode range (" forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. [a] -> [a] -> [a]
++ (String
"): " forall a. [a] -> [a] -> [a]
++ PGTextValue -> String
BSC.unpack PGTextValue
a))) forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall a. Parser a -> PGTextValue -> Either String a
P.parseOnly Parser PGTextValue (Range a)
per PGTextValue
a where
    per :: Parser PGTextValue (Range a)
per = (forall a. Range a
Empty forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Parser PGTextValue
pe) forall a. Semigroup a => a -> a -> a
<> Parser PGTextValue (Range a)
pr
    pe :: Parser PGTextValue
pe = PGTextValue -> Parser PGTextValue
P.stringCI PGTextValue
"empty"
    pb :: Parser PGTextValue (Maybe a)
pb = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (t :: Symbol) a.
PGColumn t a =>
PGTypeID t -> PGTextValue -> a
pgDecode (forall (t :: Symbol).
PGRangeType t =>
PGTypeID t -> PGTypeID (PGSubType t)
pgRangeElementType PGTypeID t
tr)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool
-> String -> (PGTextValue -> Bool) -> Parser (Maybe PGTextValue)
parsePGDQuote Bool
True String
"(),[]" PGTextValue -> Bool
BSC.null
    pc :: Char -> Char -> Parser PGTextValue Bool
pc Char
c Char
o = (Bool
True forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Parser Char
P.char Char
c) forall a. Semigroup a => a -> a -> a
<> (Bool
False forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Parser Char
P.char Char
o)
    mb :: Bool -> Maybe a -> Bound a
mb = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Bound a
Unbounded forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Bool -> a -> Bound a
Bounded
    pr :: Parser PGTextValue (Range a)
pr = do
      Bool
lc <- Char -> Char -> Parser PGTextValue Bool
pc Char
'[' Char
'('
      Maybe a
lb <- Parser PGTextValue (Maybe a)
pb
      Char
_ <- Char -> Parser Char
P.char Char
','
      Maybe a
ub <- Parser PGTextValue (Maybe a)
pb 
      Bool
uc <- Char -> Char -> Parser PGTextValue Bool
pc Char
']' Char
')'
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. LowerBound a -> UpperBound a -> Range a
Range (forall a. Bound a -> LowerBound a
Lower (forall a. Bool -> Maybe a -> Bound a
mb Bool
lc Maybe a
lb)) (forall a. Bound a -> UpperBound a
Upper (forall a. Bool -> Maybe a -> Bound a
mb Bool
uc Maybe a
ub))

instance PGType "int4range" where
  type PGVal "int4range" = Range (PGVal (PGSubType "int4range"))
instance PGRangeType "int4range" where
  type PGSubType "int4range" = "integer"
instance PGType "numrange" where
  type PGVal "numrange" = Range (PGVal (PGSubType "numrange"))
instance PGRangeType "numrange" where
  type PGSubType "numrange" = "numeric"
instance PGType "tsrange" where
  type PGVal "tsrange" = Range (PGVal (PGSubType "tsrange"))
instance PGRangeType "tsrange" where
  type PGSubType "tsrange" = "timestamp without time zone"
instance PGType "tstzrange" where
  type PGVal "tstzrange" = Range (PGVal (PGSubType "tstzrange"))
instance PGRangeType "tstzrange" where
  type PGSubType "tstzrange" = "timestamp with time zone"
instance PGType "daterange" where
  type PGVal "daterange" = Range (PGVal (PGSubType "daterange"))
instance PGRangeType "daterange" where
  type PGSubType "daterange" = "date"
instance PGType "int8range" where
  type PGVal "int8range" = Range (PGVal (PGSubType "int8range"))
instance PGRangeType "int8range" where
  type PGSubType "int8range" = "bigint"