{-# 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 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
data Bound a
= Unbounded
| Bounded
{ _boundClosed :: Bool
, _bound :: a
}
deriving (Eq)
instance Functor Bound where
fmap _ Unbounded = Unbounded
fmap f (Bounded c a) = Bounded c (f a)
newtype LowerBound a = Lower { boundLower :: Bound a } deriving (Eq, Functor)
instance Ord a => Ord (LowerBound a) where
compare (Lower Unbounded) (Lower Unbounded) = EQ
compare (Lower Unbounded) _ = LT
compare _ (Lower Unbounded) = GT
compare (Lower (Bounded ac a)) (Lower (Bounded bc b)) = compare a b <> compare bc ac
instance Bounded a => Bounded (LowerBound a) where
minBound = Lower Unbounded
maxBound = Lower (Bounded False maxBound)
newtype UpperBound a = Upper { boundUpper :: Bound a } deriving (Eq, Functor)
instance Ord a => Ord (UpperBound a) where
compare (Upper Unbounded) (Upper Unbounded) = EQ
compare (Upper Unbounded) _ = GT
compare _ (Upper Unbounded) = LT
compare (Upper (Bounded ac a)) (Upper (Bounded bc b)) = compare a b <> compare ac bc
instance Bounded a => Bounded (UpperBound a) where
minBound = Upper (Bounded False minBound)
maxBound = Upper Unbounded
compareBounds :: Ord a => LowerBound a -> UpperBound a -> Bound Bool
compareBounds (Lower (Bounded lc l)) (Upper (Bounded uc u)) =
case compare l u of
LT -> Bounded True True
EQ -> Bounded (lc /= uc) (lc && uc)
GT -> Bounded False False
compareBounds _ _ = Unbounded
data Range a
= Empty
| Range
{ lower :: LowerBound a
, upper :: UpperBound a
}
deriving (Eq, Ord)
instance Functor Range where
fmap _ Empty = Empty
fmap f (Range l u) = Range (fmap f l) (fmap f u)
instance Show a => Show (Range a) where
showsPrec _ Empty = showString "empty"
showsPrec _ (Range (Lower l) (Upper u)) =
sc '[' '(' l . sb l . showChar ',' . sb u . sc ']' ')' u where
sc c o b = showChar $ if boundClosed b then c else o
sb = maybe id (showsPrec 10) . bound
bound :: Bound a -> Maybe a
bound Unbounded = Nothing
bound (Bounded _ b) = Just b
boundClosed :: Bound a -> Bool
boundClosed Unbounded = False
boundClosed (Bounded c _) = c
makeBound :: Bool -> Maybe a -> Bound a
makeBound c (Just a) = Bounded c a
makeBound False Nothing = Unbounded
makeBound True Nothing = error "makeBound: unbounded may not be closed"
lowerBound :: Range a -> Bound a
lowerBound Empty = Unbounded
lowerBound (Range (Lower b) _) = b
upperBound :: Range a -> Bound a
upperBound Empty = Unbounded
upperBound (Range _ (Upper b)) = b
lowerClosed :: Range a -> Bool
lowerClosed Empty = False
lowerClosed (Range (Lower b) _) = boundClosed b
upperClosed :: Range a -> Bool
upperClosed Empty = False
upperClosed (Range _ (Upper b)) = boundClosed b
empty :: Range a
empty = Empty
isEmpty :: Ord a => Range a -> Bool
isEmpty Empty = True
isEmpty (Range l u)
| Bounded _ n <- compareBounds l u = not n
| otherwise = False
full :: Range a
full = Range (Lower Unbounded) (Upper Unbounded)
isFull :: Range a -> Bool
isFull (Range (Lower Unbounded) (Upper Unbounded)) = True
isFull _ = False
point :: a -> Range a
point a = Range (Lower (Bounded True a)) (Upper (Bounded True a))
getPoint :: Eq a => Range a -> Maybe a
getPoint (Range (Lower (Bounded True l)) (Upper (Bounded True u))) = u <$ guard (u == l)
getPoint _ = Nothing
range :: Ord a => Bound a -> Bound a -> Range a
range l u = normalize $ Range (Lower l) (Upper u)
normal :: Ord a => Maybe a -> Maybe a -> Range a
normal l u = range (mb True l) (mb (l == u) u) where
mb = maybe Unbounded . Bounded
bounded :: Ord a => a -> a -> Range a
bounded l u = normal (Just l) (Just u)
normalize :: Ord a => Range a -> Range a
normalize r
| isEmpty r = Empty
| otherwise = r
normalize' :: (Ord a, Enum a) => Range a -> Range a
normalize' Empty = Empty
normalize' (Range (Lower l) (Upper u)) = normalize $ range l' u'
where
l' = case l of
Bounded False b -> Bounded True (succ b)
_ -> l
u' = case u of
Bounded True b -> Bounded False (succ b)
_ -> u
(@>), (<@) :: Ord a => Range a -> Range a -> Bool
_ @> Empty = True
Empty @> r = isEmpty r
Range la ua @> Range lb ub = la <= lb && ua >= ub
a <@ b = b @> a
(@>.) :: Ord a => Range a -> a -> Bool
r @>. a = r @> point a
overlaps :: Ord a => Range a -> Range a -> Bool
overlaps a b = intersect a b /= Empty
intersect :: Ord a => Range a -> Range a -> Range a
intersect (Range la ua) (Range lb ub) = normalize $ Range (max la lb) (min ua ub)
intersect _ _ = Empty
union :: Ord a => Range a -> Range a -> Range a
union Empty r = r
union r Empty = r
union _ra@(Range la ua) _rb@(Range lb ub)
| Bounded False False <- compareBounds lb ua = error "union: disjoint Ranges"
| Bounded False False <- compareBounds la ub = error "union: disjoint Ranges"
| otherwise = Range (min la lb) (max ua ub)
#if MIN_VERSION_base(4,9,0)
instance Ord a => Semigroup (Range a) where
(<>) = union
#endif
instance Ord a => Monoid (Range a) where
mempty = Empty
mappend = union
class (PGType t, PGType (PGSubType t)) => PGRangeType t where
type PGSubType t :: Symbol
pgRangeElementType :: PGTypeID t -> PGTypeID (PGSubType t)
pgRangeElementType PGTypeProxy = PGTypeProxy
instance (PGRangeType t, PGParameter (PGSubType t) a) => PGParameter t (Range a) where
pgEncode _ Empty = BSC.pack "empty"
pgEncode tr (Range (Lower l) (Upper u)) = buildPGValue $
pc '[' '(' l
<> pb (bound l)
<> BSB.char7 ','
<> pb (bound u)
<> pc ']' ')' u
where
pb Nothing = mempty
pb (Just b) = pgDQuoteFrom "(),[]" $ pgEncode (pgRangeElementType tr) b
pc c o b = BSB.char7 $ if boundClosed b then c else o
instance (PGRangeType t, PGColumn (PGSubType t) a) => PGColumn t (Range a) where
pgDecode tr a = either (error . ("pgDecode range (" ++) . (++ ("): " ++ BSC.unpack a))) id $ P.parseOnly per a where
per = (Empty <$ pe) <> pr
pe = P.stringCI "empty"
pb = fmap (pgDecode (pgRangeElementType tr)) <$> parsePGDQuote True "(),[]" BSC.null
pc c o = (True <$ P.char c) <> (False <$ P.char o)
mb = maybe Unbounded . Bounded
pr = do
lc <- pc '[' '('
lb <- pb
_ <- P.char ','
ub <- pb
uc <- pc ']' ')'
return $ Range (Lower (mb lc lb)) (Upper (mb uc 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"