git.iko.soy/squeal
on d6ad73f help sign in
ddc9847
swap
0 ahead, 97 behind
README.md+6−6
since splitsnapshots
unifiedsplit
@@ -121,7 +121,7 @@ type Schemas = Public Schema
121
121
122Notice the use of type operators.
122Notice the use of type operators.
123
123
124−`:::` is used to pair an alias `Symbol` with a `SchemumType`,
124+`:::` is used to pair an alias `GHC.TypeLits.Symbol` with a `SchemumType`,
125a `TableConstraint` or a `ColumnType`. It is intended to connote Haskell's `::`
125a `TableConstraint` or a `ColumnType`. It is intended to connote Haskell's `::`
126operator.
126operator.
127
127
@@ -180,8 +180,8 @@ DROP TABLE "emails";
180DROP TABLE "users";
180DROP TABLE "users";
181```
181```
182
182
183−We'll need a Haskell type for `User`s. We give the type `SOP.Generic` and
183+We'll need a Haskell type for @User@s. We give the type `Generics.SOP.Generic` and
184−`SOP.HasDatatypeInfo` instances so that we can encode and decode `User`s.
184+`Generics.SOP.HasDatatypeInfo` instances so that we can encode and decode @User@s.
185
185
186```Haskell
186```Haskell
187>>> data User = User { userName :: Text, userEmail :: Maybe Text } deriving (Show, GHC.Generic)
187>>> data User = User { userName :: Text, userEmail :: Maybe Text } deriving (Show, GHC.Generic)
@@ -189,12 +189,12 @@ We'll need a Haskell type for `User`s. We give the type `SOP.Generic` and
189>>> instance SOP.HasDatatypeInfo User
189>>> instance SOP.HasDatatypeInfo User
190```
190```
191
191
192−Next, we'll write `Manipulation_`s to insert `User`s into our two tables.
192+Next, we'll write `Manipulation_`s to insert @User@s into our two tables.
193A `Manipulation_` like `insertInto`, `update` or `deleteFrom`
193A `Manipulation_` like `insertInto`, `update` or `deleteFrom`
194has three type parameters, the schemas it refers to, input parameters
194has three type parameters, the schemas it refers to, input parameters
195and an output row. When
195and an output row. When
196−we insert into the users table, we will need a parameter for the `name`
196+we insert into the users table, we will need a parameter for the @name@
197−field but not for the `id` field. Since it's serial, we can use a default
197+field but not for the @id@ field. Since it's serial, we can use a default
198value. However, since the emails table refers to the users table, we will
198value. However, since the emails table refers to the users table, we will
199need to retrieve the user id that the insert generates and insert it into
199need to retrieve the user id that the insert generates and insert it into
200the emails table. We can do this in a single `Manipulation_` by using a
200the emails table. We can do this in a single `Manipulation_` by using a
RELEASE NOTES.md+2−2
@@ -138,11 +138,11 @@ type Expr x
138 . Expression outer commons grp schemas params from x
138 . Expression outer commons grp schemas params from x
139```
139```
140
140
141−There is also a function type `(-->)`, which is a subtype of the usual Haskell function
141+There is also a function type `(:-->)`, which is a subtype of the usual Haskell function
142type `(->)`.
142type `(->)`.
143
143
144```Haskell
144```Haskell
145−type (-->) x y
145+type (:-->) x y
146 = forall outer commons grp schemas params from
146 = forall outer commons grp schemas params from
147 . Expression outer commons grp schemas params from x
147 . Expression outer commons grp schemas params from x
148 -> Expression outer commons grp schemas params from y
148 -> Expression outer commons grp schemas params from y
squeal-postgresql/exe/Example.hs+3−6
@@ -38,7 +38,6 @@ type Schema =
38 , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
38 , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
39 , "email" ::: 'NoDef :=> 'Null 'PGtext
39 , "email" ::: 'NoDef :=> 'Null 'PGtext
40 ])
40 ])
41− , "positive" ::: 'Typedef 'PGfloat4
42 ]
41 ]
43
42
44type Schemas = Public Schema
43type Schemas = Public Schema
@@ -53,16 +52,14 @@ setup =
53 >>>
52 >>>
54 createTable #emails
53 createTable #emails
55 ( serial `as` #id :*
54 ( serial `as` #id :*
56− hask @Int32 `as` #user_id :*
55+ (int & notNullable) `as` #user_id :*
57− hask @(Maybe Text) `as` #email )
56+ (text & nullable) `as` #email )
58 ( primaryKey #id `as` #pk_emails :*
57 ( primaryKey #id `as` #pk_emails :*
59 foreignKey #user_id #users #id
58 foreignKey #user_id #users #id
60 OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
59 OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
61− >>>
62− createDomain #positive real (#value .> 0 .&& (#value & isNotNull))
63
60
64teardown :: Definition Schemas (Public '[])
61teardown :: Definition Schemas (Public '[])
65−teardown = dropType #positive >>> dropTable #emails >>> dropTable #users
62+teardown = dropTable #emails >>> dropTable #users
66
63
67insertUser :: Manipulation_ Schemas (Text, VarArray (Vector (Maybe Int16))) (Only Int32)
64insertUser :: Manipulation_ Schemas (Text, VarArray (Vector (Maybe Int16))) (Only Int32)
68insertUser = insertInto #users
65insertUser = insertInto #users
squeal-postgresql/squeal-postgresql.cabal+9−32
@@ -25,13 +25,6 @@ library
25 Squeal.PostgreSQL.Alias
25 Squeal.PostgreSQL.Alias
26 Squeal.PostgreSQL.Binary
26 Squeal.PostgreSQL.Binary
27 Squeal.PostgreSQL.Definition
27 Squeal.PostgreSQL.Definition
28− Squeal.PostgreSQL.Definition.Function
29− Squeal.PostgreSQL.Definition.Index
30− Squeal.PostgreSQL.Definition.Table
31− Squeal.PostgreSQL.Definition.Table.Constraint
32− Squeal.PostgreSQL.Definition.Type
33− Squeal.PostgreSQL.Definition.Schema
34− Squeal.PostgreSQL.Definition.View
35 Squeal.PostgreSQL.Expression
28 Squeal.PostgreSQL.Expression
36 Squeal.PostgreSQL.Expression.Aggregate
29 Squeal.PostgreSQL.Expression.Aggregate
37 Squeal.PostgreSQL.Expression.Collection
30 Squeal.PostgreSQL.Expression.Collection
@@ -43,7 +36,7 @@ library
43 Squeal.PostgreSQL.Expression.Null
36 Squeal.PostgreSQL.Expression.Null
44 Squeal.PostgreSQL.Expression.Parameter
37 Squeal.PostgreSQL.Expression.Parameter
45 Squeal.PostgreSQL.Expression.Range
38 Squeal.PostgreSQL.Expression.Range
46− Squeal.PostgreSQL.Expression.Set
39+ Squeal.PostgreSQL.Expression.SetOf
47 Squeal.PostgreSQL.Expression.Sort
40 Squeal.PostgreSQL.Expression.Sort
48 Squeal.PostgreSQL.Expression.Subquery
41 Squeal.PostgreSQL.Expression.Subquery
49 Squeal.PostgreSQL.Expression.Text
42 Squeal.PostgreSQL.Expression.Text
@@ -70,7 +63,6 @@ library
70 , bytestring >= 0.10.8.2
63 , bytestring >= 0.10.8.2
71 , bytestring-strict-builder >= 0.4.5
64 , bytestring-strict-builder >= 0.4.5
72 , deepseq >= 1.4.3.0
65 , deepseq >= 1.4.3.0
73− , free-categories >= 0.1.0.0
74 , generics-sop >= 0.3.2.0 && < 0.5.0.0
66 , generics-sop >= 0.3.2.0 && < 0.5.0.0
75 , mmorph >= 1.1.1
67 , mmorph >= 1.1.1
76 , mtl >= 2.2.2
68 , mtl >= 2.2.2
@@ -88,50 +80,35 @@ library
88 , uuid-types >= 1.0.3
80 , uuid-types >= 1.0.3
89 , vector >= 0.12.0.1
81 , vector >= 0.12.0.1
90
82
91−test-suite doctest
83+test-suite squeal-postgresql-doctest
92 default-language: Haskell2010
84 default-language: Haskell2010
93 type: exitcode-stdio-1.0
85 type: exitcode-stdio-1.0
94 hs-source-dirs: test
86 hs-source-dirs: test
95 ghc-options: -Wall
87 ghc-options: -Wall
96− main-is: Doc.hs
88+ main-is: DocTest.hs
97 build-depends:
89 build-depends:
98 base >= 4.10.0.0
90 base >= 4.10.0.0
99 , doctest >= 0.11.4
91 , doctest >= 0.11.4
100− , squeal-postgresql
101−
102−test-suite properties
103− default-language: Haskell2010
104− type: exitcode-stdio-1.0
105− hs-source-dirs: test
106− ghc-options: -Wall
107− main-is: Property.hs
108− build-depends:
109− base >= 4.10.0.0
110− , bytestring >= 0.10.8.2
111− , hedgehog >= 1.0
112− , mtl >= 2.2.2
113− , scientific >= 0.3.5.3
114− , squeal-postgresql
115− , time >= 1.8.0.2
116
92
117−test-suite spec
93+test-suite squeal-postgresql-specs
118 default-language: Haskell2010
94 default-language: Haskell2010
119 type: exitcode-stdio-1.0
95 type: exitcode-stdio-1.0
120− hs-source-dirs: test
96+ hs-source-dirs: test/Specs
121 ghc-options: -Wall
97 ghc-options: -Wall
122− main-is: Spec.hs
98+ main-is: Specs.hs
99+ other-modules: ExceptionHandling
123 build-depends:
100 build-depends:
124 base >= 4.10.0.0
101 base >= 4.10.0.0
125 , async >= 2.2.2
102 , async >= 2.2.2
126 , bytestring >= 0.10.8.2
103 , bytestring >= 0.10.8.2
127 , generics-sop >= 0.3.1.0
104 , generics-sop >= 0.3.1.0
128 , hspec >= 2.4.8
105 , hspec >= 2.4.8
129− , mtl >= 2.2.2
130 , squeal-postgresql
106 , squeal-postgresql
131 , text >= 1.2.2.2
107 , text >= 1.2.2.2
108+ , transformers >= 0.5.2.0
132 , vector >= 0.12.0.1
109 , vector >= 0.12.0.1
133
110
134−executable example
111+executable squeal-postgresql-example
135 default-language: Haskell2010
112 default-language: Haskell2010
136 hs-source-dirs: exe
113 hs-source-dirs: exe
137 ghc-options: -Wall
114 ghc-options: -Wall
squeal-postgresql/src/Squeal/PostgreSQL.hs+1−8
@@ -195,13 +195,6 @@ module Squeal.PostgreSQL (module X, RenderSQL(..), printSQL) where
195import Squeal.PostgreSQL.Alias as X
195import Squeal.PostgreSQL.Alias as X
196import Squeal.PostgreSQL.Binary as X
196import Squeal.PostgreSQL.Binary as X
197import Squeal.PostgreSQL.Definition as X
197import Squeal.PostgreSQL.Definition as X
198−import Squeal.PostgreSQL.Definition.Function as X
199−import Squeal.PostgreSQL.Definition.Index as X
200−import Squeal.PostgreSQL.Definition.Schema as X
201−import Squeal.PostgreSQL.Definition.Table as X
202−import Squeal.PostgreSQL.Definition.Table.Constraint as X
203−import Squeal.PostgreSQL.Definition.Type as X
204−import Squeal.PostgreSQL.Definition.View as X
205import Squeal.PostgreSQL.Expression as X
198import Squeal.PostgreSQL.Expression as X
206import Squeal.PostgreSQL.Expression.Aggregate as X
199import Squeal.PostgreSQL.Expression.Aggregate as X
207import Squeal.PostgreSQL.Expression.Collection as X
200import Squeal.PostgreSQL.Expression.Collection as X
@@ -213,7 +206,7 @@ import Squeal.PostgreSQL.Expression.Math as X
213import Squeal.PostgreSQL.Expression.Null as X
206import Squeal.PostgreSQL.Expression.Null as X
214import Squeal.PostgreSQL.Expression.Parameter as X
207import Squeal.PostgreSQL.Expression.Parameter as X
215import Squeal.PostgreSQL.Expression.Range as X
208import Squeal.PostgreSQL.Expression.Range as X
216−import Squeal.PostgreSQL.Expression.Set as X
209+import Squeal.PostgreSQL.Expression.SetOf as X
217import Squeal.PostgreSQL.Expression.Sort as X
210import Squeal.PostgreSQL.Expression.Sort as X
218import Squeal.PostgreSQL.Expression.Subquery as X
211import Squeal.PostgreSQL.Expression.Subquery as X
219import Squeal.PostgreSQL.Expression.Text as X
212import Squeal.PostgreSQL.Expression.Text as X
squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs+48−139
@@ -216,9 +216,8 @@ module Squeal.PostgreSQL.Binary
216 -- * Only
216 -- * Only
217 , Only (..)
217 , Only (..)
218 -- * Oid
218 -- * Oid
219− , OidOf (..)
219+ , HasOid (..)
220− , OidOfParam (..)
220+ , HasAliasedOid (..)
221− , OidOfField (..)
222 ) where
221 ) where
223
222
224import BinaryParser
223import BinaryParser
@@ -232,7 +231,6 @@ import Data.Time
232import Data.UUID.Types
231import Data.UUID.Types
233import Data.Vector (Vector)
232import Data.Vector (Vector)
234import Data.Word
233import Data.Word
235−import Foreign.C.Types (CUInt(CUInt))
236import Generics.SOP
234import Generics.SOP
237import Generics.SOP.Record
235import Generics.SOP.Record
238import GHC.TypeLits
236import GHC.TypeLits
@@ -246,7 +244,6 @@ import qualified Data.Text.Lazy as Lazy (Text)
246import qualified Data.Text as Strict (Text)
244import qualified Data.Text as Strict (Text)
247import qualified Data.Text as Strict.Text
245import qualified Data.Text as Strict.Text
248import qualified Data.Vector as Vector
246import qualified Data.Vector as Vector
249−import qualified Database.PostgreSQL.LibPQ as LibPQ
250import qualified GHC.Generics as GHC
247import qualified GHC.Generics as GHC
251import qualified PostgreSQL.Binary.Decoding as Decoding
248import qualified PostgreSQL.Binary.Decoding as Decoding
252import qualified PostgreSQL.Binary.Encoding as Encoding
249import qualified PostgreSQL.Binary.Encoding as Encoding
@@ -277,9 +274,11 @@ class ToParam (x :: Type) (pg :: PGType) where
277 toParam :: x -> K Encoding.Encoding pg
274 toParam :: x -> K Encoding.Encoding pg
278instance ToParam Bool 'PGbool where toParam = K . Encoding.bool
275instance ToParam Bool 'PGbool where toParam = K . Encoding.bool
279instance ToParam Int16 'PGint2 where toParam = K . Encoding.int2_int16
276instance ToParam Int16 'PGint2 where toParam = K . Encoding.int2_int16
277+instance ToParam Word16 'PGint2 where toParam = K . Encoding.int2_word16
280instance ToParam Int32 'PGint4 where toParam = K . Encoding.int4_int32
278instance ToParam Int32 'PGint4 where toParam = K . Encoding.int4_int32
279+instance ToParam Word32 'PGint4 where toParam = K . Encoding.int4_word32
281instance ToParam Int64 'PGint8 where toParam = K . Encoding.int8_int64
280instance ToParam Int64 'PGint8 where toParam = K . Encoding.int8_int64
282−instance ToParam Oid 'PGoid where toParam = K . Encoding.int4_word32 . getOid
281+instance ToParam Word64 'PGint8 where toParam = K . Encoding.int8_word64
283instance ToParam Float 'PGfloat4 where toParam = K . Encoding.float4
282instance ToParam Float 'PGfloat4 where toParam = K . Encoding.float4
284instance ToParam Double 'PGfloat8 where toParam = K . Encoding.float8
283instance ToParam Double 'PGfloat8 where toParam = K . Encoding.float8
285instance ToParam Scientific 'PGnumeric where toParam = K . Encoding.numeric
284instance ToParam Scientific 'PGnumeric where toParam = K . Encoding.numeric
@@ -312,26 +311,24 @@ instance Aeson.ToJSON x => ToParam (Json x) 'PGjson where
312instance Aeson.ToJSON x => ToParam (Jsonb x) 'PGjsonb where
311instance Aeson.ToJSON x => ToParam (Jsonb x) 'PGjsonb where
313 toParam = K . Encoding.jsonb_bytes
312 toParam = K . Encoding.jsonb_bytes
314 . Lazy.ByteString.toStrict . Aeson.encode . getJsonb
313 . Lazy.ByteString.toStrict . Aeson.encode . getJsonb
315−instance (ToNullityParam x ty, ty ~ nullity pg, OidOf pg)
314+instance (ToNullityParam x ty, ty ~ nullity pg, HasOid pg)
316 => ToParam (VarArray [x]) ('PGvararray ty) where
315 => ToParam (VarArray [x]) ('PGvararray ty) where
317 toParam = K
316 toParam = K
318− . Encoding.array_foldable
317+ . Encoding.array_foldable (oid @pg) (unK . toNullityParam @x @ty)
319− (getOid (oidOf @pg)) (unK . toNullityParam @x @ty)
320 . getVarArray
318 . getVarArray
321−instance (ToParam x pg, OidOf pg)
319+instance (ToParam x pg, HasOid pg)
322 => ToParam (VarArray (Vector x)) ('PGvararray ('NotNull pg)) where
320 => ToParam (VarArray (Vector x)) ('PGvararray ('NotNull pg)) where
323 toParam = K
321 toParam = K
324− . Encoding.array_vector (getOid (oidOf @pg)) (unK . toParam @x @pg)
322+ . Encoding.array_vector (oid @pg) (unK . toParam @x @pg)
325 . getVarArray
323 . getVarArray
326−instance (ToParam x pg, OidOf pg)
324+instance (ToParam x pg, HasOid pg)
327 => ToParam (VarArray (Vector (Maybe x))) ('PGvararray ('Null pg)) where
325 => ToParam (VarArray (Vector (Maybe x))) ('PGvararray ('Null pg)) where
328 toParam = K
326 toParam = K
329− . Encoding.nullableArray_vector
327+ . Encoding.nullableArray_vector (oid @pg) (unK . toParam @x @pg)
330− (getOid (oidOf @pg)) (unK . toParam @x @pg)
331 . getVarArray
328 . getVarArray
332−instance (ToFixArray x dims ty, ty ~ nullity pg, OidOf pg)
329+instance (ToFixArray x dims ty, ty ~ nullity pg, HasOid pg)
333 => ToParam (FixArray x) ('PGfixarray dims ty) where
330 => ToParam (FixArray x) ('PGfixarray dims ty) where
334− toParam = K . Encoding.array (getOid (oidOf @pg))
331+ toParam = K . Encoding.array (oid @pg)
335 . unK . unK . toFixArray @x @dims @ty . getFixArray
332 . unK . unK . toFixArray @x @dims @ty . getFixArray
336instance
333instance
337 ( IsEnumType x
334 ( IsEnumType x
@@ -356,7 +353,7 @@ instance
356 ( SListI fields
353 ( SListI fields
357 , IsRecord x xs
354 , IsRecord x xs
358 , AllZip ToField xs fields
355 , AllZip ToField xs fields
359− , All OidOfField fields
356+ , All HasAliasedOid fields
360 ) => ToParam (Composite x) ('PGcomposite fields) where
357 ) => ToParam (Composite x) ('PGcomposite fields) where
361 toParam =
358 toParam =
362 let
359 let
@@ -364,7 +361,7 @@ instance
364 encoders = htrans (Proxy @ToField) toField
361 encoders = htrans (Proxy @ToField) toField
365
362
366 composite
363 composite
367− :: All OidOfField row
364+ :: All HasAliasedOid row
368 => NP (K (Maybe Encoding.Encoding)) row
365 => NP (K (Maybe Encoding.Encoding)) row
369 -> K Encoding.Encoding ('PGcomposite row)
366 -> K Encoding.Encoding ('PGcomposite row)
370 composite fields = K $
367 composite fields = K $
@@ -381,18 +378,18 @@ instance
381 int32BE (fromIntegral (lengthSList (Proxy @xs))) <>
378 int32BE (fromIntegral (lengthSList (Proxy @xs))) <>
382 let
379 let
383 each
380 each
384− :: OidOfField field
381+ :: HasAliasedOid field
385 => K (Maybe Encoding.Encoding) field
382 => K (Maybe Encoding.Encoding) field
386 -> Encoding.Encoding
383 -> Encoding.Encoding
387 each (K field :: K (Maybe Encoding.Encoding) field) =
384 each (K field :: K (Maybe Encoding.Encoding) field) =
388− word32BE (getOid (oidOfField @field))
385+ word32BE (aliasedOid @field)
389 <> case field of
386 <> case field of
390 Nothing -> int64BE (-1)
387 Nothing -> int64BE (-1)
391 Just value ->
388 Just value ->
392 int32BE (fromIntegral (builderLength value))
389 int32BE (fromIntegral (builderLength value))
393 <> value
390 <> value
394 in
391 in
395− hcfoldMap (Proxy @OidOfField) each fields
392+ hcfoldMap (Proxy @HasAliasedOid) each fields
396
393
397 in
394 in
398 composite . encoders . toRecord . getComposite
395 composite . encoders . toRecord . getComposite
@@ -400,120 +397,36 @@ instance
400-- | The object identifier of a `PGType`.
397-- | The object identifier of a `PGType`.
401--
398--
402-- >>> :set -XTypeApplications
399-- >>> :set -XTypeApplications
403−-- >>> oidOf @'PGbool
400+-- >>> oid @'PGbool
404−-- Oid 16
401+-- 16
405−class OidOf (ty :: PGType) where oidOf :: LibPQ.Oid
402+class HasOid (ty :: PGType) where oid :: Word32
406−instance OidOf 'PGbool where oidOf = LibPQ.Oid 16
403+instance HasOid 'PGbool where oid = 16
407−instance OidOf ('PGfixarray ns (null 'PGbool)) where oidOf = LibPQ.Oid 1000
404+instance HasOid 'PGint2 where oid = 21
408−instance OidOf ('PGvararray (null 'PGbool)) where oidOf = LibPQ.Oid 1000
405+instance HasOid 'PGint4 where oid = 23
409−instance OidOf 'PGint2 where oidOf = LibPQ.Oid 21
406+instance HasOid 'PGint8 where oid = 20
410−instance OidOf ('PGfixarray ns (null 'PGint2)) where oidOf = LibPQ.Oid 1005
411−instance OidOf ('PGvararray (null 'PGint2)) where oidOf = LibPQ.Oid 1005
412−instance OidOf 'PGint4 where oidOf = LibPQ.Oid 23
413−instance OidOf ('PGfixarray ns (null 'PGint4)) where oidOf = LibPQ.Oid 1007
414−instance OidOf ('PGvararray (null 'PGint4)) where oidOf = LibPQ.Oid 1007
415−instance OidOf 'PGint8 where oidOf = LibPQ.Oid 20
416−instance OidOf ('PGfixarray ns (null 'PGint8)) where oidOf = LibPQ.Oid 1016
417−instance OidOf ('PGvararray (null 'PGint8)) where oidOf = LibPQ.Oid 1016
418−instance OidOf 'PGnumeric where oidOf = LibPQ.Oid 1700
407+instance HasOid 'PGnumeric where oid = 1700
419−instance OidOf ('PGfixarray ns (null 'PGnumeric)) where oidOf = LibPQ.Oid 1231
420−instance OidOf ('PGvararray (null 'PGnumeric)) where oidOf = LibPQ.Oid 1231
421−instance OidOf 'PGfloat4 where oidOf = LibPQ.Oid 700
408+instance HasOid 'PGfloat4 where oid = 700
422−instance OidOf ('PGfixarray ns (null 'PGfloat4)) where oidOf = LibPQ.Oid 1021
423−instance OidOf ('PGvararray (null 'PGfloat4)) where oidOf = LibPQ.Oid 1021
424−instance OidOf 'PGfloat8 where oidOf = LibPQ.Oid 701
409+instance HasOid 'PGfloat8 where oid = 701
425−instance OidOf ('PGfixarray ns (null 'PGfloat8)) where oidOf = LibPQ.Oid 1022
410+instance HasOid ('PGchar n) where oid = 18
426−instance OidOf ('PGvararray (null 'PGfloat8)) where oidOf = LibPQ.Oid 1022
427−instance OidOf 'PGmoney where oidOf = LibPQ.Oid 790
428−instance OidOf ('PGfixarray ns (null 'PGmoney)) where oidOf = LibPQ.Oid 791
429−instance OidOf ('PGvararray (null 'PGmoney)) where oidOf = LibPQ.Oid 791
430−instance OidOf ('PGchar n) where oidOf = LibPQ.Oid 18
431−instance OidOf ('PGfixarray ns (null ('PGchar n))) where oidOf = LibPQ.Oid 1002
432−instance OidOf ('PGvararray (null ('PGchar n))) where oidOf = LibPQ.Oid 1002
433−instance OidOf ('PGvarchar n) where oidOf = LibPQ.Oid 1043
411+instance HasOid ('PGvarchar n) where oid = 1043
434−instance OidOf ('PGfixarray ns (null ('PGvarchar n))) where oidOf = LibPQ.Oid 1015
412+instance HasOid 'PGtext where oid = 25
435−instance OidOf ('PGvararray (null ('PGvarchar n))) where oidOf = LibPQ.Oid 1015
413+instance HasOid 'PGbytea where oid = 17
436−instance OidOf 'PGtext where oidOf = LibPQ.Oid 25
437−instance OidOf ('PGfixarray ns (null 'PGtext)) where oidOf = LibPQ.Oid 1009
438−instance OidOf ('PGvararray (null 'PGtext)) where oidOf = LibPQ.Oid 1009
439−instance OidOf 'PGbytea where oidOf = LibPQ.Oid 17
440−instance OidOf ('PGfixarray ns (null 'PGbytea)) where oidOf = LibPQ.Oid 1001
441−instance OidOf ('PGvararray (null 'PGbytea)) where oidOf = LibPQ.Oid 1001
442−instance OidOf 'PGtimestamp where oidOf = LibPQ.Oid 1114
414+instance HasOid 'PGtimestamp where oid = 1114
443−instance OidOf ('PGfixarray ns (null 'PGtimestamp)) where oidOf = LibPQ.Oid 1115
444−instance OidOf ('PGvararray (null 'PGtimestamp)) where oidOf = LibPQ.Oid 1115
445−instance OidOf 'PGtimestamptz where oidOf = LibPQ.Oid 1184
415+instance HasOid 'PGtimestamptz where oid = 1184
446−instance OidOf ('PGfixarray ns (null 'PGtimestamptz)) where oidOf = LibPQ.Oid 1185
447−instance OidOf ('PGvararray (null 'PGtimestamptz)) where oidOf = LibPQ.Oid 1185
448−instance OidOf 'PGdate where oidOf = LibPQ.Oid 1082
416+instance HasOid 'PGdate where oid = 1082
449−instance OidOf ('PGfixarray ns (null 'PGdate)) where oidOf = LibPQ.Oid 1182
450−instance OidOf ('PGvararray (null 'PGdate)) where oidOf = LibPQ.Oid 1182
451−instance OidOf 'PGtime where oidOf = LibPQ.Oid 1083
417+instance HasOid 'PGtime where oid = 1083
452−instance OidOf ('PGfixarray ns (null 'PGtime)) where oidOf = LibPQ.Oid 1183
453−instance OidOf ('PGvararray (null 'PGtime)) where oidOf = LibPQ.Oid 1183
454−instance OidOf 'PGtimetz where oidOf = LibPQ.Oid 1266
418+instance HasOid 'PGtimetz where oid = 1266
455−instance OidOf ('PGfixarray ns (null 'PGtimetz)) where oidOf = LibPQ.Oid 1270
456−instance OidOf ('PGvararray (null 'PGtimetz)) where oidOf = LibPQ.Oid 1270
457−instance OidOf 'PGinterval where oidOf = LibPQ.Oid 1186
419+instance HasOid 'PGinterval where oid = 1186
458−instance OidOf ('PGfixarray ns (null 'PGinterval)) where oidOf = LibPQ.Oid 1187
459−instance OidOf ('PGvararray (null 'PGinterval)) where oidOf = LibPQ.Oid 1187
460−instance OidOf 'PGuuid where oidOf = LibPQ.Oid 2950
420+instance HasOid 'PGuuid where oid = 2950
461−instance OidOf ('PGfixarray ns (null 'PGuuid)) where oidOf = LibPQ.Oid 2951
421+instance HasOid 'PGinet where oid = 869
462−instance OidOf ('PGvararray (null 'PGuuid)) where oidOf = LibPQ.Oid 2951
422+instance HasOid 'PGjson where oid = 114
463−instance OidOf 'PGinet where oidOf = LibPQ.Oid 869
464−instance OidOf ('PGfixarray ns (null 'PGinet)) where oidOf = LibPQ.Oid 1041
465−instance OidOf ('PGvararray (null 'PGinet)) where oidOf = LibPQ.Oid 1041
466−instance OidOf 'PGjson where oidOf = LibPQ.Oid 114
467−instance OidOf ('PGfixarray ns (null 'PGjson)) where oidOf = LibPQ.Oid 199
468−instance OidOf ('PGvararray (null 'PGjson)) where oidOf = LibPQ.Oid 199
469−instance OidOf 'PGjsonb where oidOf = LibPQ.Oid 3802
423+instance HasOid 'PGjsonb where oid = 3802
470−instance OidOf ('PGfixarray ns (null 'PGjsonb)) where oidOf = LibPQ.Oid 3807
424+
471−instance OidOf ('PGvararray (null 'PGjsonb)) where oidOf = LibPQ.Oid 3807
472−instance OidOf 'PGtsvector where oidOf = LibPQ.Oid 3614
473−instance OidOf ('PGfixarray ns (null 'PGtsvector)) where oidOf = LibPQ.Oid 3643
474−instance OidOf ('PGvararray (null 'PGtsvector)) where oidOf = LibPQ.Oid 3643
475−instance OidOf 'PGtsquery where oidOf = LibPQ.Oid 3615
476−instance OidOf ('PGfixarray ns (null 'PGtsquery)) where oidOf = LibPQ.Oid 3645
477−instance OidOf ('PGvararray (null 'PGtsquery)) where oidOf = LibPQ.Oid 3645
478−instance OidOf 'PGoid where oidOf = LibPQ.Oid 26
479−instance OidOf ('PGfixarray ns (null 'PGoid)) where oidOf = LibPQ.Oid 1028
480−instance OidOf ('PGvararray (null 'PGoid)) where oidOf = LibPQ.Oid 1028
481−instance OidOf ('PGrange 'PGint4) where oidOf = LibPQ.Oid 3904
482−instance OidOf ('PGfixarray ns (null ('PGrange 'PGint4))) where oidOf = LibPQ.Oid 3905
483−instance OidOf ('PGvararray (null ('PGrange 'PGint4))) where oidOf = LibPQ.Oid 3905
484−instance OidOf ('PGrange 'PGint8) where oidOf = LibPQ.Oid 3926
485−instance OidOf ('PGfixarray ns (null ('PGrange 'PGint8))) where oidOf = LibPQ.Oid 3927
486−instance OidOf ('PGvararray (null ('PGrange 'PGint8))) where oidOf = LibPQ.Oid 3927
487−instance OidOf ('PGrange 'PGnumeric) where oidOf = LibPQ.Oid 3906
488−instance OidOf ('PGfixarray ns (null ('PGrange 'PGnumeric))) where oidOf = LibPQ.Oid 3907
489−instance OidOf ('PGvararray (null ('PGrange 'PGnumeric))) where oidOf = LibPQ.Oid 3907
490−instance OidOf ('PGrange 'PGtimestamp) where oidOf = LibPQ.Oid 3908
491−instance OidOf ('PGfixarray ns (null ('PGrange 'PGtimestamp))) where oidOf = LibPQ.Oid 3909
492−instance OidOf ('PGvararray (null ('PGrange 'PGtimestamp))) where oidOf = LibPQ.Oid 3909
493−instance OidOf ('PGrange 'PGtimestamptz) where oidOf = LibPQ.Oid 3910
494−instance OidOf ('PGfixarray ns (null ('PGrange 'PGtimestamptz))) where oidOf = LibPQ.Oid 3911
495−instance OidOf ('PGvararray (null ('PGrange 'PGtimestamptz))) where oidOf = LibPQ.Oid 3911
496−instance OidOf ('PGrange 'PGdate) where oidOf = LibPQ.Oid 3912
497−instance OidOf ('PGfixarray ns (null ('PGrange 'PGdate))) where oidOf = LibPQ.Oid 3913
498−instance OidOf ('PGvararray (null ('PGrange 'PGdate))) where oidOf = LibPQ.Oid 3913
499−instance {-# OVERLAPPABLE #-} OidOf ('PGrange ty) where oidOf = LibPQ.invalidOid
500−instance {-# OVERLAPPABLE #-} OidOf ('PGfixarray ns (null ('PGrange ty))) where oidOf = LibPQ.invalidOid
501−instance {-# OVERLAPPABLE #-} OidOf ('PGvararray (null ('PGrange ty))) where oidOf = LibPQ.invalidOid
502−instance {-# OVERLAPPABLE #-} OidOf ('PGcomposite row) where oidOf = LibPQ.invalidOid
503−instance {-# OVERLAPPABLE #-} OidOf ('PGfixarray ns (null ('PGcomposite row))) where oidOf = LibPQ.invalidOid
504−instance {-# OVERLAPPABLE #-} OidOf ('PGvararray (null ('PGcomposite row))) where oidOf = LibPQ.invalidOid
505−instance {-# OVERLAPPABLE #-} OidOf ('PGenum labels) where oidOf = LibPQ.invalidOid
506−instance {-# OVERLAPPABLE #-} OidOf ('PGfixarray ns (null ('PGenum labels))) where oidOf = LibPQ.invalidOid
507−instance {-# OVERLAPPABLE #-} OidOf ('PGvararray (null ('PGenum labels))) where oidOf = LibPQ.invalidOid
508−
509−class OidOfParam (ty :: NullityType) where oidOfParam :: Oid
510−instance OidOf ty => OidOfParam (null ty) where oidOfParam = oidOf @ty
511−
512−-- | Lifts a `OidOf` constraint to a field.
425+-- | Lifts a `HasOid` constraint to a field.
513−class OidOfField (field :: (Symbol, NullityType)) where
426+class HasAliasedOid (field :: (Symbol, NullityType)) where
514− oidOfField :: Oid
427+ aliasedOid :: Word32
515−instance OidOf ty => OidOfField (alias ::: nullity ty) where
428+instance HasOid ty => HasAliasedOid (alias ::: nullity ty) where
516− oidOfField = oidOf @ty
429+ aliasedOid = oid @ty
517
430
518-- | A `ToNullityParam` constraint gives an encoding of a Haskell `Type` into
431-- | A `ToNullityParam` constraint gives an encoding of a Haskell `Type` into
519-- into the binary format of a PostgreSQL `NullityType`.
432-- into the binary format of a PostgreSQL `NullityType`.
@@ -582,7 +495,6 @@ instance FromValue 'PGbool Bool where fromValue = Decoding.bool
582instance FromValue 'PGint2 Int16 where fromValue = Decoding.int
495instance FromValue 'PGint2 Int16 where fromValue = Decoding.int
583instance FromValue 'PGint4 Int32 where fromValue = Decoding.int
496instance FromValue 'PGint4 Int32 where fromValue = Decoding.int
584instance FromValue 'PGint8 Int64 where fromValue = Decoding.int
497instance FromValue 'PGint8 Int64 where fromValue = Decoding.int
585−instance FromValue 'PGoid Word32 where fromValue = Decoding.int
586instance FromValue 'PGfloat4 Float where fromValue = Decoding.float4
498instance FromValue 'PGfloat4 Float where fromValue = Decoding.float4
587instance FromValue 'PGfloat8 Double where fromValue = Decoding.float8
499instance FromValue 'PGfloat8 Double where fromValue = Decoding.float8
588instance FromValue 'PGnumeric Scientific where fromValue = Decoding.numeric
500instance FromValue 'PGnumeric Scientific where fromValue = Decoding.numeric
@@ -843,6 +755,3 @@ replicateMN
843 => m x -> m (NP I xs)
755 => m x -> m (NP I xs)
844replicateMN mx = hsequence' $
756replicateMN mx = hsequence' $
845 hcpure (Proxy :: Proxy ((~) x)) (Comp (I <$> mx))
757 hcpure (Proxy :: Proxy ((~) x)) (Comp (I <$> mx))
846−
847−getOid :: LibPQ.Oid -> Word32
848−getOid (LibPQ.Oid (CUInt oid)) = oid
squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs+1042−4
@@ -11,15 +11,13 @@ Squeal data definition language.
11{-# LANGUAGE
11{-# LANGUAGE
12 AllowAmbiguousTypes
12 AllowAmbiguousTypes
13 , ConstraintKinds
13 , ConstraintKinds
14− , DeriveAnyClass
15 , DeriveGeneric
14 , DeriveGeneric
16− , DerivingStrategies
17 , FlexibleContexts
15 , FlexibleContexts
18 , FlexibleInstances
16 , FlexibleInstances
19 , GADTs
17 , GADTs
18+ , GeneralizedNewtypeDeriving
20 , LambdaCase
19 , LambdaCase
21 , MultiParamTypeClasses
20 , MultiParamTypeClasses
22− , OverloadedLabels
23 , OverloadedStrings
21 , OverloadedStrings
24 , RankNTypes
22 , RankNTypes
25 , ScopedTypeVariables
23 , ScopedTypeVariables
@@ -27,7 +25,6 @@ Squeal data definition language.
27 , TypeInType
25 , TypeInType
28 , TypeOperators
26 , TypeOperators
29 , UndecidableSuperClasses
27 , UndecidableSuperClasses
30− , UndecidableInstances
31#-}
28#-}
32
29
33module Squeal.PostgreSQL.Definition
30module Squeal.PostgreSQL.Definition
@@ -35,16 +32,79 @@ module Squeal.PostgreSQL.Definition
35 Definition (..)
32 Definition (..)
36 , (>>>)
33 , (>>>)
37 , manipDefinition
34 , manipDefinition
35+ -- * Tables
36+ -- ** Create
37+ , createSchema
38+ , createSchemaIfNotExists
39+ , createTable
40+ , createTableIfNotExists
41+ , createView
42+ , createTypeEnum
43+ , createTypeEnumFrom
44+ , createTypeComposite
45+ , createTypeCompositeFrom
46+ , FieldTyped (..)
47+ , createDomain
48+ , createTypeRange
49+ , TableConstraintExpression (..)
50+ , check
51+ , unique
52+ , primaryKey
53+ , foreignKey
54+ , ForeignKeyed
55+ , OnDeleteClause (..)
56+ , OnUpdateClause (..)
57+ -- ** Drop
58+ , dropSchema
59+ , dropTable
60+ , dropView
61+ , dropType
62+ -- ** Alter
63+ , alterTable
64+ , alterTableRename
65+ , AlterTable (..)
66+ , addConstraint
67+ , dropConstraint
68+ , AddColumn (..)
69+ , dropColumn
70+ , renameColumn
71+ , alterColumn
72+ , AlterColumn (..)
73+ , setDefault
74+ , dropDefault
75+ , setNotNull
76+ , dropNotNull
77+ , alterType
78+ -- * Columns
79+ , ColumnTypeExpression (..)
80+ , nullable
81+ , notNullable
82+ , default_
83+ , serial2
84+ , smallserial
85+ , serial4
86+ , serial
87+ , serial8
88+ , bigserial
38 ) where
89 ) where
39
90
40import Control.Category
91import Control.Category
41import Control.DeepSeq
92import Control.DeepSeq
42import Data.ByteString
93import Data.ByteString
43import Data.Monoid
94import Data.Monoid
95+import GHC.TypeLits
44import Prelude hiding ((.), id)
96import Prelude hiding ((.), id)
45
97
98+import qualified Generics.SOP as SOP
46import qualified GHC.Generics as GHC
99import qualified GHC.Generics as GHC
47
100
101+import Squeal.PostgreSQL.Alias
102+import Squeal.PostgreSQL.Expression
103+import Squeal.PostgreSQL.Expression.Logic
104+import Squeal.PostgreSQL.Expression.Type
105+import Squeal.PostgreSQL.List
106+import Squeal.PostgreSQL.PG
107+import Squeal.PostgreSQL.Query
48import Squeal.PostgreSQL.Manipulation
108import Squeal.PostgreSQL.Manipulation
49import Squeal.PostgreSQL.Render
109import Squeal.PostgreSQL.Render
50import Squeal.PostgreSQL.Schema
110import Squeal.PostgreSQL.Schema
@@ -80,3 +140,981 @@ manipDefinition
80 -- ^ no input or output
140 -- ^ no input or output
81 -> Definition schemas schemas
141 -> Definition schemas schemas
82manipDefinition = UnsafeDefinition . (<> ";") . renderSQL
142manipDefinition = UnsafeDefinition . (<> ";") . renderSQL
143+
144+{-----------------------------------------
145+CREATE statements
146+-----------------------------------------}
147+
148+{- |
149+`createSchema` enters a new schema into the current database.
150+The schema name must be distinct from the name of any existing schema
151+in the current database.
152+
153+A schema is essentially a namespace: it contains named objects
154+(tables, data types, functions, and operators) whose names
155+can duplicate those of other objects existing in other schemas.
156+Named objects are accessed by `QualifiedAlias`es with the schema
157+name as a prefix.
158+-}
159+createSchema
160+ :: KnownSymbol sch
161+ => Alias sch
162+ -> Definition schemas (Create sch '[] schemas)
163+createSchema sch = UnsafeDefinition $
164+ "CREATE" <+> "SCHEMA" <+> renderSQL sch <> ";"
165+
166+{- | Idempotent version of `createSchema`. -}
167+createSchemaIfNotExists
168+ :: (KnownSymbol sch, Has sch schemas schema)
169+ => Alias sch
170+ -> Definition schemas schemas
171+createSchemaIfNotExists sch = UnsafeDefinition $
172+ "CREATE" <+> "SCHEMA" <+> "IF" <+> "NOT" <+> "EXISTS"
173+ <+> renderSQL sch <> ";"
174+
175+{- | `createTable` adds a table to the schema.
176+
177+>>> :set -XOverloadedLabels
178+>>> :{
179+type Table = '[] :=>
180+ '[ "a" ::: 'NoDef :=> 'Null 'PGint4
181+ , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]
182+:}
183+
184+>>> :{
185+let
186+ setup :: Definition (Public '[]) (Public '["tab" ::: 'Table Table])
187+ setup = createTable #tab
188+ (nullable int `as` #a :* nullable real `as` #b) Nil
189+in printSQL setup
190+:}
191+CREATE TABLE "tab" ("a" int NULL, "b" real NULL);
192+-}
193+createTable
194+ :: ( KnownSymbol sch
195+ , KnownSymbol tab
196+ , columns ~ (col ': cols)
197+ , SOP.SListI columns
198+ , SOP.SListI constraints
199+ , Has sch schemas0 schema0
200+ , schemas1 ~ Alter sch (Create tab ('Table (constraints :=> columns)) schema0) schemas0 )
201+ => QualifiedAlias sch tab -- ^ the name of the table to add
202+ -> NP (Aliased (ColumnTypeExpression schemas0)) columns
203+ -- ^ the names and datatype of each column
204+ -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints
205+ -- ^ constraints that must hold for the table
206+ -> Definition schemas0 schemas1
207+createTable tab columns constraints = UnsafeDefinition $
208+ "CREATE TABLE" <+> renderCreation tab columns constraints
209+
210+{-| `createTableIfNotExists` creates a table if it doesn't exist, but does not add it to the schema.
211+Instead, the schema already has the table so if the table did not yet exist, the schema was wrong.
212+`createTableIfNotExists` fixes this. Interestingly, this property makes it an idempotent in
213+the `Category` of `Definition`s.
214+
215+>>> :set -XOverloadedLabels -XTypeApplications
216+>>> :{
217+type Table = '[] :=>
218+ '[ "a" ::: 'NoDef :=> 'Null 'PGint4
219+ , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]
220+:}
221+
222+>>> type Schemas = Public '["tab" ::: 'Table Table]
223+
224+>>> :{
225+let
226+ setup :: Definition Schemas Schemas
227+ setup = createTableIfNotExists #tab
228+ (nullable int `as` #a :* nullable real `as` #b) Nil
229+in printSQL setup
230+:}
231+CREATE TABLE IF NOT EXISTS "tab" ("a" int NULL, "b" real NULL);
232+-}
233+createTableIfNotExists
234+ :: ( Has sch schemas schema
235+ , Has tab schema ('Table (constraints :=> columns))
236+ , SOP.SListI columns
237+ , SOP.SListI constraints )
238+ => QualifiedAlias sch tab -- ^ the name of the table to add
239+ -> NP (Aliased (ColumnTypeExpression schemas)) columns
240+ -- ^ the names and datatype of each column
241+ -> NP (Aliased (TableConstraintExpression sch tab schemas)) constraints
242+ -- ^ constraints that must hold for the table
243+ -> Definition schemas schemas
244+createTableIfNotExists tab columns constraints = UnsafeDefinition $
245+ "CREATE TABLE IF NOT EXISTS"
246+ <+> renderCreation tab columns constraints
247+
248+-- helper function for `createTable` and `createTableIfNotExists`
249+renderCreation
250+ :: ( KnownSymbol sch
251+ , KnownSymbol tab
252+ , SOP.SListI columns
253+ , SOP.SListI constraints )
254+ => QualifiedAlias sch tab -- ^ the name of the table to add
255+ -> NP (Aliased (ColumnTypeExpression schemas0)) columns
256+ -- ^ the names and datatype of each column
257+ -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints
258+ -- ^ constraints that must hold for the table
259+ -> ByteString
260+renderCreation tab columns constraints = renderSQL tab
261+ <+> parenthesized
262+ ( renderCommaSeparated renderColumnDef columns
263+ <> ( case constraints of
264+ Nil -> ""
265+ _ -> ", " <>
266+ renderCommaSeparated renderConstraint constraints ) )
267+ <> ";"
268+ where
269+ renderColumnDef :: Aliased (ColumnTypeExpression schemas) x -> ByteString
270+ renderColumnDef (ty `As` column) =
271+ renderSQL column <+> renderColumnTypeExpression ty
272+ renderConstraint
273+ :: Aliased (TableConstraintExpression sch tab schemas) constraint
274+ -> ByteString
275+ renderConstraint (constraint `As` alias) =
276+ "CONSTRAINT" <+> renderSQL alias <+> renderSQL constraint
277+
278+-- | Data types are a way to limit the kind of data that can be stored in a
279+-- table. For many applications, however, the constraint they provide is
280+-- too coarse. For example, a column containing a product price should
281+-- probably only accept positive values. But there is no standard data type
282+-- that accepts only positive numbers. Another issue is that you might want
283+-- to constrain column data with respect to other columns or rows.
284+-- For example, in a table containing product information,
285+-- there should be only one row for each product number.
286+-- `TableConstraint`s give you as much control over the data in your tables
287+-- as you wish. If a user attempts to store data in a column that would
288+-- violate a constraint, an error is raised. This applies
289+-- even if the value came from the default value definition.
290+newtype TableConstraintExpression
291+ (sch :: Symbol)
292+ (tab :: Symbol)
293+ (schemas :: SchemasType)
294+ (constraint :: TableConstraint)
295+ = UnsafeTableConstraintExpression
296+ { renderTableConstraintExpression :: ByteString }
297+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
298+instance RenderSQL
299+ (TableConstraintExpression sch tab schemas constraint) where
300+ renderSQL = renderTableConstraintExpression
301+
302+{-| A `check` constraint is the most generic `TableConstraint` type.
303+It allows you to specify that the value in a certain column must satisfy
304+a Boolean (truth-value) expression.
305+
306+>>> :{
307+type Schema = '[
308+ "tab" ::: 'Table ('[ "inequality" ::: 'Check '["a","b"]] :=> '[
309+ "a" ::: 'NoDef :=> 'NotNull 'PGint4,
310+ "b" ::: 'NoDef :=> 'NotNull 'PGint4
311+ ])]
312+:}
313+
314+>>> :{
315+let
316+ definition :: Definition (Public '[]) (Public Schema)
317+ definition = createTable #tab
318+ ( (int & notNullable) `as` #a :*
319+ (int & notNullable) `as` #b )
320+ ( check (#a :* #b) (#a .> #b) `as` #inequality )
321+:}
322+
323+>>> printSQL definition
324+CREATE TABLE "tab" ("a" int NOT NULL, "b" int NOT NULL, CONSTRAINT "inequality" CHECK (("a" > "b")));
325+-}
326+check
327+ :: ( Has sch schemas schema
328+ , Has tab schema ('Table table)
329+ , HasAll aliases (TableToRow table) subcolumns )
330+ => NP Alias aliases
331+ -- ^ specify the subcolumns which are getting checked
332+ -> (forall t. Condition '[] '[] 'Ungrouped schemas '[] '[t ::: subcolumns])
333+ -- ^ a closed `Condition` on those subcolumns
334+ -> TableConstraintExpression sch tab schemas ('Check aliases)
335+check _cols condition = UnsafeTableConstraintExpression $
336+ "CHECK" <+> parenthesized (renderSQL condition)
337+
338+{-| A `unique` constraint ensure that the data contained in a column,
339+or a group of columns, is unique among all the rows in the table.
340+
341+>>> :{
342+type Schema = '[
343+ "tab" ::: 'Table( '[ "uq_a_b" ::: 'Unique '["a","b"]] :=> '[
344+ "a" ::: 'NoDef :=> 'Null 'PGint4,
345+ "b" ::: 'NoDef :=> 'Null 'PGint4
346+ ])]
347+:}
348+
349+>>> :{
350+let
351+ definition :: Definition (Public '[]) (Public Schema)
352+ definition = createTable #tab
353+ ( (int & nullable) `as` #a :*
354+ (int & nullable) `as` #b )
355+ ( unique (#a :* #b) `as` #uq_a_b )
356+:}
357+
358+>>> printSQL definition
359+CREATE TABLE "tab" ("a" int NULL, "b" int NULL, CONSTRAINT "uq_a_b" UNIQUE ("a", "b"));
360+-}
361+unique
362+ :: ( Has sch schemas schema
363+ , Has tab schema('Table table)
364+ , HasAll aliases (TableToRow table) subcolumns )
365+ => NP Alias aliases
366+ -- ^ specify subcolumns which together are unique for each row
367+ -> TableConstraintExpression sch tab schemas ('Unique aliases)
368+unique columns = UnsafeTableConstraintExpression $
369+ "UNIQUE" <+> parenthesized (renderSQL columns)
370+
371+{-| A `primaryKey` constraint indicates that a column, or group of columns,
372+can be used as a unique identifier for rows in the table.
373+This requires that the values be both unique and not null.
374+
375+>>> :{
376+type Schema = '[
377+ "tab" ::: 'Table ('[ "pk_id" ::: 'PrimaryKey '["id"]] :=> '[
378+ "id" ::: 'Def :=> 'NotNull 'PGint4,
379+ "name" ::: 'NoDef :=> 'NotNull 'PGtext
380+ ])]
381+:}
382+
383+>>> :{
384+let
385+ definition :: Definition (Public '[]) (Public Schema)
386+ definition = createTable #tab
387+ ( serial `as` #id :*
388+ (text & notNullable) `as` #name )
389+ ( primaryKey #id `as` #pk_id )
390+:}
391+
392+>>> printSQL definition
393+CREATE TABLE "tab" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_id" PRIMARY KEY ("id"));
394+-}
395+primaryKey
396+ :: ( Has sch schemas schema
397+ , Has tab schema ('Table table)
398+ , HasAll aliases (TableToColumns table) subcolumns
399+ , AllNotNull subcolumns )
400+ => NP Alias aliases
401+ -- ^ specify the subcolumns which together form a primary key.
402+ -> TableConstraintExpression sch tab schemas ('PrimaryKey aliases)
403+primaryKey columns = UnsafeTableConstraintExpression $
404+ "PRIMARY KEY" <+> parenthesized (renderSQL columns)
405+
406+{-| A `foreignKey` specifies that the values in a column
407+(or a group of columns) must match the values appearing in some row of
408+another table. We say this maintains the referential integrity
409+between two related tables.
410+
411+>>> :{
412+type Schema =
413+ '[ "users" ::: 'Table (
414+ '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
415+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
416+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext
417+ ])
418+ , "emails" ::: 'Table (
419+ '[ "pk_emails" ::: 'PrimaryKey '["id"]
420+ , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
421+ ] :=>
422+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
423+ , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
424+ , "email" ::: 'NoDef :=> 'Null 'PGtext
425+ ])
426+ ]
427+:}
428+
429+>>> :{
430+let
431+ setup :: Definition (Public '[]) (Public Schema)
432+ setup =
433+ createTable #users
434+ ( serial `as` #id :*
435+ (text & notNullable) `as` #name )
436+ ( primaryKey #id `as` #pk_users ) >>>
437+ createTable #emails
438+ ( serial `as` #id :*
439+ (int & notNullable) `as` #user_id :*
440+ (text & nullable) `as` #email )
441+ ( primaryKey #id `as` #pk_emails :*
442+ foreignKey #user_id #users #id
443+ OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
444+in printSQL setup
445+:}
446+CREATE TABLE "users" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_users" PRIMARY KEY ("id"));
447+CREATE TABLE "emails" ("id" serial, "user_id" int NOT NULL, "email" text NULL, CONSTRAINT "pk_emails" PRIMARY KEY ("id"), CONSTRAINT "fk_user_id" FOREIGN KEY ("user_id") REFERENCES "users" ("id") ON DELETE CASCADE ON UPDATE CASCADE);
448+
449+A `foreignKey` can even be a table self-reference.
450+
451+>>> :{
452+type Schema =
453+ '[ "employees" ::: 'Table (
454+ '[ "employees_pk" ::: 'PrimaryKey '["id"]
455+ , "employees_employer_fk" ::: 'ForeignKey '["employer_id"] "employees" '["id"]
456+ ] :=>
457+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
458+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext
459+ , "employer_id" ::: 'NoDef :=> 'Null 'PGint4
460+ ])
461+ ]
462+:}
463+
464+>>> :{
465+let
466+ setup :: Definition (Public '[]) (Public Schema)
467+ setup =
468+ createTable #employees
469+ ( serial `as` #id :*
470+ (text & notNullable) `as` #name :*
471+ (integer & nullable) `as` #employer_id )
472+ ( primaryKey #id `as` #employees_pk :*
473+ foreignKey #employer_id #employees #id
474+ OnDeleteCascade OnUpdateCascade `as` #employees_employer_fk )
475+in printSQL setup
476+:}
477+CREATE TABLE "employees" ("id" serial, "name" text NOT NULL, "employer_id" integer NULL, CONSTRAINT "employees_pk" PRIMARY KEY ("id"), CONSTRAINT "employees_employer_fk" FOREIGN KEY ("employer_id") REFERENCES "employees" ("id") ON DELETE CASCADE ON UPDATE CASCADE);
478+-}
479+foreignKey
480+ :: (ForeignKeyed schemas sch schema child parent
481+ table reftable
482+ columns refcolumns
483+ constraints cols
484+ reftys tys )
485+ => NP Alias columns
486+ -- ^ column or columns in the table
487+ -> Alias parent
488+ -- ^ reference table
489+ -> NP Alias refcolumns
490+ -- ^ reference column or columns in the reference table
491+ -> OnDeleteClause
492+ -- ^ what to do when reference is deleted
493+ -> OnUpdateClause
494+ -- ^ what to do when reference is updated
495+ -> TableConstraintExpression sch child schemas
496+ ('ForeignKey columns parent refcolumns)
497+foreignKey keys parent refs ondel onupd = UnsafeTableConstraintExpression $
498+ "FOREIGN KEY" <+> parenthesized (renderSQL keys)
499+ <+> "REFERENCES" <+> renderSQL parent
500+ <+> parenthesized (renderSQL refs)
501+ <+> renderSQL ondel
502+ <+> renderSQL onupd
503+
504+-- | A constraint synonym between types involved in a foreign key constraint.
505+type ForeignKeyed schemas
506+ sch
507+ schema
508+ child parent
509+ table reftable
510+ columns refcolumns
511+ constraints cols
512+ reftys tys =
513+ ( Has sch schemas schema
514+ , Has child schema ('Table table)
515+ , Has parent schema ('Table reftable)
516+ , HasAll columns (TableToColumns table) tys
517+ , reftable ~ (constraints :=> cols)
518+ , HasAll refcolumns cols reftys
519+ , SOP.AllZip SamePGType tys reftys
520+ , Uniquely refcolumns constraints )
521+
522+-- | `OnDeleteClause` indicates what to do with rows that reference a deleted row.
523+data OnDeleteClause
524+ = OnDeleteNoAction
525+ -- ^ if any referencing rows still exist when the constraint is checked,
526+ -- an error is raised
527+ | OnDeleteRestrict -- ^ prevents deletion of a referenced row
528+ | OnDeleteCascade
529+ -- ^ specifies that when a referenced row is deleted,
530+ -- row(s) referencing it should be automatically deleted as well
531+ deriving (GHC.Generic,Show,Eq,Ord)
532+instance NFData OnDeleteClause
533+-- | Render `OnDeleteClause`.
534+instance RenderSQL OnDeleteClause where
535+ renderSQL = \case
536+ OnDeleteNoAction -> "ON DELETE NO ACTION"
537+ OnDeleteRestrict -> "ON DELETE RESTRICT"
538+ OnDeleteCascade -> "ON DELETE CASCADE"
539+
540+-- | Analagous to `OnDeleteClause` there is also `OnUpdateClause` which is invoked
541+-- when a referenced column is changed (updated).
542+data OnUpdateClause
543+ = OnUpdateNoAction
544+ -- ^ if any referencing rows has not changed when the constraint is checked,
545+ -- an error is raised
546+ | OnUpdateRestrict -- ^ prevents update of a referenced row
547+ | OnUpdateCascade
548+ -- ^ the updated values of the referenced column(s) should be copied
549+ -- into the referencing row(s)
550+ deriving (GHC.Generic,Show,Eq,Ord)
551+instance NFData OnUpdateClause
552+
553+-- | Render `OnUpdateClause`.
554+instance RenderSQL OnUpdateClause where
555+ renderSQL = \case
556+ OnUpdateNoAction -> "ON UPDATE NO ACTION"
557+ OnUpdateRestrict -> "ON UPDATE RESTRICT"
558+ OnUpdateCascade -> "ON UPDATE CASCADE"
559+
560+{-----------------------------------------
561+DROP statements
562+-----------------------------------------}
563+
564+-- | >>> :{
565+-- let
566+-- definition :: Definition '["muh_schema" ::: schema, "public" ::: public] '["public" ::: public]
567+-- definition = dropSchema #muh_schema
568+-- :}
569+--
570+-- >>> printSQL definition
571+-- DROP SCHEMA "muh_schema";
572+dropSchema
573+ :: Has sch schemas schema
574+ => Alias sch
575+ -> Definition schemas (Drop sch schemas)
576+dropSchema sch = UnsafeDefinition $ "DROP SCHEMA" <+> renderSQL sch <> ";"
577+
578+-- | `dropTable` removes a table from the schema.
579+--
580+-- >>> :{
581+-- let
582+-- definition :: Definition '["public" ::: '["muh_table" ::: 'Table t]] (Public '[])
583+-- definition = dropTable #muh_table
584+-- :}
585+--
586+-- >>> printSQL definition
587+-- DROP TABLE "muh_table";
588+dropTable
589+ :: ( Has sch schemas schema
590+ , Has tab schema ('Table table))
591+ => QualifiedAlias sch tab -- ^ table to remove
592+ -> Definition schemas (Alter sch (Drop tab schema) schemas)
593+dropTable tab = UnsafeDefinition $ "DROP TABLE" <+> renderSQL tab <> ";"
594+
595+{-----------------------------------------
596+ALTER statements
597+-----------------------------------------}
598+
599+-- | `alterTable` changes the definition of a table from the schema.
600+alterTable
601+ :: (Has sch schemas schema, Has tab schema ('Table table0))
602+ => QualifiedAlias sch tab -- ^ table to alter
603+ -> AlterTable sch tab schemas table1 -- ^ alteration to perform
604+ -> Definition schemas (Alter sch (Alter tab ('Table table1) schema) schemas)
605+alterTable tab alteration = UnsafeDefinition $
606+ "ALTER TABLE"
607+ <+> renderSQL tab
608+ <+> renderAlterTable alteration
609+ <> ";"
610+
611+-- | `alterTableRename` changes the name of a table from the schema.
612+--
613+-- >>> printSQL $ alterTableRename #foo #bar
614+-- ALTER TABLE "foo" RENAME TO "bar";
615+alterTableRename
616+ :: (KnownSymbol table0, KnownSymbol table1)
617+ => Alias table0 -- ^ table to rename
618+ -> Alias table1 -- ^ what to rename it
619+ -> Definition schema (Rename table0 table1 schema)
620+alterTableRename table0 table1 = UnsafeDefinition $
621+ "ALTER TABLE" <+> renderSQL table0
622+ <+> "RENAME TO" <+> renderSQL table1 <> ";"
623+
624+-- | An `AlterTable` describes the alteration to perform on the columns
625+-- of a table.
626+newtype AlterTable
627+ (sch :: Symbol)
628+ (tab :: Symbol)
629+ (schemas :: SchemasType)
630+ (table :: TableType) =
631+ UnsafeAlterTable {renderAlterTable :: ByteString}
632+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
633+
634+-- | An `addConstraint` adds a table constraint.
635+--
636+-- >>> :{
637+-- let
638+-- definition :: Definition
639+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
640+-- '["public" ::: '["tab" ::: 'Table ('["positive" ::: 'Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
641+-- definition = alterTable #tab (addConstraint #positive (check #col (#col .> 0)))
642+-- in printSQL definition
643+-- :}
644+-- ALTER TABLE "tab" ADD CONSTRAINT "positive" CHECK (("col" > 0));
645+addConstraint
646+ :: ( KnownSymbol alias
647+ , Has sch schemas schema
648+ , Has tab schema ('Table table0)
649+ , table0 ~ (constraints :=> columns)
650+ , table1 ~ (Create alias constraint constraints :=> columns) )
651+ => Alias alias
652+ -> TableConstraintExpression sch tab schemas constraint
653+ -- ^ constraint to add
654+ -> AlterTable sch tab schemas table1
655+addConstraint alias constraint = UnsafeAlterTable $
656+ "ADD" <+> "CONSTRAINT" <+> renderSQL alias
657+ <+> renderSQL constraint
658+
659+-- | A `dropConstraint` drops a table constraint.
660+--
661+-- >>> :{
662+-- let
663+-- definition :: Definition
664+-- '["public" ::: '["tab" ::: 'Table ('["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
665+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
666+-- definition = alterTable #tab (dropConstraint #positive)
667+-- in printSQL definition
668+-- :}
669+-- ALTER TABLE "tab" DROP CONSTRAINT "positive";
670+dropConstraint
671+ :: ( KnownSymbol constraint
672+ , Has sch schemas schema
673+ , Has tab schema ('Table table0)
674+ , table0 ~ (constraints :=> columns)
675+ , table1 ~ (Drop constraint constraints :=> columns) )
676+ => Alias constraint
677+ -- ^ constraint to drop
678+ -> AlterTable sch tab schemas table1
679+dropConstraint constraint = UnsafeAlterTable $
680+ "DROP" <+> "CONSTRAINT" <+> renderSQL constraint
681+
682+-- | An `AddColumn` is either @NULL@ or has @DEFAULT@.
683+class AddColumn ty where
684+ -- | `addColumn` adds a new column, initially filled with whatever
685+ -- default value is given or with @NULL@.
686+ --
687+ -- >>> :{
688+ -- let
689+ -- definition :: Definition
690+ -- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]
691+ -- '["public" ::: '["tab" ::: 'Table ('[] :=>
692+ -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
693+ -- , "col2" ::: 'Def :=> 'Null 'PGtext ])]]
694+ -- definition = alterTable #tab (addColumn #col2 (text & nullable & default_ "foo"))
695+ -- in printSQL definition
696+ -- :}
697+ -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL DEFAULT E'foo';
698+ --
699+ -- >>> :{
700+ -- let
701+ -- definition :: Definition
702+ -- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]
703+ -- '["public" ::: '["tab" ::: 'Table ('[] :=>
704+ -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
705+ -- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]]
706+ -- definition = alterTable #tab (addColumn #col2 (text & nullable))
707+ -- in printSQL definition
708+ -- :}
709+ -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL;
710+ addColumn
711+ :: ( KnownSymbol column
712+ , Has sch schemas schema
713+ , Has tab schema ('Table table0)
714+ , table0 ~ (constraints :=> columns) )
715+ => Alias column -- ^ column to add
716+ -> ColumnTypeExpression schemas ty -- ^ type of the new column
717+ -> AlterTable sch tab schemas (constraints :=> Create column ty columns)
718+ addColumn column ty = UnsafeAlterTable $
719+ "ADD COLUMN" <+> renderSQL column <+> renderColumnTypeExpression ty
720+instance {-# OVERLAPPING #-} AddColumn ('Def :=> ty)
721+instance {-# OVERLAPPABLE #-} AddColumn ('NoDef :=> 'Null ty)
722+
723+-- | A `dropColumn` removes a column. Whatever data was in the column
724+-- disappears. Table constraints involving the column are dropped, too.
725+-- However, if the column is referenced by a foreign key constraint of
726+-- another table, PostgreSQL will not silently drop that constraint.
727+--
728+-- >>> :{
729+-- let
730+-- definition :: Definition
731+-- '["public" ::: '["tab" ::: 'Table ('[] :=>
732+-- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
733+-- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]]
734+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]
735+-- definition = alterTable #tab (dropColumn #col2)
736+-- in printSQL definition
737+-- :}
738+-- ALTER TABLE "tab" DROP COLUMN "col2";
739+dropColumn
740+ :: ( KnownSymbol column
741+ , Has sch schemas schema
742+ , Has tab schema ('Table table0)
743+ , table0 ~ (constraints :=> columns)
744+ , table1 ~ (constraints :=> Drop column columns) )
745+ => Alias column -- ^ column to remove
746+ -> AlterTable sch tab schemas table1
747+dropColumn column = UnsafeAlterTable $
748+ "DROP COLUMN" <+> renderSQL column
749+
750+-- | A `renameColumn` renames a column.
751+--
752+-- >>> :{
753+-- let
754+-- definition :: Definition
755+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["foo" ::: 'NoDef :=> 'Null 'PGint4])]]
756+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["bar" ::: 'NoDef :=> 'Null 'PGint4])]]
757+-- definition = alterTable #tab (renameColumn #foo #bar)
758+-- in printSQL definition
759+-- :}
760+-- ALTER TABLE "tab" RENAME COLUMN "foo" TO "bar";
761+renameColumn
762+ :: ( KnownSymbol column0
763+ , KnownSymbol column1
764+ , Has sch schemas schema
765+ , Has tab schema ('Table table0)
766+ , table0 ~ (constraints :=> columns)
767+ , table1 ~ (constraints :=> Rename column0 column1 columns) )
768+ => Alias column0 -- ^ column to rename
769+ -> Alias column1 -- ^ what to rename the column
770+ -> AlterTable sch tab schemas table1
771+renameColumn column0 column1 = UnsafeAlterTable $
772+ "RENAME COLUMN" <+> renderSQL column0 <+> "TO" <+> renderSQL column1
773+
774+-- | An `alterColumn` alters a single column.
775+alterColumn
776+ :: ( KnownSymbol column
777+ , Has sch schemas schema
778+ , Has tab schema ('Table table0)
779+ , table0 ~ (constraints :=> columns)
780+ , Has column columns ty0
781+ , table1 ~ (constraints :=> Alter column ty1 columns))
782+ => Alias column -- ^ column to alter
783+ -> AlterColumn schemas ty0 ty1 -- ^ alteration to perform
784+ -> AlterTable sch tab schemas table1
785+alterColumn column alteration = UnsafeAlterTable $
786+ "ALTER COLUMN" <+> renderSQL column <+> renderAlterColumn alteration
787+
788+-- | An `AlterColumn` describes the alteration to perform on a single column.
789+newtype AlterColumn (schemas :: SchemasType) (ty0 :: ColumnType) (ty1 :: ColumnType) =
790+ UnsafeAlterColumn {renderAlterColumn :: ByteString}
791+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
792+
793+-- | A `setDefault` sets a new default for a column. Note that this doesn't
794+-- affect any existing rows in the table, it just changes the default for
795+-- future insert and update commands.
796+--
797+-- >>> :{
798+-- let
799+-- definition :: Definition
800+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
801+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]]
802+-- definition = alterTable #tab (alterColumn #col (setDefault 5))
803+-- in printSQL definition
804+-- :}
805+-- ALTER TABLE "tab" ALTER COLUMN "col" SET DEFAULT 5;
806+setDefault
807+ :: Expression '[] '[] 'Ungrouped schemas '[] '[] ty -- ^ default value to set
808+ -> AlterColumn schemas (constraint :=> ty) ('Def :=> ty)
809+setDefault expression = UnsafeAlterColumn $
810+ "SET DEFAULT" <+> renderExpression expression
811+
812+-- | A `dropDefault` removes any default value for a column.
813+--
814+-- >>> :{
815+-- let
816+-- definition :: Definition
817+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]]
818+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
819+-- definition = alterTable #tab (alterColumn #col dropDefault)
820+-- in printSQL definition
821+-- :}
822+-- ALTER TABLE "tab" ALTER COLUMN "col" DROP DEFAULT;
823+dropDefault :: AlterColumn schemas ('Def :=> ty) ('NoDef :=> ty)
824+dropDefault = UnsafeAlterColumn $ "DROP DEFAULT"
825+
826+-- | A `setNotNull` adds a @NOT NULL@ constraint to a column.
827+-- The constraint will be checked immediately, so the table data must satisfy
828+-- the constraint before it can be added.
829+--
830+-- >>> :{
831+-- let
832+-- definition :: Definition
833+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
834+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
835+-- definition = alterTable #tab (alterColumn #col setNotNull)
836+-- in printSQL definition
837+-- :}
838+-- ALTER TABLE "tab" ALTER COLUMN "col" SET NOT NULL;
839+setNotNull
840+ :: AlterColumn schemas (constraint :=> 'Null ty) (constraint :=> 'NotNull ty)
841+setNotNull = UnsafeAlterColumn $ "SET NOT NULL"
842+
843+-- | A `dropNotNull` drops a @NOT NULL@ constraint from a column.
844+--
845+-- >>> :{
846+-- let
847+-- definition :: Definition
848+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
849+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
850+-- definition = alterTable #tab (alterColumn #col dropNotNull)
851+-- in printSQL definition
852+-- :}
853+-- ALTER TABLE "tab" ALTER COLUMN "col" DROP NOT NULL;
854+dropNotNull
855+ :: AlterColumn schemas (constraint :=> 'NotNull ty) (constraint :=> 'Null ty)
856+dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL"
857+
858+-- | An `alterType` converts a column to a different data type.
859+-- This will succeed only if each existing entry in the column can be
860+-- converted to the new type by an implicit cast.
861+--
862+-- >>> :{
863+-- let
864+-- definition :: Definition
865+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
866+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGnumeric])]]
867+-- definition =
868+-- alterTable #tab (alterColumn #col (alterType (numeric & notNullable)))
869+-- in printSQL definition
870+-- :}
871+-- ALTER TABLE "tab" ALTER COLUMN "col" TYPE numeric NOT NULL;
872+alterType :: ColumnTypeExpression schemas ty -> AlterColumn schemas ty0 ty
873+alterType ty = UnsafeAlterColumn $ "TYPE" <+> renderColumnTypeExpression ty
874+
875+{- | Create a view.
876+>>> type ABC = '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4]
877+>>> type BC = '["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4]
878+>>> :{
879+let
880+ definition :: Definition
881+ '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC)]]
882+ '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC), "bc" ::: 'View BC]]
883+ definition =
884+ createView #bc (select_ (#b :* #c) (from (table #abc)))
885+in printSQL definition
886+:}
887+CREATE VIEW "bc" AS SELECT "b" AS "b", "c" AS "c" FROM "abc" AS "abc";
888+-}
889+createView
890+ :: (KnownSymbol sch, KnownSymbol vw, Has sch schemas schema)
891+ => QualifiedAlias sch vw -- ^ the name of the view to add
892+ -> Query '[] '[] schemas '[] view -- ^ query
893+ -> Definition schemas (Alter sch (Create vw ('View view) schema) schemas)
894+createView alias query = UnsafeDefinition $
895+ "CREATE" <+> "VIEW" <+> renderSQL alias <+> "AS"
896+ <+> renderQuery query <> ";"
897+
898+-- | Drop a view.
899+--
900+-- >>> :{
901+-- let
902+-- definition :: Definition
903+-- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])
904+-- , "bc" ::: 'View ('["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4])]]
905+-- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])]]
906+-- definition = dropView #bc
907+-- in printSQL definition
908+-- :}
909+-- DROP VIEW "bc";
910+dropView
911+ :: (Has sch schemas schema, Has vw schema ('View view))
912+ => QualifiedAlias sch vw -- ^ view to remove
913+ -> Definition schemas (Alter sch (Drop vw schema) schemas)
914+dropView vw = UnsafeDefinition $ "DROP VIEW" <+> renderSQL vw <> ";"
915+
916+-- | Enumerated types are created using the `createTypeEnum` command, for example
917+--
918+-- >>> printSQL $ (createTypeEnum #mood (label @"sad" :* label @"ok" :* label @"happy") :: Definition (Public '[]) '["public" ::: '["mood" ::: 'Typedef ('PGenum '["sad","ok","happy"])]])
919+-- CREATE TYPE "mood" AS ENUM ('sad', 'ok', 'happy');
920+createTypeEnum
921+ :: (KnownSymbol enum, Has sch schemas schema, SOP.All KnownSymbol labels)
922+ => QualifiedAlias sch enum
923+ -- ^ name of the user defined enumerated type
924+ -> NP PGlabel labels
925+ -- ^ labels of the enumerated type
926+ -> Definition schemas (Alter sch (Create enum ('Typedef ('PGenum labels)) schema) schemas)
927+createTypeEnum enum labels = UnsafeDefinition $
928+ "CREATE" <+> "TYPE" <+> renderSQL enum <+> "AS" <+> "ENUM" <+>
929+ parenthesized (renderSQL labels) <> ";"
930+
931+-- | Enumerated types can also be generated from a Haskell type, for example
932+--
933+-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic
934+-- >>> instance SOP.Generic Schwarma
935+-- >>> instance SOP.HasDatatypeInfo Schwarma
936+-- >>> :{
937+-- let
938+-- createSchwarma :: Definition (Public '[]) '["public" ::: '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))]]
939+-- createSchwarma = createTypeEnumFrom @Schwarma #schwarma
940+-- in
941+-- printSQL createSchwarma
942+-- :}
943+-- CREATE TYPE "schwarma" AS ENUM ('Beef', 'Lamb', 'Chicken');
944+createTypeEnumFrom
945+ :: forall hask sch enum schemas schema.
946+ ( SOP.Generic hask
947+ , SOP.All KnownSymbol (LabelsPG hask)
948+ , KnownSymbol enum
949+ , Has sch schemas schema )
950+ => QualifiedAlias sch enum
951+ -- ^ name of the user defined enumerated type
952+ -> Definition schemas (Alter sch (Create enum ('Typedef (PG (Enumerated hask))) schema) schemas)
953+createTypeEnumFrom enum = createTypeEnum enum
954+ (SOP.hpure label :: NP PGlabel (LabelsPG hask))
955+
956+{- | `createTypeComposite` creates a composite type. The composite type is
957+specified by a list of attribute names and data types.
958+
959+>>> :{
960+type PGcomplex = 'PGcomposite
961+ '[ "real" ::: 'NotNull 'PGfloat8
962+ , "imaginary" ::: 'NotNull 'PGfloat8 ]
963+:}
964+
965+>>> :{
966+let
967+ setup :: Definition (Public '[]) '["public" ::: '["complex" ::: 'Typedef PGcomplex]]
968+ setup = createTypeComposite #complex
969+ (float8 `as` #real :* float8 `as` #imaginary)
970+in printSQL setup
971+:}
972+CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);
973+-}
974+createTypeComposite
975+ :: (KnownSymbol ty, Has sch schemas schema, SOP.SListI fields)
976+ => QualifiedAlias sch ty
977+ -- ^ name of the user defined composite type
978+ -> NP (Aliased (TypeExpression schemas)) fields
979+ -- ^ list of attribute names and data types
980+ -> Definition schemas (Alter sch (Create ty ('Typedef ('PGcomposite fields)) schema) schemas)
981+createTypeComposite ty fields = UnsafeDefinition $
982+ "CREATE" <+> "TYPE" <+> renderSQL ty <+> "AS" <+> parenthesized
983+ (renderCommaSeparated renderField fields) <> ";"
984+ where
985+ renderField :: Aliased (TypeExpression schemas) x -> ByteString
986+ renderField (typ `As` alias) =
987+ renderSQL alias <+> renderSQL typ
988+
989+-- | Composite types can also be generated from a Haskell type, for example
990+--
991+-- >>> data Complex = Complex {real :: Double, imaginary :: Double} deriving GHC.Generic
992+-- >>> instance SOP.Generic Complex
993+-- >>> instance SOP.HasDatatypeInfo Complex
994+-- >>> type Schema = '["complex" ::: 'Typedef (PG (Composite Complex))]
995+-- >>> :{
996+-- let
997+-- createComplex :: Definition (Public '[]) (Public Schema)
998+-- createComplex = createTypeCompositeFrom @Complex #complex
999+-- in
1000+-- printSQL createComplex
1001+-- :}
1002+-- CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);
1003+createTypeCompositeFrom
1004+ :: forall hask sch ty schemas schema.
1005+ ( SOP.All (FieldTyped schemas) (RowPG hask)
1006+ , KnownSymbol ty
1007+ , Has sch schemas schema )
1008+ => QualifiedAlias sch ty
1009+ -- ^ name of the user defined composite type
1010+ -> Definition schemas (Alter sch (Create ty ( 'Typedef (PG (Composite hask))) schema) schemas)
1011+createTypeCompositeFrom ty = createTypeComposite ty
1012+ (SOP.hcpure (SOP.Proxy :: SOP.Proxy (FieldTyped schemas)) fieldtype
1013+ :: NP (Aliased (TypeExpression schemas)) (RowPG hask))
1014+
1015+{-|
1016+`createDomain` creates a new domain. A domain is essentially a data type
1017+with constraints (restrictions on the allowed set of values).
1018+
1019+Domains are useful for abstracting common constraints on fields
1020+into a single location for maintenance. For example, several tables might
1021+contain email address columns, all requiring the same `check` constraint
1022+to verify the address syntax. Define a domain rather than setting up
1023+each table's constraint individually.
1024+
1025+>>> :{
1026+let
1027+ createPositive :: Definition (Public '[]) (Public '["positive" ::: 'Typedef 'PGfloat4])
1028+ createPositive = createDomain #positive real (#value .> 0 .&& (#value & isNotNull))
1029+in printSQL createPositive
1030+:}
1031+CREATE DOMAIN "positive" AS real CHECK ((("value" > 0) AND "value" IS NOT NULL));
1032+-}
1033+createDomain
1034+ :: (Has sch schemas schema, KnownSymbol dom)
1035+ => QualifiedAlias sch dom
1036+ -> (forall null. TypeExpression schemas (null ty))
1037+ -> (forall tab. Condition '[] '[] 'Ungrouped schemas '[] '[tab ::: '["value" ::: 'Null ty]])
1038+ -> Definition schemas (Alter sch (Create dom ('Typedef ty) schema) schemas)
1039+createDomain dom ty condition =
1040+ UnsafeDefinition $ "CREATE DOMAIN" <+> renderSQL dom
1041+ <+> "AS" <+> renderTypeExpression ty
1042+ <+> "CHECK" <+> parenthesized (renderSQL condition) <> ";"
1043+
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+
1053+-- | Lift `PGTyped` to a field
1054+class FieldTyped schemas ty where
1055+ fieldtype :: Aliased (TypeExpression schemas) ty
1056+instance (KnownSymbol alias, PGTyped schemas ty)
1057+ => FieldTyped schemas (alias ::: ty) where
1058+ fieldtype = pgtype `As` Alias
1059+
1060+-- | Drop a type.
1061+--
1062+-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic
1063+-- >>> instance SOP.Generic Schwarma
1064+-- >>> instance SOP.HasDatatypeInfo Schwarma
1065+-- >>> printSQL (dropType #schwarma :: Definition '["public" ::: '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))]] (Public '[]))
1066+-- DROP TYPE "schwarma";
1067+dropType
1068+ :: (Has sch schemas schema, Has td schema ('Typedef ty))
1069+ => QualifiedAlias sch td
1070+ -- ^ name of the user defined type
1071+ -> Definition schemas (Alter sch (Drop td schema) schemas)
1072+dropType tydef = UnsafeDefinition $ "DROP" <+> "TYPE" <+> renderSQL tydef <> ";"
1073+
1074+-- | `ColumnTypeExpression`s are used in `createTable` commands.
1075+newtype ColumnTypeExpression (schemas :: SchemasType) (ty :: ColumnType)
1076+ = UnsafeColumnTypeExpression { renderColumnTypeExpression :: ByteString }
1077+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
1078+instance RenderSQL (ColumnTypeExpression schemas ty) where
1079+ renderSQL = renderColumnTypeExpression
1080+
1081+-- | used in `createTable` commands as a column constraint to note that
1082+-- @NULL@ may be present in a column
1083+nullable
1084+ :: TypeExpression schemas (nullity ty)
1085+ -> ColumnTypeExpression schemas ('NoDef :=> 'Null ty)
1086+nullable ty = UnsafeColumnTypeExpression $ renderSQL ty <+> "NULL"
1087+
1088+-- | used in `createTable` commands as a column constraint to ensure
1089+-- @NULL@ is not present in a column
1090+notNullable
1091+ :: TypeExpression schemas (nullity ty)
1092+ -> ColumnTypeExpression schemas ('NoDef :=> 'NotNull ty)
1093+notNullable ty = UnsafeColumnTypeExpression $ renderSQL ty <+> "NOT NULL"
1094+
1095+-- | used in `createTable` commands as a column constraint to give a default
1096+default_
1097+ :: Expression '[] '[] 'Ungrouped schemas '[] '[] ty
1098+ -> ColumnTypeExpression schemas ('NoDef :=> ty)
1099+ -> ColumnTypeExpression schemas ('Def :=> ty)
1100+default_ x ty = UnsafeColumnTypeExpression $
1101+ renderSQL ty <+> "DEFAULT" <+> renderExpression x
1102+
1103+-- | not a true type, but merely a notational convenience for creating
1104+-- unique identifier columns with type `PGint2`
1105+serial2, smallserial
1106+ :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint2)
1107+serial2 = UnsafeColumnTypeExpression "serial2"
1108+smallserial = UnsafeColumnTypeExpression "smallserial"
1109+-- | not a true type, but merely a notational convenience for creating
1110+-- unique identifier columns with type `PGint4`
1111+serial4, serial
1112+ :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint4)
1113+serial4 = UnsafeColumnTypeExpression "serial4"
1114+serial = UnsafeColumnTypeExpression "serial"
1115+-- | not a true type, but merely a notational convenience for creating
1116+-- unique identifier columns with type `PGint8`
1117+serial8, bigserial
1118+ :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint8)
1119+serial8 = UnsafeColumnTypeExpression "serial8"
1120+bigserial = UnsafeColumnTypeExpression "bigserial"
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Function.hsdeleted−238
@@ -1,238 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Definition.Function
3−Description: Create and drop function and operator definitions
4−Copyright: (c) Eitan Chatav, 2017
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Create and drop function and operator definitions.
9−-}
10−
11−{-# LANGUAGE
12− AllowAmbiguousTypes
13− , ConstraintKinds
14− , DeriveAnyClass
15− , DeriveGeneric
16− , DerivingStrategies
17− , FlexibleContexts
18− , FlexibleInstances
19− , GADTs
20− , LambdaCase
21− , MultiParamTypeClasses
22− , OverloadedLabels
23− , OverloadedStrings
24− , RankNTypes
25− , ScopedTypeVariables
26− , TypeApplications
27− , TypeInType
28− , TypeOperators
29− , UndecidableSuperClasses
30−#-}
31−
32−module Squeal.PostgreSQL.Definition.Function
33− ( createFunction
34− , createOrReplaceFunction
35− , createSetFunction
36− , createOrReplaceSetFunction
37− , createBinaryOp
38− , createLeftOp
39− , createRightOp
40− , dropFunction
41− , dropFunctionIfExists
42− , dropOperator
43− , dropOperatorIfExists
44− , FunctionDefinition(..)
45− , languageSqlExpr
46− , languageSqlQuery
47− ) where
48−
49−import Control.DeepSeq
50−import Data.ByteString
51−import GHC.TypeLits
52−
53−import qualified Generics.SOP as SOP
54−import qualified GHC.Generics as GHC
55−
56−import Squeal.PostgreSQL.Alias
57−import Squeal.PostgreSQL.Definition
58−import Squeal.PostgreSQL.Expression
59−import Squeal.PostgreSQL.Expression.Type
60−import Squeal.PostgreSQL.List
61−import Squeal.PostgreSQL.Query
62−import Squeal.PostgreSQL.Render
63−import Squeal.PostgreSQL.Schema
64−
65−-- $setup
66−-- >>> import Squeal.PostgreSQL
67−
68−createFunction
69− :: ( Has sch schemas schema
70− , KnownSymbol fun
71− , SOP.SListI args )
72− => QualifiedAlias sch fun
73− -> NP (TypeExpression schemas) args
74− -> TypeExpression schemas ret
75− -> FunctionDefinition schemas args ('Returns ret)
76− -> Definition schemas (Alter sch (Create fun ('Function (args :=> 'Returns ret)) schema) schemas)
77−createFunction fun args ret fundef = UnsafeDefinition $
78− "CREATE" <+> "FUNCTION" <+> renderSQL fun
79− <+> parenthesized (renderCommaSeparated renderSQL args)
80− <+> "RETURNS" <+> renderSQL ret <+> renderSQL fundef <> ";"
81−
82−createOrReplaceFunction
83− :: ( Has sch schemas schema
84− , KnownSymbol fun
85− , SOP.SListI args )
86− => QualifiedAlias sch fun
87− -> NP (TypeExpression schemas) args
88− -> TypeExpression schemas ret
89− -> FunctionDefinition schemas args ('Returns ret)
90− -> Definition schemas (Alter sch (CreateOrReplace fun ('Function (args :=> 'Returns ret)) schema) schemas)
91−createOrReplaceFunction fun args ret fundef = UnsafeDefinition $
92− "CREATE" <+> "OR" <+> "REPLACE" <+> "FUNCTION" <+> renderSQL fun
93− <+> parenthesized (renderCommaSeparated renderSQL args)
94− <+> "RETURNS" <+> renderSQL ret <+> renderSQL fundef <> ";"
95−
96−languageSqlExpr
97− :: Expression '[] '[] 'Ungrouped schemas args '[] ret
98− -> FunctionDefinition schemas args ('Returns ret)
99−languageSqlExpr expr = UnsafeFunctionDefinition $
100− "language sql as"
101− <+> "$$" <+> renderSQL (values_ (expr `as` #ret)) <+> "$$"
102−
103−languageSqlQuery
104− :: Query '[] '[] schemas args rets
105− -> FunctionDefinition schemas args ('ReturnsTable rets)
106−languageSqlQuery qry = UnsafeFunctionDefinition $
107− "language sql as" <+> "$$" <+> renderSQL qry <+> "$$"
108−
109−createSetFunction
110− :: ( Has sch schemas schema
111− , KnownSymbol fun
112− , SOP.SListI args
113− , SOP.SListI rets )
114− => QualifiedAlias sch fun
115− -> NP (TypeExpression schemas) args
116− -> NP (Aliased (TypeExpression schemas)) rets
117− -> FunctionDefinition schemas args ('ReturnsTable rets)
118− -> Definition schemas (Alter sch (Create fun ('Function (args :=> 'ReturnsTable rets)) schema) schemas)
119−createSetFunction fun args rets fundef = UnsafeDefinition $
120− "CREATE" <+> "FUNCTION" <+> renderSQL fun
121− <+> parenthesized (renderCommaSeparated renderSQL args)
122− <+> "RETURNS" <+> "TABLE"
123− <+> parenthesized (renderCommaSeparated renderRet rets)
124− <+> renderSQL fundef <> ";"
125− where
126− renderRet :: Aliased (TypeExpression s) r -> ByteString
127− renderRet (ty `As` col) = renderSQL col <+> renderSQL ty
128−
129−createOrReplaceSetFunction
130− :: ( Has sch schemas schema
131− , KnownSymbol fun
132− , SOP.SListI args
133− , SOP.SListI rets )
134− => QualifiedAlias sch fun
135− -> NP (TypeExpression schemas) args
136− -> NP (Aliased (TypeExpression schemas)) rets
137− -> FunctionDefinition schemas args ('ReturnsTable rets)
138− -> Definition schemas (Alter sch (CreateOrReplace fun ('Function (args :=> 'ReturnsTable rets)) schema) schemas)
139−createOrReplaceSetFunction fun args rets fundef = UnsafeDefinition $
140− "CREATE" <+> "OR" <+> "REPLACE" <+> "FUNCTION" <+> renderSQL fun
141− <+> parenthesized (renderCommaSeparated renderSQL args)
142− <+> "RETURNS" <+> "TABLE"
143− <+> parenthesized (renderCommaSeparated renderRet rets)
144− <+> renderSQL fundef <> ";"
145− where
146− renderRet :: Aliased (TypeExpression s) r -> ByteString
147− renderRet (ty `As` col) = renderSQL col <+> renderSQL ty
148−
149−createBinaryOp
150− :: forall op fun sch schemas schema x y z.
151− ( Has sch schemas schema
152− , Has fun schema ('Function ('[x,y] :=> 'Returns z))
153− , KnownSymbol op )
154− => QualifiedAlias sch fun
155− -> TypeExpression schemas x
156− -> TypeExpression schemas y
157− -> Definition schemas
158− (Alter sch (Create op ('Operator ('BinaryOp x y z)) schema) schemas)
159−createBinaryOp fun x y = UnsafeDefinition $
160− "CREATE" <+> "OPERATOR" <+> renderSymbol @op
161− <+> parenthesized (commaSeparated opdef)
162− where
163− opdef =
164− [ "FUNCTION" <+> "=" <+> renderSQL fun
165− , "LEFTARG" <+> "=" <+> renderSQL x
166− , "RIGHTARG" <+> "=" <+> renderSQL y ]
167−
168−createLeftOp
169− :: forall op fun sch schemas schema x y.
170− ( Has sch schemas schema
171− , Has fun schema ('Function ('[x] :=> 'Returns y))
172− , KnownSymbol op )
173− => QualifiedAlias sch fun
174− -> TypeExpression schemas x
175− -> Definition schemas
176− (Alter sch (Create op ('Operator ('LeftOp x y)) schema) schemas)
177−createLeftOp fun x = UnsafeDefinition $
178− "CREATE" <+> "OPERATOR" <+> renderSymbol @op
179− <+> parenthesized (commaSeparated opdef)
180− where
181− opdef =
182− [ "FUNCTION" <+> "=" <+> renderSQL fun
183− , "RIGHTARG" <+> "=" <+> renderSQL x ]
184−
185−createRightOp
186− :: forall op fun sch schemas schema x y.
187− ( Has sch schemas schema
188− , Has fun schema ('Function ('[x] :=> 'Returns y))
189− , KnownSymbol op )
190− => QualifiedAlias sch fun
191− -> TypeExpression schemas x
192− -> Definition schemas
193− (Alter sch (Create op ('Operator ('RightOp x y)) schema) schemas)
194−createRightOp fun x = UnsafeDefinition $
195− "CREATE" <+> "OPERATOR" <+> renderSymbol @op
196− <+> parenthesized (commaSeparated opdef)
197− where
198− opdef =
199− [ "FUNCTION" <+> "=" <+> renderSQL fun
200− , "LEFTARG" <+> "=" <+> renderSQL x ]
201−
202−dropFunction
203− :: (Has sch schemas schema, KnownSymbol fun)
204− => QualifiedAlias sch fun
205− -- ^ name of the user defined function
206− -> Definition schemas (Alter sch (DropSchemum fun 'Function schema) schemas)
207−dropFunction fun = UnsafeDefinition $
208− "DROP" <+> "FUNCTION" <+> renderSQL fun <> ";"
209−
210−dropFunctionIfExists
211− :: (Has sch schemas schema, KnownSymbol fun)
212− => QualifiedAlias sch fun
213− -- ^ name of the user defined function
214− -> Definition schemas (Alter sch (DropSchemumIfExists fun 'Function schema) schemas)
215−dropFunctionIfExists fun = UnsafeDefinition $
216− "DROP FUNCTION IF EXISTS" <+> renderSQL fun <> ";"
217−
218−dropOperator
219− :: (Has sch schemas schema, KnownSymbol op)
220− => QualifiedAlias sch op
221− -- ^ name of the user defined operator
222− -> Definition schemas (Alter sch (DropSchemum op 'Operator schema) schemas)
223−dropOperator op = UnsafeDefinition $
224− "DROP" <+> "OPERATOR" <+> renderSQL op <> ";"
225−
226−dropOperatorIfExists
227− :: (Has sch schemas schema, KnownSymbol op)
228− => QualifiedAlias sch op
229− -- ^ name of the user defined operator
230− -> Definition schemas (Alter sch (DropSchemumIfExists op 'Operator schema) schemas)
231−dropOperatorIfExists op = UnsafeDefinition $
232− "DROP OPERATOR IF EXISTS" <+> renderSQL op <> ";"
233−
234−newtype FunctionDefinition schemas args ret = UnsafeFunctionDefinition
235− { renderFunctionDefinition :: ByteString }
236− deriving (Eq,Show,GHC.Generic,NFData)
237−instance RenderSQL (FunctionDefinition schemas args ret) where
238− renderSQL = renderFunctionDefinition
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Index.hsdeleted−159
@@ -1,159 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Definition.Index
3−Description: Create and drop index definitions
4−Copyright: (c) Eitan Chatav, 2017
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Create and drop index definitions.
9−-}
10−
11−{-# LANGUAGE
12− AllowAmbiguousTypes
13− , ConstraintKinds
14− , DeriveAnyClass
15− , DeriveGeneric
16− , DerivingStrategies
17− , FlexibleContexts
18− , FlexibleInstances
19− , GADTs
20− , LambdaCase
21− , MultiParamTypeClasses
22− , OverloadedLabels
23− , OverloadedStrings
24− , RankNTypes
25− , ScopedTypeVariables
26− , TypeApplications
27− , TypeInType
28− , TypeOperators
29− , UndecidableSuperClasses
30−#-}
31−
32−module Squeal.PostgreSQL.Definition.Index
33− ( createIndex
34− , createIndexIfNotExists
35− , dropIndex
36− , dropIndexIfExists
37− , IndexMethod (..)
38− , btree
39− , hash
40− , gist
41− , spgist
42− , gin
43− , brin
44− ) where
45−
46−import Data.ByteString
47−import GHC.TypeLits
48−
49−import qualified GHC.Generics as GHC
50−
51−import Squeal.PostgreSQL.Alias
52−import Squeal.PostgreSQL.Definition
53−import Squeal.PostgreSQL.Expression.Sort
54−import Squeal.PostgreSQL.Render
55−import Squeal.PostgreSQL.Schema
56−
57−-- $setup
58−-- >>> import Squeal.PostgreSQL
59−
60−{- |
61−>>> :{
62−type Table = '[] :=>
63− '[ "a" ::: 'NoDef :=> 'Null 'PGint4
64− , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]
65−:}
66−
67−>>> :{
68−let
69− setup :: Definition (Public '[]) (Public '["tab" ::: 'Table Table, "ix" ::: 'Index 'Btree])
70− setup =
71− createTable #tab (nullable int `as` #a :* nullable real `as` #b) Nil >>>
72− createIndex #ix #tab btree [#a & AscNullsFirst, #b & AscNullsLast]
73−in printSQL setup
74−:}
75−CREATE TABLE "tab" ("a" int NULL, "b" real NULL);
76−CREATE INDEX "ix" ON "tab" USING btree (("a") ASC NULLS FIRST, ("b") ASC NULLS LAST);
77−-}
78−createIndex
79− :: (Has sch schemas schema, Has tab schema ('Table table), KnownSymbol ix)
80− => Alias ix
81− -> QualifiedAlias sch tab
82− -> IndexMethod method
83− -> [SortExpression '[] '[] 'Ungrouped schemas '[] '[tab ::: TableToRow table]]
84− -> Definition schemas (Alter sch (Create ix ('Index method) schema) schemas)
85−createIndex ix tab method cols = UnsafeDefinition $
86− "CREATE" <+> "INDEX" <+> renderSQL ix <+> "ON" <+> renderSQL tab
87− <+> "USING" <+> renderSQL method
88− <+> parenthesized (commaSeparated (renderIndex <$> cols))
89− <> ";"
90− where
91− renderIndex = \case
92− Asc expression -> parenthesized (renderSQL expression) <+> "ASC"
93− Desc expression -> parenthesized (renderSQL expression) <+> "DESC"
94− AscNullsFirst expression -> parenthesized (renderSQL expression)
95− <+> "ASC NULLS FIRST"
96− DescNullsFirst expression -> parenthesized (renderSQL expression)
97− <+> "DESC NULLS FIRST"
98− AscNullsLast expression -> parenthesized (renderSQL expression)
99− <+> "ASC NULLS LAST"
100− DescNullsLast expression -> parenthesized (renderSQL expression)
101− <+> "DESC NULLS LAST"
102−
103−createIndexIfNotExists
104− :: (Has sch schemas schema, Has tab schema ('Table table), KnownSymbol ix)
105− => Alias ix
106− -> QualifiedAlias sch tab
107− -> IndexMethod method
108− -> [SortExpression '[] '[] 'Ungrouped schemas '[] '[tab ::: TableToRow table]]
109− -> Definition schemas (Alter sch (CreateIfNotExists ix ('Index method) schema) schemas)
110−createIndexIfNotExists ix tab method cols = UnsafeDefinition $
111− "CREATE INDEX IF NOT EXISTS" <+> renderSQL ix <+> "ON" <+> renderSQL tab
112− <+> "USING" <+> renderSQL method
113− <+> parenthesized (commaSeparated (renderIndex <$> cols))
114− <> ";"
115− where
116− renderIndex = \case
117− Asc expression -> parenthesized (renderSQL expression) <+> "ASC"
118− Desc expression -> parenthesized (renderSQL expression) <+> "DESC"
119− AscNullsFirst expression -> parenthesized (renderSQL expression)
120− <+> "ASC NULLS FIRST"
121− DescNullsFirst expression -> parenthesized (renderSQL expression)
122− <+> "DESC NULLS FIRST"
123− AscNullsLast expression -> parenthesized (renderSQL expression)
124− <+> "ASC NULLS LAST"
125− DescNullsLast expression -> parenthesized (renderSQL expression)
126− <+> "DESC NULLS LAST"
127−
128−newtype IndexMethod ty = UnsafeIndexMethod {renderIndexMethod :: ByteString}
129− deriving stock (Eq, Ord, Show, GHC.Generic)
130−instance RenderSQL (IndexMethod ty) where renderSQL = renderIndexMethod
131−btree :: IndexMethod 'Btree
132−btree = UnsafeIndexMethod "btree"
133−hash :: IndexMethod 'Hash
134−hash = UnsafeIndexMethod "hash"
135−gist :: IndexMethod 'Gist
136−gist = UnsafeIndexMethod "gist"
137−spgist :: IndexMethod 'Spgist
138−spgist = UnsafeIndexMethod "spgist"
139−gin :: IndexMethod 'Gin
140−gin = UnsafeIndexMethod "gin"
141−brin :: IndexMethod 'Brin
142−brin = UnsafeIndexMethod "brin"
143−
144−-- |
145−-- >>> printSQL (dropIndex #ix :: Definition (Public '["ix" ::: 'Index 'Btree]) (Public '[]))
146−-- DROP INDEX "ix";
147−dropIndex
148− :: (Has sch schemas schema, KnownSymbol ix)
149− => QualifiedAlias sch ix
150− -- ^ name of the user defined index
151− -> Definition schemas (Alter sch (DropSchemum ix 'Index schema) schemas)
152−dropIndex ix = UnsafeDefinition $ "DROP" <+> "INDEX" <+> renderSQL ix <> ";"
153−
154−dropIndexIfExists
155− :: (Has sch schemas schema, KnownSymbol ix)
156− => QualifiedAlias sch ix
157− -- ^ name of the user defined index
158− -> Definition schemas (Alter sch (DropSchemumIfExists ix 'Index schema) schemas)
159−dropIndexIfExists ix = UnsafeDefinition $ "DROP INDEX IF EXISTS" <+> renderSQL ix <> ";"
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Schema.hsdeleted−96
@@ -1,96 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Definition.Schema
3−Description: Create and drop schema definitions
4−Copyright: (c) Eitan Chatav, 2017
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Create and drop schema definitions.
9−-}
10−
11−{-# LANGUAGE
12− AllowAmbiguousTypes
13− , ConstraintKinds
14− , DeriveAnyClass
15− , DeriveGeneric
16− , DerivingStrategies
17− , FlexibleContexts
18− , FlexibleInstances
19− , GADTs
20− , LambdaCase
21− , MultiParamTypeClasses
22− , OverloadedLabels
23− , OverloadedStrings
24− , RankNTypes
25− , ScopedTypeVariables
26− , TypeApplications
27− , TypeInType
28− , TypeOperators
29− , UndecidableSuperClasses
30−#-}
31−
32−module Squeal.PostgreSQL.Definition.Schema
33− ( createSchema
34− , createSchemaIfNotExists
35− , dropSchema
36− , dropSchemaIfExists
37− ) where
38−
39−import GHC.TypeLits
40−
41−import Squeal.PostgreSQL.Alias
42−import Squeal.PostgreSQL.Definition
43−import Squeal.PostgreSQL.Render
44−import Squeal.PostgreSQL.Schema
45−
46−-- $setup
47−-- >>> import Squeal.PostgreSQL
48−
49−{- |
50−`createSchema` enters a new schema into the current database.
51−The schema name must be distinct from the name of any existing schema
52−in the current database.
53−
54−A schema is essentially a namespace: it contains named objects
55−(tables, data types, functions, and operators) whose names
56−can duplicate those of other objects existing in other schemas.
57−Named objects are accessed by `QualifiedAlias`es with the schema
58−name as a prefix.
59−-}
60−createSchema
61− :: KnownSymbol sch
62− => Alias sch
63− -> Definition schemas (Create sch '[] schemas)
64−createSchema sch = UnsafeDefinition $
65− "CREATE" <+> "SCHEMA" <+> renderSQL sch <> ";"
66−
67−{- | Idempotent version of `createSchema`. -}
68−createSchemaIfNotExists
69− :: (KnownSymbol sch, Has sch schemas schema)
70− => Alias sch
71− -> Definition schemas (CreateIfNotExists sch '[] schemas)
72−createSchemaIfNotExists sch = UnsafeDefinition $
73− "CREATE" <+> "SCHEMA" <+> "IF" <+> "NOT" <+> "EXISTS"
74− <+> renderSQL sch <> ";"
75−
76−-- | >>> :{
77−-- let
78−-- definition :: Definition '["muh_schema" ::: schema, "public" ::: public] '["public" ::: public]
79−-- definition = dropSchema #muh_schema
80−-- :}
81−--
82−-- >>> printSQL definition
83−-- DROP SCHEMA "muh_schema";
84−dropSchema
85− :: KnownSymbol sch
86− => Alias sch
87− -- ^ user defined schema
88− -> Definition schemas (Drop sch schemas)
89−dropSchema sch = UnsafeDefinition $ "DROP SCHEMA" <+> renderSQL sch <> ";"
90−
91−dropSchemaIfExists
92− :: KnownSymbol sch
93− => Alias sch
94− -- ^ user defined schema
95− -> Definition schemas (DropIfExists sch schemas)
96−dropSchemaIfExists sch = UnsafeDefinition $ "DROP SCHEMA" <+> renderSQL sch <> ";"
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Table.hsdeleted−500
@@ -1,500 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Definition.Table
3−Description: Create, drop and alter table definitions
4−Copyright: (c) Eitan Chatav, 2017
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Create, drop and alter table definitions.
9−-}
10−
11−{-# LANGUAGE
12− AllowAmbiguousTypes
13− , ConstraintKinds
14− , DeriveAnyClass
15− , DeriveGeneric
16− , DerivingStrategies
17− , FlexibleContexts
18− , FlexibleInstances
19− , GADTs
20− , LambdaCase
21− , MultiParamTypeClasses
22− , OverloadedLabels
23− , OverloadedStrings
24− , RankNTypes
25− , ScopedTypeVariables
26− , TypeApplications
27− , TypeInType
28− , TypeOperators
29− , UndecidableSuperClasses
30−#-}
31−
32−module Squeal.PostgreSQL.Definition.Table
33− ( createTable
34− , createTableIfNotExists
35− , dropTable
36− , dropTableIfExists
37− , alterTable
38− , alterTableIfExists
39− , alterTableRename
40− , alterTableIfExistsRename
41− , AlterTable (..)
42− , addConstraint
43− , dropConstraint
44− , AddColumn (..)
45− , dropColumn
46− , renameColumn
47− , alterColumn
48− , AlterColumn (..)
49− , setDefault
50− , dropDefault
51− , setNotNull
52− , dropNotNull
53− , alterType
54− ) where
55−
56−import Control.DeepSeq
57−import Data.ByteString
58−import GHC.TypeLits
59−
60−import qualified Generics.SOP as SOP
61−import qualified GHC.Generics as GHC
62−
63−import Squeal.PostgreSQL.Alias
64−import Squeal.PostgreSQL.Definition
65−import Squeal.PostgreSQL.Definition.Table.Constraint
66−import Squeal.PostgreSQL.Expression
67−import Squeal.PostgreSQL.Expression.Type
68−import Squeal.PostgreSQL.List
69−import Squeal.PostgreSQL.Render
70−import Squeal.PostgreSQL.Schema
71−
72−-- $setup
73−-- >>> import Squeal.PostgreSQL
74−
75−{- | `createTable` adds a table to the schema.
76−
77−>>> :set -XOverloadedLabels
78−>>> :{
79−type Table = '[] :=>
80− '[ "a" ::: 'NoDef :=> 'Null 'PGint4
81− , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]
82−:}
83−
84−>>> :{
85−let
86− setup :: Definition (Public '[]) (Public '["tab" ::: 'Table Table])
87− setup = createTable #tab
88− (nullable int `as` #a :* nullable real `as` #b) Nil
89−in printSQL setup
90−:}
91−CREATE TABLE "tab" ("a" int NULL, "b" real NULL);
92−-}
93−createTable
94− :: ( KnownSymbol sch
95− , KnownSymbol tab
96− , columns ~ (col ': cols)
97− , SOP.SListI columns
98− , SOP.SListI constraints
99− , Has sch schemas0 schema0
100− , schemas1 ~ Alter sch (Create tab ('Table (constraints :=> columns)) schema0) schemas0 )
101− => QualifiedAlias sch tab -- ^ the name of the table to add
102− -> NP (Aliased (ColumnTypeExpression schemas0)) columns
103− -- ^ the names and datatype of each column
104− -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints
105− -- ^ constraints that must hold for the table
106− -> Definition schemas0 schemas1
107−createTable tab columns constraints = UnsafeDefinition $
108− "CREATE TABLE" <+> renderCreation tab columns constraints
109−
110−{-| `createTableIfNotExists` creates a table if it doesn't exist, but does not add it to the schema.
111−Instead, the schema already has the table so if the table did not yet exist, the schema was wrong.
112−`createTableIfNotExists` fixes this. Interestingly, this property makes it an idempotent in
113−the `Category` of `Definition`s.
114−
115−>>> :set -XOverloadedLabels -XTypeApplications
116−>>> :{
117−type Table = '[] :=>
118− '[ "a" ::: 'NoDef :=> 'Null 'PGint4
119− , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]
120−:}
121−
122−>>> type Schemas = Public '["tab" ::: 'Table Table]
123−
124−>>> :{
125−let
126− setup :: Definition Schemas Schemas
127− setup = createTableIfNotExists #tab
128− (nullable int `as` #a :* nullable real `as` #b) Nil
129−in printSQL setup
130−:}
131−CREATE TABLE IF NOT EXISTS "tab" ("a" int NULL, "b" real NULL);
132−-}
133−createTableIfNotExists
134− :: ( KnownSymbol sch
135− , KnownSymbol tab
136− , columns ~ (col ': cols)
137− , SOP.SListI columns
138− , SOP.SListI constraints
139− , Has sch schemas0 schema0
140− , schemas1 ~ Alter sch (CreateIfNotExists tab ('Table (constraints :=> columns)) schema0) schemas0 )
141− => QualifiedAlias sch tab -- ^ the name of the table to add
142− -> NP (Aliased (ColumnTypeExpression schemas0)) columns
143− -- ^ the names and datatype of each column
144− -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints
145− -- ^ constraints that must hold for the table
146− -> Definition schemas0 schemas1
147−createTableIfNotExists tab columns constraints = UnsafeDefinition $
148− "CREATE TABLE IF NOT EXISTS"
149− <+> renderCreation tab columns constraints
150−
151−-- helper function for `createTable` and `createTableIfNotExists`
152−renderCreation
153− :: ( KnownSymbol sch
154− , KnownSymbol tab
155− , SOP.SListI columns
156− , SOP.SListI constraints )
157− => QualifiedAlias sch tab -- ^ the name of the table to add
158− -> NP (Aliased (ColumnTypeExpression schemas0)) columns
159− -- ^ the names and datatype of each column
160− -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints
161− -- ^ constraints that must hold for the table
162− -> ByteString
163−renderCreation tab columns constraints = renderSQL tab
164− <+> parenthesized
165− ( renderCommaSeparated renderColumnDef columns
166− <> ( case constraints of
167− Nil -> ""
168− _ -> ", " <>
169− renderCommaSeparated renderConstraint constraints ) )
170− <> ";"
171− where
172− renderColumnDef :: Aliased (ColumnTypeExpression schemas) x -> ByteString
173− renderColumnDef (ty `As` column) =
174− renderSQL column <+> renderColumnTypeExpression ty
175− renderConstraint
176− :: Aliased (TableConstraintExpression sch tab schemas) constraint
177− -> ByteString
178− renderConstraint (constraint `As` alias) =
179− "CONSTRAINT" <+> renderSQL alias <+> renderSQL constraint
180−
181−-- | `dropTable` removes a table from the schema.
182−--
183−-- >>> :{
184−-- let
185−-- definition :: Definition '["public" ::: '["muh_table" ::: 'Table t]] (Public '[])
186−-- definition = dropTable #muh_table
187−-- :}
188−--
189−-- >>> printSQL definition
190−-- DROP TABLE "muh_table";
191−dropTable
192− :: ( Has sch schemas schema
193− , KnownSymbol tab )
194− => QualifiedAlias sch tab -- ^ table to remove
195− -> Definition schemas (Alter sch (DropSchemum tab 'Table schema) schemas)
196−dropTable tab = UnsafeDefinition $ "DROP TABLE" <+> renderSQL tab <> ";"
197−
198−dropTableIfExists
199− :: ( Has sch schemas schema
200− , KnownSymbol tab)
201− => QualifiedAlias sch tab -- ^ table to remove
202− -> Definition schemas (Alter sch (DropSchemumIfExists tab 'Table schema) schemas)
203−dropTableIfExists tab = UnsafeDefinition $ "DROP TABLE IF EXISTS" <+> renderSQL tab <> ";"
204−
205−-- | `alterTable` changes the definition of a table from the schema.
206−alterTable
207− :: (Has sch schemas schema, KnownSymbol tab)
208− => QualifiedAlias sch tab -- ^ table to alter
209− -> AlterTable sch tab schemas table -- ^ alteration to perform
210− -> Definition schemas (Alter sch (Alter tab ('Table table) schema) schemas)
211−alterTable tab alteration = UnsafeDefinition $
212− "ALTER TABLE"
213− <+> renderSQL tab
214− <+> renderAlterTable alteration
215− <> ";"
216−
217−-- | `alterTable` changes the definition of a table from the schema.
218−alterTableIfExists
219− :: (Has sch schemas schema, KnownSymbol tab)
220− => QualifiedAlias sch tab -- ^ table to alter
221− -> AlterTable sch tab schemas table -- ^ alteration to perform
222− -> Definition schemas (Alter sch (AlterIfExists tab ('Table table) schema) schemas)
223−alterTableIfExists tab alteration = UnsafeDefinition $
224− "ALTER TABLE IF EXISTS"
225− <+> renderSQL tab
226− <+> renderAlterTable alteration
227− <> ";"
228−
229−-- | `alterTableRename` changes the name of a table from the schema.
230−--
231−-- >>> printSQL $ alterTableRename #foo #bar
232−-- ALTER TABLE "foo" RENAME TO "bar";
233−alterTableRename
234− :: (KnownSymbol tab0, KnownSymbol tab1)
235− => Alias tab0 -- ^ table to rename
236− -> Alias tab1 -- ^ what to rename it
237− -> Definition schema (Rename tab0 tab1 schema)
238−alterTableRename tab0 tab1 = UnsafeDefinition $
239− "ALTER TABLE" <+> renderSQL tab0
240− <+> "RENAME TO" <+> renderSQL tab1 <> ";"
241−
242−alterTableIfExistsRename
243− :: (KnownSymbol tab0, KnownSymbol tab1)
244− => Alias tab0 -- ^ table to rename
245− -> Alias tab1 -- ^ what to rename it
246− -> Definition schema (RenameIfExists tab0 tab1 schema)
247−alterTableIfExistsRename tab0 tab1 = UnsafeDefinition $
248− "ALTER TABLE IF EXISTS" <+> renderSQL tab0
249− <+> "RENAME TO" <+> renderSQL tab1 <> ";"
250−
251−-- | An `AlterTable` describes the alteration to perform on the columns
252−-- of a table.
253−newtype AlterTable
254− (sch :: Symbol)
255− (tab :: Symbol)
256− (schemas :: SchemasType)
257− (table :: TableType) =
258− UnsafeAlterTable {renderAlterTable :: ByteString}
259− deriving (GHC.Generic,Show,Eq,Ord,NFData)
260−
261−-- | An `addConstraint` adds a table constraint.
262−--
263−-- >>> :{
264−-- let
265−-- definition :: Definition
266−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
267−-- '["public" ::: '["tab" ::: 'Table ('["positive" ::: 'Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
268−-- definition = alterTable #tab (addConstraint #positive (check #col (#col .> 0)))
269−-- in printSQL definition
270−-- :}
271−-- ALTER TABLE "tab" ADD CONSTRAINT "positive" CHECK (("col" > 0));
272−addConstraint
273− :: ( KnownSymbol alias
274− , Has sch schemas schema
275− , Has tab schema ('Table table0)
276− , table0 ~ (constraints :=> columns)
277− , table1 ~ (Create alias constraint constraints :=> columns) )
278− => Alias alias
279− -> TableConstraintExpression sch tab schemas constraint
280− -- ^ constraint to add
281− -> AlterTable sch tab schemas table1
282−addConstraint alias constraint = UnsafeAlterTable $
283− "ADD" <+> "CONSTRAINT" <+> renderSQL alias
284− <+> renderSQL constraint
285−
286−-- | A `dropConstraint` drops a table constraint.
287−--
288−-- >>> :{
289−-- let
290−-- definition :: Definition
291−-- '["public" ::: '["tab" ::: 'Table ('["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
292−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
293−-- definition = alterTable #tab (dropConstraint #positive)
294−-- in printSQL definition
295−-- :}
296−-- ALTER TABLE "tab" DROP CONSTRAINT "positive";
297−dropConstraint
298− :: ( KnownSymbol constraint
299− , Has sch schemas schema
300− , Has tab schema ('Table table0)
301− , table0 ~ (constraints :=> columns)
302− , table1 ~ (Drop constraint constraints :=> columns) )
303− => Alias constraint
304− -- ^ constraint to drop
305− -> AlterTable sch tab schemas table1
306−dropConstraint constraint = UnsafeAlterTable $
307− "DROP" <+> "CONSTRAINT" <+> renderSQL constraint
308−
309−-- | An `AddColumn` is either @NULL@ or has @DEFAULT@.
310−class AddColumn ty where
311− -- | `addColumn` adds a new column, initially filled with whatever
312− -- default value is given or with @NULL@.
313− --
314− -- >>> :{
315− -- let
316− -- definition :: Definition
317− -- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]
318− -- '["public" ::: '["tab" ::: 'Table ('[] :=>
319− -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
320− -- , "col2" ::: 'Def :=> 'Null 'PGtext ])]]
321− -- definition = alterTable #tab (addColumn #col2 (text & nullable & default_ "foo"))
322− -- in printSQL definition
323− -- :}
324− -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL DEFAULT E'foo';
325− --
326− -- >>> :{
327− -- let
328− -- definition :: Definition
329− -- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]
330− -- '["public" ::: '["tab" ::: 'Table ('[] :=>
331− -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
332− -- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]]
333− -- definition = alterTable #tab (addColumn #col2 (text & nullable))
334− -- in printSQL definition
335− -- :}
336− -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL;
337− addColumn
338− :: ( KnownSymbol column
339− , Has sch schemas schema
340− , Has tab schema ('Table table0)
341− , table0 ~ (constraints :=> columns) )
342− => Alias column -- ^ column to add
343− -> ColumnTypeExpression schemas ty -- ^ type of the new column
344− -> AlterTable sch tab schemas (constraints :=> Create column ty columns)
345− addColumn column ty = UnsafeAlterTable $
346− "ADD COLUMN" <+> renderSQL column <+> renderColumnTypeExpression ty
347−instance {-# OVERLAPPING #-} AddColumn ('Def :=> ty)
348−instance {-# OVERLAPPABLE #-} AddColumn ('NoDef :=> 'Null ty)
349−
350−-- | A `dropColumn` removes a column. Whatever data was in the column
351−-- disappears. Table constraints involving the column are dropped, too.
352−-- However, if the column is referenced by a foreign key constraint of
353−-- another table, PostgreSQL will not silently drop that constraint.
354−--
355−-- >>> :{
356−-- let
357−-- definition :: Definition
358−-- '["public" ::: '["tab" ::: 'Table ('[] :=>
359−-- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
360−-- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]]
361−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]
362−-- definition = alterTable #tab (dropColumn #col2)
363−-- in printSQL definition
364−-- :}
365−-- ALTER TABLE "tab" DROP COLUMN "col2";
366−dropColumn
367− :: ( KnownSymbol column
368− , Has sch schemas schema
369− , Has tab schema ('Table table0)
370− , table0 ~ (constraints :=> columns)
371− , table1 ~ (constraints :=> Drop column columns) )
372− => Alias column -- ^ column to remove
373− -> AlterTable sch tab schemas table1
374−dropColumn column = UnsafeAlterTable $
375− "DROP COLUMN" <+> renderSQL column
376−
377−-- | A `renameColumn` renames a column.
378−--
379−-- >>> :{
380−-- let
381−-- definition :: Definition
382−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["foo" ::: 'NoDef :=> 'Null 'PGint4])]]
383−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["bar" ::: 'NoDef :=> 'Null 'PGint4])]]
384−-- definition = alterTable #tab (renameColumn #foo #bar)
385−-- in printSQL definition
386−-- :}
387−-- ALTER TABLE "tab" RENAME COLUMN "foo" TO "bar";
388−renameColumn
389− :: ( KnownSymbol column0
390− , KnownSymbol column1
391− , Has sch schemas schema
392− , Has tab schema ('Table table0)
393− , table0 ~ (constraints :=> columns)
394− , table1 ~ (constraints :=> Rename column0 column1 columns) )
395− => Alias column0 -- ^ column to rename
396− -> Alias column1 -- ^ what to rename the column
397− -> AlterTable sch tab schemas table1
398−renameColumn column0 column1 = UnsafeAlterTable $
399− "RENAME COLUMN" <+> renderSQL column0 <+> "TO" <+> renderSQL column1
400−
401−-- | An `alterColumn` alters a single column.
402−alterColumn
403− :: ( KnownSymbol column
404− , Has sch schemas schema
405− , Has tab schema ('Table table0)
406− , table0 ~ (constraints :=> columns)
407− , Has column columns ty0
408− , table1 ~ (constraints :=> Alter column ty1 columns))
409− => Alias column -- ^ column to alter
410− -> AlterColumn schemas ty0 ty1 -- ^ alteration to perform
411− -> AlterTable sch tab schemas table1
412−alterColumn column alteration = UnsafeAlterTable $
413− "ALTER COLUMN" <+> renderSQL column <+> renderAlterColumn alteration
414−
415−-- | An `AlterColumn` describes the alteration to perform on a single column.
416−newtype AlterColumn (schemas :: SchemasType) (ty0 :: ColumnType) (ty1 :: ColumnType) =
417− UnsafeAlterColumn {renderAlterColumn :: ByteString}
418− deriving (GHC.Generic,Show,Eq,Ord,NFData)
419−
420−-- | A `setDefault` sets a new default for a column. Note that this doesn't
421−-- affect any existing rows in the table, it just changes the default for
422−-- future insert and update commands.
423−--
424−-- >>> :{
425−-- let
426−-- definition :: Definition
427−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
428−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]]
429−-- definition = alterTable #tab (alterColumn #col (setDefault 5))
430−-- in printSQL definition
431−-- :}
432−-- ALTER TABLE "tab" ALTER COLUMN "col" SET DEFAULT 5;
433−setDefault
434− :: Expression '[] '[] 'Ungrouped schemas '[] '[] ty -- ^ default value to set
435− -> AlterColumn schemas (constraint :=> ty) ('Def :=> ty)
436−setDefault expression = UnsafeAlterColumn $
437− "SET DEFAULT" <+> renderExpression expression
438−
439−-- | A `dropDefault` removes any default value for a column.
440−--
441−-- >>> :{
442−-- let
443−-- definition :: Definition
444−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]]
445−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
446−-- definition = alterTable #tab (alterColumn #col dropDefault)
447−-- in printSQL definition
448−-- :}
449−-- ALTER TABLE "tab" ALTER COLUMN "col" DROP DEFAULT;
450−dropDefault :: AlterColumn schemas ('Def :=> ty) ('NoDef :=> ty)
451−dropDefault = UnsafeAlterColumn $ "DROP DEFAULT"
452−
453−-- | A `setNotNull` adds a @NOT NULL@ constraint to a column.
454−-- The constraint will be checked immediately, so the table data must satisfy
455−-- the constraint before it can be added.
456−--
457−-- >>> :{
458−-- let
459−-- definition :: Definition
460−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
461−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
462−-- definition = alterTable #tab (alterColumn #col setNotNull)
463−-- in printSQL definition
464−-- :}
465−-- ALTER TABLE "tab" ALTER COLUMN "col" SET NOT NULL;
466−setNotNull
467− :: AlterColumn schemas (constraint :=> 'Null ty) (constraint :=> 'NotNull ty)
468−setNotNull = UnsafeAlterColumn $ "SET NOT NULL"
469−
470−-- | A `dropNotNull` drops a @NOT NULL@ constraint from a column.
471−--
472−-- >>> :{
473−-- let
474−-- definition :: Definition
475−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
476−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
477−-- definition = alterTable #tab (alterColumn #col dropNotNull)
478−-- in printSQL definition
479−-- :}
480−-- ALTER TABLE "tab" ALTER COLUMN "col" DROP NOT NULL;
481−dropNotNull
482− :: AlterColumn schemas (constraint :=> 'NotNull ty) (constraint :=> 'Null ty)
483−dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL"
484−
485−-- | An `alterType` converts a column to a different data type.
486−-- This will succeed only if each existing entry in the column can be
487−-- converted to the new type by an implicit cast.
488−--
489−-- >>> :{
490−-- let
491−-- definition :: Definition
492−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
493−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGnumeric])]]
494−-- definition =
495−-- alterTable #tab (alterColumn #col (alterType (numeric & notNullable)))
496−-- in printSQL definition
497−-- :}
498−-- ALTER TABLE "tab" ALTER COLUMN "col" TYPE numeric NOT NULL;
499−alterType :: ColumnTypeExpression schemas ty -> AlterColumn schemas ty0 ty
500−alterType ty = UnsafeAlterColumn $ "TYPE" <+> renderColumnTypeExpression ty
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Table/Constraint.hsdeleted−339
@@ -1,339 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Definition.Table.Constraint
3−Description: Table constraint expressions
4−Copyright: (c) Eitan Chatav, 2017
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Table constraint expressions.
9−-}
10−
11−{-# LANGUAGE
12− AllowAmbiguousTypes
13− , ConstraintKinds
14− , DeriveAnyClass
15− , DeriveGeneric
16− , DerivingStrategies
17− , FlexibleContexts
18− , FlexibleInstances
19− , GADTs
20− , LambdaCase
21− , MultiParamTypeClasses
22− , OverloadedLabels
23− , OverloadedStrings
24− , RankNTypes
25− , ScopedTypeVariables
26− , TypeApplications
27− , TypeInType
28− , TypeOperators
29− , UndecidableSuperClasses
30−#-}
31−
32−module Squeal.PostgreSQL.Definition.Table.Constraint
33− ( TableConstraintExpression (..)
34− , check
35− , unique
36− , primaryKey
37− , foreignKey
38− , ForeignKeyed
39− , OnDeleteClause (..)
40− , OnUpdateClause (..)
41− ) where
42−
43−import Control.DeepSeq
44−import Data.ByteString
45−import GHC.TypeLits
46−
47−import qualified Generics.SOP as SOP
48−import qualified GHC.Generics as GHC
49−
50−import Squeal.PostgreSQL.Alias
51−import Squeal.PostgreSQL.Expression.Logic
52−import Squeal.PostgreSQL.List
53−import Squeal.PostgreSQL.Render
54−import Squeal.PostgreSQL.Schema
55−
56−-- $setup
57−-- >>> import Squeal.PostgreSQL
58−
59−-- | Data types are a way to limit the kind of data that can be stored in a
60−-- table. For many applications, however, the constraint they provide is
61−-- too coarse. For example, a column containing a product price should
62−-- probably only accept positive values. But there is no standard data type
63−-- that accepts only positive numbers. Another issue is that you might want
64−-- to constrain column data with respect to other columns or rows.
65−-- For example, in a table containing product information,
66−-- there should be only one row for each product number.
67−-- `TableConstraint`s give you as much control over the data in your tables
68−-- as you wish. If a user attempts to store data in a column that would
69−-- violate a constraint, an error is raised. This applies
70−-- even if the value came from the default value definition.
71−newtype TableConstraintExpression
72− (sch :: Symbol)
73− (tab :: Symbol)
74− (schemas :: SchemasType)
75− (constraint :: TableConstraint)
76− = UnsafeTableConstraintExpression
77− { renderTableConstraintExpression :: ByteString }
78− deriving (GHC.Generic,Show,Eq,Ord,NFData)
79−instance RenderSQL
80− (TableConstraintExpression sch tab schemas constraint) where
81− renderSQL = renderTableConstraintExpression
82−
83−{-| A `check` constraint is the most generic `TableConstraint` type.
84−It allows you to specify that the value in a certain column must satisfy
85−a Boolean (truth-value) expression.
86−
87−>>> :{
88−type Schema = '[
89− "tab" ::: 'Table ('[ "inequality" ::: 'Check '["a","b"]] :=> '[
90− "a" ::: 'NoDef :=> 'NotNull 'PGint4,
91− "b" ::: 'NoDef :=> 'NotNull 'PGint4
92− ])]
93−:}
94−
95−>>> :{
96−let
97− definition :: Definition (Public '[]) (Public Schema)
98− definition = createTable #tab
99− ( (int & notNullable) `as` #a :*
100− (int & notNullable) `as` #b )
101− ( check (#a :* #b) (#a .> #b) `as` #inequality )
102−:}
103−
104−>>> printSQL definition
105−CREATE TABLE "tab" ("a" int NOT NULL, "b" int NOT NULL, CONSTRAINT "inequality" CHECK (("a" > "b")));
106−-}
107−check
108− :: ( Has sch schemas schema
109− , Has tab schema ('Table table)
110− , HasAll aliases (TableToRow table) subcolumns )
111− => NP Alias aliases
112− -- ^ specify the subcolumns which are getting checked
113− -> (forall t. Condition '[] '[] 'Ungrouped schemas '[] '[t ::: subcolumns])
114− -- ^ a closed `Condition` on those subcolumns
115− -> TableConstraintExpression sch tab schemas ('Check aliases)
116−check _cols condition = UnsafeTableConstraintExpression $
117− "CHECK" <+> parenthesized (renderSQL condition)
118−
119−{-| A `unique` constraint ensure that the data contained in a column,
120−or a group of columns, is unique among all the rows in the table.
121−
122−>>> :{
123−type Schema = '[
124− "tab" ::: 'Table( '[ "uq_a_b" ::: 'Unique '["a","b"]] :=> '[
125− "a" ::: 'NoDef :=> 'Null 'PGint4,
126− "b" ::: 'NoDef :=> 'Null 'PGint4
127− ])]
128−:}
129−
130−>>> :{
131−let
132− definition :: Definition (Public '[]) (Public Schema)
133− definition = createTable #tab
134− ( (int & nullable) `as` #a :*
135− (int & nullable) `as` #b )
136− ( unique (#a :* #b) `as` #uq_a_b )
137−:}
138−
139−>>> printSQL definition
140−CREATE TABLE "tab" ("a" int NULL, "b" int NULL, CONSTRAINT "uq_a_b" UNIQUE ("a", "b"));
141−-}
142−unique
143− :: ( Has sch schemas schema
144− , Has tab schema('Table table)
145− , HasAll aliases (TableToRow table) subcolumns )
146− => NP Alias aliases
147− -- ^ specify subcolumns which together are unique for each row
148− -> TableConstraintExpression sch tab schemas ('Unique aliases)
149−unique columns = UnsafeTableConstraintExpression $
150− "UNIQUE" <+> parenthesized (renderSQL columns)
151−
152−{-| A `primaryKey` constraint indicates that a column, or group of columns,
153−can be used as a unique identifier for rows in the table.
154−This requires that the values be both unique and not null.
155−
156−>>> :{
157−type Schema = '[
158− "tab" ::: 'Table ('[ "pk_id" ::: 'PrimaryKey '["id"]] :=> '[
159− "id" ::: 'Def :=> 'NotNull 'PGint4,
160− "name" ::: 'NoDef :=> 'NotNull 'PGtext
161− ])]
162−:}
163−
164−>>> :{
165−let
166− definition :: Definition (Public '[]) (Public Schema)
167− definition = createTable #tab
168− ( serial `as` #id :*
169− (text & notNullable) `as` #name )
170− ( primaryKey #id `as` #pk_id )
171−:}
172−
173−>>> printSQL definition
174−CREATE TABLE "tab" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_id" PRIMARY KEY ("id"));
175−-}
176−primaryKey
177− :: ( Has sch schemas schema
178− , Has tab schema ('Table table)
179− , HasAll aliases (TableToColumns table) subcolumns
180− , AllNotNull subcolumns )
181− => NP Alias aliases
182− -- ^ specify the subcolumns which together form a primary key.
183− -> TableConstraintExpression sch tab schemas ('PrimaryKey aliases)
184−primaryKey columns = UnsafeTableConstraintExpression $
185− "PRIMARY KEY" <+> parenthesized (renderSQL columns)
186−
187−{-| A `foreignKey` specifies that the values in a column
188−(or a group of columns) must match the values appearing in some row of
189−another table. We say this maintains the referential integrity
190−between two related tables.
191−
192−>>> :{
193−type Schema =
194− '[ "users" ::: 'Table (
195− '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
196− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
197− , "name" ::: 'NoDef :=> 'NotNull 'PGtext
198− ])
199− , "emails" ::: 'Table (
200− '[ "pk_emails" ::: 'PrimaryKey '["id"]
201− , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
202− ] :=>
203− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
204− , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
205− , "email" ::: 'NoDef :=> 'Null 'PGtext
206− ])
207− ]
208−:}
209−
210−>>> :{
211−let
212− setup :: Definition (Public '[]) (Public Schema)
213− setup =
214− createTable #users
215− ( serial `as` #id :*
216− (text & notNullable) `as` #name )
217− ( primaryKey #id `as` #pk_users ) >>>
218− createTable #emails
219− ( serial `as` #id :*
220− (int & notNullable) `as` #user_id :*
221− (text & nullable) `as` #email )
222− ( primaryKey #id `as` #pk_emails :*
223− foreignKey #user_id #users #id
224− OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
225−in printSQL setup
226−:}
227−CREATE TABLE "users" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_users" PRIMARY KEY ("id"));
228−CREATE TABLE "emails" ("id" serial, "user_id" int NOT NULL, "email" text NULL, CONSTRAINT "pk_emails" PRIMARY KEY ("id"), CONSTRAINT "fk_user_id" FOREIGN KEY ("user_id") REFERENCES "users" ("id") ON DELETE CASCADE ON UPDATE CASCADE);
229−
230−A `foreignKey` can even be a table self-reference.
231−
232−>>> :{
233−type Schema =
234− '[ "employees" ::: 'Table (
235− '[ "employees_pk" ::: 'PrimaryKey '["id"]
236− , "employees_employer_fk" ::: 'ForeignKey '["employer_id"] "employees" '["id"]
237− ] :=>
238− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
239− , "name" ::: 'NoDef :=> 'NotNull 'PGtext
240− , "employer_id" ::: 'NoDef :=> 'Null 'PGint4
241− ])
242− ]
243−:}
244−
245−>>> :{
246−let
247− setup :: Definition (Public '[]) (Public Schema)
248− setup =
249− createTable #employees
250− ( serial `as` #id :*
251− (text & notNullable) `as` #name :*
252− (integer & nullable) `as` #employer_id )
253− ( primaryKey #id `as` #employees_pk :*
254− foreignKey #employer_id #employees #id
255− OnDeleteCascade OnUpdateCascade `as` #employees_employer_fk )
256−in printSQL setup
257−:}
258−CREATE TABLE "employees" ("id" serial, "name" text NOT NULL, "employer_id" integer NULL, CONSTRAINT "employees_pk" PRIMARY KEY ("id"), CONSTRAINT "employees_employer_fk" FOREIGN KEY ("employer_id") REFERENCES "employees" ("id") ON DELETE CASCADE ON UPDATE CASCADE);
259−-}
260−foreignKey
261− :: (ForeignKeyed schemas sch schema child parent
262− table reftable
263− columns refcolumns
264− constraints cols
265− reftys tys )
266− => NP Alias columns
267− -- ^ column or columns in the table
268− -> Alias parent
269− -- ^ reference table
270− -> NP Alias refcolumns
271− -- ^ reference column or columns in the reference table
272− -> OnDeleteClause
273− -- ^ what to do when reference is deleted
274− -> OnUpdateClause
275− -- ^ what to do when reference is updated
276− -> TableConstraintExpression sch child schemas
277− ('ForeignKey columns parent refcolumns)
278−foreignKey keys parent refs ondel onupd = UnsafeTableConstraintExpression $
279− "FOREIGN KEY" <+> parenthesized (renderSQL keys)
280− <+> "REFERENCES" <+> renderSQL parent
281− <+> parenthesized (renderSQL refs)
282− <+> renderSQL ondel
283− <+> renderSQL onupd
284−
285−-- | A constraint synonym between types involved in a foreign key constraint.
286−type ForeignKeyed schemas
287− sch
288− schema
289− child parent
290− table reftable
291− columns refcolumns
292− constraints cols
293− reftys tys =
294− ( Has sch schemas schema
295− , Has child schema ('Table table)
296− , Has parent schema ('Table reftable)
297− , HasAll columns (TableToColumns table) tys
298− , reftable ~ (constraints :=> cols)
299− , HasAll refcolumns cols reftys
300− , SOP.AllZip SamePGType tys reftys
301− , Uniquely refcolumns constraints )
302−
303−-- | `OnDeleteClause` indicates what to do with rows that reference a deleted row.
304−data OnDeleteClause
305− = OnDeleteNoAction
306− -- ^ if any referencing rows still exist when the constraint is checked,
307− -- an error is raised
308− | OnDeleteRestrict -- ^ prevents deletion of a referenced row
309− | OnDeleteCascade
310− -- ^ specifies that when a referenced row is deleted,
311− -- row(s) referencing it should be automatically deleted as well
312− deriving (GHC.Generic,Show,Eq,Ord)
313−instance NFData OnDeleteClause
314−-- | Render `OnDeleteClause`.
315−instance RenderSQL OnDeleteClause where
316− renderSQL = \case
317− OnDeleteNoAction -> "ON DELETE NO ACTION"
318− OnDeleteRestrict -> "ON DELETE RESTRICT"
319− OnDeleteCascade -> "ON DELETE CASCADE"
320−
321−-- | Analagous to `OnDeleteClause` there is also `OnUpdateClause` which is invoked
322−-- when a referenced column is changed (updated).
323−data OnUpdateClause
324− = OnUpdateNoAction
325− -- ^ if any referencing rows has not changed when the constraint is checked,
326− -- an error is raised
327− | OnUpdateRestrict -- ^ prevents update of a referenced row
328− | OnUpdateCascade
329− -- ^ the updated values of the referenced column(s) should be copied
330− -- into the referencing row(s)
331− deriving (GHC.Generic,Show,Eq,Ord)
332−instance NFData OnUpdateClause
333−
334−-- | Render `OnUpdateClause`.
335−instance RenderSQL OnUpdateClause where
336− renderSQL = \case
337− OnUpdateNoAction -> "ON UPDATE NO ACTION"
338− OnUpdateRestrict -> "ON UPDATE RESTRICT"
339− OnUpdateCascade -> "ON UPDATE CASCADE"
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Type.hsdeleted−229
@@ -1,229 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Definition.Type
3−Description: Create and drop type definitions
4−Copyright: (c) Eitan Chatav, 2017
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Create and drop type definitions.
9−-}
10−
11−{-# LANGUAGE
12− AllowAmbiguousTypes
13− , ConstraintKinds
14− , DeriveAnyClass
15− , DeriveGeneric
16− , DerivingStrategies
17− , FlexibleContexts
18− , FlexibleInstances
19− , GADTs
20− , LambdaCase
21− , MultiParamTypeClasses
22− , OverloadedLabels
23− , OverloadedStrings
24− , RankNTypes
25− , ScopedTypeVariables
26− , TypeApplications
27− , TypeInType
28− , TypeOperators
29− , UndecidableSuperClasses
30−#-}
31−
32−module Squeal.PostgreSQL.Definition.Type
33− ( createTypeEnum
34− , createTypeEnumFrom
35− , createTypeComposite
36− , createTypeCompositeFrom
37− , createTypeRange
38− , createDomain
39− , dropType
40− , dropTypeIfExists
41− ) where
42−
43−import Data.ByteString
44−import Data.Monoid
45−import GHC.TypeLits
46−import Prelude hiding ((.), id)
47−
48−import qualified Generics.SOP as SOP
49−
50−import Squeal.PostgreSQL.Alias
51−import Squeal.PostgreSQL.Expression.Logic
52−import Squeal.PostgreSQL.Expression.Type
53−import Squeal.PostgreSQL.Definition
54−import Squeal.PostgreSQL.List
55−import Squeal.PostgreSQL.PG
56−import Squeal.PostgreSQL.Render
57−import Squeal.PostgreSQL.Schema
58−
59−-- $setup
60−-- >>> import Squeal.PostgreSQL
61−-- >>> import qualified GHC.Generics as GHC
62−-- >>> import qualified Generics.SOP as SOP
63−
64−-- | Enumerated types are created using the `createTypeEnum` command, for example
65−--
66−-- >>> printSQL $ (createTypeEnum #mood (label @"sad" :* label @"ok" :* label @"happy") :: Definition (Public '[]) '["public" ::: '["mood" ::: 'Typedef ('PGenum '["sad","ok","happy"])]])
67−-- CREATE TYPE "mood" AS ENUM ('sad', 'ok', 'happy');
68−createTypeEnum
69− :: (KnownSymbol enum, Has sch schemas schema, SOP.All KnownSymbol labels)
70− => QualifiedAlias sch enum
71− -- ^ name of the user defined enumerated type
72− -> NP PGlabel labels
73− -- ^ labels of the enumerated type
74− -> Definition schemas (Alter sch (Create enum ('Typedef ('PGenum labels)) schema) schemas)
75−createTypeEnum enum labels = UnsafeDefinition $
76− "CREATE" <+> "TYPE" <+> renderSQL enum <+> "AS" <+> "ENUM" <+>
77− parenthesized (renderSQL labels) <> ";"
78−
79−-- | Enumerated types can also be generated from a Haskell type, for example
80−--
81−-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic
82−-- >>> instance SOP.Generic Schwarma
83−-- >>> instance SOP.HasDatatypeInfo Schwarma
84−-- >>> :{
85−-- let
86−-- createSchwarma :: Definition (Public '[]) '["public" ::: '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))]]
87−-- createSchwarma = createTypeEnumFrom @Schwarma #schwarma
88−-- in
89−-- printSQL createSchwarma
90−-- :}
91−-- CREATE TYPE "schwarma" AS ENUM ('Beef', 'Lamb', 'Chicken');
92−createTypeEnumFrom
93− :: forall hask sch enum schemas schema.
94− ( SOP.Generic hask
95− , SOP.All KnownSymbol (LabelsPG hask)
96− , KnownSymbol enum
97− , Has sch schemas schema )
98− => QualifiedAlias sch enum
99− -- ^ name of the user defined enumerated type
100− -> Definition schemas (Alter sch (Create enum ('Typedef (PG (Enumerated hask))) schema) schemas)
101−createTypeEnumFrom enum = createTypeEnum enum
102− (SOP.hpure label :: NP PGlabel (LabelsPG hask))
103−
104−{- | `createTypeComposite` creates a composite type. The composite type is
105−specified by a list of attribute names and data types.
106−
107−>>> :{
108−type PGcomplex = 'PGcomposite
109− '[ "real" ::: 'NotNull 'PGfloat8
110− , "imaginary" ::: 'NotNull 'PGfloat8 ]
111−:}
112−
113−>>> :{
114−let
115− setup :: Definition (Public '[]) '["public" ::: '["complex" ::: 'Typedef PGcomplex]]
116− setup = createTypeComposite #complex
117− (float8 `as` #real :* float8 `as` #imaginary)
118−in printSQL setup
119−:}
120−CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);
121−-}
122−createTypeComposite
123− :: (KnownSymbol ty, Has sch schemas schema, SOP.SListI fields)
124− => QualifiedAlias sch ty
125− -- ^ name of the user defined composite type
126− -> NP (Aliased (TypeExpression schemas)) fields
127− -- ^ list of attribute names and data types
128− -> Definition schemas (Alter sch (Create ty ('Typedef ('PGcomposite fields)) schema) schemas)
129−createTypeComposite ty fields = UnsafeDefinition $
130− "CREATE" <+> "TYPE" <+> renderSQL ty <+> "AS" <+> parenthesized
131− (renderCommaSeparated renderField fields) <> ";"
132− where
133− renderField :: Aliased (TypeExpression schemas) x -> ByteString
134− renderField (typ `As` alias) =
135− renderSQL alias <+> renderSQL typ
136−
137−-- | Composite types can also be generated from a Haskell type, for example
138−--
139−-- >>> data Complex = Complex {real :: Double, imaginary :: Double} deriving GHC.Generic
140−-- >>> instance SOP.Generic Complex
141−-- >>> instance SOP.HasDatatypeInfo Complex
142−-- >>> type Schema = '["complex" ::: 'Typedef (PG (Composite Complex))]
143−-- >>> :{
144−-- let
145−-- createComplex :: Definition (Public '[]) (Public Schema)
146−-- createComplex = createTypeCompositeFrom @Complex #complex
147−-- in
148−-- printSQL createComplex
149−-- :}
150−-- CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);
151−createTypeCompositeFrom
152− :: forall hask sch ty schemas schema.
153− ( SOP.All (FieldTyped schemas) (RowPG hask)
154− , KnownSymbol ty
155− , Has sch schemas schema )
156− => QualifiedAlias sch ty
157− -- ^ name of the user defined composite type
158− -> Definition schemas (Alter sch (Create ty ( 'Typedef (PG (Composite hask))) schema) schemas)
159−createTypeCompositeFrom ty = createTypeComposite ty
160− (SOP.hcpure (SOP.Proxy :: SOP.Proxy (FieldTyped schemas)) fieldtype
161− :: NP (Aliased (TypeExpression schemas)) (RowPG hask))
162−
163−{-|
164−`createDomain` creates a new domain. A domain is essentially a data type
165−with constraints (restrictions on the allowed set of values).
166−
167−Domains are useful for abstracting common constraints on fields
168−into a single location for maintenance. For example, several tables might
169−contain email address columns, all requiring the same `check` constraint
170−to verify the address syntax. Define a domain rather than setting up
171−each table's constraint individually.
172−
173−>>> :{
174−let
175− createPositive :: Definition (Public '[]) (Public '["positive" ::: 'Typedef 'PGfloat4])
176− createPositive = createDomain #positive real (#value .> 0 .&& (#value & isNotNull))
177−in printSQL createPositive
178−:}
179−CREATE DOMAIN "positive" AS real CHECK ((("value" > 0) AND "value" IS NOT NULL));
180−-}
181−createDomain
182− :: (Has sch schemas schema, KnownSymbol dom)
183− => QualifiedAlias sch dom
184− -> (forall null. TypeExpression schemas (null ty))
185− -> (forall tab. Condition '[] '[] 'Ungrouped schemas '[] '[tab ::: '["value" ::: 'Null ty]])
186− -> Definition schemas (Alter sch (Create dom ('Typedef ty) schema) schemas)
187−createDomain dom ty condition =
188− UnsafeDefinition $ "CREATE DOMAIN" <+> renderSQL dom
189− <+> "AS" <+> renderTypeExpression ty
190− <+> "CHECK" <+> parenthesized (renderSQL condition) <> ";"
191−
192−{- |
193−>>> :{
194−let
195− createSmallIntRange :: Definition (Public '[]) (Public '["int2range" ::: 'Typedef ('PGrange 'PGint2)])
196− createSmallIntRange = createTypeRange #int2range int2
197−in printSQL createSmallIntRange
198−:}
199−CREATE TYPE "int2range" AS RANGE (subtype = int2);
200−-}
201−createTypeRange
202− :: (Has sch schemas schema, KnownSymbol range)
203− => QualifiedAlias sch range
204− -> (forall null. TypeExpression schemas (null ty))
205− -> Definition schemas (Alter sch (Create range ('Typedef ('PGrange ty)) schema) schemas)
206−createTypeRange range ty = UnsafeDefinition $
207− "CREATE" <+> "TYPE" <+> renderSQL range <+> "AS" <+> "RANGE" <+>
208− parenthesized ("subtype" <+> "=" <+> renderTypeExpression ty) <> ";"
209−
210−-- | Drop a type.
211−--
212−-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic
213−-- >>> instance SOP.Generic Schwarma
214−-- >>> instance SOP.HasDatatypeInfo Schwarma
215−-- >>> printSQL (dropType #schwarma :: Definition '["public" ::: '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))]] (Public '[]))
216−-- DROP TYPE "schwarma";
217−dropType
218− :: (Has sch schemas schema, KnownSymbol td)
219− => QualifiedAlias sch td
220− -- ^ name of the user defined type
221− -> Definition schemas (Alter sch (DropSchemum td 'Typedef schema) schemas)
222−dropType tydef = UnsafeDefinition $ "DROP" <+> "TYPE" <+> renderSQL tydef <> ";"
223−
224−dropTypeIfExists
225− :: (Has sch schemas schema, KnownSymbol td)
226− => QualifiedAlias sch td
227− -- ^ name of the user defined type
228− -> Definition schemas (Alter sch (DropSchemumIfExists td 'Typedef schema) schemas)
229−dropTypeIfExists tydef = UnsafeDefinition $ "DROP" <+> "TYPE" <+> renderSQL tydef <> ";"
squeal-postgresql/src/Squeal/PostgreSQL/Definition/View.hsdeleted−104
@@ -1,104 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Definition.View
3−Description: Create and drop view definitions
4−Copyright: (c) Eitan Chatav, 2017
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Create and drop view definitions.
9−-}
10−
11−{-# LANGUAGE
12− AllowAmbiguousTypes
13− , ConstraintKinds
14− , DeriveAnyClass
15− , DeriveGeneric
16− , DerivingStrategies
17− , FlexibleContexts
18− , FlexibleInstances
19− , GADTs
20− , LambdaCase
21− , MultiParamTypeClasses
22− , OverloadedLabels
23− , OverloadedStrings
24− , RankNTypes
25− , ScopedTypeVariables
26− , TypeApplications
27− , TypeInType
28− , TypeOperators
29− , UndecidableSuperClasses
30−#-}
31−
32−module Squeal.PostgreSQL.Definition.View
33− ( createView
34− , createOrReplaceView
35− , dropView
36− , dropViewIfExists
37− ) where
38−
39−import GHC.TypeLits
40−
41−import Squeal.PostgreSQL.Alias
42−import Squeal.PostgreSQL.Definition
43−import Squeal.PostgreSQL.Query
44−import Squeal.PostgreSQL.Render
45−import Squeal.PostgreSQL.Schema
46−
47−-- $setup
48−-- >>> import Squeal.PostgreSQL
49−
50−{- | Create a view.
51−>>> type ABC = '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4]
52−>>> type BC = '["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4]
53−>>> :{
54−let
55− definition :: Definition
56− '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC)]]
57− '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC), "bc" ::: 'View BC]]
58− definition =
59− createView #bc (select_ (#b :* #c) (from (table #abc)))
60−in printSQL definition
61−:}
62−CREATE VIEW "bc" AS SELECT "b" AS "b", "c" AS "c" FROM "abc" AS "abc";
63−-}
64−createView
65− :: (Has sch schemas schema, KnownSymbol vw)
66− => QualifiedAlias sch vw -- ^ the name of the view to add
67− -> Query '[] '[] schemas '[] view -- ^ query
68− -> Definition schemas (Alter sch (Create vw ('View view) schema) schemas)
69−createView alias query = UnsafeDefinition $
70− "CREATE" <+> "VIEW" <+> renderSQL alias <+> "AS"
71− <+> renderQuery query <> ";"
72−
73−createOrReplaceView
74− :: (Has sch schemas schema, KnownSymbol vw)
75− => QualifiedAlias sch vw -- ^ the name of the view to add
76− -> Query '[] '[] schemas '[] view -- ^ query
77− -> Definition schemas (Alter sch (CreateOrReplace vw ('View view) schema) schemas)
78−createOrReplaceView alias query = UnsafeDefinition $
79− "CREATE OR REPLACE VIEW" <+> renderSQL alias <+> "AS"
80− <+> renderQuery query <> ";"
81−
82−-- | Drop a view.
83−--
84−-- >>> :{
85−-- let
86−-- definition :: Definition
87−-- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])
88−-- , "bc" ::: 'View ('["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4])]]
89−-- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])]]
90−-- definition = dropView #bc
91−-- in printSQL definition
92−-- :}
93−-- DROP VIEW "bc";
94−dropView
95− :: (Has sch schemas schema, KnownSymbol vw)
96− => QualifiedAlias sch vw -- ^ view to remove
97− -> Definition schemas (Alter sch (DropSchemum vw 'View schema) schemas)
98−dropView vw = UnsafeDefinition $ "DROP VIEW" <+> renderSQL vw <> ";"
99−
100−dropViewIfExists
101− :: (Has sch schemas schema, KnownSymbol vw)
102− => QualifiedAlias sch vw -- ^ view to remove
103− -> Definition schemas (Alter sch (DropIfExists vw schema) schemas)
104−dropViewIfExists vw = UnsafeDefinition $ "DROP VIEW IF EXISTS" <+> renderSQL vw <> ";"
squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs+17−90
@@ -34,26 +34,17 @@ module Squeal.PostgreSQL.Expression
34 ( -- * Expression
34 ( -- * Expression
35 Expression (..)
35 Expression (..)
36 , Expr
36 , Expr
37− , type (-->)
37+ , (:-->)
38− , FunctionDB
39 , unsafeFunction
38 , unsafeFunction
40− , function
39+ , unsafeUnaryOpL
41− , unsafeLeftOp
40+ , unsafeUnaryOpR
42− , leftOp
43− , unsafeRightOp
44− , rightOp
45 , Operator
41 , Operator
46− , OperatorDB
47 , unsafeBinaryOp
42 , unsafeBinaryOp
48− , binaryOp
49 , FunctionVar
43 , FunctionVar
50 , unsafeFunctionVar
44 , unsafeFunctionVar
51− , type (--->)
45+ , FunctionN
52− , FunctionNDB
53 , unsafeFunctionN
46 , unsafeFunctionN
54− , functionN
55 , PGSubset (..)
47 , PGSubset (..)
56− , PGIntersect (..)
57 -- * Re-export
48 -- * Re-export
58 , (&)
49 , (&)
59 , K (..)
50 , K (..)
@@ -145,54 +136,31 @@ type Operator x1 x2 y
145 -> Expression outer commons grp schemas params from y
136 -> Expression outer commons grp schemas params from y
146 -- ^ output
137 -- ^ output
147
138
148−type OperatorDB schemas x1 x2 y
149− = forall outer commons grp params from
150− . Expression outer commons grp schemas params from x1
151− -- ^ left input
152− -> Expression outer commons grp schemas params from x2
153− -- ^ right input
154− -> Expression outer commons grp schemas params from y
155− -- ^ output
156−
157-- | A @RankNType@ for functions with a single argument.
139-- | A @RankNType@ for functions with a single argument.
158-- These could be either function calls or unary operators.
140-- These could be either function calls or unary operators.
159-- This is a subtype of the usual Haskell function type `Prelude.->`,
141-- This is a subtype of the usual Haskell function type `Prelude.->`,
160-- indeed a subcategory as it is closed under the usual
142-- indeed a subcategory as it is closed under the usual
161-- `Prelude..` and `Prelude.id`.
143-- `Prelude..` and `Prelude.id`.
162−type (-->) x y
144+type (:-->) x y
163 = forall outer commons grp schemas params from
145 = forall outer commons grp schemas params from
164 . Expression outer commons grp schemas params from x
146 . Expression outer commons grp schemas params from x
165 -- ^ input
147 -- ^ input
166 -> Expression outer commons grp schemas params from y
148 -> Expression outer commons grp schemas params from y
167 -- ^ output
149 -- ^ output
168
150
169−type FunctionDB schemas x y
170− = forall outer commons grp params from
171− . Expression outer commons grp schemas params from x
172− -- ^ input
173− -> Expression outer commons grp schemas params from y
174− -- ^ output
175−
176{- | A @RankNType@ for functions with a fixed-length list of heterogeneous arguments.
151{- | A @RankNType@ for functions with a fixed-length list of heterogeneous arguments.
177Use the `*:` operator to end your argument lists, like so.
152Use the `*:` operator to end your argument lists, like so.
178
153
179>>> printSQL (unsafeFunctionN "fun" (true :* false :* localTime *: true))
154>>> printSQL (unsafeFunctionN "fun" (true :* false :* localTime *: true))
180fun(TRUE, FALSE, LOCALTIME, TRUE)
155fun(TRUE, FALSE, LOCALTIME, TRUE)
181-}
156-}
182−type (--->) xs y
157+type FunctionN xs y
183 = forall outer commons grp schemas params from
158 = forall outer commons grp schemas params from
184 . NP (Expression outer commons grp schemas params from) xs
159 . NP (Expression outer commons grp schemas params from) xs
185 -- ^ inputs
160 -- ^ inputs
186 -> Expression outer commons grp schemas params from y
161 -> Expression outer commons grp schemas params from y
187 -- ^ output
162 -- ^ output
188
163
189−type FunctionNDB schemas xs y
190− = forall outer commons grp params from
191− . NP (Expression outer commons grp schemas params from) xs
192− -- ^ inputs
193− -> Expression outer commons grp schemas params from y
194− -- ^ output
195−
196{- | A @RankNType@ for functions with a variable-length list of
164{- | A @RankNType@ for functions with a variable-length list of
197homogeneous arguments and at least 1 more argument.
165homogeneous arguments and at least 1 more argument.
198-}
166-}
@@ -318,63 +286,28 @@ unsafeBinaryOp :: ByteString -> Operator ty0 ty1 ty2
318unsafeBinaryOp op x y = UnsafeExpression $ parenthesized $
286unsafeBinaryOp op x y = UnsafeExpression $ parenthesized $
319 renderSQL x <+> op <+> renderSQL y
287 renderSQL x <+> op <+> renderSQL y
320
288
321−binaryOp
322− :: forall op sch schemas schema x y z.
323− ( Has sch schemas schema
324− , Has op schema ('Operator ('BinaryOp x y z)) )
325− => OperatorDB schemas x y z
326−binaryOp = unsafeBinaryOp $ renderSymbol @op
327−
328−-- | >>> printSQL $ unsafeLeftOp "NOT" true
289+-- | >>> printSQL $ unsafeUnaryOpL "NOT" true
329-- (NOT TRUE)
290-- (NOT TRUE)
330−unsafeLeftOp :: ByteString -> x --> y
291+unsafeUnaryOpL :: ByteString -> x :--> y
331−unsafeLeftOp op x = UnsafeExpression $ parenthesized $ op <+> renderSQL x
292+unsafeUnaryOpL op x = UnsafeExpression $ parenthesized $ op <+> renderSQL x
332
293
333−leftOp
334− :: forall op sch schemas schema x y.
335− ( Has sch schemas schema
336− , Has op schema ('Operator ('LeftOp x y)) )
337− => FunctionDB schemas x y
338−leftOp = unsafeLeftOp $ renderSymbol @op
339−
340−-- | >>> printSQL $ true & unsafeRightOp "IS NOT TRUE"
294+-- | >>> printSQL $ true & unsafeUnaryOpR "IS NOT TRUE"
341-- (TRUE IS NOT TRUE)
295-- (TRUE IS NOT TRUE)
342−unsafeRightOp :: ByteString -> x --> y
296+unsafeUnaryOpR :: ByteString -> x :--> y
343−unsafeRightOp op x = UnsafeExpression $ parenthesized $ renderSQL x <+> op
297+unsafeUnaryOpR op x = UnsafeExpression $ parenthesized $ renderSQL x <+> op
344−
345−rightOp
346− :: forall op sch schemas schema x y.
347− ( Has sch schemas schema
348− , Has op schema ('Operator ('RightOp x y)) )
349− => FunctionDB schemas x y
350−rightOp = unsafeRightOp $ renderSymbol @op
351
298
352-- | >>> printSQL $ unsafeFunction "f" true
299-- | >>> printSQL $ unsafeFunction "f" true
353-- f(TRUE)
300-- f(TRUE)
354−unsafeFunction :: ByteString -> x --> y
301+unsafeFunction :: ByteString -> x :--> y
355unsafeFunction fun x = UnsafeExpression $
302unsafeFunction fun x = UnsafeExpression $
356 fun <> parenthesized (renderSQL x)
303 fun <> parenthesized (renderSQL x)
357
304
358−function
359− :: (Has sch schemas schema, Has fun schema ('Function ('[x] :=> 'Returns y)))
360− => QualifiedAlias sch fun
361− -> FunctionDB schemas x y
362−function = unsafeFunction . renderSQL
363−
364-- | >>> printSQL $ unsafeFunctionN "f" (currentTime :* localTimestamp :* false *: literal 'a')
305-- | >>> printSQL $ unsafeFunctionN "f" (currentTime :* localTimestamp :* false *: literal 'a')
365-- f(CURRENT_TIME, LOCALTIMESTAMP, FALSE, E'a')
306-- f(CURRENT_TIME, LOCALTIMESTAMP, FALSE, E'a')
366−unsafeFunctionN :: SListI xs => ByteString -> xs ---> y
307+unsafeFunctionN :: SListI xs => ByteString -> FunctionN xs y
367unsafeFunctionN fun xs = UnsafeExpression $
308unsafeFunctionN fun xs = UnsafeExpression $
368 fun <> parenthesized (renderCommaSeparated renderSQL xs)
309 fun <> parenthesized (renderCommaSeparated renderSQL xs)
369
310
370−functionN
371− :: ( Has sch schemas schema
372− , Has fun schema ('Function (xs :=> 'Returns y))
373− , SListI xs )
374− => QualifiedAlias sch fun
375− -> FunctionNDB schemas xs y
376−functionN = unsafeFunctionN . renderSQL
377−
378instance ty `In` PGNum
311instance ty `In` PGNum
379 => Num (Expression outer commons grp schemas params from (null ty)) where
312 => Num (Expression outer commons grp schemas params from (null ty)) where
380 (+) = unsafeBinaryOp "+"
313 (+) = unsafeBinaryOp "+"
@@ -420,22 +353,16 @@ instance (ty `In` PGNum, ty `In` PGFloating) => Floating
420 atanh x = log ((1 + x) / (1 - x)) / 2
353 atanh x = log ((1 + x) / (1 - x)) / 2
421
354
422-- | Contained by operators
355-- | Contained by operators
423−class PGSubset ty where
356+class PGSubset container where
424− (@>) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
357+ (@>) :: Operator (null0 container) (null1 container) ('Null 'PGbool)
425 (@>) = unsafeBinaryOp "@>"
358 (@>) = unsafeBinaryOp "@>"
426− (<@) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
359+ (<@) :: Operator (null0 container) (null1 container) ('Null 'PGbool)
427 (<@) = unsafeBinaryOp "<@"
360 (<@) = unsafeBinaryOp "<@"
428instance PGSubset 'PGjsonb
361instance PGSubset 'PGjsonb
429instance PGSubset 'PGtsquery
362instance PGSubset 'PGtsquery
430instance PGSubset ('PGvararray ty)
363instance PGSubset ('PGvararray ty)
431instance PGSubset ('PGrange ty)
364instance PGSubset ('PGrange ty)
432
365
433−class PGIntersect ty where
434− (@&&) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
435− (@&&) = unsafeBinaryOp "&&"
436−instance PGIntersect ('PGvararray ty)
437−instance PGIntersect ('PGrange ty)
438−
439instance IsString
366instance IsString
440 (Expression outer commons grp schemas params from (null 'PGtext)) where
367 (Expression outer commons grp schemas params from (null 'PGtext)) where
441 fromString str = UnsafeExpression $
368 fromString str = UnsafeExpression $
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Collection.hs+5−5
@@ -42,7 +42,7 @@ import qualified Generics.SOP as SOP
42
42
43import Squeal.PostgreSQL.Alias
43import Squeal.PostgreSQL.Alias
44import Squeal.PostgreSQL.Expression
44import Squeal.PostgreSQL.Expression
45−import Squeal.PostgreSQL.Expression.Set
45+import Squeal.PostgreSQL.Expression.SetOf
46import Squeal.PostgreSQL.List
46import Squeal.PostgreSQL.List
47import Squeal.PostgreSQL.Render
47import Squeal.PostgreSQL.Render
48import Squeal.PostgreSQL.Schema
48import Squeal.PostgreSQL.Schema
@@ -111,20 +111,20 @@ array2 xss = UnsafeExpression $ "ARRAY" <>
111
111
112-- | >>> printSQL $ cardinality (array [null_, false, true])
112-- | >>> printSQL $ cardinality (array [null_, false, true])
113-- cardinality(ARRAY[NULL, FALSE, TRUE])
113-- cardinality(ARRAY[NULL, FALSE, TRUE])
114−cardinality :: null ('PGvararray ty) --> null 'PGint8
114+cardinality :: null ('PGvararray ty) :--> null 'PGint8
115cardinality = unsafeFunction "cardinality"
115cardinality = unsafeFunction "cardinality"
116
116
117-- | >>> printSQL $ array [null_, false, true] & index 2
117-- | >>> printSQL $ array [null_, false, true] & index 2
118-- (ARRAY[NULL, FALSE, TRUE])[2]
118-- (ARRAY[NULL, FALSE, TRUE])[2]
119index
119index
120 :: Word64 -- ^ index
120 :: Word64 -- ^ index
121− -> null ('PGvararray ty) --> NullifyType ty
121+ -> null ('PGvararray ty) :--> NullifyType ty
122index n expr = UnsafeExpression $
122index n expr = UnsafeExpression $
123 parenthesized (renderSQL expr) <> "[" <> fromString (show n) <> "]"
123 parenthesized (renderSQL expr) <> "[" <> fromString (show n) <> "]"
124
124
125-- | Expand an array to a set of rows
125-- | Expand an array to a set of rows
126−unnest :: SetFunction "unnest" (null ('PGvararray ty)) '["unnest" ::: ty]
126+unnest :: SetOfFunction "unnest" (null ('PGvararray ty)) '["unnest" ::: ty]
127−unnest = unsafeSetFunction
127+unnest = unsafeSetOfFunction
128
128
129-- | A row constructor is an expression that builds a row value
129-- | A row constructor is an expression that builds a row value
130-- (also called a composite value) using values for its member fields.
130-- (also called a composite value) using values for its member fields.
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Comparison.hs+12−12
@@ -162,45 +162,45 @@ isNotDistinctFrom = unsafeBinaryOp "IS NOT DISTINCT FROM"
162>>> printSQL $ true & isTrue
162>>> printSQL $ true & isTrue
163(TRUE IS TRUE)
163(TRUE IS TRUE)
164-}
164-}
165−isTrue :: null0 'PGbool --> null1 'PGbool
165+isTrue :: null0 'PGbool :--> null1 'PGbool
166−isTrue = unsafeRightOp "IS TRUE"
166+isTrue = unsafeUnaryOpR "IS TRUE"
167
167
168{- | is false or unknown
168{- | is false or unknown
169
169
170>>> printSQL $ true & isNotTrue
170>>> printSQL $ true & isNotTrue
171(TRUE IS NOT TRUE)
171(TRUE IS NOT TRUE)
172-}
172-}
173−isNotTrue :: null0 'PGbool --> null1 'PGbool
173+isNotTrue :: null0 'PGbool :--> null1 'PGbool
174−isNotTrue = unsafeRightOp "IS NOT TRUE"
174+isNotTrue = unsafeUnaryOpR "IS NOT TRUE"
175
175
176{- | is false
176{- | is false
177
177
178>>> printSQL $ true & isFalse
178>>> printSQL $ true & isFalse
179(TRUE IS FALSE)
179(TRUE IS FALSE)
180-}
180-}
181−isFalse :: null0 'PGbool --> null1 'PGbool
181+isFalse :: null0 'PGbool :--> null1 'PGbool
182−isFalse = unsafeRightOp "IS FALSE"
182+isFalse = unsafeUnaryOpR "IS FALSE"
183
183
184{- | is true or unknown
184{- | is true or unknown
185
185
186>>> printSQL $ true & isNotFalse
186>>> printSQL $ true & isNotFalse
187(TRUE IS NOT FALSE)
187(TRUE IS NOT FALSE)
188-}
188-}
189−isNotFalse :: null0 'PGbool --> null1 'PGbool
189+isNotFalse :: null0 'PGbool :--> null1 'PGbool
190−isNotFalse = unsafeRightOp "IS NOT FALSE"
190+isNotFalse = unsafeUnaryOpR "IS NOT FALSE"
191
191
192{- | is unknown
192{- | is unknown
193
193
194>>> printSQL $ true & isUnknown
194>>> printSQL $ true & isUnknown
195(TRUE IS UNKNOWN)
195(TRUE IS UNKNOWN)
196-}
196-}
197−isUnknown :: null0 'PGbool --> null1 'PGbool
197+isUnknown :: null0 'PGbool :--> null1 'PGbool
198−isUnknown = unsafeRightOp "IS UNKNOWN"
198+isUnknown = unsafeUnaryOpR "IS UNKNOWN"
199
199
200{- | is true or false
200{- | is true or false
201
201
202>>> printSQL $ true & isNotUnknown
202>>> printSQL $ true & isNotUnknown
203(TRUE IS NOT UNKNOWN)
203(TRUE IS NOT UNKNOWN)
204-}
204-}
205−isNotUnknown :: null0 'PGbool --> null1 'PGbool
205+isNotUnknown :: null0 'PGbool :--> null1 'PGbool
206−isNotUnknown = unsafeRightOp "IS NOT UNKNOWN"
206+isNotUnknown = unsafeUnaryOpR "IS NOT UNKNOWN"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Json.hs+47−40
@@ -81,7 +81,7 @@ import GHC.TypeLits
81
81
82import Squeal.PostgreSQL.Alias
82import Squeal.PostgreSQL.Alias
83import Squeal.PostgreSQL.Expression
83import Squeal.PostgreSQL.Expression
84−import Squeal.PostgreSQL.Expression.Set
84+import Squeal.PostgreSQL.Expression.SetOf
85import Squeal.PostgreSQL.Expression.Type
85import Squeal.PostgreSQL.Expression.Type
86import Squeal.PostgreSQL.List
86import Squeal.PostgreSQL.List
87import Squeal.PostgreSQL.Query
87import Squeal.PostgreSQL.Query
@@ -188,7 +188,7 @@ Table 9.45: JSON creation functions
188-- otherwise, a scalar value is produced. For any scalar type other than a
188-- otherwise, a scalar value is produced. For any scalar type other than a
189-- number, a Boolean, or a null value, the text representation will be used, in
189-- number, a Boolean, or a null value, the text representation will be used, in
190-- such a fashion that it is a valid json value.
190-- such a fashion that it is a valid json value.
191−toJson :: null ty --> null 'PGjson
191+toJson :: null ty :--> null 'PGjson
192toJson = unsafeFunction "to_json"
192toJson = unsafeFunction "to_json"
193
193
194-- | Returns the value as jsonb. Arrays and composites are converted
194-- | Returns the value as jsonb. Arrays and composites are converted
@@ -197,26 +197,26 @@ toJson = unsafeFunction "to_json"
197-- otherwise, a scalar value is produced. For any scalar type other than a
197-- otherwise, a scalar value is produced. For any scalar type other than a
198-- number, a Boolean, or a null value, the text representation will be used, in
198-- number, a Boolean, or a null value, the text representation will be used, in
199-- such a fashion that it is a valid jsonb value.
199-- such a fashion that it is a valid jsonb value.
200−toJsonb :: null ty --> null 'PGjsonb
200+toJsonb :: null ty :--> null 'PGjsonb
201toJsonb = unsafeFunction "to_jsonb"
201toJsonb = unsafeFunction "to_jsonb"
202
202
203-- | Returns the array as a JSON array. A PostgreSQL multidimensional array
203-- | Returns the array as a JSON array. A PostgreSQL multidimensional array
204-- becomes a JSON array of arrays.
204-- becomes a JSON array of arrays.
205−arrayToJson :: null ('PGvararray ty) --> null 'PGjson
205+arrayToJson :: null ('PGvararray ty) :--> null 'PGjson
206arrayToJson = unsafeFunction "array_to_json"
206arrayToJson = unsafeFunction "array_to_json"
207
207
208-- | Returns the row as a JSON object.
208-- | Returns the row as a JSON object.
209−rowToJson :: null ('PGcomposite ty) --> null 'PGjson
209+rowToJson :: null ('PGcomposite ty) :--> null 'PGjson
210rowToJson = unsafeFunction "row_to_json"
210rowToJson = unsafeFunction "row_to_json"
211
211
212-- | Builds a possibly-heterogeneously-typed JSON array out of a variadic
212-- | Builds a possibly-heterogeneously-typed JSON array out of a variadic
213-- argument list.
213-- argument list.
214−jsonBuildArray :: SOP.SListI tuple => tuple ---> null 'PGjson
214+jsonBuildArray :: SOP.SListI tuple => FunctionN tuple (null 'PGjson)
215jsonBuildArray = unsafeFunctionN "json_build_array"
215jsonBuildArray = unsafeFunctionN "json_build_array"
216
216
217-- | Builds a possibly-heterogeneously-typed (binary) JSON array out of a
217-- | Builds a possibly-heterogeneously-typed (binary) JSON array out of a
218-- variadic argument list.
218-- variadic argument list.
219−jsonbBuildArray :: SOP.SListI tuple => tuple ---> null 'PGjsonb
219+jsonbBuildArray :: SOP.SListI tuple => FunctionN tuple (null 'PGjsonb)
220jsonbBuildArray = unsafeFunctionN "jsonb_build_array"
220jsonbBuildArray = unsafeFunctionN "jsonb_build_array"
221
221
222-- | Builds a possibly-heterogeneously-typed JSON object out of a variadic
222-- | Builds a possibly-heterogeneously-typed JSON object out of a variadic
@@ -224,10 +224,10 @@ jsonbBuildArray = unsafeFunctionN "jsonb_build_array"
224-- and values.
224-- and values.
225class SOP.SListI tys => JsonBuildObject tys where
225class SOP.SListI tys => JsonBuildObject tys where
226
226
227− jsonBuildObject :: tys ---> null 'PGjson
227+ jsonBuildObject :: FunctionN tys (null 'PGjson)
228 jsonBuildObject = unsafeFunctionN "json_build_object"
228 jsonBuildObject = unsafeFunctionN "json_build_object"
229
229
230− jsonbBuildObject :: tys ---> null 'PGjsonb
230+ jsonbBuildObject :: FunctionN tys (null 'PGjsonb)
231 jsonbBuildObject = unsafeFunctionN "jsonb_build_object"
231 jsonbBuildObject = unsafeFunctionN "jsonb_build_object"
232
232
233instance JsonBuildObject '[]
233instance JsonBuildObject '[]
@@ -240,7 +240,7 @@ instance (JsonBuildObject tys, key `In` PGJsonKey)
240-- which are taken as a key/value pair.
240-- which are taken as a key/value pair.
241jsonObject
241jsonObject
242 :: null ('PGfixarray '[n,2] ('NotNull 'PGtext))
242 :: null ('PGfixarray '[n,2] ('NotNull 'PGtext))
243− --> null 'PGjson
243+ :--> null 'PGjson
244jsonObject = unsafeFunction "json_object"
244jsonObject = unsafeFunction "json_object"
245
245
246-- | Builds a binary JSON object out of a text array.
246-- | Builds a binary JSON object out of a text array.
@@ -249,24 +249,24 @@ jsonObject = unsafeFunction "json_object"
249-- which are taken as a key/value pair.
249-- which are taken as a key/value pair.
250jsonbObject
250jsonbObject
251 :: null ('PGfixarray '[n,2] ('NotNull 'PGtext))
251 :: null ('PGfixarray '[n,2] ('NotNull 'PGtext))
252− --> null 'PGjsonb
252+ :--> null 'PGjsonb
253jsonbObject = unsafeFunction "jsonb_object"
253jsonbObject = unsafeFunction "jsonb_object"
254
254
255-- | This is an alternate form of 'jsonObject' that takes two arrays; one for
255-- | This is an alternate form of 'jsonObject' that takes two arrays; one for
256-- keys and one for values, that are zipped pairwise to create a JSON object.
256-- keys and one for values, that are zipped pairwise to create a JSON object.
257−jsonZipObject ::
257+jsonZipObject :: FunctionN
258 '[ null ('PGvararray ('NotNull 'PGtext))
258 '[ null ('PGvararray ('NotNull 'PGtext))
259 , null ('PGvararray ('NotNull 'PGtext)) ]
259 , null ('PGvararray ('NotNull 'PGtext)) ]
260− ---> null 'PGjson
260+ ( null 'PGjson )
261jsonZipObject = unsafeFunctionN "json_object"
261jsonZipObject = unsafeFunctionN "json_object"
262
262
263-- | This is an alternate form of 'jsonbObject' that takes two arrays; one for
263-- | This is an alternate form of 'jsonbObject' that takes two arrays; one for
264-- keys and one for values, that are zipped pairwise to create a binary JSON
264-- keys and one for values, that are zipped pairwise to create a binary JSON
265-- object.
265-- object.
266−jsonbZipObject ::
266+jsonbZipObject :: FunctionN
267 '[ null ('PGvararray ('NotNull 'PGtext))
267 '[ null ('PGvararray ('NotNull 'PGtext))
268 , null ('PGvararray ('NotNull 'PGtext)) ]
268 , null ('PGvararray ('NotNull 'PGtext)) ]
269− ---> null 'PGjsonb
269+ ( null 'PGjsonb )
270jsonbZipObject = unsafeFunctionN "jsonb_object"
270jsonbZipObject = unsafeFunctionN "jsonb_object"
271
271
272{-----------------------------------------
272{-----------------------------------------
@@ -274,31 +274,31 @@ Table 9.46: JSON processing functions
274-----------------------------------------}
274-----------------------------------------}
275
275
276-- | Returns the number of elements in the outermost JSON array.
276-- | Returns the number of elements in the outermost JSON array.
277−jsonArrayLength :: null 'PGjson --> null 'PGint4
277+jsonArrayLength :: null 'PGjson :--> null 'PGint4
278jsonArrayLength = unsafeFunction "json_array_length"
278jsonArrayLength = unsafeFunction "json_array_length"
279
279
280-- | Returns the number of elements in the outermost binary JSON array.
280-- | Returns the number of elements in the outermost binary JSON array.
281−jsonbArrayLength :: null 'PGjsonb --> null 'PGint4
281+jsonbArrayLength :: null 'PGjsonb :--> null 'PGint4
282jsonbArrayLength = unsafeFunction "jsonb_array_length"
282jsonbArrayLength = unsafeFunction "jsonb_array_length"
283
283
284-- | Returns the type of the outermost JSON value as a text string. Possible
284-- | Returns the type of the outermost JSON value as a text string. Possible
285-- types are object, array, string, number, boolean, and null.
285-- types are object, array, string, number, boolean, and null.
286−jsonTypeof :: null 'PGjson --> null 'PGtext
286+jsonTypeof :: null 'PGjson :--> null 'PGtext
287jsonTypeof = unsafeFunction "json_typeof"
287jsonTypeof = unsafeFunction "json_typeof"
288
288
289-- | Returns the type of the outermost binary JSON value as a text string.
289-- | Returns the type of the outermost binary JSON value as a text string.
290-- Possible types are object, array, string, number, boolean, and null.
290-- Possible types are object, array, string, number, boolean, and null.
291−jsonbTypeof :: null 'PGjsonb --> null 'PGtext
291+jsonbTypeof :: null 'PGjsonb :--> null 'PGtext
292jsonbTypeof = unsafeFunction "jsonb_typeof"
292jsonbTypeof = unsafeFunction "jsonb_typeof"
293
293
294-- | Returns its argument with all object fields that have null values omitted.
294-- | Returns its argument with all object fields that have null values omitted.
295-- Other null values are untouched.
295-- Other null values are untouched.
296−jsonStripNulls :: null 'PGjson --> null 'PGjson
296+jsonStripNulls :: null 'PGjson :--> null 'PGjson
297jsonStripNulls = unsafeFunction "json_strip_nulls"
297jsonStripNulls = unsafeFunction "json_strip_nulls"
298
298
299-- | Returns its argument with all object fields that have null values omitted.
299-- | Returns its argument with all object fields that have null values omitted.
300-- Other null values are untouched.
300-- Other null values are untouched.
301−jsonbStripNulls :: null 'PGjsonb --> null 'PGjsonb
301+jsonbStripNulls :: null 'PGjsonb :--> null 'PGjsonb
302jsonbStripNulls = unsafeFunction "jsonb_strip_nulls"
302jsonbStripNulls = unsafeFunction "jsonb_strip_nulls"
303
303
304-- | @ jsonbSet target path new_value create_missing @
304-- | @ jsonbSet target path new_value create_missing @
@@ -309,9 +309,12 @@ jsonbStripNulls = unsafeFunction "jsonb_strip_nulls"
309-- item designated by path does not exist. As with the path orientated
309-- item designated by path does not exist. As with the path orientated
310-- operators, negative integers that appear in path count from the end of JSON
310-- operators, negative integers that appear in path count from the end of JSON
311-- arrays.
311-- arrays.
312−jsonbSet ::
312+jsonbSet
313+ :: FunctionN
314+ '[ null 'PGjsonb
313− '[ null 'PGjsonb, null ('PGvararray ('NotNull 'PGtext))
315+ , null ('PGvararray ('NotNull 'PGtext))
316+ , null 'PGjsonb
314− , null 'PGjsonb, null 'PGbool ] ---> null 'PGjsonb
317+ , null 'PGbool ] (null 'PGjsonb)
315jsonbSet = unsafeFunctionN "jsonbSet"
318jsonbSet = unsafeFunctionN "jsonbSet"
316
319
317-- | @ jsonbInsert target path new_value insert_after @
320-- | @ jsonbInsert target path new_value insert_after @
@@ -323,23 +326,27 @@ jsonbSet = unsafeFunctionN "jsonbSet"
323-- path is in JSONB object, @new_value@ will be inserted only if target does not
326-- path is in JSONB object, @new_value@ will be inserted only if target does not
324-- exist. As with the path orientated operators, negative integers that appear
327-- exist. As with the path orientated operators, negative integers that appear
325-- in path count from the end of JSON arrays.
328-- in path count from the end of JSON arrays.
326−jsonbInsert ::
329+jsonbInsert
330+ :: FunctionN
331+ '[ null 'PGjsonb
327− '[ null 'PGjsonb, null ('PGvararray ('NotNull 'PGtext))
332+ , null ('PGvararray ('NotNull 'PGtext))
333+ , null 'PGjsonb
328− , null 'PGjsonb, null 'PGbool ] ---> null 'PGjsonb
334+ , null 'PGbool ] (null 'PGjsonb)
329jsonbInsert = unsafeFunctionN "jsonb_insert"
335jsonbInsert = unsafeFunctionN "jsonb_insert"
330
336
331-- | Returns its argument as indented JSON text.
337-- | Returns its argument as indented JSON text.
332−jsonbPretty :: null 'PGjsonb --> null 'PGtext
338+jsonbPretty :: null 'PGjsonb :--> null 'PGtext
333jsonbPretty = unsafeFunction "jsonb_pretty"
339jsonbPretty = unsafeFunction "jsonb_pretty"
334
340
341+
335{- | Expands the outermost JSON object into a set of key/value pairs.
342{- | Expands the outermost JSON object into a set of key/value pairs.
336
343
337>>> printSQL (select Star (from (jsonEach (literal (Json (object ["a" .= "foo", "b" .= "bar"]))))))
344>>> printSQL (select Star (from (jsonEach (literal (Json (object ["a" .= "foo", "b" .= "bar"]))))))
338SELECT * FROM json_each(('{"a":"foo","b":"bar"}' :: json))
345SELECT * FROM json_each(('{"a":"foo","b":"bar"}' :: json))
339-}
346-}
340−jsonEach :: SetFunction "json_each" (null 'PGjson)
347+jsonEach :: SetOfFunction "json_each" (null 'PGjson)
341 '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGjson]
348 '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGjson]
342−jsonEach = unsafeSetFunction
349+jsonEach = unsafeSetOfFunction
343
350
344{- | Expands the outermost binary JSON object into a set of key/value pairs.
351{- | Expands the outermost binary JSON object into a set of key/value pairs.
345
352
@@ -347,9 +354,9 @@ jsonEach = unsafeSetFunction
347SELECT * FROM jsonb_each(('{"a":"foo","b":"bar"}' :: jsonb))
354SELECT * FROM jsonb_each(('{"a":"foo","b":"bar"}' :: jsonb))
348-}
355-}
349jsonbEach
356jsonbEach
350− :: SetFunction "jsonb_each" (nullity 'PGjsonb)
357+ :: SetOfFunction "jsonb_each" (nullity 'PGjsonb)
351 '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGjson]
358 '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGjson]
352−jsonbEach = unsafeSetFunction
359+jsonbEach = unsafeSetOfFunction
353
360
354{- | Expands the outermost JSON object into a set of key/value pairs.
361{- | Expands the outermost JSON object into a set of key/value pairs.
355
362
@@ -357,9 +364,9 @@ jsonbEach = unsafeSetFunction
357SELECT * FROM json_each_text(('{"a":"foo","b":"bar"}' :: json))
364SELECT * FROM json_each_text(('{"a":"foo","b":"bar"}' :: json))
358-}
365-}
359jsonEachText
366jsonEachText
360− :: SetFunction "json_each_text" (null 'PGjson)
367+ :: SetOfFunction "json_each_text" (null 'PGjson)
361 '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext]
368 '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext]
362−jsonEachText = unsafeSetFunction
369+jsonEachText = unsafeSetOfFunction
363
370
364{- | Expands the outermost binary JSON object into a set of key/value pairs.
371{- | Expands the outermost binary JSON object into a set of key/value pairs.
365
372
@@ -367,9 +374,9 @@ jsonEachText = unsafeSetFunction
367SELECT * FROM jsonb_each_text(('{"a":"foo","b":"bar"}' :: jsonb))
374SELECT * FROM jsonb_each_text(('{"a":"foo","b":"bar"}' :: jsonb))
368-}
375-}
369jsonbEachText
376jsonbEachText
370− :: SetFunction "jsonb_each_text" (null 'PGjsonb)
377+ :: SetOfFunction "jsonb_each_text" (null 'PGjsonb)
371 '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext]
378 '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext]
372−jsonbEachText = unsafeSetFunction
379+jsonbEachText = unsafeSetOfFunction
373
380
374{- | Returns set of keys in the outermost JSON object.
381{- | Returns set of keys in the outermost JSON object.
375
382
@@ -377,9 +384,9 @@ jsonbEachText = unsafeSetFunction
377json_object_keys(('{"a":"foo","b":"bar"}' :: json))
384json_object_keys(('{"a":"foo","b":"bar"}' :: json))
378-}
385-}
379jsonObjectKeys
386jsonObjectKeys
380− :: SetFunction "json_object_keys" (nullity 'PGjson)
387+ :: SetOfFunction "json_object_keys" (nullity 'PGjson)
381 '["json_object_keys" ::: 'NotNull 'PGtext]
388 '["json_object_keys" ::: 'NotNull 'PGtext]
382−jsonObjectKeys = unsafeSetFunction
389+jsonObjectKeys = unsafeSetOfFunction
383
390
384{- | Returns set of keys in the outermost JSON object.
391{- | Returns set of keys in the outermost JSON object.
385
392
@@ -387,9 +394,9 @@ jsonObjectKeys = unsafeSetFunction
387jsonb_object_keys(('{"a":"foo","b":"bar"}' :: jsonb))
394jsonb_object_keys(('{"a":"foo","b":"bar"}' :: jsonb))
388-}
395-}
389jsonbObjectKeys
396jsonbObjectKeys
390− :: SetFunction "jsonb_object_keys" (null 'PGjsonb)
397+ :: SetOfFunction "jsonb_object_keys" (null 'PGjsonb)
391 '["jsonb_object_keys" ::: 'NotNull 'PGtext]
398 '["jsonb_object_keys" ::: 'NotNull 'PGtext]
392−jsonbObjectKeys = unsafeSetFunction
399+jsonbObjectKeys = unsafeSetOfFunction
393
400
394-- | Build rows from Json types.
401-- | Build rows from Json types.
395type JsonPopulateFunction fun json
402type JsonPopulateFunction fun json
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Logic.hs+2−2
@@ -47,8 +47,8 @@ false = UnsafeExpression "FALSE"
47
47
48-- | >>> printSQL $ not_ true
48-- | >>> printSQL $ not_ true
49-- (NOT TRUE)
49-- (NOT TRUE)
50−not_ :: null 'PGbool --> null 'PGbool
50+not_ :: null 'PGbool :--> null 'PGbool
51−not_ = unsafeLeftOp "NOT"
51+not_ = unsafeUnaryOpL "NOT"
52
52
53-- | >>> printSQL $ true .&& false
53-- | >>> printSQL $ true .&& false
54-- (TRUE AND FALSE)
54-- (TRUE AND FALSE)
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Math.hs+6−4
@@ -37,7 +37,9 @@ import Squeal.PostgreSQL.Schema
37-- in printSQL expression
37-- in printSQL expression
38-- :}
38-- :}
39-- atan2(pi(), 2)
39-- atan2(pi(), 2)
40+atan2_
41+ :: float `In` PGFloating
40−atan2_ :: float `In` PGFloating => '[ null float, null float] ---> null float
42+ => FunctionN '[ null float, null float] (null float)
41atan2_ = unsafeFunctionN "atan2"
43atan2_ = unsafeFunctionN "atan2"
42
44
43
45
@@ -76,7 +78,7 @@ rem_ = unsafeBinaryOp "%"
76-- in printSQL expression
78-- in printSQL expression
77-- :}
79-- :}
78-- trunc(pi())
80-- trunc(pi())
79−trunc :: frac `In` PGFloating => null frac --> null frac
81+trunc :: frac `In` PGFloating => null frac :--> null frac
80trunc = unsafeFunction "trunc"
82trunc = unsafeFunction "trunc"
81
83
82-- | >>> :{
84-- | >>> :{
@@ -86,7 +88,7 @@ trunc = unsafeFunction "trunc"
86-- in printSQL expression
88-- in printSQL expression
87-- :}
89-- :}
88-- round(pi())
90-- round(pi())
89−round_ :: frac `In` PGFloating => null frac --> null frac
91+round_ :: frac `In` PGFloating => null frac :--> null frac
90round_ = unsafeFunction "round"
92round_ = unsafeFunction "round"
91
93
92-- | >>> :{
94-- | >>> :{
@@ -96,5 +98,5 @@ round_ = unsafeFunction "round"
96-- in printSQL expression
98-- in printSQL expression
97-- :}
99-- :}
98-- ceiling(pi())
100-- ceiling(pi())
99−ceiling_ :: frac `In` PGFloating => null frac --> null frac
101+ceiling_ :: frac `In` PGFloating => null frac :--> null frac
100ceiling_ = unsafeFunction "ceiling"
102ceiling_ = unsafeFunction "ceiling"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Null.hs+4−4
@@ -44,7 +44,7 @@ null_ = UnsafeExpression "NULL"
44--
44--
45-- >>> printSQL $ notNull true
45-- >>> printSQL $ notNull true
46-- TRUE
46-- TRUE
47−notNull :: 'NotNull ty --> 'Null ty
47+notNull :: 'NotNull ty :--> 'Null ty
48notNull = UnsafeExpression . renderSQL
48notNull = UnsafeExpression . renderSQL
49
49
50-- | return the leftmost value which is not NULL
50-- | return the leftmost value which is not NULL
@@ -69,12 +69,12 @@ fromNull notNullx nullx = coalesce [nullx] notNullx
69
69
70-- | >>> printSQL $ null_ & isNull
70-- | >>> printSQL $ null_ & isNull
71-- NULL IS NULL
71-- NULL IS NULL
72−isNull :: 'Null ty --> null 'PGbool
72+isNull :: 'Null ty :--> null 'PGbool
73isNull x = UnsafeExpression $ renderSQL x <+> "IS NULL"
73isNull x = UnsafeExpression $ renderSQL x <+> "IS NULL"
74
74
75-- | >>> printSQL $ null_ & isNotNull
75-- | >>> printSQL $ null_ & isNotNull
76-- NULL IS NOT NULL
76-- NULL IS NOT NULL
77−isNotNull :: 'Null ty --> null 'PGbool
77+isNotNull :: 'Null ty :--> null 'PGbool
78isNotNull x = UnsafeExpression $ renderSQL x <+> "IS NOT NULL"
78isNotNull x = UnsafeExpression $ renderSQL x <+> "IS NOT NULL"
79
79
80-- | analagous to `maybe` using @IS NULL@
80-- | analagous to `maybe` using @IS NULL@
@@ -100,5 +100,5 @@ matchNull y f x = ifThenElse (isNull x) y
100>>> printSQL expr
100>>> printSQL expr
101NULLIF(FALSE, ($1 :: bool))
101NULLIF(FALSE, ($1 :: bool))
102-}
102-}
103−nullIf :: '[ 'NotNull ty, 'NotNull ty] ---> 'Null ty
103+nullIf :: FunctionN '[ 'NotNull ty, 'NotNull ty] ('Null ty)
104nullIf = unsafeFunctionN "NULLIF"
104nullIf = unsafeFunctionN "NULLIF"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Range.hs+31−147
@@ -38,34 +38,14 @@ 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− , (.<@)
41+ , closed, open
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
42 ) where
60
43
61−import BinaryParser
44+import Data.Bool
62−import ByteString.StrictBuilder
45+
63−import Data.Bits
64import qualified GHC.Generics as GHC
46import qualified GHC.Generics as GHC
65import qualified Generics.SOP as SOP
47import qualified Generics.SOP as SOP
66−import qualified PostgreSQL.Binary.Decoding as Decoding
67
48
68−import Squeal.PostgreSQL.Binary
69import Squeal.PostgreSQL.Expression
49import Squeal.PostgreSQL.Expression
70import Squeal.PostgreSQL.Expression.Type hiding (bool)
50import Squeal.PostgreSQL.Expression.Type hiding (bool)
71import Squeal.PostgreSQL.PG
51import Squeal.PostgreSQL.PG
@@ -81,150 +61,54 @@ import Squeal.PostgreSQL.Schema
81-- tstzrange(now(), NULL, '[)')
61-- tstzrange(now(), NULL, '[)')
82-- >>> printSQL $ range numrange (0 <=..< 2*pi)
62-- >>> printSQL $ range numrange (0 <=..< 2*pi)
83-- numrange(0, (2 * pi()), '[)')
63-- numrange(0, (2 * pi()), '[)')
84−-- >>> printSQL $ range int4range Empty
85−-- ('empty' :: int4range)
86range
64range
87 :: TypeExpression schemas (null ('PGrange ty))
65 :: TypeExpression schemas (null ('PGrange ty))
88 -> Range (Expression outer commons grp schemas params from ('NotNull ty))
66 -> Range (Expression outer commons grp schemas params from ('NotNull ty))
89 -> Expression outer commons grp schemas params from (null ('PGrange ty))
67 -> Expression outer commons grp schemas params from (null ('PGrange ty))
90range ty = \case
68range ty = \case
91− Empty -> UnsafeExpression $ parenthesized
69+ Empty -> UnsafeExpression "empty"
92− (emp <+> "::" <+> renderSQL ty)
93 NonEmpty l u -> UnsafeExpression $ renderSQL ty <> parenthesized
70 NonEmpty l u -> UnsafeExpression $ renderSQL ty <> parenthesized
94− (commaSeparated (args l u))
71+ (commaSeparated [renderArg l, renderArg u, renderClopen l u])
95− where
72+ where
96− emp = singleQuote <> "empty" <> singleQuote
73+ renderArg (Bound _ x) = maybe "NULL" renderSQL x
97− args l u = [arg l, arg u, singleQuote <> bra l <> ket u <> singleQuote]
74+ renderClopen (Bound l' _) (Bound u' _) =
98− singleQuote = "\'"
75+ "\'" <> bool "(" "[" l' <> bool ")" "]" u' <> "\'"
99− arg = \case
76+
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
77+data Bound x = Bound
78+ { closedBound :: Bool
79+ , getBound :: Maybe x
105− deriving
80+ } deriving
106 ( Eq, Ord, Show, Read, GHC.Generic
81 ( Eq, Ord, Show, Read, GHC.Generic
107 , Functor, Foldable, Traversable )
82 , Functor, Foldable, Traversable )
108−
83+ deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
84+closed, open :: Maybe x -> Bound x
85+closed = Bound True
86+open = Bound False
87+
88+data Range x
89+ = Empty
109−data Range x = Empty | NonEmpty (Bound x) (Bound x)
90+ | NonEmpty (Bound x) (Bound x)
110 deriving
91 deriving
111 ( Eq, Ord, Show, Read, GHC.Generic
92 ( Eq, Ord, Show, Read, GHC.Generic
112 , Functor, Foldable, Traversable )
93 , Functor, Foldable, Traversable )
113 deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
94 deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
114type instance PG (Range x) = 'PGrange (PG x)
95type 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
96
159(<=..<=), (<..<), (<=..<), (<..<=) :: x -> x -> Range x
97(<=..<=), (<..<), (<=..<), (<..<=) :: x -> x -> Range x
160infix 4 <=..<=, <..<, <=..<, <..<=
98infix 4 <=..<=, <..<, <=..<, <..<=
161−x <=..<= y = NonEmpty (Closed x) (Closed y)
99+x <=..<= y = NonEmpty (closed (Just x)) (closed (Just y))
162−x <..< y = NonEmpty (Open x) (Open y)
100+x <..< y = NonEmpty (open (Just x)) (open (Just y))
163−x <=..< y = NonEmpty (Closed x) (Open y)
101+x <=..< y = NonEmpty (closed (Just x)) (open (Just y))
164−x <..<= y = NonEmpty (Open x) (Closed y)
102+x <..<= y = NonEmpty (open (Just x)) (closed (Just y))
165
103
166moreThan, atLeast, lessThan, atMost :: x -> Range x
104moreThan, atLeast, lessThan, atMost :: x -> Range x
167−moreThan x = NonEmpty (Open x) Infinite
105+moreThan x = NonEmpty (open (Just x)) (open Nothing)
168−atLeast x = NonEmpty (Closed x) Infinite
106+atLeast x = NonEmpty (closed (Just x)) (open Nothing)
169−lessThan x = NonEmpty Infinite (Open x)
107+lessThan x = NonEmpty (open Nothing) (open (Just x))
170−atMost x = NonEmpty Infinite (Closed x)
108+atMost x = NonEmpty (open Nothing) (closed (Just x))
171
109
172singleton :: x -> Range x
110singleton :: x -> Range x
173singleton x = x <=..<= x
111singleton x = x <=..<= x
174
112
175whole :: Range x
113whole :: Range x
176−whole = NonEmpty Infinite Infinite
114+whole = NonEmpty (open Nothing) (open Nothing)
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 :: '[null ('PGrange ty), null ('PGrange ty)] ---> null ('PGrange ty)
230−rangeMerge = unsafeFunctionN "range_merge"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Set.hs → squeal-postgresql/src/Squeal/PostgreSQL/Expression/SetOf.hsrenamed+24−57
@@ -1,5 +1,5 @@
1{-|
1{-|
2−Module: Squeal.PostgreSQL.Expression.Set
2+Module: Squeal.PostgreSQL.Expression.SetOf
3Description: Set returning functions
3Description: Set returning functions
4Copyright: (c) Eitan Chatav, 2019
4Copyright: (c) Eitan Chatav, 2019
5Maintainer: eitan@morphism.tech
5Maintainer: eitan@morphism.tech
@@ -20,18 +20,14 @@ Set returning functions
20 , TypeOperators
20 , TypeOperators
21#-}
21#-}
22
22
23−module Squeal.PostgreSQL.Expression.Set
23+module Squeal.PostgreSQL.Expression.SetOf
24 ( generateSeries
24 ( generateSeries
25 , generateSeriesStep
25 , generateSeriesStep
26 , generateSeriesTimestamp
26 , generateSeriesTimestamp
27− , SetFunction
27+ , SetOfFunction
28− , unsafeSetFunction
28+ , unsafeSetOfFunction
29− , SetFunctionDB
29+ , SetOfFunctionN
30− , setFunction
30+ , unsafeSetOfFunctionN
31− , SetFunctionN
32− , unsafeSetFunctionN
33− , SetFunctionNDB
34− , setFunctionN
35 ) where
31 ) where
36
32
37import GHC.TypeLits
33import GHC.TypeLits
@@ -48,75 +44,46 @@ import Squeal.PostgreSQL.Schema
48{- |
44{- |
49A @RankNType@ for set returning functions with 1 argument.
45A @RankNType@ for set returning functions with 1 argument.
50-}
46-}
51−type SetFunction fun ty row
47+type SetOfFunction fun ty setof
52 = forall outer commons schemas params
48 = forall outer commons schemas params
53 . Expression outer commons 'Ungrouped schemas params '[] ty
49 . Expression outer commons 'Ungrouped schemas params '[] ty
54 -- ^ input
50 -- ^ input
55− -> FromClause outer commons schemas params '[fun ::: row]
51+ -> FromClause outer commons schemas params '[fun ::: setof]
56− -- ^ output
57−
58−type SetFunctionDB fun schemas ty row
59− = forall outer commons params
60− . Expression outer commons 'Ungrouped schemas params '[] ty
61− -- ^ input
62− -> FromClause outer commons schemas params '[fun ::: row]
63 -- ^ output
52 -- ^ output
64
53
65-- | Escape hatch for a set returning function with 1 argument.
54-- | Escape hatch for a set returning function with 1 argument.
66−unsafeSetFunction
55+unsafeSetOfFunction
67− :: forall fun ty row. KnownSymbol fun
56+ :: forall fun ty setof. KnownSymbol fun
68− => SetFunction fun ty row -- ^ set returning function
57+ => SetOfFunction fun ty setof -- ^ set returning function
69−unsafeSetFunction x = UnsafeFromClause $
58+unsafeSetOfFunction x = UnsafeFromClause $
70 renderSymbol @fun <> parenthesized (renderSQL x)
59 renderSymbol @fun <> parenthesized (renderSQL x)
71
60
72−setFunction
73− :: ( Has sch schemas schema
74− , Has fun schema ('Function ('[ty] :=> 'ReturnsTable row)) )
75− => QualifiedAlias sch fun
76− -> SetFunctionDB fun schemas ty row
77−setFunction _ = unsafeSetFunction
78−
79{- |
61{- |
80A @RankNType@ for set returning functions with multiple argument.
62A @RankNType@ for set returning functions with multiple argument.
81-}
63-}
82−type SetFunctionN fun tys row
64+type SetOfFunctionN fun tys setof
83 = forall outer commons schemas params
65 = forall outer commons schemas params
84 . NP (Expression outer commons 'Ungrouped schemas params '[]) tys
66 . NP (Expression outer commons 'Ungrouped schemas params '[]) tys
85 -- ^ inputs
67 -- ^ inputs
86− -> FromClause outer commons schemas params '[fun ::: row]
68+ -> FromClause outer commons schemas params '[fun ::: setof]
87 -- ^ output
69 -- ^ output
88
70
89-- | Escape hatch for a set returning function with multiple argument.
71-- | Escape hatch for a set returning function with multiple argument.
90−unsafeSetFunctionN
72+unsafeSetOfFunctionN
91− :: forall fun tys row. (SOP.SListI tys, KnownSymbol fun)
73+ :: forall fun tys setof. (SOP.SListI tys, KnownSymbol fun)
92− => SetFunctionN fun tys row -- ^ set returning function
74+ => SetOfFunctionN fun tys setof -- ^ set returning function
93−unsafeSetFunctionN xs = UnsafeFromClause $
75+unsafeSetOfFunctionN xs = UnsafeFromClause $
94 renderSymbol @fun <> parenthesized (renderCommaSeparated renderSQL xs)
76 renderSymbol @fun <> parenthesized (renderCommaSeparated renderSQL xs)
95
77
96−type SetFunctionNDB fun schemas tys row
97− = forall outer commons params
98− . NP (Expression outer commons 'Ungrouped schemas params '[]) tys
99− -- ^ inputs
100− -> FromClause outer commons schemas params '[fun ::: row]
101− -- ^ output
102−
103−setFunctionN
104− :: ( Has sch schemas schema
105− , Has fun schema ('Function (tys :=> 'ReturnsTable row))
106− , SOP.SListI tys )
107− => QualifiedAlias sch fun
108− -> SetFunctionNDB fun schemas tys row
109−setFunctionN _ = unsafeSetFunctionN
110−
111{- | @generateSeries (start *: stop)@
78{- | @generateSeries (start *: stop)@
112
79
113Generate a series of values, from @start@ to @stop@ with a step size of one
80Generate a series of values, from @start@ to @stop@ with a step size of one
114-}
81-}
115generateSeries
82generateSeries
116 :: ty `In` '[ 'PGint4, 'PGint8, 'PGnumeric]
83 :: ty `In` '[ 'PGint4, 'PGint8, 'PGnumeric]
117− => SetFunctionN "generate_series" '[ null ty, null ty]
84+ => SetOfFunctionN "generate_series" '[ null ty, null ty]
118 '["generate_series" ::: null ty] -- ^ set returning function
85 '["generate_series" ::: null ty] -- ^ set returning function
119−generateSeries = unsafeSetFunctionN
86+generateSeries = unsafeSetOfFunctionN
120
87
121{- | @generateSeries (start :* stop *: step)@
88{- | @generateSeries (start :* stop *: step)@
122
89
@@ -124,9 +91,9 @@ Generate a series of values, from @start@ to @stop@ with a step size of @step@
124-}
91-}
125generateSeriesStep
92generateSeriesStep
126 :: ty `In` '[ 'PGint4, 'PGint8, 'PGnumeric]
93 :: ty `In` '[ 'PGint4, 'PGint8, 'PGnumeric]
127− => SetFunctionN "generate_series" '[null ty, null ty, null ty]
94+ => SetOfFunctionN "generate_series" '[null ty, null ty, null ty]
128 '["generate_series" ::: null ty] -- ^ set returning function
95 '["generate_series" ::: null ty] -- ^ set returning function
129−generateSeriesStep = unsafeSetFunctionN
96+generateSeriesStep = unsafeSetOfFunctionN
130
97
131{- | @generateSeries (start :* stop *: step)@
98{- | @generateSeries (start :* stop *: step)@
132
99
@@ -134,6 +101,6 @@ Generate a series of values, from @start@ to @stop@ with a step size of @step@
134-}
101-}
135generateSeriesTimestamp
102generateSeriesTimestamp
136 :: ty `In` '[ 'PGtimestamp, 'PGtimestamptz]
103 :: ty `In` '[ 'PGtimestamp, 'PGtimestamptz]
137− => SetFunctionN "generate_series" '[null ty, null ty, null 'PGinterval]
104+ => SetOfFunctionN "generate_series" '[null ty, null ty, null 'PGinterval]
138 '["generate_series" ::: null ty] -- ^ set returning function
105 '["generate_series" ::: null ty] -- ^ set returning function
139−generateSeriesTimestamp = unsafeSetFunctionN
106+generateSeriesTimestamp = unsafeSetOfFunctionN
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Text.hs+3−3
@@ -30,17 +30,17 @@ import Squeal.PostgreSQL.Schema
30
30
31-- | >>> printSQL $ lower "ARRRGGG"
31-- | >>> printSQL $ lower "ARRRGGG"
32-- lower(E'ARRRGGG')
32-- lower(E'ARRRGGG')
33−lower :: null 'PGtext --> null 'PGtext
33+lower :: null 'PGtext :--> null 'PGtext
34lower = unsafeFunction "lower"
34lower = unsafeFunction "lower"
35
35
36-- | >>> printSQL $ upper "eeee"
36-- | >>> printSQL $ upper "eeee"
37-- upper(E'eeee')
37-- upper(E'eeee')
38−upper :: null 'PGtext --> null 'PGtext
38+upper :: null 'PGtext :--> null 'PGtext
39upper = unsafeFunction "upper"
39upper = unsafeFunction "upper"
40
40
41-- | >>> printSQL $ charLength "four"
41-- | >>> printSQL $ charLength "four"
42-- char_length(E'four')
42-- char_length(E'four')
43−charLength :: null 'PGtext --> null 'PGint4
43+charLength :: null 'PGtext :--> null 'PGint4
44charLength = unsafeFunction "char_length"
44charLength = unsafeFunction "char_length"
45
45
46-- | The `like` expression returns true if the @string@ matches
46-- | The `like` expression returns true if the @string@ matches
squeal-postgresql/src/Squeal/PostgreSQL/Expression/TextSearch.hs+21−20
@@ -55,8 +55,8 @@ import Squeal.PostgreSQL.Schema
55(.|) = unsafeBinaryOp "||"
55(.|) = unsafeBinaryOp "||"
56
56
57-- | negate a `Squeal.PostgreSQL.Expression.Type.tsquery`
57-- | negate a `Squeal.PostgreSQL.Expression.Type.tsquery`
58−(.!) :: null 'PGtsquery --> null 'PGtsquery
58+(.!) :: null 'PGtsquery :--> null 'PGtsquery
59−(.!) = unsafeLeftOp "!!"
59+(.!) = unsafeUnaryOpL "!!"
60
60
61-- | `Squeal.PostgreSQL.Expression.Type.tsquery` followed by
61-- | `Squeal.PostgreSQL.Expression.Type.tsquery` followed by
62-- `Squeal.PostgreSQL.Expression.Type.tsquery`
62-- `Squeal.PostgreSQL.Expression.Type.tsquery`
@@ -66,50 +66,51 @@ import Squeal.PostgreSQL.Schema
66-- | convert array of lexemes to `Squeal.PostgreSQL.Expression.Type.tsvector`
66-- | convert array of lexemes to `Squeal.PostgreSQL.Expression.Type.tsvector`
67arrayToTSvector
67arrayToTSvector
68 :: null ('PGvararray ('NotNull 'PGtext))
68 :: null ('PGvararray ('NotNull 'PGtext))
69− --> null 'PGtsvector
69+ :--> null 'PGtsvector
70arrayToTSvector = unsafeFunction "array_to_tsvector"
70arrayToTSvector = unsafeFunction "array_to_tsvector"
71
71
72-- | number of lexemes in `Squeal.PostgreSQL.Expression.Type.tsvector`
72-- | number of lexemes in `Squeal.PostgreSQL.Expression.Type.tsvector`
73−tsvectorLength :: null 'PGtsvector --> null 'PGint4
73+tsvectorLength :: null 'PGtsvector :--> null 'PGint4
74tsvectorLength = unsafeFunction "length"
74tsvectorLength = unsafeFunction "length"
75
75
76-- | number of lexemes plus operators in `Squeal.PostgreSQL.Expression.Type.tsquery`
76-- | number of lexemes plus operators in `Squeal.PostgreSQL.Expression.Type.tsquery`
77−numnode :: null 'PGtsquery --> null 'PGint4
77+numnode :: null 'PGtsquery :--> null 'PGint4
78numnode = unsafeFunction "numnode"
78numnode = unsafeFunction "numnode"
79
79
80-- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` ignoring punctuation
80-- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` ignoring punctuation
81−plainToTSquery :: null 'PGtext --> null 'PGtsquery
81+plainToTSquery :: null 'PGtext :--> null 'PGtsquery
82plainToTSquery = unsafeFunction "plainto_tsquery"
82plainToTSquery = unsafeFunction "plainto_tsquery"
83
83
84-- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` that searches for a phrase,
84-- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` that searches for a phrase,
85-- ignoring punctuation
85-- ignoring punctuation
86−phraseToTSquery :: null 'PGtext --> null 'PGtsquery
86+phraseToTSquery :: null 'PGtext :--> null 'PGtsquery
87phraseToTSquery = unsafeFunction "phraseto_tsquery"
87phraseToTSquery = unsafeFunction "phraseto_tsquery"
88
88
89-- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` from a web search style query
89-- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` from a web search style query
90−websearchToTSquery :: null 'PGtext --> null 'PGtsquery
90+websearchToTSquery :: null 'PGtext :--> null 'PGtsquery
91websearchToTSquery = unsafeFunction "websearch_to_tsquery"
91websearchToTSquery = unsafeFunction "websearch_to_tsquery"
92
92
93-- | get indexable part of a `Squeal.PostgreSQL.Expression.Type.tsquery`
93-- | get indexable part of a `Squeal.PostgreSQL.Expression.Type.tsquery`
94−queryTree :: null 'PGtsquery --> null 'PGtext
94+queryTree :: null 'PGtsquery :--> null 'PGtext
95queryTree = unsafeFunction "query_tree"
95queryTree = unsafeFunction "query_tree"
96
96
97-- | normalize words and convert to `Squeal.PostgreSQL.Expression.Type.tsquery`
97-- | normalize words and convert to `Squeal.PostgreSQL.Expression.Type.tsquery`
98−toTSquery :: null 'PGtext --> null 'PGtsquery
98+toTSquery :: null 'PGtext :--> null 'PGtsquery
99toTSquery = unsafeFunction "to_tsquery"
99toTSquery = unsafeFunction "to_tsquery"
100
100
101-- | reduce document text to `Squeal.PostgreSQL.Expression.Type.tsvector`
101-- | reduce document text to `Squeal.PostgreSQL.Expression.Type.tsvector`
102toTSvector
102toTSvector
103 :: ty `In` '[ 'PGtext, 'PGjson, 'PGjsonb]
103 :: ty `In` '[ 'PGtext, 'PGjson, 'PGjsonb]
104− => null ty --> null 'PGtsvector
104+ => null ty :--> null 'PGtsvector
105toTSvector = unsafeFunction "to_tsvector"
105toTSvector = unsafeFunction "to_tsvector"
106
106
107-- | assign weight to each element of `Squeal.PostgreSQL.Expression.Type.tsvector`
107-- | assign weight to each element of `Squeal.PostgreSQL.Expression.Type.tsvector`
108+setWeight
108−setWeight :: '[null 'PGtsvector, null ('PGchar 1)] ---> null 'PGtsvector
109+ :: FunctionN '[null 'PGtsvector, null ('PGchar 1)] (null 'PGtsvector)
109setWeight = unsafeFunctionN "set_weight"
110setWeight = unsafeFunctionN "set_weight"
110
111
111-- | remove positions and weights from `Squeal.PostgreSQL.Expression.Type.tsvector`
112-- | remove positions and weights from `Squeal.PostgreSQL.Expression.Type.tsvector`
112−strip :: null 'PGtsvector --> null 'PGtsvector
113+strip :: null 'PGtsvector :--> null 'PGtsvector
113strip = unsafeFunction "strip"
114strip = unsafeFunction "strip"
114
115
115-- | @jsonToTSvector (document *: filter)@
116-- | @jsonToTSvector (document *: filter)@
@@ -122,7 +123,7 @@ strip = unsafeFunction "strip"
122-- "boolean" (to include all Boolean values in the string format "true"/"false"),
123-- "boolean" (to include all Boolean values in the string format "true"/"false"),
123-- "key" (to include all keys) or "all" (to include all above).
124-- "key" (to include all keys) or "all" (to include all above).
124-- These values can be combined together to include, e.g. all string and numeric values.
125-- These values can be combined together to include, e.g. all string and numeric values.
125−jsonToTSvector :: '[null 'PGjson, null 'PGjson] ---> null 'PGtsvector
126+jsonToTSvector :: FunctionN '[null 'PGjson, null 'PGjson] (null 'PGtsvector)
126jsonToTSvector = unsafeFunctionN "json_to_tsvector"
127jsonToTSvector = unsafeFunctionN "json_to_tsvector"
127
128
128-- | @jsonbToTSvector (document *: filter)@
129-- | @jsonbToTSvector (document *: filter)@
@@ -135,23 +136,23 @@ jsonToTSvector = unsafeFunctionN "json_to_tsvector"
135-- "boolean" (to include all Boolean values in the string format "true"/"false"),
136-- "boolean" (to include all Boolean values in the string format "true"/"false"),
136-- "key" (to include all keys) or "all" (to include all above).
137-- "key" (to include all keys) or "all" (to include all above).
137-- These values can be combined together to include, e.g. all string and numeric values.
138-- These values can be combined together to include, e.g. all string and numeric values.
138−jsonbToTSvector :: '[null 'PGjsonb, null 'PGjsonb] ---> null 'PGtsvector
139+jsonbToTSvector :: FunctionN '[null 'PGjsonb, null 'PGjsonb] (null 'PGtsvector)
139jsonbToTSvector = unsafeFunctionN "jsonb_to_tsvector"
140jsonbToTSvector = unsafeFunctionN "jsonb_to_tsvector"
140
141
141-- | remove given lexeme from `Squeal.PostgreSQL.Expression.Type.tsvector`
142-- | remove given lexeme from `Squeal.PostgreSQL.Expression.Type.tsvector`
142−tsDelete ::
143+tsDelete :: FunctionN
143 '[null 'PGtsvector, null ('PGvararray ('NotNull 'PGtext))]
144 '[null 'PGtsvector, null ('PGvararray ('NotNull 'PGtext))]
144− ---> null 'PGtsvector
145+ (null 'PGtsvector)
145tsDelete = unsafeFunctionN "ts_delete"
146tsDelete = unsafeFunctionN "ts_delete"
146
147
147-- | select only elements with given weights from `Squeal.PostgreSQL.Expression.Type.tsvector`
148-- | select only elements with given weights from `Squeal.PostgreSQL.Expression.Type.tsvector`
148−tsFilter ::
149+tsFilter :: FunctionN
149 '[null 'PGtsvector, null ('PGvararray ('NotNull ('PGchar 1)))]
150 '[null 'PGtsvector, null ('PGvararray ('NotNull ('PGchar 1)))]
150− ---> null 'PGtsvector
151+ (null 'PGtsvector)
151tsFilter = unsafeFunctionN "ts_filter"
152tsFilter = unsafeFunctionN "ts_filter"
152
153
153-- | display a `Squeal.PostgreSQL.Expression.Type.tsquery` match
154-- | display a `Squeal.PostgreSQL.Expression.Type.tsquery` match
154tsHeadline
155tsHeadline
155 :: document `In` '[ 'PGtext, 'PGjson, 'PGjsonb]
156 :: document `In` '[ 'PGtext, 'PGjson, 'PGjsonb]
156− => '[null document, null 'PGtsquery] ---> null 'PGtext
157+ => FunctionN '[null document, null 'PGtsquery] (null 'PGtext)
157tsHeadline = unsafeFunctionN "ts_headline"
158tsHeadline = unsafeFunctionN "ts_headline"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Time.hs+12−7
@@ -17,7 +17,6 @@ Date/Time functions and operators
17 , OverloadedStrings
17 , OverloadedStrings
18 , PolyKinds
18 , PolyKinds
19 , RankNTypes
19 , RankNTypes
20− , TypeOperators
21#-}
20#-}
22
21
23module Squeal.PostgreSQL.Expression.Time
22module Squeal.PostgreSQL.Expression.Time
@@ -86,7 +85,9 @@ Create date from year, month and day fields
86>>> printSQL (makeDate (1984 :* 7 *: 3))
85>>> printSQL (makeDate (1984 :* 7 *: 3))
87make_date(1984, 7, 3)
86make_date(1984, 7, 3)
88-}
87-}
88+makeDate :: FunctionN
89−makeDate :: '[ null 'PGint4, null 'PGint4, null 'PGint4 ] ---> null 'PGdate
89+ '[ null 'PGint4, null 'PGint4, null 'PGint4 ]
90+ ( null 'PGdate )
90makeDate = unsafeFunctionN "make_date"
91makeDate = unsafeFunctionN "make_date"
91
92
92{-|
93{-|
@@ -95,7 +96,9 @@ Create time from hour, minute and seconds fields
95>>> printSQL (makeTime (8 :* 15 *: 23.5))
96>>> printSQL (makeTime (8 :* 15 *: 23.5))
96make_time(8, 15, 23.5)
97make_time(8, 15, 23.5)
97-}
98-}
99+makeTime :: FunctionN
98−makeTime :: '[ null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtime
100+ '[ null 'PGint4, null 'PGint4, null 'PGfloat8 ]
101+ ( null 'PGtime )
99makeTime = unsafeFunctionN "make_time"
102makeTime = unsafeFunctionN "make_time"
100
103
101{-|
104{-|
@@ -104,9 +107,10 @@ Create timestamp from year, month, day, hour, minute and seconds fields
104>>> printSQL (makeTimestamp (2013 :* 7 :* 15 :* 8 :* 15 *: 23.5))
107>>> printSQL (makeTimestamp (2013 :* 7 :* 15 :* 8 :* 15 *: 23.5))
105make_timestamp(2013, 7, 15, 8, 15, 23.5)
108make_timestamp(2013, 7, 15, 8, 15, 23.5)
106-}
109-}
107−makeTimestamp ::
110+makeTimestamp :: FunctionN
108 '[ null 'PGint4, null 'PGint4, null 'PGint4
111 '[ null 'PGint4, null 'PGint4, null 'PGint4
109− , null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtimestamp
112+ , null 'PGint4, null 'PGint4, null 'PGfloat8 ]
113+ ( null 'PGtimestamp )
110makeTimestamp = unsafeFunctionN "make_timestamp"
114makeTimestamp = unsafeFunctionN "make_timestamp"
111
115
112{-|
116{-|
@@ -117,9 +121,10 @@ the current time zone is used
117>>> printSQL (makeTimestamptz (2013 :* 7 :* 15 :* 8 :* 15 *: 23.5))
121>>> printSQL (makeTimestamptz (2013 :* 7 :* 15 :* 8 :* 15 *: 23.5))
118make_timestamptz(2013, 7, 15, 8, 15, 23.5)
122make_timestamptz(2013, 7, 15, 8, 15, 23.5)
119-}
123-}
120−makeTimestamptz ::
124+makeTimestamptz :: FunctionN
121 '[ null 'PGint4, null 'PGint4, null 'PGint4
125 '[ null 'PGint4, null 'PGint4, null 'PGint4
122− , null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtimestamptz
126+ , null 'PGint4, null 'PGint4, null 'PGfloat8 ]
127+ ( null 'PGtimestamptz )
123makeTimestamptz = unsafeFunctionN "make_timestamptz"
128makeTimestamptz = unsafeFunctionN "make_timestamptz"
124
129
125{-|
130{-|
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Type.hs+5−120
@@ -23,16 +23,14 @@ Type expressions.
23 , ScopedTypeVariables
23 , ScopedTypeVariables
24 , TypeApplications
24 , TypeApplications
25 , TypeOperators
25 , TypeOperators
26− , UndecidableInstances
27#-}
26#-}
28
27
29module Squeal.PostgreSQL.Expression.Type
28module Squeal.PostgreSQL.Expression.Type
30− ( -- * type casting
29+ ( TypeExpression (..)
31− cast
30+ , cast
32 , astype
31 , astype
33 , inferredtype
32 , inferredtype
34− -- * type expressions
33+ , PGTyped (..)
35− , TypeExpression (..)
36 , typedef
34 , typedef
37 , typetable
35 , typetable
38 , typeview
36 , typeview
@@ -58,11 +56,9 @@ module Squeal.PostgreSQL.Expression.Type
58 , bytea
56 , bytea
59 , timestamp
57 , timestamp
60 , timestampWithTimeZone
58 , timestampWithTimeZone
61− , timestamptz
62 , date
59 , date
63 , time
60 , time
64 , timeWithTimeZone
61 , timeWithTimeZone
65− , timetz
66 , interval
62 , interval
67 , uuid
63 , uuid
68 , inet
64 , inet
@@ -72,29 +68,12 @@ module Squeal.PostgreSQL.Expression.Type
72 , fixarray
68 , fixarray
73 , tsvector
69 , tsvector
74 , tsquery
70 , tsquery
75− , oid
76 , int4range
71 , int4range
77 , int8range
72 , int8range
78 , numrange
73 , numrange
79 , tsrange
74 , tsrange
80 , tstzrange
75 , tstzrange
81 , daterange
76 , daterange
82− -- * column type definitions
83− , ColumnTypeExpression (..)
84− , nullable
85− , notNullable
86− , default_
87− , serial2
88− , smallserial
89− , serial4
90− , serial
91− , serial8
92− , bigserial
93− , hask
94− -- * type inference
95− , PGTyped (..)
96− , PGNullityTyped (..)
97− , FieldTyped (..)
98 ) where
77 ) where
99
78
100import Control.DeepSeq
79import Control.DeepSeq
@@ -108,7 +87,6 @@ import qualified Generics.SOP as SOP
108
87
109import Squeal.PostgreSQL.Alias
88import Squeal.PostgreSQL.Alias
110import Squeal.PostgreSQL.Expression
89import Squeal.PostgreSQL.Expression
111−import Squeal.PostgreSQL.PG
112import Squeal.PostgreSQL.Render
90import Squeal.PostgreSQL.Render
113import Squeal.PostgreSQL.Schema
91import Squeal.PostgreSQL.Schema
114
92
@@ -150,7 +128,6 @@ astype = cast
150inferredtype
128inferredtype
151 :: PGTyped schemas ty
129 :: PGTyped schemas ty
152 => Expression outer common grp schemas params from ty
130 => Expression outer common grp schemas params from ty
153− -- ^ value
154 -> Expression outer common grp schemas params from ty
131 -> Expression outer common grp schemas params from ty
155inferredtype = astype pgtype
132inferredtype = astype pgtype
156
133
@@ -170,7 +147,6 @@ instance RenderSQL (TypeExpression schemas ty) where
170typedef
147typedef
171 :: (Has sch schemas schema, Has td schema ('Typedef ty))
148 :: (Has sch schemas schema, Has td schema ('Typedef ty))
172 => QualifiedAlias sch td
149 => QualifiedAlias sch td
173− -- ^ type alias
174 -> TypeExpression schemas (null ty)
150 -> TypeExpression schemas (null ty)
175typedef = UnsafeTypeExpression . renderSQL
151typedef = UnsafeTypeExpression . renderSQL
176
152
@@ -179,7 +155,6 @@ typedef = UnsafeTypeExpression . renderSQL
179typetable
155typetable
180 :: (Has sch schemas schema, Has tab schema ('Table table))
156 :: (Has sch schemas schema, Has tab schema ('Table table))
181 => QualifiedAlias sch tab
157 => QualifiedAlias sch tab
182− -- ^ table alias
183 -> TypeExpression schemas (null ('PGcomposite (TableToRow table)))
158 -> TypeExpression schemas (null ('PGcomposite (TableToRow table)))
184typetable = UnsafeTypeExpression . renderSQL
159typetable = UnsafeTypeExpression . renderSQL
185
160
@@ -188,7 +163,6 @@ typetable = UnsafeTypeExpression . renderSQL
188typeview
163typeview
189 :: (Has sch schemas schema, Has vw schema ('View view))
164 :: (Has sch schemas schema, Has vw schema ('View view))
190 => QualifiedAlias sch vw
165 => QualifiedAlias sch vw
191− -- ^ view alias
192 -> TypeExpression schemas (null ('PGcomposite view))
166 -> TypeExpression schemas (null ('PGcomposite view))
193typeview = UnsafeTypeExpression . renderSQL
167typeview = UnsafeTypeExpression . renderSQL
194
168
@@ -245,9 +219,8 @@ bytea = UnsafeTypeExpression "bytea"
245timestamp :: TypeExpression schemas (null 'PGtimestamp)
219timestamp :: TypeExpression schemas (null 'PGtimestamp)
246timestamp = UnsafeTypeExpression "timestamp"
220timestamp = UnsafeTypeExpression "timestamp"
247-- | date and time, including time zone
221-- | date and time, including time zone
248−timestampWithTimeZone, timestamptz :: TypeExpression schemas (null 'PGtimestamptz)
222+timestampWithTimeZone :: TypeExpression schemas (null 'PGtimestamptz)
249timestampWithTimeZone = UnsafeTypeExpression "timestamp with time zone"
223timestampWithTimeZone = UnsafeTypeExpression "timestamp with time zone"
250−timestamptz = UnsafeTypeExpression "timestamptz"
251-- | calendar date (year, month, day)
224-- | calendar date (year, month, day)
252date :: TypeExpression schemas (null 'PGdate)
225date :: TypeExpression schemas (null 'PGdate)
253date = UnsafeTypeExpression "date"
226date = UnsafeTypeExpression "date"
@@ -255,9 +228,8 @@ date = UnsafeTypeExpression "date"
255time :: TypeExpression schemas (null 'PGtime)
228time :: TypeExpression schemas (null 'PGtime)
256time = UnsafeTypeExpression "time"
229time = UnsafeTypeExpression "time"
257-- | time of day, including time zone
230-- | time of day, including time zone
258−timeWithTimeZone, timetz :: TypeExpression schemas (null 'PGtimetz)
231+timeWithTimeZone :: TypeExpression schemas (null 'PGtimetz)
259timeWithTimeZone = UnsafeTypeExpression "time with time zone"
232timeWithTimeZone = UnsafeTypeExpression "time with time zone"
260−timetz = UnsafeTypeExpression "timetz"
261-- | time span
233-- | time span
262interval :: TypeExpression schemas (null 'PGinterval)
234interval :: TypeExpression schemas (null 'PGinterval)
263interval = UnsafeTypeExpression "interval"
235interval = UnsafeTypeExpression "interval"
@@ -304,10 +276,6 @@ tsvector = UnsafeTypeExpression "tsvector"
304-- | text search document
276-- | text search document
305tsquery :: TypeExpression schemas (null 'PGtsquery)
277tsquery :: TypeExpression schemas (null 'PGtsquery)
306tsquery = UnsafeTypeExpression "tsquery"
278tsquery = UnsafeTypeExpression "tsquery"
307−-- | Object identifiers (OIDs) are used internally by PostgreSQL
308−-- as primary keys for various system tables.
309−oid :: TypeExpression schemas (null 'PGoid)
310−oid = UnsafeTypeExpression "oid"
311-- | Range of integer
279-- | Range of integer
312int4range :: TypeExpression schemas (null ('PGrange 'PGint4))
280int4range :: TypeExpression schemas (null ('PGrange 'PGint4))
313int4range = UnsafeTypeExpression "int4range"
281int4range = UnsafeTypeExpression "int4range"
@@ -361,86 +329,3 @@ instance (SOP.All KnownNat dims, PGTyped schemas ty)
361 pgtype = fixarray @dims (pgtype @schemas @ty)
329 pgtype = fixarray @dims (pgtype @schemas @ty)
362instance PGTyped schemas (null 'PGtsvector) where pgtype = tsvector
330instance PGTyped schemas (null 'PGtsvector) where pgtype = tsvector
363instance PGTyped schemas (null 'PGtsquery) where pgtype = tsquery
331instance PGTyped schemas (null 'PGtsquery) where pgtype = tsquery
364−instance PGTyped schemas (null 'PGoid) where pgtype = oid
365−instance PGTyped schemas (null ('PGrange 'PGint4)) where pgtype = int4range
366−instance PGTyped schemas (null ('PGrange 'PGint8)) where pgtype = int8range
367−instance PGTyped schemas (null ('PGrange 'PGnumeric)) where pgtype = numrange
368−instance PGTyped schemas (null ('PGrange 'PGtimestamp)) where pgtype = tsrange
369−instance PGTyped schemas (null ('PGrange 'PGtimestamptz)) where pgtype = tstzrange
370−instance PGTyped schemas (null ('PGrange 'PGdate)) where pgtype = daterange
371−
372−-- | Lift `PGTyped` to a field
373−class FieldTyped schemas ty where
374− fieldtype :: Aliased (TypeExpression schemas) ty
375−instance (KnownSymbol alias, PGTyped schemas ty)
376− => FieldTyped schemas (alias ::: ty) where
377− fieldtype = pgtype `As` Alias
378−
379−-- | `ColumnTypeExpression`s are used in `createTable` commands.
380−newtype ColumnTypeExpression (schemas :: SchemasType) (ty :: ColumnType)
381− = UnsafeColumnTypeExpression { renderColumnTypeExpression :: ByteString }
382− deriving (GHC.Generic,Show,Eq,Ord,NFData)
383−instance RenderSQL (ColumnTypeExpression schemas ty) where
384− renderSQL = renderColumnTypeExpression
385−
386−-- | used in `createTable` commands as a column constraint to note that
387−-- @NULL@ may be present in a column
388−nullable
389− :: TypeExpression schemas (nullity ty)
390− -> ColumnTypeExpression schemas ('NoDef :=> 'Null ty)
391−nullable ty = UnsafeColumnTypeExpression $ renderSQL ty <+> "NULL"
392−
393−-- | used in `createTable` commands as a column constraint to ensure
394−-- @NULL@ is not present in a column
395−notNullable
396− :: TypeExpression schemas (nullity ty)
397− -> ColumnTypeExpression schemas ('NoDef :=> 'NotNull ty)
398−notNullable ty = UnsafeColumnTypeExpression $ renderSQL ty <+> "NOT NULL"
399−
400−-- | used in `createTable` commands as a column constraint to give a default
401−default_
402− :: Expression '[] '[] 'Ungrouped schemas '[] '[] ty
403− -> ColumnTypeExpression schemas ('NoDef :=> ty)
404− -> ColumnTypeExpression schemas ('Def :=> ty)
405−default_ x ty = UnsafeColumnTypeExpression $
406− renderSQL ty <+> "DEFAULT" <+> renderExpression x
407−
408−-- | not a true type, but merely a notational convenience for creating
409−-- unique identifier columns with type `PGint2`
410−serial2, smallserial
411− :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint2)
412−serial2 = UnsafeColumnTypeExpression "serial2"
413−smallserial = UnsafeColumnTypeExpression "smallserial"
414−-- | not a true type, but merely a notational convenience for creating
415−-- unique identifier columns with type `PGint4`
416−serial4, serial
417− :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint4)
418−serial4 = UnsafeColumnTypeExpression "serial4"
419−serial = UnsafeColumnTypeExpression "serial"
420−-- | not a true type, but merely a notational convenience for creating
421−-- unique identifier columns with type `PGint8`
422−serial8, bigserial
423− :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint8)
424−serial8 = UnsafeColumnTypeExpression "serial8"
425−bigserial = UnsafeColumnTypeExpression "bigserial"
426−
427−-- | Like @PGTyped@ but also accounts for nullity.
428−class PGNullityTyped schemas (nullty :: NullityType) where
429− pgNullityType :: ColumnTypeExpression schemas ('NoDef :=> nullty)
430−
431−instance PGTyped schemas ('Null ty) => PGNullityTyped schemas ('Null ty) where
432− pgNullityType = nullable (pgtype @_ @('Null ty))
433−
434−instance PGTyped schemas ('NotNull ty) => PGNullityTyped schemas ('NotNull ty) where
435− pgNullityType = notNullable (pgtype @_ @('NotNull ty))
436−
437−-- | Allow you to specify pg column types in relation to haskell types.
438−-- >>> printSQL $ hask @(Maybe String)
439−-- text NULL
440−--
441−-- >>> printSQL $ hask @Double
442−-- float8 NOT NULL
443−hask
444− :: forall hask schemas. PGNullityTyped schemas (NullPG hask)
445− => ColumnTypeExpression schemas ('NoDef :=> NullPG hask)
446−hask = pgNullityType
squeal-postgresql/src/Squeal/PostgreSQL/List.hs+46−17
@@ -33,16 +33,16 @@ module Squeal.PostgreSQL.List
33 , Join
33 , Join
34 , disjoin
34 , disjoin
35 , Additional (..)
35 , Additional (..)
36− , Path (..)
36+ , AlignedList (..)
37− , CFunctor (..)
37+ , single
38− , CFoldable (..)
38+ , extractList
39− , CFree (..)
39+ , mapAligned
40 , Elem
40 , Elem
41 , In
41 , In
42 , Length
42 , Length
43 ) where
43 ) where
44
44
45−import Control.Category.Free
45+import Control.Category
46import Data.Function ((&))
46import Data.Function ((&))
47import Data.Kind
47import Data.Kind
48import Data.Type.Bool
48import Data.Type.Bool
@@ -50,6 +50,8 @@ import GHC.TypeLits
50
50
51import Generics.SOP as SOP
51import Generics.SOP as SOP
52
52
53+import Squeal.PostgreSQL.Render
54+
53-- | `Join` is simply promoted `++` and is used in @JOIN@s in
55-- | `Join` is simply promoted `++` and is used in @JOIN@s in
54-- `Squeal.PostgreSQL.Query.FromClause`s.
56-- `Squeal.PostgreSQL.Query.FromClause`s.
55type family Join xs ys where
57type family Join xs ys where
@@ -76,6 +78,42 @@ instance Additional (NP expr) where
76 Nil -> ys
78 Nil -> ys
77 x :* xs -> x :* (xs & also ys)
79 x :* xs -> x :* (xs & also ys)
78
80
81+-- | An `AlignedList` is a type-aligned list or free category.
82+data AlignedList p x0 x1 where
83+ Done :: AlignedList p x x
84+ (:>>) :: p x0 x1 -> AlignedList p x1 x2 -> AlignedList p x0 x2
85+infixr 7 :>>
86+instance Category (AlignedList p) where
87+ id = Done
88+ (.) list = \case
89+ Done -> list
90+ step :>> steps -> step :>> (steps >>> list)
91+instance (forall t0 t1. RenderSQL (p t0 t1))
92+ => RenderSQL (AlignedList p x0 x1) where
93+ renderSQL = \case
94+ Done -> ""
95+ step :>> Done -> renderSQL step
96+ step :>> steps -> renderSQL step <> ", " <> renderSQL steps
97+
98+-- | `extractList` turns an `AlignedList` into a standard list.
99+extractList :: (forall a0 a1. p a0 a1 -> b) -> AlignedList p x0 x1 -> [b]
100+extractList f = \case
101+ Done -> []
102+ step :>> steps -> (f step):extractList f steps
103+
104+-- | `mapAligned` applies a function to each element of an `AlignedList`.
105+mapAligned
106+ :: (forall z0 z1. p z0 z1 -> q z0 z1)
107+ -> AlignedList p x0 x1
108+ -> AlignedList q x0 x1
109+mapAligned f = \case
110+ Done -> Done
111+ x :>> xs -> f x :>> mapAligned f xs
112+
113+-- | A `single` step.
114+single :: p x0 x1 -> AlignedList p x0 x1
115+single step = step :>> Done
116+
79-- | A useful operator for ending an `NP` list of length at least 2 without `Nil`.
117-- | A useful operator for ending an `NP` list of length at least 2 without `Nil`.
80(*:) :: f x -> f y -> NP f '[x,y]
118(*:) :: f x -> f y -> NP f '[x,y]
81x *: y = x :* y :* Nil
119x *: y = x :* y :* Nil
@@ -84,18 +122,13 @@ infixl 9 *:
84-- | @Elem@ is a promoted `Data.List.elem`.
122-- | @Elem@ is a promoted `Data.List.elem`.
85type family Elem x xs where
123type family Elem x xs where
86 Elem x '[] = 'False
124 Elem x '[] = 'False
87− Elem x (x ': _) = 'True
125+ Elem x (x ': xs) = 'True
88− Elem x (_ ': x ': _) = 'True
89− Elem x (_ ': _ ': x ': _) = 'True
90− Elem x (_ ': _ ': _ ': x ': _) = 'True
91− Elem x (_ ': _ ': _ ': _ ': x ': _) = 'True
92− Elem x (_ ': _ ': _ ': _ ': _ ': x ': _) = 'True
93 Elem x (_ ': xs) = Elem x xs
126 Elem x (_ ': xs) = Elem x xs
94
127
95-- | @In x xs@ is a constraint that proves that @x@ is in @xs@.
128-- | @In x xs@ is a constraint that proves that @x@ is in @xs@.
96type family In x xs :: Constraint where
129type family In x xs :: Constraint where
97 In x xs = If (Elem x xs) (() :: Constraint)
130 In x xs = If (Elem x xs) (() :: Constraint)
98− (TypeError ('ShowType x ':<>: 'Text " is not in " ':<>: 'ShowType xs))
131+ (TypeError ('ShowType x ':<>: 'Text "is not in " ':<>: 'ShowType xs))
99
132
100{- | Calculate the `Length` of a type level list
133{- | Calculate the `Length` of a type level list
101
134
@@ -104,9 +137,5 @@ Length '[Char,String,Bool,Double] :: Nat
104= 4
137= 4
105-}
138-}
106type family Length (xs :: [k]) :: Nat where
139type family Length (xs :: [k]) :: Nat where
107− Length (_ ': _ ': _ ': _ ': _ : xs) = 5 + Length xs
108− Length (_ ': _ ': _ ': _ : xs) = 4 + Length xs
109− Length (_ ': _ ': _ : xs) = 3 + Length xs
110− Length (_ ': _ : xs) = 2 + Length xs
111− Length (_ : xs) = 1 + Length xs
140+ Length (x : xs) = 1 + Length xs
112 Length '[] = 0
141 Length '[] = 0
squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs+24−33
@@ -99,7 +99,7 @@ instance RenderSQL (Manipulation commons schemas params columns) where
99instance With Manipulation where
99instance With Manipulation where
100 with Done manip = manip
100 with Done manip = manip
101 with ctes manip = UnsafeManipulation $
101 with ctes manip = UnsafeManipulation $
102− "WITH" <+> commaSeparated (ctoList renderSQL ctes) <+> renderSQL manip
102+ "WITH" <+> renderSQL ctes <+> renderSQL manip
103
103
104{- |
104{- |
105The top level `Manipulation_` type is parameterized by a @schemas@ `SchemasType`,
105The top level `Manipulation_` type is parameterized by a @schemas@ `SchemasType`,
@@ -249,7 +249,6 @@ type family Manipulation_ (schemas :: SchemasType) (params :: Type) (row :: Type
249-- | Convert a `Query` into a `Manipulation`.
249-- | Convert a `Query` into a `Manipulation`.
250queryStatement
250queryStatement
251 :: Query '[] commons schemas params columns
251 :: Query '[] commons schemas params columns
252− -- ^ `Query` to embed as a `Manipulation`
253 -> Manipulation commons schemas params columns
252 -> Manipulation commons schemas params columns
254queryStatement q = UnsafeManipulation $ renderSQL q
253queryStatement q = UnsafeManipulation $ renderSQL q
255
254
@@ -272,13 +271,9 @@ insertInto
272 , SOP.SListI columns
271 , SOP.SListI columns
273 , SOP.SListI row1 )
272 , SOP.SListI row1 )
274 => QualifiedAlias sch tab
273 => QualifiedAlias sch tab
275− -- ^ table
276 -> QueryClause commons schemas params columns
274 -> QueryClause commons schemas params columns
277− -- ^ what to insert
278 -> ConflictClause tab commons schemas params table
275 -> ConflictClause tab commons schemas params table
279− -- ^ what to do in case of conflict
280 -> ReturningClause commons schemas params '[tab ::: row0] row1
276 -> ReturningClause commons schemas params '[tab ::: row0] row1
281− -- ^ what to return
282 -> Manipulation commons schemas params row1
277 -> Manipulation commons schemas params row1
283insertInto tab qry conflict ret = UnsafeManipulation $
278insertInto tab qry conflict ret = UnsafeManipulation $
284 "INSERT" <+> "INTO" <+> renderSQL tab
279 "INSERT" <+> "INTO" <+> renderSQL tab
@@ -286,7 +281,7 @@ insertInto tab qry conflict ret = UnsafeManipulation $
286 <> renderSQL conflict
281 <> renderSQL conflict
287 <> renderSQL ret
282 <> renderSQL ret
288
283
289−-- | Like `insertInto` but with `OnConflictDoRaise` and `no` `ReturningClause`.
284+-- | Like `insertInto` but with `OnConflictDoRaise` and no `ReturningClause`.
290insertInto_
285insertInto_
291 :: ( Has sch schemas schema
286 :: ( Has sch schemas schema
292 , Has tab schema ('Table table)
287 , Has tab schema ('Table table)
@@ -294,33 +289,30 @@ insertInto_
294 , row ~ TableToRow table
289 , row ~ TableToRow table
295 , SOP.SListI columns )
290 , SOP.SListI columns )
296 => QualifiedAlias sch tab
291 => QualifiedAlias sch tab
297− -- ^ table
298 -> QueryClause commons schemas params columns
292 -> QueryClause commons schemas params columns
299− -- ^ what to insert
300 -> Manipulation commons schemas params '[]
293 -> Manipulation commons schemas params '[]
301insertInto_ tab qry =
294insertInto_ tab qry =
302 insertInto tab qry OnConflictDoRaise (Returning_ Nil)
295 insertInto tab qry OnConflictDoRaise (Returning_ Nil)
303
296
304-- | A `QueryClause` describes what to `insertInto` a table.
297-- | A `QueryClause` describes what to `insertInto` a table.
305data QueryClause commons schemas params columns where
298data QueryClause commons schemas params columns where
299+ -- | `Values` describes `NP` lists of `Aliased` `Optional` `Expression`s
300+ -- whose `ColumnsType` must match the tables'.
306 Values
301 Values
307 :: SOP.SListI columns
302 :: SOP.SListI columns
308 => NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[]))) columns
303 => NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[]))) columns
309− -- ^ row of values
310 -> [NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[]))) columns]
304 -> [NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[]))) columns]
311− -- ^ additional rows of values
312 -> QueryClause commons schemas params columns
305 -> QueryClause commons schemas params columns
306+ -- | `Select` describes a subquery that permits use of `Optional` `Expression`s.
313 Select
307 Select
314 :: SOP.SListI columns
308 :: SOP.SListI columns
315 => NP (Aliased (Optional (Expression '[] commons grp schemas params from))) columns
309 => NP (Aliased (Optional (Expression '[] commons grp schemas params from))) columns
316− -- ^ row of values
317 -> TableExpression '[] commons grp schemas params from
310 -> TableExpression '[] commons grp schemas params from
318− -- ^ from a table expression
319 -> QueryClause commons schemas params columns
311 -> QueryClause commons schemas params columns
312+ -- | `Subquery` describes a subquery whose `RowType` must match the tables'.
320 Subquery
313 Subquery
321 :: ColumnsToRow columns ~ row
314 :: ColumnsToRow columns ~ row
322 => Query '[] commons schemas params row
315 => Query '[] commons schemas params row
323− -- ^ subquery to insert
324 -> QueryClause commons schemas params columns
316 -> QueryClause commons schemas params columns
325
317
326instance RenderSQL (QueryClause commons schemas params columns) where
318instance RenderSQL (QueryClause commons schemas params columns) where
@@ -358,7 +350,6 @@ instance RenderSQL (QueryClause commons schemas params columns) where
358pattern Values_
350pattern Values_
359 :: SOP.SListI columns
351 :: SOP.SListI columns
360 => NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[]))) columns
352 => NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[]))) columns
361− -- ^ row of values
362 -> QueryClause commons schemas params columns
353 -> QueryClause commons schemas params columns
363pattern Values_ vals = Values vals []
354pattern Values_ vals = Values vals []
364
355
@@ -383,7 +374,7 @@ instance (forall x. RenderSQL (expr x)) => RenderSQL (Optional expr ty) where
383-- deleted will be returned. For example, if a row was locked
374-- deleted will be returned. For example, if a row was locked
384-- but not updated because an `OnConflict` `DoUpdate` condition was not satisfied,
375-- but not updated because an `OnConflict` `DoUpdate` condition was not satisfied,
385-- the row will not be returned. `Returning` `Star` will return all columns
376-- the row will not be returned. `Returning` `Star` will return all columns
386−-- in the row. Use `Returning` `Nil` in the common case where no return
377+-- in the row. Use @Returning Nil@ in the common case where no return
387-- values are desired.
378-- values are desired.
388newtype ReturningClause commons schemas params from row =
379newtype ReturningClause commons schemas params from row =
389 Returning (Selection '[] commons 'Ungrouped schemas params from row)
380 Returning (Selection '[] commons 'Ungrouped schemas params from row)
@@ -397,7 +388,6 @@ instance RenderSQL (ReturningClause commons schemas params from row) where
397pattern Returning_
388pattern Returning_
398 :: SOP.SListI row
389 :: SOP.SListI row
399 => NP (Aliased (Expression '[] commons 'Ungrouped schemas params from)) row
390 => NP (Aliased (Expression '[] commons 'Ungrouped schemas params from)) row
400− -- ^ row of values
401 -> ReturningClause commons schemas params from row
391 -> ReturningClause commons schemas params from row
402pattern Returning_ list = Returning (List list)
392pattern Returning_ list = Returning (List list)
403
393
@@ -410,9 +400,7 @@ data ConflictClause tab commons schemas params table where
410 OnConflictDoRaise :: ConflictClause tab commons schemas params table
400 OnConflictDoRaise :: ConflictClause tab commons schemas params table
411 OnConflict
401 OnConflict
412 :: ConflictTarget constraints
402 :: ConflictTarget constraints
413− -- ^ conflict target
414 -> ConflictAction tab commons schemas params columns
403 -> ConflictAction tab commons schemas params columns
415− -- ^ conflict action
416 -> ConflictClause tab commons schemas params (constraints :=> columns)
404 -> ConflictClause tab commons schemas params (constraints :=> columns)
417
405
418-- | Render a `ConflictClause`.
406-- | Render a `ConflictClause`.
@@ -430,12 +418,12 @@ the exact details of the `update` action to be performed in case of a conflict.
430The `Set` and WHERE `Condition`s in `OnConflict` `DoUpdate` have access to the
418The `Set` and WHERE `Condition`s in `OnConflict` `DoUpdate` have access to the
431existing row using the table's name (or an alias), and to rows proposed
419existing row using the table's name (or an alias), and to rows proposed
432for insertion using the special @#excluded@ table.
420for insertion using the special @#excluded@ table.
433−`OnConflict` `DoNothing` simply avoids inserting a row as its alternative action.
434−`OnConflict` `DoUpdate` updates the existing row that conflicts
435−with the row proposed for insertion as its alternative action.
436-}
421-}
437data ConflictAction tab commons schemas params columns where
422data ConflictAction tab commons schemas params columns where
423+ -- | `OnConflict` `DoNothing` simply avoids inserting a row as its alternative action.
438 DoNothing :: ConflictAction tab commons schemas params columns
424 DoNothing :: ConflictAction tab commons schemas params columns
425+ -- | `OnConflict` `DoUpdate` updates the existing row that conflicts
426+ -- with the row proposed for insertion as its alternative action.
439 DoUpdate
427 DoUpdate
440 :: ( row ~ ColumnsToRow columns
428 :: ( row ~ ColumnsToRow columns
441 , SOP.SListI columns
429 , SOP.SListI columns
@@ -485,6 +473,7 @@ UPDATE statements
485update
473update
486 :: ( SOP.SListI columns
474 :: ( SOP.SListI columns
487 , SOP.SListI row1
475 , SOP.SListI row1
476+ , db ~ (commons :=> schemas)
488 , Has sch schemas schema
477 , Has sch schemas schema
489 , Has tab schema ('Table table)
478 , Has tab schema ('Table table)
490 , row0 ~ TableToRow table
479 , row0 ~ TableToRow table
@@ -509,6 +498,7 @@ update tab columns wh returning = UnsafeManipulation $
509-- | Update a row returning `Nil`.
498-- | Update a row returning `Nil`.
510update_
499update_
511 :: ( SOP.SListI columns
500 :: ( SOP.SListI columns
501+ , db ~ (commons :=> schemas)
512 , Has sch schemas schema
502 , Has sch schemas schema
513 , Has tab schema ('Table table)
503 , Has tab schema ('Table table)
514 , row ~ TableToRow table
504 , row ~ TableToRow table
@@ -527,25 +517,25 @@ update_ tab columns wh = update tab columns wh (Returning_ Nil)
527DELETE statements
517DELETE statements
528-----------------------------------------}
518-----------------------------------------}
529
519
530−-- | Specify additional tables with `Using`
520+-- | Specify additional tables.
531−-- an `also` list of table expressions, allowing columns
532−-- from other tables to appear in the WHERE condition.
533−-- This is similar to the list of tables that can be specified
534−-- in the FROM Clause of a SELECT statement;
535−-- for example, an alias for the table name can be specified.
536−-- Do not repeat the target table in the `Using` list,
537−-- unless you wish to set up a self-join.
538−-- `NoUsing` if no additional tables are to be used.
539data UsingClause commons schemas params from where
521data UsingClause commons schemas params from where
522+ -- | No `UsingClause`
540 NoUsing :: UsingClause commons schemas params '[]
523 NoUsing :: UsingClause commons schemas params '[]
524+ -- | An `also` list of table expressions, allowing columns
525+ -- from other tables to appear in the WHERE condition.
526+ -- This is similar to the list of tables that can be specified
527+ -- in the FROM Clause of a SELECT statement;
528+ -- for example, an alias for the table name can be specified.
529+ -- Do not repeat the target table in the `Using` list,
530+ -- unless you wish to set up a self-join.
541 Using
531 Using
542 :: FromClause '[] commons schemas params from
532 :: FromClause '[] commons schemas params from
543− -- ^ what to use
544 -> UsingClause commons schemas params from
533 -> UsingClause commons schemas params from
545
534
546-- | Delete rows from a table.
535-- | Delete rows from a table.
547deleteFrom
536deleteFrom
548 :: ( SOP.SListI row1
537 :: ( SOP.SListI row1
538+ , db ~ (commons :=> schemas)
549 , Has sch schemas schema
539 , Has sch schemas schema
550 , Has tab schema ('Table table)
540 , Has tab schema ('Table table)
551 , row0 ~ TableToRow table
541 , row0 ~ TableToRow table
@@ -567,7 +557,8 @@ deleteFrom tab using wh returning = UnsafeManipulation $
567
557
568-- | Delete rows returning `Nil`.
558-- | Delete rows returning `Nil`.
569deleteFrom_
559deleteFrom_
560+ :: ( db ~ (commons :=> schemas)
570− :: ( Has sch schemas schema
561+ , Has sch schemas schema
571 , Has tab schema ('Table table)
562 , Has tab schema ('Table table)
572 , row ~ TableToRow table
563 , row ~ TableToRow table
573 , columns ~ TableToColumns table )
564 , columns ~ TableToColumns table )
squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs+12−14
@@ -66,7 +66,7 @@ let
66 }
66 }
67:}
67:}
68
68
69−Now that we have a couple migrations we can chain them together into a `Path`.
69+Now that we have a couple migrations we can chain them together into an `AlignedList`.
70
70
71>>> let migrations = makeUsers :>> makeEmails :>> Done
71>>> let migrations = makeUsers :>> makeEmails :>> Done
72
72
@@ -167,8 +167,6 @@ import qualified GHC.Generics as GHC
167import Squeal.PostgreSQL.Alias
167import Squeal.PostgreSQL.Alias
168import Squeal.PostgreSQL.Binary
168import Squeal.PostgreSQL.Binary
169import Squeal.PostgreSQL.Definition
169import Squeal.PostgreSQL.Definition
170−import Squeal.PostgreSQL.Definition.Table
171−import Squeal.PostgreSQL.Definition.Table.Constraint
172import Squeal.PostgreSQL.Expression.Comparison
170import Squeal.PostgreSQL.Expression.Comparison
173import Squeal.PostgreSQL.Expression.Parameter
171import Squeal.PostgreSQL.Expression.Parameter
174import Squeal.PostgreSQL.Expression.Time
172import Squeal.PostgreSQL.Expression.Time
@@ -192,34 +190,34 @@ data Migration p schemas0 schemas1 = Migration
192
190
193{- |
191{- |
194A `Migratory` @p@ is a `Category` for which one can execute or rewind
192A `Migratory` @p@ is a `Category` for which one can execute or rewind
195−a `Path` of `Migration`s over @p@. This includes the category of pure
193+an `AlignedList` of `Migration`s over @p@. This includes the category of pure
196SQL `Definition`s and the category of impure `Terminally` `PQ` `IO` actions.
194SQL `Definition`s and the category of impure `Terminally` `PQ` `IO` actions.
197-}
195-}
198class Category p => Migratory p where
196class Category p => Migratory p where
199
197
200 {- |
198 {- |
201− Run a `Path` of `Migration`s.
199+ Run an `AlignedList` of `Migration`s.
202 Create the `MigrationsTable` as @public.schema_migrations@ if it does not already exist.
200 Create the `MigrationsTable` as @public.schema_migrations@ if it does not already exist.
203 In one transaction, for each each `Migration` query to see if the `Migration` has been executed;
201 In one transaction, for each each `Migration` query to see if the `Migration` has been executed;
204 if not, `up` the `Migration` and insert its `name` in the `MigrationsTable`.
202 if not, `up` the `Migration` and insert its `name` in the `MigrationsTable`.
205 -}
203 -}
206 migrateUp
204 migrateUp
207− :: Path (Migration p) schemas0 schemas1
205+ :: AlignedList (Migration p) schemas0 schemas1
208 -> PQ schemas0 schemas1 IO ()
206 -> PQ schemas0 schemas1 IO ()
209
207
210 {- |
208 {- |
211− Rewind a `Path` of `Migration`s.
209+ Rewind an `AlignedList` of `Migration`s.
212 Create the `MigrationsTable` as @public.schema_migrations@ if it does not already exist.
210 Create the `MigrationsTable` as @public.schema_migrations@ if it does not already exist.
213 In one transaction, for each each `Migration` query to see if the `Migration` has been executed;
211 In one transaction, for each each `Migration` query to see if the `Migration` has been executed;
214 if so, `down` the `Migration` and delete its `name` in the `MigrationsTable`.
212 if so, `down` the `Migration` and delete its `name` in the `MigrationsTable`.
215 -}
213 -}
216 migrateDown
214 migrateDown
217− :: Path (Migration p) schemas0 schemas1
215+ :: AlignedList (Migration p) schemas0 schemas1
218 -> PQ schemas1 schemas0 IO ()
216 -> PQ schemas1 schemas0 IO ()
219
217
220instance Migratory Definition where
218instance Migratory Definition where
221− migrateUp = migrateUp . cmap pureMigration
219+ migrateUp = migrateUp . mapAligned pureMigration
222− migrateDown = migrateDown . cmap pureMigration
220+ migrateDown = migrateDown . mapAligned pureMigration
223
221
224{- | `Terminally` turns an indexed monad transformer and the monad it transforms
222{- | `Terminally` turns an indexed monad transformer and the monad it transforms
225into a category by restricting the return type to @()@ and permuting the type variables.
223into a category by restricting the return type to @()@ and permuting the type variables.
@@ -268,7 +266,7 @@ instance Migratory (Terminally PQ IO) where
268 where
266 where
269
267
270 upMigrations
268 upMigrations
271− :: Path (Migration (Terminally PQ IO)) schemas0 schemas1
269+ :: AlignedList (Migration (Terminally PQ IO)) schemas0 schemas1
272 -> PQ MigrationsSchemas MigrationsSchemas IO ()
270 -> PQ MigrationsSchemas MigrationsSchemas IO ()
273 upMigrations = \case
271 upMigrations = \case
274 Done -> return ()
272 Done -> return ()
@@ -297,7 +295,7 @@ instance Migratory (Terminally PQ IO) where
297 where
295 where
298
296
299 downMigrations
297 downMigrations
300− :: Path (Migration (Terminally PQ IO)) schemas0 schemas1
298+ :: AlignedList (Migration (Terminally PQ IO)) schemas0 schemas1
301 -> PQ MigrationsSchemas MigrationsSchemas IO ()
299 -> PQ MigrationsSchemas MigrationsSchemas IO ()
302 downMigrations = \case
300 downMigrations = \case
303 Done -> return ()
301 Done -> return ()
@@ -384,7 +382,7 @@ defaultMain
384 :: Migratory p
382 :: Migratory p
385 => ByteString
383 => ByteString
386 -- ^ connection string
384 -- ^ connection string
387− -> Path (Migration p) db0 db1
385+ -> AlignedList (Migration p) db0 db1
388 -- ^ migrations
386 -- ^ migrations
389 -> IO ()
387 -> IO ()
390defaultMain connectTo migrations = do
388defaultMain connectTo migrations = do
@@ -405,7 +403,7 @@ defaultMain connectTo migrations = do
405 migrateStatus :: PQ schema schema IO ()
403 migrateStatus :: PQ schema schema IO ()
406 migrateStatus = unsafePQ $ do
404 migrateStatus = unsafePQ $ do
407 runNames <- getRunMigrationNames
405 runNames <- getRunMigrationNames
408− let names = ctoList name migrations
406+ let names = extractList name migrations
409 unrunNames = names \\ runNames
407 unrunNames = names \\ runNames
410 liftIO $ displayRunned runNames >> displayUnrunned unrunNames
408 liftIO $ displayRunned runNames >> displayUnrunned unrunNames
411
409
squeal-postgresql/src/Squeal/PostgreSQL/PG.hs+17−39
@@ -10,12 +10,10 @@ Stability: experimental
10-}
10-}
11{-# LANGUAGE
11{-# LANGUAGE
12 AllowAmbiguousTypes
12 AllowAmbiguousTypes
13− , DeriveAnyClass
14 , DeriveFoldable
13 , DeriveFoldable
15 , DeriveFunctor
14 , DeriveFunctor
16 , DeriveGeneric
15 , DeriveGeneric
17 , DeriveTraversable
16 , DeriveTraversable
18− , DerivingStrategies
19 , DefaultSignatures
17 , DefaultSignatures
20 , FlexibleContexts
18 , FlexibleContexts
21 , FlexibleInstances
19 , FlexibleInstances
@@ -24,6 +22,7 @@ Stability: experimental
24 , LambdaCase
22 , LambdaCase
25 , MultiParamTypeClasses
23 , MultiParamTypeClasses
26 , OverloadedStrings
24 , OverloadedStrings
25+ , PatternSynonyms
27 , ScopedTypeVariables
26 , ScopedTypeVariables
28 , TypeApplications
27 , TypeApplications
29 , TypeFamilies
28 , TypeFamilies
@@ -39,7 +38,7 @@ module Squeal.PostgreSQL.PG
39 , NullPG
38 , NullPG
40 , TuplePG
39 , TuplePG
41 , RowPG
40 , RowPG
42− -- * Storage newtypes
41+ -- * Storage types
43 , Money (..)
42 , Money (..)
44 , Json (..)
43 , Json (..)
45 , Jsonb (..)
44 , Jsonb (..)
@@ -47,7 +46,6 @@ module Squeal.PostgreSQL.PG
47 , Enumerated (..)
46 , Enumerated (..)
48 , VarArray (..)
47 , VarArray (..)
49 , FixArray (..)
48 , FixArray (..)
50− , LibPQ.Oid (..)
51 -- * Type families
49 -- * Type families
52 , LabelsPG
50 , LabelsPG
53 , DimPG
51 , DimPG
@@ -66,6 +64,7 @@ import Data.Int (Int16, Int32, Int64)
66import Data.Scientific (Scientific)
64import Data.Scientific (Scientific)
67import Data.Time (Day, DiffTime, LocalTime, TimeOfDay, TimeZone, UTCTime)
65import Data.Time (Day, DiffTime, LocalTime, TimeOfDay, TimeZone, UTCTime)
68import Data.Vector (Vector)
66import Data.Vector (Vector)
67+import Data.Word (Word16, Word32, Word64)
69import Data.UUID.Types (UUID)
68import Data.UUID.Types (UUID)
70import GHC.TypeLits
69import GHC.TypeLits
71import Network.IP.Addr (NetAddr, IP)
70import Network.IP.Addr (NetAddr, IP)
@@ -74,7 +73,6 @@ import qualified Data.ByteString.Lazy as Lazy (ByteString)
74import qualified Data.ByteString as Strict (ByteString)
73import qualified Data.ByteString as Strict (ByteString)
75import qualified Data.Text.Lazy as Lazy (Text)
74import qualified Data.Text.Lazy as Lazy (Text)
76import qualified Data.Text as Strict (Text)
75import qualified Data.Text as Strict (Text)
77−import qualified Database.PostgreSQL.LibPQ as LibPQ
78import qualified GHC.Generics as GHC
76import qualified GHC.Generics as GHC
79import qualified Generics.SOP as SOP
77import qualified Generics.SOP as SOP
80import qualified Generics.SOP.Record as SOP
78import qualified Generics.SOP.Record as SOP
@@ -108,7 +106,11 @@ type instance PG Int32 = 'PGint4
108-- | `PGint8`
106-- | `PGint8`
109type instance PG Int64 = 'PGint8
107type instance PG Int64 = 'PGint8
110-- | `PGint2`
108-- | `PGint2`
111−type instance PG LibPQ.Oid = 'PGoid
109+type instance PG Word16 = 'PGint2
110+-- | `PGint4`
111+type instance PG Word32 = 'PGint4
112+-- | `PGint8`
113+type instance PG Word64 = 'PGint8
112-- | `PGnumeric`
114-- | `PGnumeric`
113type instance PG Scientific = 'PGnumeric
115type instance PG Scientific = 'PGnumeric
114-- | `PGfloat4`
116-- | `PGfloat4`
@@ -178,16 +180,8 @@ type family RowPG (hask :: Type) :: RowType where
178
180
179-- | `RowOf` applies `NullPG` to the fields of a list.
181-- | `RowOf` applies `NullPG` to the fields of a list.
180type family RowOf (record :: [(Symbol, Type)]) :: RowType where
182type family RowOf (record :: [(Symbol, Type)]) :: RowType where
181− RowOf (col ::: ty ': col1 ::: ty1 ': col2 ::: ty2 ': col3 ::: ty3 ': col4 ::: ty4 ': record) =
182− col ::: NullPG ty ': col1 ::: NullPG ty1 ': col2 ::: NullPG ty2 ': col3 ::: NullPG ty3 ': col4 ::: NullPG ty4 ': RowOf record
183− RowOf (col ::: ty ': col1 ::: ty1 ': col2 ::: ty2 ': col3 ::: ty3 ': record) =
184− col ::: NullPG ty ': col1 ::: NullPG ty1 ': col2 ::: NullPG ty2 ': col3 ::: NullPG ty3 ': RowOf record
185− RowOf (col ::: ty ': col1 ::: ty1 ': col2 ::: ty2 ': record) =
186− col ::: NullPG ty ': col1 ::: NullPG ty1 ': col2 ::: NullPG ty2 ': RowOf record
187− RowOf (col ::: ty ': col1 ::: ty1 ': record) =
188− col ::: NullPG ty ': col1::: NullPG ty1 ': RowOf record
189− RowOf (col ::: ty ': record) = col ::: NullPG ty ': RowOf record
190 RowOf '[] = '[]
183 RowOf '[] = '[]
184+ RowOf (col ::: ty ': record) = col ::: NullPG ty ': RowOf record
191
185
192{- | `NullPG` turns a Haskell type into a `NullityType`.
186{- | `NullPG` turns a Haskell type into a `NullityType`.
193
187
@@ -214,17 +208,8 @@ type family TuplePG (hask :: Type) :: [NullityType] where
214
208
215-- | `TupleOf` turns a list of Haskell `Type`s into a list of `NullityType`s.
209-- | `TupleOf` turns a list of Haskell `Type`s into a list of `NullityType`s.
216type family TupleOf (tuple :: [Type]) :: [NullityType] where
210type family TupleOf (tuple :: [Type]) :: [NullityType] where
217− TupleOf (hask ': hask1 ': hask2 ': hask3 ': hask4 ': hask5 ': tuple) =
218− NullPG hask ': NullPG hask1 ': NullPG hask2 ': NullPG hask3 ': NullPG hask4 ': NullPG hask5 ': TupleOf tuple
219− TupleOf (hask ': hask1 ': hask2 ': hask3 ': hask4 ': tuple) =
220− NullPG hask ': NullPG hask1 ': NullPG hask2 ': NullPG hask3 ': NullPG hask4 ': TupleOf tuple
221− TupleOf (hask ': hask1 ': hask2 ': hask3 ': tuple) =
222− NullPG hask ': NullPG hask1 ': NullPG hask2 ': NullPG hask3 ': TupleOf tuple
223− TupleOf (hask ': hask1 ': hask2 ': tuple) =
224− NullPG hask ': NullPG hask1 ': NullPG hask2 ': TupleOf tuple
225− TupleOf (hask ': hask1 ': tuple) = NullPG hask ': NullPG hask1 ': TupleOf tuple
226− TupleOf (hask ': tuple) = NullPG hask ': TupleOf tuple
227 TupleOf '[] = '[]
211 TupleOf '[] = '[]
212+ TupleOf (hask ': tuple) = NullPG hask ': TupleOf tuple
228
213
229-- | `TupleCodeOf` takes the `SOP.Code` of a haskell `Type`
214-- | `TupleCodeOf` takes the `SOP.Code` of a haskell `Type`
230-- and if it's a simple product returns it, otherwise giving a `TypeError`.
215-- and if it's a simple product returns it, otherwise giving a `TypeError`.
@@ -319,8 +304,7 @@ withConnection "host=localhost port=5432 dbname=exampledb" $ do
319True
304True
320-}
305-}
321newtype Money = Money { cents :: Int64 }
306newtype Money = Money { cents :: Int64 }
322− deriving stock (Eq, Ord, Show, Read, GHC.Generic)
307+ deriving (Eq, Ord, Show, Read, GHC.Generic)
323− deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
324-- | `PGmoney`
308-- | `PGmoney`
325type instance PG Money = 'PGmoney
309type instance PG Money = 'PGmoney
326
310
@@ -328,8 +312,7 @@ type instance PG Money = 'PGmoney
328type it's applied to should be stored as a `PGjson`.
312type it's applied to should be stored as a `PGjson`.
329-}
313-}
330newtype Json hask = Json {getJson :: hask}
314newtype Json hask = Json {getJson :: hask}
331− deriving stock (Eq, Ord, Show, Read, GHC.Generic)
315+ deriving (Eq, Ord, Show, Read, GHC.Generic)
332− deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
333-- | `PGjson`
316-- | `PGjson`
334type instance PG (Json hask) = 'PGjson
317type instance PG (Json hask) = 'PGjson
335
318
@@ -337,8 +320,7 @@ type instance PG (Json hask) = 'PGjson
337type it's applied to should be stored as a `PGjsonb`.
320type it's applied to should be stored as a `PGjsonb`.
338-}
321-}
339newtype Jsonb hask = Jsonb {getJsonb :: hask}
322newtype Jsonb hask = Jsonb {getJsonb :: hask}
340− deriving stock (Eq, Ord, Show, Read, GHC.Generic)
323+ deriving (Eq, Ord, Show, Read, GHC.Generic)
341− deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
342-- | `PGjsonb`
324-- | `PGjsonb`
343type instance PG (Jsonb hask) = 'PGjsonb
325type instance PG (Jsonb hask) = 'PGjsonb
344
326
@@ -346,8 +328,7 @@ type instance PG (Jsonb hask) = 'PGjsonb
346type it's applied to should be stored as a `PGcomposite`.
328type it's applied to should be stored as a `PGcomposite`.
347-}
329-}
348newtype Composite record = Composite {getComposite :: record}
330newtype Composite record = Composite {getComposite :: record}
349− deriving stock (Eq, Ord, Show, Read, GHC.Generic)
331+ deriving (Eq, Ord, Show, Read, GHC.Generic)
350− deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
351-- | `PGcomposite` @(@`RowPG` @hask)@
332-- | `PGcomposite` @(@`RowPG` @hask)@
352type instance PG (Composite hask) = 'PGcomposite (RowPG hask)
333type instance PG (Composite hask) = 'PGcomposite (RowPG hask)
353
334
@@ -355,8 +336,7 @@ type instance PG (Composite hask) = 'PGcomposite (RowPG hask)
355type it's applied to should be stored as a `PGenum`.
336type it's applied to should be stored as a `PGenum`.
356-}
337-}
357newtype Enumerated enum = Enumerated {getEnumerated :: enum}
338newtype Enumerated enum = Enumerated {getEnumerated :: enum}
358− deriving stock (Eq, Ord, Show, Read, GHC.Generic)
339+ deriving (Eq, Ord, Show, Read, GHC.Generic)
359− deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
360-- | `PGenum` @(@`LabelsPG` @hask)@
340-- | `PGenum` @(@`LabelsPG` @hask)@
361type instance PG (Enumerated hask) = 'PGenum (LabelsPG hask)
341type instance PG (Enumerated hask) = 'PGenum (LabelsPG hask)
362
342
@@ -368,8 +348,7 @@ PG (VarArray (Vector Double)) :: PGType
368= 'PGvararray ('NotNull 'PGfloat8)
348= 'PGvararray ('NotNull 'PGfloat8)
369-}
349-}
370newtype VarArray arr = VarArray {getVarArray :: arr}
350newtype VarArray arr = VarArray {getVarArray :: arr}
371− deriving stock (Eq, Ord, Show, Read, GHC.Generic)
351+ deriving (Eq, Ord, Show, Read, GHC.Generic)
372− deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
373-- | `PGvararray` @(@`NullPG` @hask)@
352-- | `PGvararray` @(@`NullPG` @hask)@
374type instance PG (VarArray (Vector hask)) = 'PGvararray (NullPG hask)
353type instance PG (VarArray (Vector hask)) = 'PGvararray (NullPG hask)
375type instance PG (VarArray [hask]) = 'PGvararray (NullPG hask)
354type instance PG (VarArray [hask]) = 'PGvararray (NullPG hask)
@@ -382,7 +361,6 @@ PG (FixArray ((Double, Double), (Double, Double))) :: PGType
382= 'PGfixarray '[2, 2] ('NotNull 'PGfloat8)
361= 'PGfixarray '[2, 2] ('NotNull 'PGfloat8)
383-}
362-}
384newtype FixArray arr = FixArray {getFixArray :: arr}
363newtype FixArray arr = FixArray {getFixArray :: arr}
385− deriving stock (Eq, Ord, Show, Read, GHC.Generic)
364+ deriving (Eq, Ord, Show, Read, GHC.Generic)
386− deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
387-- | `PGfixarray` @(@`DimPG` @hask) (@`FixPG` @hask)@
365-- | `PGfixarray` @(@`DimPG` @hask) (@`FixPG` @hask)@
388type instance PG (FixArray hask) = 'PGfixarray (DimPG hask) (FixPG hask)
366type instance PG (FixArray hask) = 'PGfixarray (DimPG hask) (FixPG hask)
squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs+18−42
@@ -78,7 +78,6 @@ import UnliftIO (MonadUnliftIO (..), bracket, catch, handle, try)
78import Data.ByteString (ByteString)
78import Data.ByteString (ByteString)
79import Data.Foldable
79import Data.Foldable
80import Data.Function ((&))
80import Data.Function ((&))
81−import Data.Functor ((<&>))
82import Data.Kind
81import Data.Kind
83import Data.Text (pack, Text)
82import Data.Text (pack, Text)
84import Data.Traversable
83import Data.Traversable
@@ -87,7 +86,6 @@ import PostgreSQL.Binary.Encoding (encodingBytes)
87
86
88import qualified Control.Monad.Fail as Fail
87import qualified Control.Monad.Fail as Fail
89import qualified Database.PostgreSQL.LibPQ as LibPQ
88import qualified Database.PostgreSQL.LibPQ as LibPQ
90−import qualified PostgreSQL.Binary.Encoding as Encoding
91
89
92import Squeal.PostgreSQL.Binary
90import Squeal.PostgreSQL.Binary
93import Squeal.PostgreSQL.Definition
91import Squeal.PostgreSQL.Definition
@@ -317,13 +315,13 @@ a default instance.
317-}
315-}
318class Monad pq => MonadPQ schemas pq | pq -> schemas where
316class Monad pq => MonadPQ schemas pq | pq -> schemas where
319 manipulateParams
317 manipulateParams
320− :: (ToParams x params, All OidOfParam params)
318+ :: ToParams x params
321 => Manipulation '[] schemas params ys
319 => Manipulation '[] schemas params ys
322 -- ^ `insertInto`, `update` or `deleteFrom`
320 -- ^ `insertInto`, `update` or `deleteFrom`
323 -> x -> pq (K LibPQ.Result ys)
321 -> x -> pq (K LibPQ.Result ys)
324 default manipulateParams
322 default manipulateParams
325 :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)
323 :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)
326− => (ToParams x params, All OidOfParam params)
324+ => ToParams x params
327 => Manipulation '[] schemas params ys
325 => Manipulation '[] schemas params ys
328 -- ^ `insertInto`, `update` or `deleteFrom`
326 -- ^ `insertInto`, `update` or `deleteFrom`
329 -> x -> pq (K LibPQ.Result ys)
327 -> x -> pq (K LibPQ.Result ys)
@@ -331,7 +329,7 @@ class Monad pq => MonadPQ schemas pq | pq -> schemas where
331 manipulateParams manipulation params
329 manipulateParams manipulation params
332
330
333 manipulateParams_
331 manipulateParams_
334− :: (ToParams x params, All OidOfParam params)
332+ :: ToParams x params
335 => Manipulation '[] schemas params '[]
333 => Manipulation '[] schemas params '[]
336 -- ^ `insertInto`, `update` or `deleteFrom`
334 -- ^ `insertInto`, `update` or `deleteFrom`
337 -> x -> pq ()
335 -> x -> pq ()
@@ -344,7 +342,7 @@ class Monad pq => MonadPQ schemas pq | pq -> schemas where
344 manipulate_ = void . manipulate
342 manipulate_ = void . manipulate
345
343
346 runQueryParams
344 runQueryParams
347− :: (ToParams x params, All OidOfParam params)
345+ :: ToParams x params
348 => Query '[] '[] schemas params ys
346 => Query '[] '[] schemas params ys
349 -- ^ `select` and friends
347 -- ^ `select` and friends
350 -> x -> pq (K LibPQ.Result ys)
348 -> x -> pq (K LibPQ.Result ys)
@@ -357,19 +355,19 @@ class Monad pq => MonadPQ schemas pq | pq -> schemas where
357 runQuery q = runQueryParams q ()
355 runQuery q = runQueryParams q ()
358
356
359 traversePrepared
357 traversePrepared
360− :: (ToParams x params, Traversable list, All OidOfParam params)
358+ :: (ToParams x params, Traversable list)
361 => Manipulation '[] schemas params ys
359 => Manipulation '[] schemas params ys
362 -- ^ `insertInto`, `update`, or `deleteFrom`, and friends
360 -- ^ `insertInto`, `update`, or `deleteFrom`, and friends
363 -> list x -> pq (list (K LibPQ.Result ys))
361 -> list x -> pq (list (K LibPQ.Result ys))
364 default traversePrepared
362 default traversePrepared
365 :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)
363 :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)
366− => (ToParams x params, Traversable list, All OidOfParam params)
364+ => (ToParams x params, Traversable list)
367 => Manipulation '[] schemas params ys -> list x -> pq (list (K LibPQ.Result ys))
365 => Manipulation '[] schemas params ys -> list x -> pq (list (K LibPQ.Result ys))
368 traversePrepared manipulation params = lift $
366 traversePrepared manipulation params = lift $
369 traversePrepared manipulation params
367 traversePrepared manipulation params
370
368
371 forPrepared
369 forPrepared
372− :: (ToParams x params, Traversable list, All OidOfParam params)
370+ :: (ToParams x params, Traversable list)
373 => list x
371 => list x
374 -> Manipulation '[] schemas params ys
372 -> Manipulation '[] schemas params ys
375 -- ^ `insertInto`, `update` or `deleteFrom`
373 -- ^ `insertInto`, `update` or `deleteFrom`
@@ -377,13 +375,13 @@ class Monad pq => MonadPQ schemas pq | pq -> schemas where
377 forPrepared = flip traversePrepared
375 forPrepared = flip traversePrepared
378
376
379 traversePrepared_
377 traversePrepared_
380− :: (ToParams x params, Foldable list, All OidOfParam params)
378+ :: (ToParams x params, Foldable list)
381 => Manipulation '[] schemas params '[]
379 => Manipulation '[] schemas params '[]
382 -- ^ `insertInto`, `update` or `deleteFrom`
380 -- ^ `insertInto`, `update` or `deleteFrom`
383 -> list x -> pq ()
381 -> list x -> pq ()
384 default traversePrepared_
382 default traversePrepared_
385 :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)
383 :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)
386− => (ToParams x params, Foldable list, All OidOfParam params)
384+ => (ToParams x params, Foldable list)
387 => Manipulation '[] schemas params '[]
385 => Manipulation '[] schemas params '[]
388 -- ^ `insertInto`, `update` or `deleteFrom`
386 -- ^ `insertInto`, `update` or `deleteFrom`
389 -> list x -> pq ()
387 -> list x -> pq ()
@@ -391,7 +389,7 @@ class Monad pq => MonadPQ schemas pq | pq -> schemas where
391 traversePrepared_ manipulation params
389 traversePrepared_ manipulation params
392
390
393 forPrepared_
391 forPrepared_
394− :: (ToParams x params, Foldable list, All OidOfParam params)
392+ :: (ToParams x params, Foldable list)
395 => list x
393 => list x
396 -> Manipulation '[] schemas params '[]
394 -> Manipulation '[] schemas params '[]
397 -- ^ `insertInto`, `update` or `deleteFrom`
395 -- ^ `insertInto`, `update` or `deleteFrom`
@@ -411,17 +409,9 @@ instance (MonadIO io, schemas0 ~ schemas, schemas1 ~ schemas)
411 (UnsafeManipulation q :: Manipulation '[] schemas ps ys) (params :: x) =
409 (UnsafeManipulation q :: Manipulation '[] schemas ps ys) (params :: x) =
412 PQ $ \ (K conn) -> do
410 PQ $ \ (K conn) -> do
413 let
411 let
414− paramSet
412+ toParam' encoding =
415− :: forall param. OidOfParam param
416− => K (Maybe Encoding.Encoding) param
417− -> K (Maybe (LibPQ.Oid, ByteString, LibPQ.Format)) param
418− paramSet (K maybeEncoding) = K $
419− maybeEncoding <&> \encoding ->
420− (oidOfParam @param, encodingBytes encoding, LibPQ.Binary)
413+ (LibPQ.invalidOid, encodingBytes encoding, LibPQ.Binary)
421− params'
422− = hcollapse
423− . hcmap (Proxy @OidOfParam) paramSet
424− $ toParams @x @ps params
414+ params' = fmap (fmap toParam') (hcollapse (toParams @x @ps params))
425 q' = q <> ";"
415 q' = q <> ";"
426 resultMaybe <- liftIO $ LibPQ.execParams conn q' params' LibPQ.Binary
416 resultMaybe <- liftIO $ LibPQ.execParams conn q' params' LibPQ.Binary
427 case resultMaybe of
417 case resultMaybe of
@@ -434,22 +424,15 @@ instance (MonadIO io, schemas0 ~ schemas, schemas1 ~ schemas)
434 traversePrepared
424 traversePrepared
435 (UnsafeManipulation q :: Manipulation '[] schemas xs ys) (list :: list x) =
425 (UnsafeManipulation q :: Manipulation '[] schemas xs ys) (list :: list x) =
436 PQ $ \ (K conn) -> liftIO $ do
426 PQ $ \ (K conn) -> liftIO $ do
437− let
438− temp = "temporary_statement"
427+ let temp = "temporary_statement"
439− paramOid :: forall p. OidOfParam p => K LibPQ.Oid p
440− paramOid = K (oidOfParam @p)
441− paramOids :: NP (K LibPQ.Oid) xs
442− paramOids = hcpure (Proxy @OidOfParam) paramOid
443− paramOids' :: [LibPQ.Oid]
444− paramOids' = hcollapse paramOids
445− prepResultMaybe <- LibPQ.prepare conn temp q (Just paramOids')
428+ prepResultMaybe <- LibPQ.prepare conn temp q Nothing
446 case prepResultMaybe of
429 case prepResultMaybe of
447 Nothing -> throw $ ResultException
430 Nothing -> throw $ ResultException
448 "traversePrepared: LibPQ.prepare returned no results"
431 "traversePrepared: LibPQ.prepare returned no results"
449 Just prepResult -> okResult_ prepResult
432 Just prepResult -> okResult_ prepResult
450 results <- for list $ \ params -> do
433 results <- for list $ \ params -> do
451 let
434 let
452− toParam' encoding = (encodingBytes encoding, LibPQ.Binary)
435+ toParam' encoding = (encodingBytes encoding,LibPQ.Binary)
453 params' = fmap (fmap toParam') (hcollapse (toParams @x @xs params))
436 params' = fmap (fmap toParam') (hcollapse (toParams @x @xs params))
454 resultMaybe <- LibPQ.execPrepared conn temp params' LibPQ.Binary
437 resultMaybe <- LibPQ.execPrepared conn temp params' LibPQ.Binary
455 case resultMaybe of
438 case resultMaybe of
@@ -468,15 +451,8 @@ instance (MonadIO io, schemas0 ~ schemas, schemas1 ~ schemas)
468 traversePrepared_
451 traversePrepared_
469 (UnsafeManipulation q :: Manipulation '[] schemas xs '[]) (list :: list x) =
452 (UnsafeManipulation q :: Manipulation '[] schemas xs '[]) (list :: list x) =
470 PQ $ \ (K conn) -> liftIO $ do
453 PQ $ \ (K conn) -> liftIO $ do
471− let
472− temp = "temporary_statement"
454+ let temp = "temporary_statement"
473− paramOid :: forall p. OidOfParam p => K LibPQ.Oid p
474− paramOid = K (oidOfParam @p)
475− paramOids :: NP (K LibPQ.Oid) xs
476− paramOids = hcpure (Proxy @OidOfParam) paramOid
477− paramOids' :: [LibPQ.Oid]
478− paramOids' = hcollapse paramOids
479− prepResultMaybe <- LibPQ.prepare conn temp q (Just paramOids')
455+ prepResultMaybe <- LibPQ.prepare conn temp q Nothing
480 case prepResultMaybe of
456 case prepResultMaybe of
481 Nothing -> throw $ ResultException
457 Nothing -> throw $ ResultException
482 "traversePrepared_: LibPQ.prepare returned no results"
458 "traversePrepared_: LibPQ.prepare returned no results"
squeal-postgresql/src/Squeal/PostgreSQL/Query.hs+22−74
@@ -39,8 +39,6 @@ module Squeal.PostgreSQL.Query
39 , select_
39 , select_
40 , selectDistinct
40 , selectDistinct
41 , selectDistinct_
41 , selectDistinct_
42− , selectDistinctOn
43− , selectDistinctOn_
44 , Selection (..)
42 , Selection (..)
45 -- ** Values
43 -- ** Values
46 , values
44 , values
@@ -554,9 +552,9 @@ select_ = select . List
554-- be subject to the elimination of duplicate rows using `selectDistinct`.
552-- be subject to the elimination of duplicate rows using `selectDistinct`.
555selectDistinct
553selectDistinct
556 :: (SListI columns, columns ~ (col ': cols))
554 :: (SListI columns, columns ~ (col ': cols))
557− => Selection outer commons grp schemas params from columns
555+ => Selection outer commons 'Ungrouped schemas params from columns
558 -- ^ selection
556 -- ^ selection
559− -> TableExpression outer commons grp schemas params from
557+ -> TableExpression outer commons 'Ungrouped schemas params from
560 -- ^ intermediate virtual table
558 -- ^ intermediate virtual table
561 -> Query outer commons schemas params columns
559 -> Query outer commons schemas params columns
562selectDistinct selection tabexpr = UnsafeQuery $
560selectDistinct selection tabexpr = UnsafeQuery $
@@ -568,62 +566,13 @@ selectDistinct selection tabexpr = UnsafeQuery $
568-- of a general `Selection`.
566-- of a general `Selection`.
569selectDistinct_
567selectDistinct_
570 :: (SListI columns, columns ~ (col ': cols))
568 :: (SListI columns, columns ~ (col ': cols))
571− => NP (Aliased (Expression outer commons grp schemas params from)) columns
569+ => NP (Aliased (Expression outer commons 'Ungrouped schemas params from)) columns
572 -- ^ select list
570 -- ^ select list
573− -> TableExpression outer commons grp schemas params from
571+ -> TableExpression outer commons 'Ungrouped schemas params from
574 -- ^ intermediate virtual table
572 -- ^ intermediate virtual table
575 -> Query outer commons schemas params columns
573 -> Query outer commons schemas params columns
576selectDistinct_ = selectDistinct . List
574selectDistinct_ = selectDistinct . List
577
575
578−{-|
579−`selectDistinctOn` keeps only the first row of each set of rows where
580−the given expressions evaluate to equal. The DISTINCT ON expressions are
581−interpreted using the same rules as for ORDER BY. ORDER BY is used to
582−ensure that the desired row appears first.
583−
584−The DISTINCT ON expression(s) must match the leftmost ORDER BY expression(s).
585−The ORDER BY clause will normally contain additional expression(s) that
586−determine the desired precedence of rows within each DISTINCT ON group.
587−
588−In order to guarantee they match and reduce redundancy, this function
589−will prepend the The DISTINCT ON expressions to the ORDER BY clause.
590−-}
591−selectDistinctOn
592− :: (SListI columns, columns ~ (col ': cols))
593− => [SortExpression outer commons grp schemas params from]
594− -- ^ DISTINCT ON expression(s) and prepended to ORDER BY clause
595− -> Selection outer commons grp schemas params from columns
596− -- ^ selection
597− -> TableExpression outer commons grp schemas params from
598− -- ^ intermediate virtual table
599− -> Query outer commons schemas params columns
600−selectDistinctOn distincts selection tab = UnsafeQuery $
601− "SELECT DISTINCT ON"
602− <+> parenthesized (commaSeparated (renderDistinctOn <$> distincts))
603− <+> renderSQL selection
604− <+> renderSQL (tab {orderByClause = distincts <> orderByClause tab})
605− where
606− renderDistinctOn = \case
607− Asc expression -> renderSQL expression
608− Desc expression -> renderSQL expression
609− AscNullsFirst expression -> renderSQL expression
610− DescNullsFirst expression -> renderSQL expression
611− AscNullsLast expression -> renderSQL expression
612− DescNullsLast expression -> renderSQL expression
613−
614−-- | Like `selectDistinctOn` but takes an `NP` list of `Expression`s instead
615−-- of a general `Selection`.
616−selectDistinctOn_
617− :: (SListI columns, columns ~ (col ': cols))
618− => [SortExpression outer commons grp schemas params from]
619− -- ^ distinct on and return the first row in ordering
620− -> NP (Aliased (Expression outer commons grp schemas params from)) columns
621− -- ^ selection
622− -> TableExpression outer commons grp schemas params from
623− -- ^ intermediate virtual table
624− -> Query outer commons schemas params columns
625−selectDistinctOn_ distincts = selectDistinctOn distincts . List
626−
627-- | `values` computes a row value or set of row values
576-- | `values` computes a row value or set of row values
628-- specified by value expressions. It is most commonly used
577-- specified by value expressions. It is most commonly used
629-- to generate a “constant table” within a larger command,
578-- to generate a “constant table” within a larger command,
@@ -757,7 +706,7 @@ instance RenderSQL (TableExpression outer commons grp schemas params from) where
757from
706from
758 :: FromClause outer commons schemas params from -- ^ table reference
707 :: FromClause outer commons schemas params from -- ^ table reference
759 -> TableExpression outer commons 'Ungrouped schemas params from
708 -> TableExpression outer commons 'Ungrouped schemas params from
760−from tab = TableExpression tab [] noGroups NoHaving [] [] []
709+from tab = TableExpression tab [] NoGroups NoHaving [] [] []
761
710
762-- | A `where_` is an endomorphism of `TableExpression`s which adds a
711-- | A `where_` is an endomorphism of `TableExpression`s which adds a
763-- search condition to the `whereClause`.
712-- search condition to the `whereClause`.
@@ -778,7 +727,7 @@ groupBy
778groupBy bys rels = TableExpression
727groupBy bys rels = TableExpression
779 { fromClause = fromClause rels
728 { fromClause = fromClause rels
780 , whereClause = whereClause rels
729 , whereClause = whereClause rels
781− , groupByClause = group bys
730+ , groupByClause = Group bys
782 , havingClause = Having []
731 , havingClause = Having []
783 , orderByClause = []
732 , orderByClause = []
784 , limitClause = limitClause rels
733 , limitClause = limitClause rels
@@ -992,20 +941,19 @@ instance (Has rel rels cols, Has col cols ty, bys ~ '[ '(rel, col)])
992-- done on @NoGroups@ while all output `Expression`s must be aggregated
941-- done on @NoGroups@ while all output `Expression`s must be aggregated
993-- in @Group Nil@. In general, all output `Expression`s in the
942-- in @Group Nil@. In general, all output `Expression`s in the
994-- complement of @bys@ must be aggregated in @Group bys@.
943-- complement of @bys@ must be aggregated in @Group bys@.
995−newtype GroupByClause grp from = UnsafeGroupByClause
944+data GroupByClause grp from where
996− { renderGroupByClause :: ByteString }
945+ NoGroups :: GroupByClause 'Ungrouped from
997− deriving (GHC.Generic,Show,Eq,Ord,NFData)
946+ Group
947+ :: SListI bys
948+ => NP (By from) bys
949+ -> GroupByClause ('Grouped bys) from
950+
951+-- | Renders a `GroupByClause`.
998instance RenderSQL (GroupByClause grp from) where
952instance RenderSQL (GroupByClause grp from) where
999− renderSQL = renderGroupByClause
953+ renderSQL = \case
1000−noGroups :: GroupByClause 'Ungrouped from
954+ NoGroups -> ""
1001−noGroups = UnsafeGroupByClause ""
1002−group
1003− :: SListI bys
1004− => NP (By from) bys
1005− -> GroupByClause ('Grouped bys) from
1006−group bys = UnsafeGroupByClause $ case bys of
1007− Nil -> ""
955+ Group Nil -> ""
1008− bys' -> " GROUP BY" <+> renderCommaSeparated renderSQL bys'
956+ Group bys -> " GROUP BY" <+> renderCommaSeparated renderSQL bys
1009
957
1010-- | A `HavingClause` is used to eliminate groups that are not of interest.
958-- | A `HavingClause` is used to eliminate groups that are not of interest.
1011-- An `Ungrouped` `TableExpression` may only use `NoHaving` while a `Grouped`
959-- An `Ungrouped` `TableExpression` may only use `NoHaving` while a `Grouped`
@@ -1049,8 +997,8 @@ instance
1049 , commons1 ~ (cte ::: common ': commons)
997 , commons1 ~ (cte ::: common ': commons)
1050 ) => Aliasable cte
998 ) => Aliasable cte
1051 (statement commons schemas params common)
999 (statement commons schemas params common)
1052− (Path (CommonTableExpression statement schemas params) commons commons1) where
1000+ (AlignedList (CommonTableExpression statement schemas params) commons commons1) where
1053− statement `as` cte = csingleton (statement `as` cte)
1001+ statement `as` cte = single (statement `as` cte)
1054
1002
1055instance (forall c s p r. RenderSQL (statement c s p r)) => RenderSQL
1003instance (forall c s p r. RenderSQL (statement c s p r)) => RenderSQL
1056 (CommonTableExpression statement schemas params commons0 commons1) where
1004 (CommonTableExpression statement schemas params commons0 commons1) where
@@ -1062,7 +1010,7 @@ instance (forall c s p r. RenderSQL (statement c s p r)) => RenderSQL
1062-- defining temporary tables that exist just for one query.
1010-- defining temporary tables that exist just for one query.
1063class With statement where
1011class With statement where
1064 with
1012 with
1065− :: Path (CommonTableExpression statement schemas params) commons0 commons1
1013+ :: AlignedList (CommonTableExpression statement schemas params) commons0 commons1
1066 -- ^ common table expressions
1014 -- ^ common table expressions
1067 -> statement commons1 schemas params row
1015 -> statement commons1 schemas params row
1068 -- ^ larger query
1016 -- ^ larger query
@@ -1070,7 +1018,7 @@ class With statement where
1070instance With (Query outer) where
1018instance With (Query outer) where
1071 with Done query = query
1019 with Done query = query
1072 with ctes query = UnsafeQuery $
1020 with ctes query = UnsafeQuery $
1073− "WITH" <+> commaSeparated (ctoList renderSQL ctes) <+> renderSQL query
1021+ "WITH" <+> renderSQL ctes <+> renderSQL query
1074
1022
1075{- |
1023{- |
1076>>> import Data.Monoid (Sum (..))
1024>>> import Data.Monoid (Sum (..))
squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs+9−155
@@ -44,10 +44,6 @@ module Squeal.PostgreSQL.Schema
44 , ColumnsType
44 , ColumnsType
45 , TableType
45 , TableType
46 , SchemumType (..)
46 , SchemumType (..)
47− , IndexType (..)
48− , FunctionType
49− , OperatorType (..)
50− , ReturnsType (..)
51 , SchemaType
47 , SchemaType
52 , SchemasType
48 , SchemasType
53 , Public
49 , Public
@@ -62,16 +58,9 @@ module Squeal.PostgreSQL.Schema
62 , PGlabel (..)
58 , PGlabel (..)
63 -- * Data Definitions
59 -- * Data Definitions
64 , Create
60 , Create
65− , CreateIfNotExists
66− , CreateOrReplace
67 , Drop
61 , Drop
68− , DropSchemum
69− , DropIfExists
70− , DropSchemumIfExists
71 , Alter
62 , Alter
72− , AlterIfExists
73 , Rename
63 , Rename
74− , RenameIfExists
75 , ConstraintInvolves
64 , ConstraintInvolves
76 , DropIfConstraintsInvolve
65 , DropIfConstraintsInvolve
77 , IsNotElem
66 , IsNotElem
@@ -144,7 +133,6 @@ data PGType
144 | 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.
133 | 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.
145 | 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.
134 | 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.
146 | 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.
147− | PGoid -- Object identifiers (OIDs) are used internally by PostgreSQL as primary keys for various system tables.
148 | PGrange PGType -- ^ Range types are data types representing a range of values of some element type (called the range's subtype).
136 | PGrange PGType -- ^ Range types are data types representing a range of values of some element type (called the range's subtype).
149 | UnsafePGType Symbol -- ^ an escape hatch for unsupported PostgreSQL types
137 | UnsafePGType Symbol -- ^ an escape hatch for unsupported PostgreSQL types
150
138
@@ -260,19 +248,9 @@ type FromType = [(Symbol,RowType)]
260
248
261-- | `ColumnsToRow` removes column constraints.
249-- | `ColumnsToRow` removes column constraints.
262type family ColumnsToRow (columns :: ColumnsType) :: RowType where
250type family ColumnsToRow (columns :: ColumnsType) :: RowType where
263− ColumnsToRow (column ::: _ :=> ty ': column1 ::: _ :=> ty1 ': column2 ::: _ :=> ty2 ': column3 ::: _ :=> ty3 ': column4 ::: _ :=> ty4 ': column5 ::: _ :=> ty5 ': columns) =
264− column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': column3 ::: ty3 ': column4 ::: ty4 ': column5 ::: ty5 ': ColumnsToRow columns
265− ColumnsToRow (column ::: _ :=> ty ': column1 ::: _ :=> ty1 ': column2 ::: _ :=> ty2 ': column3 ::: _ :=> ty3 ': column4 ::: _ :=> ty4 ': columns) =
266− column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': column3 ::: ty3 ': column4 ::: ty4 ': ColumnsToRow columns
267− ColumnsToRow (column ::: _ :=> ty ': column1 ::: _ :=> ty1 ': column2 ::: _ :=> ty2 ': column3 ::: _ :=> ty3 ': columns) =
268− column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': column3 ::: ty3 ': ColumnsToRow columns
269− ColumnsToRow (column ::: _ :=> ty ': column1 ::: _ :=> ty1 ': column2 ::: _ :=> ty2 ': columns) =
270− column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': ColumnsToRow columns
271− ColumnsToRow (column ::: _ :=> ty ': column1 ::: _ :=> ty1 ': columns) =
272− column ::: ty ': column1 ::: ty1 ': ColumnsToRow columns
273− ColumnsToRow (column ::: _ :=> ty ': columns) =
274− column ::: ty ': ColumnsToRow columns
275 ColumnsToRow '[] = '[]
251 ColumnsToRow '[] = '[]
252+ ColumnsToRow (column ::: constraint :=> ty ': columns) =
253+ column ::: ty ': ColumnsToRow columns
276
254
277-- | `TableToColumns` removes table constraints.
255-- | `TableToColumns` removes table constraints.
278type family TableToColumns (table :: TableType) :: ColumnsType where
256type family TableToColumns (table :: TableType) :: ColumnsType where
@@ -305,24 +283,14 @@ instance ty0 ~ ty1 => SamePGType
305
283
306-- | `AllNotNull` is a constraint that proves a `ColumnsType` has no @NULL@s.
284-- | `AllNotNull` is a constraint that proves a `ColumnsType` has no @NULL@s.
307type family AllNotNull (columns :: ColumnsType) :: Constraint where
285type family AllNotNull (columns :: ColumnsType) :: Constraint where
308− AllNotNull (_ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': columns) = AllNotNull columns
309− AllNotNull (_ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': columns) = AllNotNull columns
310− AllNotNull (_ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': columns) = AllNotNull columns
311− AllNotNull (_ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': columns) = AllNotNull columns
312− AllNotNull (_ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': columns) = AllNotNull columns
313− AllNotNull (_ ::: _ :=> 'NotNull _ ': columns) = AllNotNull columns
314 AllNotNull '[] = ()
286 AllNotNull '[] = ()
287+ AllNotNull (column ::: def :=> 'NotNull ty ': columns) = AllNotNull columns
315
288
316-- | `NotAllNull` is a constraint that proves a `ColumnsType` has some
289-- | `NotAllNull` is a constraint that proves a `ColumnsType` has some
317-- @NOT NULL@.
290-- @NOT NULL@.
318type family NotAllNull (columns :: ColumnsType) :: Constraint where
291type family NotAllNull (columns :: ColumnsType) :: Constraint where
319− NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()
292+ NotAllNull (column ::: def :=> 'NotNull ty ': columns) = ()
320− NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()
321− NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()
322− NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()
323− NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()
324− NotAllNull (_ ::: _ :=> 'NotNull _ ': _) = ()
325− NotAllNull (_ ::: _ :=> 'Null _ ': columns) = NotAllNull columns
293+ NotAllNull (column ::: def :=> 'Null ty ': columns) = NotAllNull columns
326
294
327-- | `NullifyType` is an idempotent that nullifies a `NullityType`.
295-- | `NullifyType` is an idempotent that nullifies a `NullityType`.
328type family NullifyType (ty :: NullityType) :: NullityType where
296type family NullifyType (ty :: NullityType) :: NullityType where
@@ -331,37 +299,17 @@ type family NullifyType (ty :: NullityType) :: NullityType where
331
299
332-- | `NullifyRow` is an idempotent that nullifies a `RowType`.
300-- | `NullifyRow` is an idempotent that nullifies a `RowType`.
333type family NullifyRow (columns :: RowType) :: RowType where
301type family NullifyRow (columns :: RowType) :: RowType where
334− NullifyRow (column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': column3 ::: ty3 ': column4 ::: ty4 ': column5 ::: ty5 ': columns) =
302+ NullifyRow '[] = '[]
335− column ::: NullifyType ty ': column1 ::: NullifyType ty1 ': column2 ::: NullifyType ty2 ': column3 ::: NullifyType ty3 ': column4 ::: NullifyType ty4 ': column5 ::: NullifyType ty5 ': NullifyRow columns
336− NullifyRow (column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': column3 ::: ty3 ': column4 ::: ty4 ': columns) =
337− column ::: NullifyType ty ': column1 ::: NullifyType ty1 ': column2 ::: NullifyType ty2 ': column3 ::: NullifyType ty3 ': column4 ::: NullifyType ty4 ': NullifyRow columns
338− NullifyRow (column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': column3 ::: ty3 ': columns) =
339− column ::: NullifyType ty ': column1 ::: NullifyType ty1 ': column2 ::: NullifyType ty2 ': column3 ::: NullifyType ty3 ': NullifyRow columns
340− NullifyRow (column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': columns) =
341− column ::: NullifyType ty ': column1 ::: NullifyType ty1 ': column2 ::: NullifyType ty2 ': NullifyRow columns
342− NullifyRow (column ::: ty ': column1 ::: ty1 ': columns) =
343− column ::: NullifyType ty ': column1 ::: NullifyType ty1 ': NullifyRow columns
344 NullifyRow (column ::: ty ': columns) =
303 NullifyRow (column ::: ty ': columns) =
345 column ::: NullifyType ty ': NullifyRow columns
304 column ::: NullifyType ty ': NullifyRow columns
346− NullifyRow '[] = '[]
347
305
348-- | `NullifyFrom` is an idempotent that nullifies a `FromType`
306-- | `NullifyFrom` is an idempotent that nullifies a `FromType`
349-- used to nullify the left or right hand side of an outer join
307-- used to nullify the left or right hand side of an outer join
350-- in a `Squeal.PostgreSQL.Query.FromClause`.
308-- in a `Squeal.PostgreSQL.Query.FromClause`.
351type family NullifyFrom (tables :: FromType) :: FromType where
309type family NullifyFrom (tables :: FromType) :: FromType where
352− NullifyFrom (table ::: columns ': table1 ::: columns1 ': table2 ::: columns2 ': table3 ::: columns3 ': table4 ::: columns4 ': table5 ::: columns5 ': tables) =
310+ NullifyFrom '[] = '[]
353− table ::: NullifyRow columns ': table1 ::: NullifyRow columns1 ': table2 ::: NullifyRow columns2 ': table3 ::: NullifyRow columns3 ': table4 ::: NullifyRow columns5 ': table5 ::: NullifyRow columns4 ': NullifyFrom tables
354− NullifyFrom (table ::: columns ': table1 ::: columns1 ': table2 ::: columns2 ': table3 ::: columns3 ': table4 ::: columns4 ': tables) =
355− table ::: NullifyRow columns ': table1 ::: NullifyRow columns1 ': table2 ::: NullifyRow columns2 ': table3 ::: NullifyRow columns3 ': table4 ::: NullifyRow columns4 ': NullifyFrom tables
356− NullifyFrom (table ::: columns ': table1 ::: columns1 ': table2 ::: columns2 ': table3 ::: columns3 ': tables) =
357− table ::: NullifyRow columns ': table1 ::: NullifyRow columns1 ': table2 ::: NullifyRow columns2 ': table3 ::: NullifyRow columns3 ': NullifyFrom tables
358− NullifyFrom (table ::: columns ': table1 ::: columns1 ': table2 ::: columns2 ': tables) =
359− table ::: NullifyRow columns ': table1 ::: NullifyRow columns1 ': table2 ::: NullifyRow columns2 ': NullifyFrom tables
360− NullifyFrom (table ::: columns ': table1 ::: columns1 ': tables) =
361− table ::: NullifyRow columns ': table1 ::: NullifyRow columns1 ': NullifyFrom tables
362 NullifyFrom (table ::: columns ': tables) =
311 NullifyFrom (table ::: columns ': tables) =
363 table ::: NullifyRow columns ': NullifyFrom tables
312 table ::: NullifyRow columns ': NullifyFrom tables
364− NullifyFrom '[] = '[]
365
313
366-- | @Create alias x xs@ adds @alias ::: x@ to the end of @xs@ and is used in
314-- | @Create alias x xs@ adds @alias ::: x@ to the end of @xs@ and is used in
367-- `Squeal.PostgreSQL.Definition.createTable` statements and in @ALTER TABLE@
315-- `Squeal.PostgreSQL.Definition.createTable` statements and in @ALTER TABLE@
@@ -371,101 +319,30 @@ type family Create alias x xs where
371 Create alias x (alias ::: y ': xs) = TypeError
319 Create alias x (alias ::: y ': xs) = TypeError
372 ('Text "Create: alias "
320 ('Text "Create: alias "
373 ':<>: 'ShowType alias
321 ':<>: 'ShowType alias
374− ':<>: 'Text "already exists")
322+ ':<>: 'Text "already in use")
375 Create alias y (x ': xs) = x ': Create alias y xs
323 Create alias y (x ': xs) = x ': Create alias y xs
376
324
377−type family CreateIfNotExists alias x xs where
378− CreateIfNotExists alias x '[] = '[alias ::: x]
379− CreateIfNotExists alias x (alias ::: y ': xs) = alias ::: y ': xs
380− CreateIfNotExists alias y (x ': xs) = x ': CreateIfNotExists alias y xs
381−
382−type family CreateOrReplace alias x xs where
383− CreateOrReplace alias x '[] = '[alias ::: x]
384− CreateOrReplace alias x (alias ::: x ': xs) = alias ::: x ': xs
385− CreateOrReplace alias x (alias ::: y ': xs) = TypeError
386− ('Text "CreateOrReplace: expected type "
387− ':<>: 'ShowType x
388− ':<>: 'Text " but alias "
389− ':<>: 'ShowType alias
390− ':<>: 'Text " has type "
391− ':<>: 'ShowType y)
392− CreateOrReplace alias y (x ': xs) = x ': CreateOrReplace alias y xs
393−
394-- | @Drop alias xs@ removes the type associated with @alias@ in @xs@
325-- | @Drop alias xs@ removes the type associated with @alias@ in @xs@
395-- and is used in `Squeal.PostgreSQL.Definition.dropTable` statements
326-- and is used in `Squeal.PostgreSQL.Definition.dropTable` statements
396-- and in @ALTER TABLE@ `Squeal.PostgreSQL.Definition.dropColumn` statements.
327-- and in @ALTER TABLE@ `Squeal.PostgreSQL.Definition.dropColumn` statements.
397type family Drop alias xs where
328type family Drop alias xs where
398− Drop alias '[] = TypeError
399− ('Text "Drop: alias "
400− ':<>: 'ShowType alias
401− ':<>: 'Text " does not exist" )
402− Drop alias (alias ::: x ': xs) = xs
329+ Drop alias ((alias ::: x) ': xs) = xs
403 Drop alias (x ': xs) = x ': Drop alias xs
330 Drop alias (x ': xs) = x ': Drop alias xs
404
331
405−type family DropSchemum alias sch xs where
406− DropSchemum alias sch '[] = TypeError
407− ('Text "DropSchemum: alias "
408− ':<>: 'ShowType alias
409− ':<>: 'Text " does not exist" )
410− DropSchemum alias sch (alias ::: sch x ': xs) = xs
411− DropSchemum alias sch0 (alias ::: sch1 x ': xs) = TypeError
412− ('Text "DropSchemum: expected schemum "
413− ':<>: 'ShowType sch0
414− ':<>: 'Text " but alias "
415− ':<>: 'ShowType alias
416− ':<>: 'Text " has schemum "
417− ':<>: 'ShowType sch1)
418− DropSchemum alias sch (x ': xs) = x ': DropSchemum alias sch xs
419−
420−type family DropIfExists alias xs where
421− DropIfExists alias '[] = '[]
422− DropIfExists alias (alias ::: x ': xs) = xs
423− DropIfExists alias (x ': xs) = x ': DropIfExists alias xs
424−
425−type family DropSchemumIfExists alias sch xs where
426− DropSchemumIfExists alias sch '[] = '[]
427− DropSchemumIfExists alias sch (alias ::: sch x ': xs) = xs
428− DropSchemumIfExists alias sch0 (alias ::: sch1 x ': xs) = TypeError
429− ('Text "DropSchemumIfExists: expected schemum "
430− ':<>: 'ShowType sch1
431− ':<>: 'Text " but alias "
432− ':<>: 'ShowType alias
433− ':<>: 'Text " has schemum "
434− ':<>: 'ShowType sch0)
435− DropSchemumIfExists alias sch (x ': xs) = x ': DropSchemumIfExists alias sch xs
436−
437-- | @Alter alias x xs@ replaces the type associated with an @alias@ in @xs@
332-- | @Alter alias x xs@ replaces the type associated with an @alias@ in @xs@
438-- with the type @x@ and is used in `Squeal.PostgreSQL.Definition.alterTable`
333-- with the type @x@ and is used in `Squeal.PostgreSQL.Definition.alterTable`
439-- and `Squeal.PostgreSQL.Definition.alterColumn`.
334-- and `Squeal.PostgreSQL.Definition.alterColumn`.
440type family Alter alias x xs where
335type family Alter alias x xs where
441− Alter alias x '[] = TypeError
442− ('Text "Alter: alias "
443− ':<>: 'ShowType alias
444− ':<>: 'Text " does not exist" )
445 Alter alias x1 (alias ::: x0 ': xs) = alias ::: x1 ': xs
336 Alter alias x1 (alias ::: x0 ': xs) = alias ::: x1 ': xs
446 Alter alias x1 (x0 ': xs) = x0 ': Alter alias x1 xs
337 Alter alias x1 (x0 ': xs) = x0 ': Alter alias x1 xs
447
338
448−type family AlterIfExists alias x xs where
449− AlterIfExists alias x '[] = '[]
450− AlterIfExists alias x1 (alias ::: x0 ': xs) = alias ::: x1 ': xs
451− AlterIfExists alias x1 (x0 ': xs) = x0 ': AlterIfExists alias x1 xs
452−
453-- | @Rename alias0 alias1 xs@ replaces the alias @alias0@ by @alias1@ in @xs@
339-- | @Rename alias0 alias1 xs@ replaces the alias @alias0@ by @alias1@ in @xs@
454-- and is used in `Squeal.PostgreSQL.Definition.alterTableRename` and
340-- and is used in `Squeal.PostgreSQL.Definition.alterTableRename` and
455-- `Squeal.PostgreSQL.Definition.renameColumn`.
341-- `Squeal.PostgreSQL.Definition.renameColumn`.
456type family Rename alias0 alias1 xs where
342type family Rename alias0 alias1 xs where
457− Rename alias0 alias1 '[] = TypeError
458− ('Text "Rename: alias "
459− ':<>: 'ShowType alias0
460− ':<>: 'Text " does not exist" )
461 Rename alias0 alias1 ((alias0 ::: x0) ': xs) = (alias1 ::: x0) ': xs
343 Rename alias0 alias1 ((alias0 ::: x0) ': xs) = (alias1 ::: x0) ': xs
462 Rename alias0 alias1 (x ': xs) = x ': Rename alias0 alias1 xs
344 Rename alias0 alias1 (x ': xs) = x ': Rename alias0 alias1 xs
463
345
464−type family RenameIfExists alias0 alias1 xs where
465− RenameIfExists alias x '[] = '[]
466− RenameIfExists alias0 alias1 ((alias0 ::: x0) ': xs) = (alias1 ::: x0) ': xs
467− RenameIfExists alias0 alias1 (x ': xs) = x ': RenameIfExists alias0 alias1 xs
468−
469-- | Check if a `TableConstraint` involves a column
346-- | Check if a `TableConstraint` involves a column
470type family ConstraintInvolves column constraint where
347type family ConstraintInvolves column constraint where
471 ConstraintInvolves column ('Check columns) = column `Elem` columns
348 ConstraintInvolves column ('Check columns) = column `Elem` columns
@@ -488,29 +365,6 @@ data SchemumType
488 = Table TableType
365 = Table TableType
489 | View RowType
366 | View RowType
490 | Typedef PGType
367 | Typedef PGType
491− | Index IndexType
492− | Function FunctionType
493− | Operator OperatorType
494− | UnsafeSchemum Symbol
495−
496−type FunctionType = ([NullityType], ReturnsType)
497−
498−data IndexType
499− = Btree
500− | Hash
501− | Gist
502− | Spgist
503− | Gin
504− | Brin
505−
506−data ReturnsType
507− = Returns NullityType
508− | ReturnsTable RowType
509−
510−data OperatorType
511− = BinaryOp NullityType NullityType NullityType
512− | LeftOp NullityType NullityType
513− | RightOp NullityType NullityType
514
368
515{- | The schema of a database consists of a list of aliased,
369{- | The schema of a database consists of a list of aliased,
516user-defined `SchemumType`s.
370user-defined `SchemumType`s.
squeal-postgresql/test/Doc.hsdeleted−6
@@ -1,6 +0,0 @@
1−module Main (main) where
2−
3−import Test.DocTest
4−
5−main :: IO ()
6−main = doctest [ "-isrc", "src" ]
squeal-postgresql/test/DocTest.hsnew file+18
@@ -0,0 +1,18 @@
1+module Main (main) where
2+
3+import Test.DocTest
4+
5+main :: IO ()
6+main = doctest
7+ [ "-isrc"
8+ , "src/Squeal/PostgreSQL.hs"
9+ , "src/Squeal/PostgreSQL/Binary.hs"
10+ , "src/Squeal/PostgreSQL/Definition.hs"
11+ , "src/Squeal/PostgreSQL/Manipulation.hs"
12+ , "src/Squeal/PostgreSQL/Query.hs"
13+ , "src/Squeal/PostgreSQL/Expression.hs"
14+ , "src/Squeal/PostgreSQL/PQ.hs"
15+ , "src/Squeal/PostgreSQL/Migration.hs"
16+ , "src/Squeal/PostgreSQL/Transaction.hs"
17+ , "src/Squeal/PostgreSQL/Pool.hs"
18+ ]
squeal-postgresql/test/Property.hsdeleted−166
@@ -1,166 +0,0 @@
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− :: (OidOf ty, 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− :: (OidOf ty, 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.hsdeleted−136
@@ -1,136 +0,0 @@
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 ]
126−
127− describe "Parameters" $ do
128−
129− it "should run queries that don't reference all their parameters" $ do
130−
131− out <- withConnection connectionString $ do
132− let
133− query :: Query_ (Public '[]) (Char,Int32) (Only Int32)
134− query = values_ (param @2 `as` #fromOnly)
135− firstRow =<< runQueryParams query ('a', 3 :: Int32)
136− (fromOnly <$> out :: Maybe Int32) `shouldBe` Just 3
squeal-postgresql/test/Specs/ExceptionHandling.hsnew file+140
@@ -0,0 +1,140 @@
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.hsnew file+7
@@ -0,0 +1,7 @@
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−3
@@ -1,8 +1,6 @@
1−resolver: nightly-2019-07-14
1+resolver: lts-13.25
2packages:
2packages:
3- squeal-postgresql
3- squeal-postgresql
4
4
5extra-deps:
5extra-deps:
6- unliftio-pool-0.2.1.0
6- unliftio-pool-0.2.1.0
7−- github: morphismtech/free-categories
8− commit: c0e555fbefb5c21619e532264c4dfeac556d0630