@@ -0,0 +1,106 @@
1+{-|
2+Module: Squeal.PostgreSQL.Expression.Range
3+Description: range types and functions
4+Copyright: (c) Eitan Chatav, 2019
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Range types and functions
9+-}
10+
11+{-# LANGUAGE
12+ AllowAmbiguousTypes
13+ , DataKinds
14+ , DeriveAnyClass
15+ , DeriveGeneric
16+ , DeriveFoldable
17+ , DerivingStrategies
18+ , DeriveTraversable
19+ , FlexibleContexts
20+ , FlexibleInstances
21+ , LambdaCase
22+ , MultiParamTypeClasses
23+ , OverloadedLabels
24+ , OverloadedStrings
25+ , PatternSynonyms
26+ , RankNTypes
27+ , ScopedTypeVariables
28+ , TypeApplications
29+ , TypeFamilies
30+ , TypeOperators
31+ , UndecidableInstances
32+#-}
33+
34+module Squeal.PostgreSQL.Expression.Range
35+ ( range
36+ , Range (..)
37+ , (<=..<=), (<..<), (<=..<), (<..<=)
38+ , pattern HalfGT, pattern HalfGTE
39+ , pattern HalfLT, pattern HalfLTE
40+ , Bound (..)
41+ , pattern Closed, pattern Open
42+ ) where
43+
44+import Data.Bool
45+
46+import qualified GHC.Generics as GHC
47+import qualified Generics.SOP as SOP
48+
49+import Squeal.PostgreSQL.Expression
50+import Squeal.PostgreSQL.PG
51+import Squeal.PostgreSQL.Render
52+import Squeal.PostgreSQL.Schema
53+
54+-- $setup
55+-- >>> import Squeal.PostgreSQL
56+
57+-- | >>> printSQL $ range (HalfGTE now)
58+-- [now(), )
59+-- >>> printSQL $ range (0 <..<= (pi & astype numeric))
60+-- (0, (pi() :: numeric)]
61+range
62+ :: Range (Expression outer commons grp schemas params from ('NotNull ty))
63+ -> Expression outer commons grp schemas params from (null ('PGrange ty))
64+range = UnsafeExpression . renderSQL
65+
66+data Bound x = Bound
67+ { closedBound :: Bool
68+ , getBound :: Maybe x
69+ } deriving
70+ ( Eq, Ord, Show, Read, GHC.Generic
71+ , Functor, Foldable, Traversable )
72+ deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
73+pattern Closed, Open :: Maybe x -> Bound x
74+pattern Closed x = Bound True x
75+pattern Open x = Bound False x
76+
77+data Range x
78+ = Empty
79+ | NonEmpty (Bound x) (Bound x)
80+ deriving
81+ ( Eq, Ord, Show, Read, GHC.Generic
82+ , Functor, Foldable, Traversable )
83+ deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
84+type instance PG (Range x) = 'PGrange (PG x)
85+
86+instance RenderSQL x => RenderSQL (Range x) where
87+ renderSQL = \case
88+ Empty -> "empty"
89+ NonEmpty l u -> commaSeparated [renderLower l, renderUpper u]
90+ where
91+ renderLower (Bound isClosed x) =
92+ bool "(" "[" isClosed <> maybe "" renderSQL x
93+ renderUpper (Bound isClosed x) =
94+ maybe "" renderSQL x <> bool ")" "]" isClosed
95+
96+(<=..<=), (<..<), (<=..<), (<..<=) :: x -> x -> Range x
97+x <=..<= y = NonEmpty (Closed (Just x)) (Closed (Just y))
98+x <..< y = NonEmpty (Open (Just x)) (Open (Just y))
99+x <=..< y = NonEmpty (Closed (Just x)) (Open (Just y))
100+x <..<= y = NonEmpty (Open (Just x)) (Closed (Just y))
101+
102+pattern HalfGT, HalfGTE, HalfLT, HalfLTE :: x -> Range x
103+pattern HalfGT x = NonEmpty (Open (Just x)) (Open Nothing)
104+pattern HalfGTE x = NonEmpty (Closed (Just x)) (Open Nothing)
105+pattern HalfLT x = NonEmpty (Open Nothing) (Open (Just x))
106+pattern HalfLTE x = NonEmpty (Open Nothing) (Closed (Just x))