git.iko.soy/squeal
on dev help sign in
rejigger ADTs
0980480Eitan Chatav
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Range.hs+27−34
compare with dev
unifiedsplit
@@ -38,7 +38,6 @@ module Squeal.PostgreSQL.Expression.Range
38 , moreThan, atLeast, lessThan, atMost
38 , moreThan, atLeast, lessThan, atMost
39 , singleton, whole
39 , singleton, whole
40 , Bound (..)
40 , Bound (..)
41− , closed, open
42 , (<@.)
41 , (<@.)
43 , (@>.)
42 , (@>.)
44 , (&&.)
43 , (&&.)
@@ -60,8 +59,6 @@ module Squeal.PostgreSQL.Expression.Range
60 , rangeMerge
59 , rangeMerge
61 ) where
60 ) where
62
61
63−import Data.Bool
64−
65import qualified GHC.Generics as GHC
62import qualified GHC.Generics as GHC
66import qualified Generics.SOP as SOP
63import qualified Generics.SOP as SOP
67
64
@@ -81,35 +78,31 @@ import Squeal.PostgreSQL.Schema
81-- >>> printSQL $ range numrange (0 <=..< 2*pi)
78-- >>> printSQL $ range numrange (0 <=..< 2*pi)
82-- numrange(0, (2 * pi()), '[)')
79-- numrange(0, (2 * pi()), '[)')
83-- >>> printSQL $ range int4range Empty
80-- >>> printSQL $ range int4range Empty
84−-- (empty :: int4range)
81+-- ('empty' :: int4range)
85range
82range
86 :: TypeExpression schemas (null ('PGrange ty))
83 :: TypeExpression schemas (null ('PGrange ty))
87 -> Range (Expression outer commons grp schemas params from ('NotNull ty))
84 -> Range (Expression outer commons grp schemas params from ('NotNull ty))
88 -> Expression outer commons grp schemas params from (null ('PGrange ty))
85 -> Expression outer commons grp schemas params from (null ('PGrange ty))
89range ty = \case
86range ty = \case
90 Empty -> UnsafeExpression $ parenthesized
87 Empty -> UnsafeExpression $ parenthesized
91− ("empty" <+> "::" <+> renderSQL ty)
88+ (empty <+> "::" <+> renderSQL ty)
92 NonEmpty l u -> UnsafeExpression $ renderSQL ty <> parenthesized
89 NonEmpty l u -> UnsafeExpression $ renderSQL ty <> parenthesized
93− (commaSeparated [renderArg l, renderArg u, renderClopen l u])
90+ (commaSeparated (args l u))
94− where
91+ where
95− renderArg (Bound _ x) = maybe "NULL" renderSQL x
92+ empty = singleQuote <> "empty" <> singleQuote
96− renderClopen (Bound l' _) (Bound u' _) =
93+ args l u = [arg l, arg u, singleQuote <> bra l <> ket u <> singleQuote]
97− "\'" <> bool "(" "[" l' <> bool ")" "]" u' <> "\'"
94+ singleQuote = "\'"
98−
95+ arg = \case
96+ Infinite -> "NULL"; Closed x -> renderSQL x; Open x -> renderSQL x
97+ bra = \case Infinite -> "("; Closed _ -> "["; Open _ -> "("
98+ ket = \case Infinite -> ")"; Closed _ -> "]"; Open _ -> ")"
99+
99−data Bound x = Bound
100+data Bound x = Infinite | Closed x | Open x
100− { closedBound :: Bool
101− , getBound :: Maybe x
102− } deriving
101+ deriving
103 ( Eq, Ord, Show, Read, GHC.Generic
102 ( Eq, Ord, Show, Read, GHC.Generic
104 , Functor, Foldable, Traversable )
103 , Functor, Foldable, Traversable )
105− deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
104+
106−closed, open :: Maybe x -> Bound x
107−closed = Bound True
108−open = Bound False
109−
110−data Range x
111− = Empty
112− | NonEmpty (Bound x) (Bound x)
105+data Range x = Empty | NonEmpty (Bound x) (Bound x)
113 deriving
106 deriving
114 ( Eq, Ord, Show, Read, GHC.Generic
107 ( Eq, Ord, Show, Read, GHC.Generic
115 , Functor, Foldable, Traversable )
108 , Functor, Foldable, Traversable )
@@ -118,22 +111,22 @@ type instance PG (Range x) = 'PGrange (PG x)
118
111
119(<=..<=), (<..<), (<=..<), (<..<=) :: x -> x -> Range x
112(<=..<=), (<..<), (<=..<), (<..<=) :: x -> x -> Range x
120infix 4 <=..<=, <..<, <=..<, <..<=
113infix 4 <=..<=, <..<, <=..<, <..<=
121−x <=..<= y = NonEmpty (closed (Just x)) (closed (Just y))
114+x <=..<= y = NonEmpty (Closed x) (Closed y)
122−x <..< y = NonEmpty (open (Just x)) (open (Just y))
115+x <..< y = NonEmpty (Open x) (Open y)
123−x <=..< y = NonEmpty (closed (Just x)) (open (Just y))
116+x <=..< y = NonEmpty (Closed x) (Open y)
124−x <..<= y = NonEmpty (open (Just x)) (closed (Just y))
117+x <..<= y = NonEmpty (Open x) (Closed y)
125
118
126moreThan, atLeast, lessThan, atMost :: x -> Range x
119moreThan, atLeast, lessThan, atMost :: x -> Range x
127−moreThan x = NonEmpty (open (Just x)) (open Nothing)
120+moreThan x = NonEmpty (Open x) Infinite
128−atLeast x = NonEmpty (closed (Just x)) (open Nothing)
121+atLeast x = NonEmpty (Closed x) Infinite
129−lessThan x = NonEmpty (open Nothing) (open (Just x))
122+lessThan x = NonEmpty Infinite (Open x)
130−atMost x = NonEmpty (open Nothing) (closed (Just x))
123+atMost x = NonEmpty Infinite (Closed x)
131
124
132singleton :: x -> Range x
125singleton :: x -> Range x
133singleton x = x <=..<= x
126singleton x = x <=..<= x
134
127
135whole :: Range x
128whole :: Range x
136−whole = NonEmpty (open Nothing) (open Nothing)
129+whole = NonEmpty Infinite Infinite
137
130
138(<@.) :: Operator ('NotNull ty) (null ('PGrange ty)) ('Null 'PGbool)
131(<@.) :: Operator ('NotNull ty) (null ('PGrange ty)) ('Null 'PGbool)
139(<@.) = unsafeBinaryOp "<@"
132(<@.) = unsafeBinaryOp "<@"
@@ -168,10 +161,10 @@ whole = NonEmpty (open Nothing) (open Nothing)
168(-.) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) (null ('PGrange ty))
161(-.) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) (null ('PGrange ty))
169(-.) = unsafeBinaryOp "-"
162(-.) = unsafeBinaryOp "-"
170
163
171−lowerBound :: null ('PGrange ty) :--> null ty
164+lowerBound :: null ('PGrange ty) :--> 'Null ty
172lowerBound = unsafeFunction "lower"
165lowerBound = unsafeFunction "lower"
173
166
174−upperBound :: null ('PGrange ty) :--> null ty
167+upperBound :: null ('PGrange ty) :--> 'Null ty
175upperBound = unsafeFunction "upper"
168upperBound = unsafeFunction "upper"
176
169
177isEmpty :: null ('PGrange ty) :--> 'Null 'PGbool
170isEmpty :: null ('PGrange ty) :--> 'Null 'PGbool