git.iko.soy/squeal
on dev help sign in
Merge pull request #140 from morphismtech/dev-range

Range types, operators and functions

commit79968042b36fae8f4985e903d58cfb1ade3b8da3 authorEitan Chatav <eitan.chatav@gmail.com> dateWed 28 Aug 2019, 13:31 (7 years ago) parent1b21626af6826b
15 files changed+604−165
compare with dev
unifiedsplit
squeal-postgresql/squeal-postgresql.cabal+24−8 squeal-postgresql/src/Squeal/PostgreSQL.hs+1 squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs+11−1 squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs+11−3 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Range.hs+231 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Type.hs+30−2 squeal-postgresql/src/Squeal/PostgreSQL/PG.hs+1−1 squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs+1−1 squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs+2−1 squeal-postgresql/test/DocTest.hs → squeal-postgresql/test/Doc.hs squeal-postgresql/test/Property.hs+166 squeal-postgresql/test/Spec.hs+125 squeal-postgresql/test/Specs/ExceptionHandling.hs−140 squeal-postgresql/test/Specs/Specs.hs−7 stack.yaml+1−1
squeal-postgresql/squeal-postgresql.cabal+24−8
@@ -35,6 +35,7 @@ library
3535 Squeal.PostgreSQL.Expression.Math
3636 Squeal.PostgreSQL.Expression.Null
3737 Squeal.PostgreSQL.Expression.Parameter
38+ Squeal.PostgreSQL.Expression.Range
3839 Squeal.PostgreSQL.Expression.SetOf
3940 Squeal.PostgreSQL.Expression.Sort
4041 Squeal.PostgreSQL.Expression.Subquery
@@ -79,35 +80,50 @@ library
7980 , uuid-types >= 1.0.3
8081 , vector >= 0.12.0.1
8182
82−test-suite squeal-postgresql-doctest
83+test-suite doctest
8384 default-language: Haskell2010
8485 type: exitcode-stdio-1.0
8586 hs-source-dirs: test
8687 ghc-options: -Wall
87− main-is: DocTest.hs
88+ main-is: Doc.hs
8889 build-depends:
8990 base >= 4.10.0.0
9091 , doctest >= 0.11.4
92+ , squeal-postgresql
93+
94+test-suite properties
95+ default-language: Haskell2010
96+ type: exitcode-stdio-1.0
97+ hs-source-dirs: test
98+ ghc-options: -Wall
99+ main-is: Property.hs
100+ build-depends:
101+ base >= 4.10.0.0
102+ , bytestring >= 0.10.8.2
103+ , hedgehog >= 1.0
104+ , mtl >= 2.2.2
105+ , scientific >= 0.3.5.3
106+ , squeal-postgresql
107+ , time >= 1.8.0.2
91108
92−test-suite squeal-postgresql-specs
109+test-suite spec
93110 default-language: Haskell2010
94111 type: exitcode-stdio-1.0
95− hs-source-dirs: test/Specs
112+ hs-source-dirs: test
96113 ghc-options: -Wall
97− main-is: Specs.hs
98− other-modules: ExceptionHandling
114+ main-is: Spec.hs
99115 build-depends:
100116 base >= 4.10.0.0
101117 , async >= 2.2.2
102118 , bytestring >= 0.10.8.2
103119 , generics-sop >= 0.3.1.0
104120 , hspec >= 2.4.8
121+ , mtl >= 2.2.2
105122 , squeal-postgresql
106123 , text >= 1.2.2.2
107− , transformers >= 0.5.2.0
108124 , vector >= 0.12.0.1
109125
110−executable squeal-postgresql-example
126+executable example
111127 default-language: Haskell2010
112128 hs-source-dirs: exe
113129 ghc-options: -Wall
squeal-postgresql/src/Squeal/PostgreSQL.hs+1
@@ -205,6 +205,7 @@ import Squeal.PostgreSQL.Expression.Logic as X
205205import Squeal.PostgreSQL.Expression.Math as X
206206import Squeal.PostgreSQL.Expression.Null as X
207207import Squeal.PostgreSQL.Expression.Parameter as X
208+import Squeal.PostgreSQL.Expression.Range as X
208209import Squeal.PostgreSQL.Expression.SetOf as X
209210import Squeal.PostgreSQL.Expression.Sort as X
210211import Squeal.PostgreSQL.Expression.Subquery as X
squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs+11−1
@@ -45,6 +45,7 @@ module Squeal.PostgreSQL.Definition
4545 , createTypeCompositeFrom
4646 , FieldTyped (..)
4747 , createDomain
48+ , createTypeRange
4849 , TableConstraintExpression (..)
4950 , check
5051 , unique
@@ -1032,7 +1033,7 @@ CREATE DOMAIN "positive" AS real CHECK ((("value" > 0) AND "value" IS NOT NULL))
10321033createDomain
10331034 :: (Has sch schemas schema, KnownSymbol dom)
10341035 => QualifiedAlias sch dom
1035− -> (forall nullity. TypeExpression schemas (nullity ty))
1036+ -> (forall null. TypeExpression schemas (null ty))
10361037 -> (forall tab. Condition '[] '[] 'Ungrouped schemas '[] '[tab ::: '["value" ::: 'Null ty]])
10371038 -> Definition schemas (Alter sch (Create dom ('Typedef ty) schema) schemas)
10381039createDomain dom ty condition =
@@ -1040,6 +1041,15 @@ createDomain dom ty condition =
10401041 <+> "AS" <+> renderTypeExpression ty
10411042 <+> "CHECK" <+> parenthesized (renderSQL condition) <> ";"
10421043
1044+createTypeRange
1045+ :: (Has sch schemas schema, KnownSymbol range)
1046+ => QualifiedAlias sch range
1047+ -> (forall null. TypeExpression schemas (null ty))
1048+ -> Definition schemas (Alter sch (Create range ('Typedef ('PGrange ty)) schema) schemas)
1049+createTypeRange range ty = UnsafeDefinition $
1050+ "CREATE" <+> "TYPE" <+> renderSQL range <+> "AS" <+> "RANGE" <+>
1051+ parenthesized ("subtype" <+> "=" <+> renderTypeExpression ty)
1052+
10431053-- | Lift `PGTyped` to a field
10441054class FieldTyped schemas ty where
10451055 fieldtype :: Aliased (TypeExpression schemas) ty
squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs+11−3
@@ -45,6 +45,7 @@ module Squeal.PostgreSQL.Expression
4545 , FunctionN
4646 , unsafeFunctionN
4747 , PGSubset (..)
48+ , PGIntersect (..)
4849 -- * Re-export
4950 , (&)
5051 , K (..)
@@ -353,14 +354,21 @@ instance (ty `In` PGNum, ty `In` PGFloating) => Floating
353354 atanh x = log ((1 + x) / (1 - x)) / 2
354355
355356-- | Contained by operators
356−class PGSubset container where
357− (@>) :: Operator (null0 container) (null1 container) ('Null 'PGbool)
357+class PGSubset ty where
358+ (@>) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
358359 (@>) = unsafeBinaryOp "@>"
359− (<@) :: Operator (null0 container) (null1 container) ('Null 'PGbool)
360+ (<@) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
360361 (<@) = unsafeBinaryOp "<@"
361362instance PGSubset 'PGjsonb
362363instance PGSubset 'PGtsquery
363364instance PGSubset ('PGvararray ty)
365+instance PGSubset ('PGrange ty)
366+
367+class PGIntersect ty where
368+ (@&&) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
369+ (@&&) = unsafeBinaryOp "&&"
370+instance PGIntersect ('PGvararray ty)
371+instance PGIntersect ('PGrange ty)
364372
365373instance IsString
366374 (Expression outer commons grp schemas params from (null 'PGtext)) where
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Range.hsnew file+231
@@ -0,0 +1,231 @@
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+ , moreThan, atLeast, lessThan, atMost
39+ , singleton, whole
40+ , Bound (..)
41+ , (.<@)
42+ , (@>.)
43+ , (<<@)
44+ , (@>>)
45+ , (&<)
46+ , (&>)
47+ , (-|-)
48+ , (@+)
49+ , (@*)
50+ , (@-)
51+ , lowerBound
52+ , upperBound
53+ , isEmpty
54+ , lowerInc
55+ , lowerInf
56+ , upperInc
57+ , upperInf
58+ , rangeMerge
59+ ) where
60+
61+import BinaryParser
62+import ByteString.StrictBuilder
63+import Data.Bits
64+import qualified GHC.Generics as GHC
65+import qualified Generics.SOP as SOP
66+import qualified PostgreSQL.Binary.Decoding as Decoding
67+
68+import Squeal.PostgreSQL.Binary
69+import Squeal.PostgreSQL.Expression
70+import Squeal.PostgreSQL.Expression.Type hiding (bool)
71+import Squeal.PostgreSQL.PG
72+import Squeal.PostgreSQL.Render
73+import Squeal.PostgreSQL.Schema
74+
75+-- $setup
76+-- >>> import Squeal.PostgreSQL
77+
78+-- | Construct a `range`
79+--
80+-- >>> printSQL $ range tstzrange (atLeast now)
81+-- tstzrange(now(), NULL, '[)')
82+-- >>> printSQL $ range numrange (0 <=..< 2*pi)
83+-- numrange(0, (2 * pi()), '[)')
84+-- >>> printSQL $ range int4range Empty
85+-- ('empty' :: int4range)
86+range
87+ :: TypeExpression schemas (null ('PGrange ty))
88+ -> Range (Expression outer commons grp schemas params from ('NotNull ty))
89+ -> Expression outer commons grp schemas params from (null ('PGrange ty))
90+range ty = \case
91+ Empty -> UnsafeExpression $ parenthesized
92+ (emp <+> "::" <+> renderSQL ty)
93+ NonEmpty l u -> UnsafeExpression $ renderSQL ty <> parenthesized
94+ (commaSeparated (args l u))
95+ where
96+ emp = singleQuote <> "empty" <> singleQuote
97+ args l u = [arg l, arg u, singleQuote <> bra l <> ket u <> singleQuote]
98+ singleQuote = "\'"
99+ arg = \case
100+ Infinite -> "NULL"; Closed x -> renderSQL x; Open x -> renderSQL x
101+ bra = \case Infinite -> "("; Closed _ -> "["; Open _ -> "("
102+ ket = \case Infinite -> ")"; Closed _ -> "]"; Open _ -> ")"
103+
104+data Bound x = Infinite | Closed x | Open x
105+ deriving
106+ ( Eq, Ord, Show, Read, GHC.Generic
107+ , Functor, Foldable, Traversable )
108+
109+data Range x = Empty | NonEmpty (Bound x) (Bound x)
110+ deriving
111+ ( Eq, Ord, Show, Read, GHC.Generic
112+ , Functor, Foldable, Traversable )
113+ deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
114+type instance PG (Range x) = 'PGrange (PG x)
115+instance ToParam x pg => ToParam (Range x) ('PGrange pg) where
116+ toParam rng = K $
117+ word8 (setFlags rng 0) <>
118+ case rng of
119+ Empty -> mempty
120+ NonEmpty lower upper -> putBound lower <> putBound upper
121+ where
122+ putBound = \case
123+ Infinite -> mempty
124+ Closed value -> putValue (unK (toParam @x @pg value))
125+ Open value -> putValue (unK (toParam @x @pg value))
126+ putValue value = int32BE (fromIntegral (builderLength value)) <> value
127+ setFlags = \case
128+ Empty -> (`setBit` 0)
129+ NonEmpty lower upper ->
130+ setLowerFlags lower . setUpperFlags upper
131+ setLowerFlags = \case
132+ Infinite -> (`setBit` 3)
133+ Closed _ -> (`setBit` 1)
134+ Open _ -> id
135+ setUpperFlags = \case
136+ Infinite -> (`setBit` 4)
137+ Closed _ -> (`setBit` 2)
138+ Open _ -> id
139+instance FromValue pg y => FromValue ('PGrange pg) (Range y) where
140+ fromValue = do
141+ flag <- byte
142+ if testBit flag 0 then return Empty else do
143+ lower <-
144+ if testBit flag 3
145+ then return Infinite
146+ else do
147+ len <- sized 4 Decoding.int
148+ l <- sized len (fromValue @pg)
149+ return $ if testBit flag 1 then Closed l else Open l
150+ upper <-
151+ if testBit flag 4
152+ then return Infinite
153+ else do
154+ len <- sized 4 Decoding.int
155+ l <- sized len (fromValue @pg)
156+ return $ if testBit flag 2 then Closed l else Open l
157+ return $ NonEmpty lower upper
158+
159+(<=..<=), (<..<), (<=..<), (<..<=) :: x -> x -> Range x
160+infix 4 <=..<=, <..<, <=..<, <..<=
161+x <=..<= y = NonEmpty (Closed x) (Closed y)
162+x <..< y = NonEmpty (Open x) (Open y)
163+x <=..< y = NonEmpty (Closed x) (Open y)
164+x <..<= y = NonEmpty (Open x) (Closed y)
165+
166+moreThan, atLeast, lessThan, atMost :: x -> Range x
167+moreThan x = NonEmpty (Open x) Infinite
168+atLeast x = NonEmpty (Closed x) Infinite
169+lessThan x = NonEmpty Infinite (Open x)
170+atMost x = NonEmpty Infinite (Closed x)
171+
172+singleton :: x -> Range x
173+singleton x = x <=..<= x
174+
175+whole :: Range x
176+whole = NonEmpty Infinite Infinite
177+
178+(.<@) :: Operator ('NotNull ty) (null ('PGrange ty)) ('Null 'PGbool)
179+(.<@) = unsafeBinaryOp "<@"
180+
181+(@>.) :: Operator (null ('PGrange ty)) ('NotNull ty) ('Null 'PGbool)
182+(@>.) = unsafeBinaryOp "<@"
183+
184+(<<@) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)
185+(<<@) = unsafeBinaryOp "<<"
186+
187+(@>>) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)
188+(@>>) = unsafeBinaryOp ">>"
189+
190+(&<) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)
191+(&<) = unsafeBinaryOp "&<"
192+
193+(&>) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)
194+(&>) = unsafeBinaryOp "&>"
195+
196+(-|-) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)
197+(-|-) = unsafeBinaryOp "-|-"
198+
199+(@+) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) (null ('PGrange ty))
200+(@+) = unsafeBinaryOp "+"
201+
202+(@*) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) (null ('PGrange ty))
203+(@*) = unsafeBinaryOp "*"
204+
205+(@-) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) (null ('PGrange ty))
206+(@-) = unsafeBinaryOp "-"
207+
208+lowerBound :: null ('PGrange ty) :--> 'Null ty
209+lowerBound = unsafeFunction "lower"
210+
211+upperBound :: null ('PGrange ty) :--> 'Null ty
212+upperBound = unsafeFunction "upper"
213+
214+isEmpty :: null ('PGrange ty) :--> 'Null 'PGbool
215+isEmpty = unsafeFunction "isempty"
216+
217+lowerInc :: null ('PGrange ty) :--> 'Null 'PGbool
218+lowerInc = unsafeFunction "lower_inc"
219+
220+lowerInf :: null ('PGrange ty) :--> 'Null 'PGbool
221+lowerInf = unsafeFunction "lower_inf"
222+
223+upperInc :: null ('PGrange ty) :--> 'Null 'PGbool
224+upperInc = unsafeFunction "upper_inc"
225+
226+upperInf :: null ('PGrange ty) :--> 'Null 'PGbool
227+upperInf = unsafeFunction "upper_inf"
228+
229+rangeMerge :: FunctionN
230+ '[ null ('PGrange ty), null ('PGrange ty)] (null ('PGrange ty))
231+rangeMerge = unsafeFunctionN "range_merge"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Type.hs+30−2
@@ -56,9 +56,11 @@ module Squeal.PostgreSQL.Expression.Type
5656 , bytea
5757 , timestamp
5858 , timestampWithTimeZone
59+ , timestamptz
5960 , date
6061 , time
6162 , timeWithTimeZone
63+ , timetz
6264 , interval
6365 , uuid
6466 , inet
@@ -68,6 +70,12 @@ module Squeal.PostgreSQL.Expression.Type
6870 , fixarray
6971 , tsvector
7072 , tsquery
73+ , int4range
74+ , int8range
75+ , numrange
76+ , tsrange
77+ , tstzrange
78+ , daterange
7179 ) where
7280
7381import Control.DeepSeq
@@ -213,8 +221,9 @@ bytea = UnsafeTypeExpression "bytea"
213221timestamp :: TypeExpression schemas (null 'PGtimestamp)
214222timestamp = UnsafeTypeExpression "timestamp"
215223-- | date and time, including time zone
216−timestampWithTimeZone :: TypeExpression schemas (null 'PGtimestamptz)
224+timestampWithTimeZone, timestamptz :: TypeExpression schemas (null 'PGtimestamptz)
217225timestampWithTimeZone = UnsafeTypeExpression "timestamp with time zone"
226+timestamptz = UnsafeTypeExpression "timestamptz"
218227-- | calendar date (year, month, day)
219228date :: TypeExpression schemas (null 'PGdate)
220229date = UnsafeTypeExpression "date"
@@ -222,8 +231,9 @@ date = UnsafeTypeExpression "date"
222231time :: TypeExpression schemas (null 'PGtime)
223232time = UnsafeTypeExpression "time"
224233-- | time of day, including time zone
225−timeWithTimeZone :: TypeExpression schemas (null 'PGtimetz)
234+timeWithTimeZone, timetz :: TypeExpression schemas (null 'PGtimetz)
226235timeWithTimeZone = UnsafeTypeExpression "time with time zone"
236+timetz = UnsafeTypeExpression "timetz"
227237-- | time span
228238interval :: TypeExpression schemas (null 'PGinterval)
229239interval = UnsafeTypeExpression "interval"
@@ -270,6 +280,24 @@ tsvector = UnsafeTypeExpression "tsvector"
270280-- | text search document
271281tsquery :: TypeExpression schemas (null 'PGtsquery)
272282tsquery = UnsafeTypeExpression "tsquery"
283+-- | Range of integer
284+int4range :: TypeExpression schemas (null ('PGrange 'PGint4))
285+int4range = UnsafeTypeExpression "int4range"
286+-- | Range of bigint
287+int8range :: TypeExpression schemas (null ('PGrange 'PGint8))
288+int8range = UnsafeTypeExpression "int8range"
289+-- | Range of numeric
290+numrange :: TypeExpression schemas (null ('PGrange 'PGnumeric))
291+numrange = UnsafeTypeExpression "numrange"
292+-- | Range of timestamp without time zone
293+tsrange :: TypeExpression schemas (null ('PGrange 'PGtimestamp))
294+tsrange = UnsafeTypeExpression "tsrange"
295+-- | Range of timestamp with time zone
296+tstzrange :: TypeExpression schemas (null ('PGrange 'PGtimestamptz))
297+tstzrange = UnsafeTypeExpression "tstzrange"
298+-- | Range of date
299+daterange :: TypeExpression schemas (null ('PGrange 'PGdate))
300+daterange = UnsafeTypeExpression "daterange"
273301
274302-- | `pgtype` is a demoted version of a `PGType`
275303class PGTyped schemas (ty :: NullityType) where
squeal-postgresql/src/Squeal/PostgreSQL/PG.hs+1−1
@@ -20,8 +20,8 @@ Stability: experimental
2020 , FunctionalDependencies
2121 , GADTs
2222 , LambdaCase
23− , OverloadedStrings
2423 , MultiParamTypeClasses
24+ , OverloadedStrings
2525 , ScopedTypeVariables
2626 , TypeApplications
2727 , TypeFamilies
squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs+1−1
@@ -432,7 +432,7 @@ instance (MonadIO io, schemas0 ~ schemas, schemas1 ~ schemas)
432432 Just prepResult -> okResult_ prepResult
433433 results <- for list $ \ params -> do
434434 let
435− toParam' encoding = (encodingBytes encoding,LibPQ.Binary)
435+ toParam' encoding = (encodingBytes encoding, LibPQ.Binary)
436436 params' = fmap (fmap toParam') (hcollapse (toParams @x @xs params))
437437 resultMaybe <- LibPQ.execPrepared conn temp params' LibPQ.Binary
438438 case resultMaybe of
squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs+2−1
@@ -132,7 +132,8 @@ data PGType
132132 | PGenum [Symbol] -- ^ enumerated (enum) types are data types that comprise a static, ordered set of values.
133133 | PGcomposite RowType -- ^ a composite type represents the structure of a row or record; it is essentially just a list of field names and their data types.
134134 | PGtsvector -- ^ A tsvector value is a sorted list of distinct lexemes, which are words that have been normalized to merge different variants of the same word.
135− | PGtsquery -- ^ A tsquery value stores lexemes that are to be searched for
135+ | PGtsquery -- ^ A tsquery value stores lexemes that are to be searched for.
136+ | PGrange PGType -- ^ Range types are data types representing a range of values of some element type (called the range's subtype).
136137 | UnsafePGType Symbol -- ^ an escape hatch for unsupported PostgreSQL types
137138
138139-- | `NullityType` encodes the potential presence or definite absence of a
squeal-postgresql/test/DocTest.hs → squeal-postgresql/test/Doc.hsrenamed

The content is the same.

squeal-postgresql/test/Property.hsnew file+166
@@ -0,0 +1,166 @@
1+{-# LANGUAGE
2+ DataKinds
3+ , GADTs
4+ , LambdaCase
5+ , OverloadedLabels
6+ , OverloadedStrings
7+ , TypeApplications
8+ , TypeOperators
9+#-}
10+
11+module Main (main) where
12+
13+import Control.Monad.Trans
14+import Data.ByteString (ByteString)
15+import Data.ByteString.Char8 (unpack)
16+import Data.Scientific (fromFloatDigits)
17+import Data.Fixed (Fixed(MkFixed), Micro, Pico)
18+import Data.String (IsString(fromString))
19+import Data.Time
20+import Squeal.PostgreSQL hiding (check, defaultMain, Group)
21+import Hedgehog hiding (Range)
22+import qualified Hedgehog.Gen as Gen
23+import qualified Hedgehog.Main as Main
24+import qualified Hedgehog.Range as Range
25+
26+main :: IO ()
27+main = Main.defaultMain [checkSequential roundtrips]
28+
29+roundtrips :: Group
30+roundtrips = Group "roundtrips"
31+ [ roundtrip int2 genInt16
32+ , roundtrip int4 genInt32
33+ , roundtrip int8 genInt64
34+ , roundtrip bool Gen.bool
35+ , roundtrip numeric genScientific
36+ , roundtrip float4 genFloat
37+ , roundtrip float8 genDouble
38+ , roundtripOn normalizeTimeOfDay time genTimeOfDay
39+ -- , roundtrip timetz genTimeWithZone normalizeTimeWithZone
40+ , roundtripOn normalizeLocalTime timestamp genLocalTime
41+ , roundtrip timestamptz genUTCTime
42+ , roundtrip date genDay
43+ , roundtrip interval genDiffTime
44+ , roundtripOn normalizeIntRange int4range (genRange genInt32)
45+ , roundtripOn normalizeIntRange int8range (genRange genInt64)
46+ , roundtrip numrange (genRange genScientific)
47+ , roundtripOn (fmap normalizeLocalTime) tsrange (genRange genLocalTime)
48+ , roundtrip tstzrange (genRange genUTCTime)
49+ , roundtripOn normalizeIntRange daterange (genRange genDay)
50+ ]
51+ where
52+ genInt16 = Gen.int16 Range.exponentialBounded
53+ genInt32 = Gen.int32 Range.exponentialBounded
54+ genInt64 = Gen.int64 Range.exponentialBounded
55+ genScientific = fromFloatDigits <$> genFloat
56+ genPosFloat = Gen.float
57+ (Range.exponentialFloatFrom 1 minPosFloat maxPosFloat)
58+ genFloat = Gen.prune $ Gen.choice
59+ [ genPosFloat
60+ , negate <$> genPosFloat
61+ , Gen.element [0,1/0] ]
62+ genPosDouble = Gen.double
63+ (Range.exponentialFloatFrom 1 minPosFloat maxPosFloat)
64+ genDouble = Gen.prune $ Gen.choice
65+ [ genPosDouble
66+ , negate <$> genPosDouble
67+ , Gen.element [0,1/0] ]
68+ genRange gen = do
69+ lb <- gen
70+ ub <- Gen.filter (lb <) gen
71+ Gen.element
72+ [ Empty, singleton lb, whole
73+ , lb <=..<= ub , lb <=..< ub, lb <..<= ub, lb <..< ub
74+ , atLeast lb, moreThan lb, atMost ub, lessThan ub ]
75+ genDay = do
76+ y <- toInteger <$> Gen.int (Range.constant 2000 2019)
77+ m <- Gen.int (Range.constant 1 12)
78+ d <- Gen.int (Range.constant 1 28)
79+ return $ fromGregorian y m d
80+ genDiffTime = secondsToDiffTime . toInteger <$>
81+ Gen.int (Range.constant 0 86401)
82+ genUTCTime = UTCTime <$> genDay <*> genDiffTime
83+ genTimeOfDay = do
84+ h <- Gen.int (Range.constant 0 23)
85+ m <- Gen.int (Range.constant 0 59)
86+ s <- MkFixed . toInteger <$> Gen.int (Range.constant 0 59)
87+ return $ TimeOfDay h m s
88+ genLocalTime = LocalTime <$> genDay <*> genTimeOfDay
89+ -- genTimeZone = Gen.element $ map (read @TimeZone)
90+ -- [ "UTC", "UT", "GMT", "EST", "EDT", "CST"
91+ -- , "CDT", "MST", "MDT", "PST", "PDT" ]
92+ -- genTimeWithZone = (,) <$> genTimeOfDay <*> genTimeZone
93+
94+roundtrip
95+ :: (ToParam x ty, FromValue ty x, Show x, Eq x)
96+ => TypeExpression schemas ('NotNull ty)
97+ -> Gen x
98+ -> (PropertyName, Property)
99+roundtrip = roundtripOn id
100+
101+roundtripOn
102+ :: (ToParam x ty, FromValue ty x, Show x, Eq x)
103+ => (x -> x)
104+ -> TypeExpression schemas ('NotNull ty)
105+ -> Gen x
106+ -> (PropertyName, Property)
107+roundtripOn norm ty gen = propertyWithName $ do
108+ x <- forAll gen
109+ Just (Only y) <- lift . withConnection connectionString $
110+ firstRow =<< runQueryParams
111+ (values_ (parameter @1 ty `as` #fromOnly)) (Only x)
112+ norm x === y
113+ where
114+ propertyWithName prop =
115+ (fromString (unpack (renderSQL ty)), property prop)
116+
117+maxPosFloat :: RealFloat a => a
118+maxPosFloat = x
119+ where
120+ n = floatDigits x
121+ b = floatRadix x
122+ (_, u) = floatRange x
123+ x = encodeFloat (b^n - 1) (u - n)
124+
125+minPosFloat :: RealFloat a => a
126+minPosFloat = x
127+ where
128+ n = floatDigits x
129+ b = floatRadix x
130+ (l, _) = floatRange x
131+ x = encodeFloat (b^n - 1) (l - n - 1)
132+
133+connectionString :: ByteString
134+connectionString = "host=localhost port=5432 dbname=exampledb"
135+
136+normalizeIntRange :: (Enum int, Ord int) => Range int -> Range int
137+normalizeIntRange = \case
138+ Empty -> Empty
139+ NonEmpty l u ->
140+ let
141+ l' = normalizeL l
142+ u' = normalizeU u
143+ in if emptyNormalized l' u' then Empty else NonEmpty l' u'
144+ where
145+ normalizeL = \case
146+ Open l -> Closed (succ l)
147+ normalized -> normalized
148+ normalizeU = \case
149+ Closed u -> Open (succ u)
150+ normalized -> normalized
151+ emptyNormalized (Closed l) (Open u) = l >= u
152+ emptyNormalized _ _ = False
153+
154+normalizeTimeOfDay :: TimeOfDay -> TimeOfDay
155+normalizeTimeOfDay (TimeOfDay h m s) = TimeOfDay h m
156+ . fromRational @Pico
157+ . toRational @Micro
158+ . fromRational @Micro
159+ . toRational @Pico
160+ $ s
161+
162+normalizeLocalTime :: LocalTime -> LocalTime
163+normalizeLocalTime (LocalTime d t) = LocalTime d (normalizeTimeOfDay t)
164+
165+-- normalizeTimeWithZone :: (TimeOfDay, TimeZone) -> (TimeOfDay, TimeZone)
166+-- normalizeTimeWithZone (t, z) = (normalizeTimeOfDay t, z)
squeal-postgresql/test/Spec.hsnew file+125
@@ -0,0 +1,125 @@
1+{-# LANGUAGE
2+ DataKinds
3+ , DeriveAnyClass
4+ , DeriveGeneric
5+ , DerivingStrategies
6+ , DuplicateRecordFields
7+ , FlexibleContexts
8+ , OverloadedLabels
9+ , OverloadedLists
10+ , OverloadedStrings
11+ , TypeApplications
12+ , TypeFamilies
13+ , TypeInType
14+ , TypeOperators
15+#-}
16+
17+module Main (main) where
18+
19+import Control.Concurrent.Async (replicateConcurrently)
20+import Data.ByteString (ByteString)
21+import Data.Int (Int32)
22+import Data.Text (Text)
23+import Test.Hspec
24+
25+import qualified Generics.SOP as SOP
26+import qualified GHC.Generics as GHC
27+
28+import Squeal.PostgreSQL
29+
30+main :: IO ()
31+main = hspec spec
32+
33+type Schemas = Public
34+ '[ "users" ::: 'Table (
35+ '[ "pk_users" ::: 'PrimaryKey '["id"]
36+ , "unique_names" ::: 'Unique '["name"]
37+ ] :=>
38+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
39+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext ] ) ]
40+
41+data User = User
42+ { userName :: Text
43+ } deriving stock (Eq, Show, GHC.Generic)
44+ deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
45+
46+insertUser :: Manipulation_ Schemas User ()
47+insertUser = insertInto_ #users
48+ (Values_ (Default `as` #id :* Set (param @1) `as` #name))
49+
50+setup :: Definition (Public '[]) Schemas
51+setup =
52+ createTable #users
53+ ( serial `as` #id :*
54+ notNullable text `as` #name )
55+ ( primaryKey #id `as` #pk_users :*
56+ unique #name `as` #unique_names )
57+
58+teardown :: Definition Schemas (Public '[])
59+teardown = dropTable #users
60+
61+silence :: MonadPQ schemas pq => pq ()
62+silence = manipulate_ $
63+ UnsafeManipulation "SET client_min_messages TO WARNING;"
64+
65+setupDB :: IO ()
66+setupDB = withConnection connectionString $
67+ silence & pqThen (define setup)
68+
69+dropDB :: IO ()
70+dropDB = withConnection connectionString $
71+ silence & pqThen (define teardown)
72+
73+connectionString :: ByteString
74+connectionString = "host=localhost port=5432 dbname=exampledb"
75+
76+spec :: Spec
77+spec = before_ setupDB . after_ dropDB $ do
78+
79+ describe "Exceptions" $ do
80+
81+ let
82+ testUser = User "TestUser"
83+ newUser = manipulateParams_ insertUser
84+ insertUserTwice = newUser testUser >> newUser testUser
85+ err23505 = PQException $ PQState FatalError (Just "23505")
86+ (Just "ERROR: duplicate key value violates unique constraint \"unique_names\"\nDETAIL: Key (name)=(TestUser) already exists.\n")
87+
88+ it "should be thrown for constraint violation" $
89+ withConnection connectionString insertUserTwice
90+ `shouldThrow` (== err23505)
91+
92+ it "should be rethrown for constraint violation in a transaction" $
93+ withConnection connectionString (transactionally_ insertUserTwice)
94+ `shouldThrow` (== err23505)
95+
96+ describe "Pools" $
97+
98+ it "should manage concurrent transactions" $ do
99+ pool <- createConnectionPool
100+ "host=localhost port=5432 dbname=exampledb" 1 0.5 10
101+ let
102+ query :: Query_ (Public '[]) () (Only Char)
103+ query = values_ (literal 'a' `as` #fromOnly)
104+ session = usingConnectionPool pool . transactionally_ $ do
105+ result <- runQuery query
106+ Just (Only chr) <- firstRow result
107+ return chr
108+ chrs <- replicateConcurrently 10 session
109+ chrs `shouldSatisfy` all (== 'a')
110+
111+ describe "Ranges" $
112+
113+ it "should correctly decode ranges" $ do
114+
115+ rangesOut <- withConnection connectionString $ do
116+ let
117+ query :: Query_ (Public '[]) () (Only (Range Int32))
118+ query = values
119+ ( range int4range (atLeast 3) `as` #fromOnly )
120+ [ range int4range (3 <=..< 5) `as` #fromOnly
121+ , range int4range Empty `as` #fromOnly
122+ , range int4range whole `as` #fromOnly ]
123+ getRows =<< runQuery query
124+ (fromOnly <$> rangesOut :: [Range Int32]) `shouldBe`
125+ [ atLeast 3, 3 <=..< 5, Empty, whole ]
squeal-postgresql/test/Specs/ExceptionHandling.hsdeleted−140
@@ -1,140 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE DeriveGeneric #-}
3−{-# LANGUAGE DuplicateRecordFields #-}
4−{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE OverloadedLabels #-}
6−{-# LANGUAGE OverloadedLists #-}
7−{-# LANGUAGE OverloadedStrings #-}
8−{-# LANGUAGE TypeApplications #-}
9−{-# LANGUAGE TypeFamilies #-}
10−{-# LANGUAGE TypeInType #-}
11−{-# LANGUAGE TypeOperators #-}
12−module ExceptionHandling
13− ( specs
14− , User (..)
15− ) where
16−
17−import Control.Concurrent.Async (replicateConcurrently)
18−import Control.Monad (void)
19−import Control.Monad.IO.Class (MonadIO (..))
20−import Data.Int (Int16)
21−import Data.Text (Text)
22−import Data.Vector (Vector)
23−import Test.Hspec
24−
25−import qualified Data.ByteString.Char8 as Char8
26−import qualified Generics.SOP as SOP
27−import qualified GHC.Generics as GHC
28−
29−import Squeal.PostgreSQL
30−
31−type Schema =
32− '[ "users" ::: 'Table (
33− '[ "pk_users" ::: 'PrimaryKey '["id"]
34− , "unique_names" ::: 'Unique '["name"]
35− ] :=>
36− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
37− , "name" ::: 'NoDef :=> 'NotNull 'PGtext
38− , "vec" ::: 'NoDef :=> 'NotNull ('PGvararray ('Null 'PGint2))
39− ])
40− , "emails" ::: 'Table (
41− '[ "pk_emails" ::: 'PrimaryKey '["id"]
42− , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
43− ] :=>
44− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
45− , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
46− , "email" ::: 'NoDef :=> 'Null 'PGtext
47− ])
48− ]
49−
50−type Schemas = Public Schema
51−
52−data User =
53− User { userName :: Text
54− , userEmail :: Maybe Text
55− , userVec :: VarArray (Vector (Maybe Int16)) }
56− deriving (Show, GHC.Generic)
57−instance SOP.Generic User
58−instance SOP.HasDatatypeInfo User
59−
60−insertUser :: Manipulation '[] Schemas '[ 'NotNull 'PGtext, 'NotNull ('PGvararray ('Null 'PGint2))]
61− '[ "fromOnly" ::: 'NotNull 'PGint4 ]
62−insertUser = insertInto #users
63− (Values_ (Default `as` #id :* Set (param @1) `as` #name :* Set (param @2) `as` #vec))
64− OnConflictDoRaise (Returning (#id `as` #fromOnly))
65−
66−setup :: Definition (Public '[]) Schemas
67−setup =
68− createTable #users
69− ( serial `as` #id :*
70− (text & notNullable) `as` #name :*
71− (vararray int2 & notNullable) `as` #vec )
72− ( primaryKey #id `as` #pk_users
73− :* unique #name `as` #unique_names )
74− >>>
75− createTable #emails
76− ( serial `as` #id :*
77− (int & notNullable) `as` #user_id :*
78− (text & nullable) `as` #email )
79− ( primaryKey #id `as` #pk_emails :*
80− foreignKey #user_id #users #id
81− OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
82−
83−teardown :: Definition Schemas (Public '[])
84−teardown = dropTable #emails >>> dropTable #users
85−
86−migration :: Migration Definition (Public '[]) Schemas
87−migration = Migration { name = "test"
88− , up = setup
89− , down = teardown }
90−
91−setupDB :: IO ()
92−setupDB = withConnection connectionString $
93− manipulate (UnsafeManipulation "SET client_min_messages TO WARNING;")
94− & pqThen (migrateUp (single migration))
95−
96−dropDB :: IO ()
97−dropDB = withConnection connectionString $
98− manipulate (UnsafeManipulation "SET client_min_messages TO WARNING;")
99− & pqThen (migrateDown (single migration))
100−
101−connectionString :: Char8.ByteString
102−connectionString = "host=localhost port=5432 dbname=exampledb"
103−
104−testUser :: User
105−testUser = User "TestUser" Nothing (VarArray [])
106−
107−newUser :: (MonadIO m, MonadPQ Schemas m) => User -> m ()
108−newUser u = void $ manipulateParams insertUser (userName u, userVec u)
109−
110−insertUserTwice :: (MonadIO m, MonadPQ Schemas m) => m ()
111−insertUserTwice = newUser testUser >> newUser testUser
112−
113−specs :: SpecWith ()
114−specs = before_ setupDB $ after_ dropDB $
115− describe "Exceptions" $ do
116−
117− let
118− dupKeyErr = PQException $ PQState FatalError (Just "23505")
119− (Just "ERROR: duplicate key value violates unique constraint \"unique_names\"\nDETAIL: Key (name)=(TestUser) already exists.\n")
120−
121− it "should be thrown for unique constraint violation in a manipulation" $
122− withConnection connectionString insertUserTwice
123− `shouldThrow` (== dupKeyErr)
124−
125− it "should be rethrown for unique constraint violation in a manipulation by a transaction" $
126− withConnection connectionString (transactionally_ insertUserTwice)
127− `shouldThrow` (== dupKeyErr)
128−
129− it "should handle concurrent transactions using pooled connections" $ do
130− pool <- createConnectionPool
131− "host=localhost port=5432 dbname=exampledb" 1 0.5 10
132− let
133− query :: Query_ (Public '[]) () (Only Char)
134− query = values_ (literal 'a' `as` #fromOnly)
135− session = usingConnectionPool pool . transactionally_ $ do
136− result <- runQuery query
137− Just (Only chr) <- firstRow result
138− return chr
139− chrs <- replicateConcurrently 10 session
140− chrs `shouldSatisfy` (all (== 'a'))
squeal-postgresql/test/Specs/Specs.hsdeleted−7
@@ -1,7 +0,0 @@
1−module Main where
2−
3−import Test.Hspec
4−import qualified ExceptionHandling
5−
6−main :: IO ()
7−main = hspec ExceptionHandling.specs
stack.yaml+1−1
@@ -1,4 +1,4 @@
1−resolver: lts-13.25
1+resolver: nightly-2019-07-14
22packages:
33- squeal-postgresql
44