{-# LANGUAGE
AllowAmbiguousTypes
, DataKinds
, DeriveAnyClass
, DeriveGeneric
, DeriveFoldable
, DerivingStrategies
, DeriveTraversable
, FlexibleContexts
, FlexibleInstances
, LambdaCase
, MultiParamTypeClasses
, OverloadedLabels
, OverloadedStrings
, PatternSynonyms
, RankNTypes
, ScopedTypeVariables
, TypeApplications
, TypeFamilies
, TypeOperators
, UndecidableInstances
#-}
module Squeal.PostgreSQL.Expression.Range
(
Range (..)
, (<=..<=), (<..<), (<=..<), (<..<=)
, moreThan, atLeast, lessThan, atMost
, singleton, whole
, Bound (..)
, range
, (.<@)
, (@>.)
, (<<@)
, (@>>)
, (&<)
, (&>)
, (-|-)
, (@+)
, (@*)
, (@-)
, lowerBound
, upperBound
, isEmpty
, lowerInc
, lowerInf
, upperInc
, upperInf
, rangeMerge
) where
import qualified GHC.Generics as GHC
import qualified Generics.SOP as SOP
import Squeal.PostgreSQL.Expression
import Squeal.PostgreSQL.Expression.Type hiding (bool)
import Squeal.PostgreSQL.Type.PG
import Squeal.PostgreSQL.Render
import Squeal.PostgreSQL.Type.Schema
range
:: TypeExpression db (null ('PGrange ty))
-> Range (Expression grp lat with db params from ('NotNull ty))
-> Expression grp lat with db params from (null ('PGrange ty))
range ty = \case
Empty -> UnsafeExpression $ parenthesized
(emp <+> "::" <+> renderSQL ty)
NonEmpty l u -> UnsafeExpression $ renderSQL ty <> parenthesized
(commaSeparated (args l u))
where
emp = singleQuote <> "empty" <> singleQuote
args l u = [arg l, arg u, singleQuote <> bra l <> ket u <> singleQuote]
singleQuote = "\'"
arg = \case
Infinite -> "NULL"; Closed x -> renderSQL x; Open x -> renderSQL x
bra = \case Infinite -> "("; Closed _ -> "["; Open _ -> "("
ket = \case Infinite -> ")"; Closed _ -> "]"; Open _ -> ")"
data Bound x
= Infinite
| Closed x
| Open x
deriving
( Eq, Ord, Show, Read, GHC.Generic
, Functor, Foldable, Traversable )
data Range x = Empty | NonEmpty (Bound x) (Bound x)
deriving
( Eq, Ord, Show, Read, GHC.Generic
, Functor, Foldable, Traversable )
deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
instance IsPG hask => IsPG (Range hask) where
type PG (Range hask) = 'PGrange (PG hask)
(<=..<=), (<..<), (<=..<), (<..<=) :: x -> x -> Range x
infix 4 <=..<=, <..<, <=..<, <..<=
x <=..<= y = NonEmpty (Closed x) (Closed y)
x <..< y = NonEmpty (Open x) (Open y)
x <=..< y = NonEmpty (Closed x) (Open y)
x <..<= y = NonEmpty (Open x) (Closed y)
moreThan, atLeast, lessThan, atMost :: x -> Range x
moreThan x = NonEmpty (Open x) Infinite
atLeast x = NonEmpty (Closed x) Infinite
lessThan x = NonEmpty Infinite (Open x)
atMost x = NonEmpty Infinite (Closed x)
singleton :: x -> Range x
singleton x = x <=..<= x
whole :: Range x
whole = NonEmpty Infinite Infinite
(.<@) :: Operator ('NotNull ty) (null ('PGrange ty)) ('Null 'PGbool)
(.<@) = unsafeBinaryOp "<@"
(@>.) :: Operator (null ('PGrange ty)) ('NotNull ty) ('Null 'PGbool)
(@>.) = unsafeBinaryOp "<@"
(<<@) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)
(<<@) = unsafeBinaryOp "<<"
(@>>) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)
(@>>) = unsafeBinaryOp ">>"
(&<) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)
(&<) = unsafeBinaryOp "&<"
(&>) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)
(&>) = unsafeBinaryOp "&>"
(-|-) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)
(-|-) = unsafeBinaryOp "-|-"
(@+) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) (null ('PGrange ty))
(@+) = unsafeBinaryOp "+"
(@*) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) (null ('PGrange ty))
(@*) = unsafeBinaryOp "*"
(@-) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) (null ('PGrange ty))
(@-) = unsafeBinaryOp "-"
lowerBound :: null ('PGrange ty) --> 'Null ty
lowerBound = unsafeFunction "lower"
upperBound :: null ('PGrange ty) --> 'Null ty
upperBound = unsafeFunction "upper"
isEmpty :: null ('PGrange ty) --> 'Null 'PGbool
isEmpty = unsafeFunction "isempty"
lowerInc :: null ('PGrange ty) --> 'Null 'PGbool
lowerInc = unsafeFunction "lower_inc"
lowerInf :: null ('PGrange ty) --> 'Null 'PGbool
lowerInf = unsafeFunction "lower_inf"
upperInc :: null ('PGrange ty) --> 'Null 'PGbool
upperInc = unsafeFunction "upper_inc"
upperInf :: null ('PGrange ty) --> 'Null 'PGbool
upperInf = unsafeFunction "upper_inf"
rangeMerge ::
'[null ('PGrange ty), null ('PGrange ty)]
---> null ('PGrange ty)
rangeMerge = unsafeFunctionN "range_merge"