on dev help sign in
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 `GHC.TypeLits.Symbol` with a `SchemumType`,
124+`:::` is used to pair an alias `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 `Generics.SOP.Generic` and
183+We'll need a Haskell type for `User`s. We give the type `SOP.Generic` and
184−`Generics.SOP.HasDatatypeInfo` instances so that we can encode and decode @User@s.
184+`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 `Generics.SOP.Generic` a
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+2−2
@@ -53,8 +53,8 @@ setup =
53 >>>
53 >>>
54 createTable #emails
54 createTable #emails
55 ( serial `as` #id :*
55 ( serial `as` #id :*
56− (int & notNullable) `as` #user_id :*
56+ hask @Int32 `as` #user_id :*
57− (text & nullable) `as` #email )
57+ hask @(Maybe Text) `as` #email )
58 ( primaryKey #id `as` #pk_emails :*
58 ( primaryKey #id `as` #pk_emails :*
59 foreignKey #user_id #users #id
59 foreignKey #user_id #users #id
60 OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
60 OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
squeal-postgresql/squeal-postgresql.cabal+9−1
@@ -25,6 +25,13 @@ 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
28 Squeal.PostgreSQL.Expression
35 Squeal.PostgreSQL.Expression
29 Squeal.PostgreSQL.Expression.Aggregate
36 Squeal.PostgreSQL.Expression.Aggregate
30 Squeal.PostgreSQL.Expression.Collection
37 Squeal.PostgreSQL.Expression.Collection
@@ -36,7 +43,7 @@ library
36 Squeal.PostgreSQL.Expression.Null
43 Squeal.PostgreSQL.Expression.Null
37 Squeal.PostgreSQL.Expression.Parameter
44 Squeal.PostgreSQL.Expression.Parameter
38 Squeal.PostgreSQL.Expression.Range
45 Squeal.PostgreSQL.Expression.Range
39− Squeal.PostgreSQL.Expression.SetOf
46+ Squeal.PostgreSQL.Expression.Set
40 Squeal.PostgreSQL.Expression.Sort
47 Squeal.PostgreSQL.Expression.Sort
41 Squeal.PostgreSQL.Expression.Subquery
48 Squeal.PostgreSQL.Expression.Subquery
42 Squeal.PostgreSQL.Expression.Text
49 Squeal.PostgreSQL.Expression.Text
@@ -63,6 +70,7 @@ library
63 , bytestring >= 0.10.8.2
70 , bytestring >= 0.10.8.2
64 , bytestring-strict-builder >= 0.4.5
71 , bytestring-strict-builder >= 0.4.5
65 , deepseq >= 1.4.3.0
72 , deepseq >= 1.4.3.0
73+ , free-categories >= 0.1.0.0
66 , generics-sop >= 0.3.2.0 && < 0.5.0.0
74 , generics-sop >= 0.3.2.0 && < 0.5.0.0
67 , mmorph >= 1.1.1
75 , mmorph >= 1.1.1
68 , mtl >= 2.2.2
76 , mtl >= 2.2.2
squeal-postgresql/src/Squeal/PostgreSQL.hs+8−1
@@ -195,6 +195,13 @@ 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
198import Squeal.PostgreSQL.Expression as X
205import Squeal.PostgreSQL.Expression as X
199import Squeal.PostgreSQL.Expression.Aggregate as X
206import Squeal.PostgreSQL.Expression.Aggregate as X
200import Squeal.PostgreSQL.Expression.Collection as X
207import Squeal.PostgreSQL.Expression.Collection as X
@@ -206,7 +213,7 @@ import Squeal.PostgreSQL.Expression.Math as X
206import Squeal.PostgreSQL.Expression.Null as X
213import Squeal.PostgreSQL.Expression.Null as X
207import Squeal.PostgreSQL.Expression.Parameter as X
214import Squeal.PostgreSQL.Expression.Parameter as X
208import Squeal.PostgreSQL.Expression.Range as X
215import Squeal.PostgreSQL.Expression.Range as X
209−import Squeal.PostgreSQL.Expression.SetOf as X
216+import Squeal.PostgreSQL.Expression.Set as X
210import Squeal.PostgreSQL.Expression.Sort as X
217import Squeal.PostgreSQL.Expression.Sort as X
211import Squeal.PostgreSQL.Expression.Subquery as X
218import Squeal.PostgreSQL.Expression.Subquery as X
212import Squeal.PostgreSQL.Expression.Text as X
219import Squeal.PostgreSQL.Expression.Text as X
squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs+130−40
@@ -216,8 +216,9 @@ module Squeal.PostgreSQL.Binary
216 -- * Only
216 -- * Only
217 , Only (..)
217 , Only (..)
218 -- * Oid
218 -- * Oid
219− , HasOid (..)
219+ , OidOf (..)
220− , HasAliasedOid (..)
220+ , OidOfParam (..)
221+ , OidOfField (..)
221 ) where
222 ) where
222
223
223import BinaryParser
224import BinaryParser
@@ -231,6 +232,7 @@ import Data.Time
231import Data.UUID.Types
232import Data.UUID.Types
232import Data.Vector (Vector)
233import Data.Vector (Vector)
233import Data.Word
234import Data.Word
235+import Foreign.C.Types (CUInt(CUInt))
234import Generics.SOP
236import Generics.SOP
235import Generics.SOP.Record
237import Generics.SOP.Record
236import GHC.TypeLits
238import GHC.TypeLits
@@ -244,6 +246,7 @@ import qualified Data.Text.Lazy as Lazy (Text)
244import qualified Data.Text as Strict (Text)
246import qualified Data.Text as Strict (Text)
245import qualified Data.Text as Strict.Text
247import qualified Data.Text as Strict.Text
246import qualified Data.Vector as Vector
248import qualified Data.Vector as Vector
249+import qualified Database.PostgreSQL.LibPQ as LibPQ
247import qualified GHC.Generics as GHC
250import qualified GHC.Generics as GHC
248import qualified PostgreSQL.Binary.Decoding as Decoding
251import qualified PostgreSQL.Binary.Decoding as Decoding
249import qualified PostgreSQL.Binary.Encoding as Encoding
252import qualified PostgreSQL.Binary.Encoding as Encoding
@@ -309,24 +312,24 @@ instance Aeson.ToJSON x => ToParam (Json x) 'PGjson where
309instance Aeson.ToJSON x => ToParam (Jsonb x) 'PGjsonb where
312instance Aeson.ToJSON x => ToParam (Jsonb x) 'PGjsonb where
310 toParam = K . Encoding.jsonb_bytes
313 toParam = K . Encoding.jsonb_bytes
311 . Lazy.ByteString.toStrict . Aeson.encode . getJsonb
314 . Lazy.ByteString.toStrict . Aeson.encode . getJsonb
312−instance (ToNullityParam x ty, ty ~ nullity pg, HasOid pg)
315+instance (ToNullityParam x ty, ty ~ nullity pg, OidOf pg)
313 => ToParam (VarArray [x]) ('PGvararray ty) where
316 => ToParam (VarArray [x]) ('PGvararray ty) where
314 toParam = K
317 toParam = K
315 . Encoding.array_foldable
318 . Encoding.array_foldable
316 (getOid (oidOf @pg)) (unK . toNullityParam @x @ty)
319 (getOid (oidOf @pg)) (unK . toNullityParam @x @ty)
317 . getVarArray
320 . getVarArray
318−instance (ToParam x pg, HasOid pg)
321+instance (ToParam x pg, OidOf pg)
319 => ToParam (VarArray (Vector x)) ('PGvararray ('NotNull pg)) where
322 => ToParam (VarArray (Vector x)) ('PGvararray ('NotNull pg)) where
320 toParam = K
323 toParam = K
321 . Encoding.array_vector (getOid (oidOf @pg)) (unK . toParam @x @pg)
324 . Encoding.array_vector (getOid (oidOf @pg)) (unK . toParam @x @pg)
322 . getVarArray
325 . getVarArray
323−instance (ToParam x pg, HasOid pg)
326+instance (ToParam x pg, OidOf pg)
324 => ToParam (VarArray (Vector (Maybe x))) ('PGvararray ('Null pg)) where
327 => ToParam (VarArray (Vector (Maybe x))) ('PGvararray ('Null pg)) where
325 toParam = K
328 toParam = K
326 . Encoding.nullableArray_vector
329 . Encoding.nullableArray_vector
327 (getOid (oidOf @pg)) (unK . toParam @x @pg)
330 (getOid (oidOf @pg)) (unK . toParam @x @pg)
328 . getVarArray
331 . getVarArray
329−instance (ToFixArray x dims ty, ty ~ nullity pg, HasOid pg)
332+instance (ToFixArray x dims ty, ty ~ nullity pg, OidOf pg)
330 => ToParam (FixArray x) ('PGfixarray dims ty) where
333 => ToParam (FixArray x) ('PGfixarray dims ty) where
331 toParam = K . Encoding.array (getOid (oidOf @pg))
334 toParam = K . Encoding.array (getOid (oidOf @pg))
332 . unK . unK . toFixArray @x @dims @ty . getFixArray
335 . unK . unK . toFixArray @x @dims @ty . getFixArray
@@ -353,7 +356,7 @@ instance
353 ( SListI fields
356 ( SListI fields
354 , IsRecord x xs
357 , IsRecord x xs
355 , AllZip ToField xs fields
358 , AllZip ToField xs fields
356− , All HasAliasedOid fields
359+ , All OidOfField fields
357 ) => ToParam (Composite x) ('PGcomposite fields) where
360 ) => ToParam (Composite x) ('PGcomposite fields) where
358 toParam =
361 toParam =
359 let
362 let
@@ -361,7 +364,7 @@ instance
361 encoders = htrans (Proxy @ToField) toField
364 encoders = htrans (Proxy @ToField) toField
362
365
363 composite
366 composite
364− :: All HasAliasedOid row
367+ :: All OidOfField row
365 => NP (K (Maybe Encoding.Encoding)) row
368 => NP (K (Maybe Encoding.Encoding)) row
366 -> K Encoding.Encoding ('PGcomposite row)
369 -> K Encoding.Encoding ('PGcomposite row)
367 composite fields = K $
370 composite fields = K $
@@ -378,18 +381,18 @@ instance
378 int32BE (fromIntegral (lengthSList (Proxy @xs))) <>
381 int32BE (fromIntegral (lengthSList (Proxy @xs))) <>
379 let
382 let
380 each
383 each
381− :: HasAliasedOid field
384+ :: OidOfField field
382 => K (Maybe Encoding.Encoding) field
385 => K (Maybe Encoding.Encoding) field
383 -> Encoding.Encoding
386 -> Encoding.Encoding
384 each (K field :: K (Maybe Encoding.Encoding) field) =
387 each (K field :: K (Maybe Encoding.Encoding) field) =
385− word32BE (getOid (aliasedOid @field))
388+ word32BE (getOid (oidOfField @field))
386 <> case field of
389 <> case field of
387 Nothing -> int64BE (-1)
390 Nothing -> int64BE (-1)
388 Just value ->
391 Just value ->
389 int32BE (fromIntegral (builderLength value))
392 int32BE (fromIntegral (builderLength value))
390 <> value
393 <> value
391 in
394 in
392− hcfoldMap (Proxy @HasAliasedOid) each fields
395+ hcfoldMap (Proxy @OidOfField) each fields
393
396
394 in
397 in
395 composite . encoders . toRecord . getComposite
398 composite . encoders . toRecord . getComposite
@@ -398,35 +401,119 @@ instance
398--
401--
399-- >>> :set -XTypeApplications
402-- >>> :set -XTypeApplications
400-- >>> oidOf @'PGbool
403-- >>> oidOf @'PGbool
401−-- Oid {getOid = 16}
404+-- Oid 16
402−class HasOid (ty :: PGType) where oidOf :: Oid
405+class OidOf (ty :: PGType) where oidOf :: LibPQ.Oid
403−instance HasOid 'PGbool where oidOf = Oid 16
406+instance OidOf 'PGbool where oidOf = LibPQ.Oid 16
407+instance OidOf ('PGfixarray ns (null 'PGbool)) where oidOf = LibPQ.Oid 1000
408+instance OidOf ('PGvararray (null 'PGbool)) where oidOf = LibPQ.Oid 1000
404−instance HasOid 'PGint2 where oidOf = Oid 21
409+instance OidOf 'PGint2 where oidOf = LibPQ.Oid 21
410+instance OidOf ('PGfixarray ns (null 'PGint2)) where oidOf = LibPQ.Oid 1005
411+instance OidOf ('PGvararray (null 'PGint2)) where oidOf = LibPQ.Oid 1005
405−instance HasOid 'PGint4 where oidOf = Oid 23
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
406−instance HasOid 'PGint8 where oidOf = Oid 20
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
407−instance HasOid 'PGnumeric where oidOf = Oid 1700
418+instance OidOf 'PGnumeric where oidOf = LibPQ.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
408−instance HasOid 'PGfloat4 where oidOf = Oid 700
421+instance OidOf 'PGfloat4 where oidOf = LibPQ.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
409−instance HasOid 'PGfloat8 where oidOf = Oid 701
424+instance OidOf 'PGfloat8 where oidOf = LibPQ.Oid 701
425+instance OidOf ('PGfixarray ns (null 'PGfloat8)) where oidOf = LibPQ.Oid 1022
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
410−instance HasOid ('PGchar n) where oidOf = Oid 18
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
411−instance HasOid ('PGvarchar n) where oidOf = Oid 1043
433+instance OidOf ('PGvarchar n) where oidOf = LibPQ.Oid 1043
434+instance OidOf ('PGfixarray ns (null ('PGvarchar n))) where oidOf = LibPQ.Oid 1015
435+instance OidOf ('PGvararray (null ('PGvarchar n))) where oidOf = LibPQ.Oid 1015
412−instance HasOid 'PGtext where oidOf = Oid 25
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
413−instance HasOid 'PGbytea where oidOf = Oid 17
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
414−instance HasOid 'PGtimestamp where oidOf = Oid 1114
442+instance OidOf 'PGtimestamp where oidOf = LibPQ.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
415−instance HasOid 'PGtimestamptz where oidOf = Oid 1184
445+instance OidOf 'PGtimestamptz where oidOf = LibPQ.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
416−instance HasOid 'PGdate where oidOf = Oid 1082
448+instance OidOf 'PGdate where oidOf = LibPQ.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
417−instance HasOid 'PGtime where oidOf = Oid 1083
451+instance OidOf 'PGtime where oidOf = LibPQ.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
418−instance HasOid 'PGtimetz where oidOf = Oid 1266
454+instance OidOf 'PGtimetz where oidOf = LibPQ.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
419−instance HasOid 'PGinterval where oidOf = Oid 1186
457+instance OidOf 'PGinterval where oidOf = LibPQ.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
420−instance HasOid 'PGuuid where oidOf = Oid 2950
460+instance OidOf 'PGuuid where oidOf = LibPQ.Oid 2950
461+instance OidOf ('PGfixarray ns (null 'PGuuid)) where oidOf = LibPQ.Oid 2951
462+instance OidOf ('PGvararray (null 'PGuuid)) where oidOf = LibPQ.Oid 2951
421−instance HasOid 'PGinet where oidOf = Oid 869
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
422−instance HasOid 'PGjson where oidOf = Oid 114
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
423−instance HasOid 'PGjsonb where oidOf = Oid 3802
469+instance OidOf 'PGjsonb where oidOf = LibPQ.Oid 3802
424−
470+instance OidOf ('PGfixarray ns (null 'PGjsonb)) where oidOf = LibPQ.Oid 3807
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+
425−-- | Lifts a `HasOid` constraint to a field.
512+-- | Lifts a `OidOf` constraint to a field.
426−class HasAliasedOid (field :: (Symbol, NullityType)) where
513+class OidOfField (field :: (Symbol, NullityType)) where
427− aliasedOid :: Oid
514+ oidOfField :: Oid
428−instance HasOid ty => HasAliasedOid (alias ::: nullity ty) where
515+instance OidOf ty => OidOfField (alias ::: nullity ty) where
429− aliasedOid = oidOf @ty
516+ oidOfField = oidOf @ty
430
517
431-- | A `ToNullityParam` constraint gives an encoding of a Haskell `Type` into
518-- | A `ToNullityParam` constraint gives an encoding of a Haskell `Type` into
432-- into the binary format of a PostgreSQL `NullityType`.
519-- into the binary format of a PostgreSQL `NullityType`.
@@ -756,3 +843,6 @@ replicateMN
756 => m x -> m (NP I xs)
843 => m x -> m (NP I xs)
757replicateMN mx = hsequence' $
844replicateMN mx = hsequence' $
758 hcpure (Proxy :: Proxy ((~) x)) (Comp (I <$> mx))
845 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+2−1226
@@ -19,6 +19,7 @@ Squeal data definition language.
19 , GADTs
19 , GADTs
20 , LambdaCase
20 , LambdaCase
21 , MultiParamTypeClasses
21 , MultiParamTypeClasses
22+ , OverloadedLabels
22 , OverloadedStrings
23 , OverloadedStrings
23 , RankNTypes
24 , RankNTypes
24 , ScopedTypeVariables
25 , ScopedTypeVariables
@@ -26,6 +27,7 @@ Squeal data definition language.
26 , TypeInType
27 , TypeInType
27 , TypeOperators
28 , TypeOperators
28 , UndecidableSuperClasses
29 , UndecidableSuperClasses
30+ , UndecidableInstances
29#-}
31#-}
30
32
31module Squeal.PostgreSQL.Definition
33module Squeal.PostgreSQL.Definition
@@ -33,90 +35,16 @@ module Squeal.PostgreSQL.Definition
33 Definition (..)
35 Definition (..)
34 , (>>>)
36 , (>>>)
35 , manipDefinition
37 , manipDefinition
36− -- * Tables
37− -- ** Create
38− , createSchema
39− , createSchemaIfNotExists
40− , createTable
41− , createTableIfNotExists
42− , createView
43− , createTypeEnum
44− , createTypeEnumFrom
45− , createTypeComposite
46− , createTypeCompositeFrom
47− , FieldTyped (..)
48− , createDomain
49− , createTypeRange
50− , createIndex
51− , createFunction
52− , createOrReplaceFunction
53− , createSetFunction
54− , createOrReplaceSetFunction
55− , TableConstraintExpression (..)
56− , check
57− , unique
58− , primaryKey
59− , foreignKey
60− , ForeignKeyed
61− , OnDeleteClause (..)
62− , OnUpdateClause (..)
63− , FunctionDefinition(..)
64− , languageSql
65− , languageSqlSet
66− -- ** Drop
67− , dropSchema
68− , dropTable
69− , dropView
70− , dropType
71− , dropIndex
72− , dropFunction
73− -- ** Alter
74− , alterTable
75− , alterTableRename
76− , AlterTable (..)
77− , addConstraint
78− , dropConstraint
79− , AddColumn (..)
80− , dropColumn
81− , renameColumn
82− , alterColumn
83− , AlterColumn (..)
84− , setDefault
85− , dropDefault
86− , setNotNull
87− , dropNotNull
88− , alterType
89− -- * Columns
90− , ColumnTypeExpression (..)
91− , nullable
92− , notNullable
93− , default_
94− , serial2
95− , smallserial
96− , serial4
97− , serial
98− , serial8
99− , bigserial
100 ) where
38 ) where
101
39
102import Control.Category
40import Control.Category
103import Control.DeepSeq
41import Control.DeepSeq
104import Data.ByteString
42import Data.ByteString
105import Data.Monoid
43import Data.Monoid
106−import GHC.TypeLits
107import Prelude hiding ((.), id)
44import Prelude hiding ((.), id)
108
45
109−import qualified Generics.SOP as SOP
110import qualified GHC.Generics as GHC
46import qualified GHC.Generics as GHC
111
47
112−import Squeal.PostgreSQL.Alias
113−import Squeal.PostgreSQL.Expression
114−import Squeal.PostgreSQL.Expression.Logic
115−import Squeal.PostgreSQL.Expression.Sort
116−import Squeal.PostgreSQL.Expression.Type
117−import Squeal.PostgreSQL.List
118−import Squeal.PostgreSQL.PG
119−import Squeal.PostgreSQL.Query
120import Squeal.PostgreSQL.Manipulation
48import Squeal.PostgreSQL.Manipulation
121import Squeal.PostgreSQL.Render
49import Squeal.PostgreSQL.Render
122import Squeal.PostgreSQL.Schema
50import Squeal.PostgreSQL.Schema
@@ -152,1155 +80,3 @@ manipDefinition
152 -- ^ no input or output
80 -- ^ no input or output
153 -> Definition schemas schemas
81 -> Definition schemas schemas
154manipDefinition = UnsafeDefinition . (<> ";") . renderSQL
82manipDefinition = UnsafeDefinition . (<> ";") . renderSQL
155−
156−{-----------------------------------------
157−CREATE statements
158−-----------------------------------------}
159−
160−{- |
161−`createSchema` enters a new schema into the current database.
162−The schema name must be distinct from the name of any existing schema
163−in the current database.
164−
165−A schema is essentially a namespace: it contains named objects
166−(tables, data types, functions, and operators) whose names
167−can duplicate those of other objects existing in other schemas.
168−Named objects are accessed by `QualifiedAlias`es with the schema
169−name as a prefix.
170−-}
171−createSchema
172− :: KnownSymbol sch
173− => Alias sch
174− -> Definition schemas (Create sch '[] schemas)
175−createSchema sch = UnsafeDefinition $
176− "CREATE" <+> "SCHEMA" <+> renderSQL sch <> ";"
177−
178−{- | Idempotent version of `createSchema`. -}
179−createSchemaIfNotExists
180− :: (KnownSymbol sch, Has sch schemas schema)
181− => Alias sch
182− -> Definition schemas schemas
183−createSchemaIfNotExists sch = UnsafeDefinition $
184− "CREATE" <+> "SCHEMA" <+> "IF" <+> "NOT" <+> "EXISTS"
185− <+> renderSQL sch <> ";"
186−
187−{- | `createTable` adds a table to the schema.
188−
189−>>> :set -XOverloadedLabels
190−>>> :{
191−type Table = '[] :=>
192− '[ "a" ::: 'NoDef :=> 'Null 'PGint4
193− , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]
194−:}
195−
196−>>> :{
197−let
198− setup :: Definition (Public '[]) (Public '["tab" ::: 'Table Table])
199− setup = createTable #tab
200− (nullable int `as` #a :* nullable real `as` #b) Nil
201−in printSQL setup
202−:}
203−CREATE TABLE "tab" ("a" int NULL, "b" real NULL);
204−-}
205−createTable
206− :: ( KnownSymbol sch
207− , KnownSymbol tab
208− , columns ~ (col ': cols)
209− , SOP.SListI columns
210− , SOP.SListI constraints
211− , Has sch schemas0 schema0
212− , schemas1 ~ Alter sch (Create tab ('Table (constraints :=> columns)) schema0) schemas0 )
213− => QualifiedAlias sch tab -- ^ the name of the table to add
214− -> NP (Aliased (ColumnTypeExpression schemas0)) columns
215− -- ^ the names and datatype of each column
216− -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints
217− -- ^ constraints that must hold for the table
218− -> Definition schemas0 schemas1
219−createTable tab columns constraints = UnsafeDefinition $
220− "CREATE TABLE" <+> renderCreation tab columns constraints
221−
222−{-| `createTableIfNotExists` creates a table if it doesn't exist, but does not add it to the schema.
223−Instead, the schema already has the table so if the table did not yet exist, the schema was wrong.
224−`createTableIfNotExists` fixes this. Interestingly, this property makes it an idempotent in
225−the `Category` of `Definition`s.
226−
227−>>> :set -XOverloadedLabels -XTypeApplications
228−>>> :{
229−type Table = '[] :=>
230− '[ "a" ::: 'NoDef :=> 'Null 'PGint4
231− , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]
232−:}
233−
234−>>> type Schemas = Public '["tab" ::: 'Table Table]
235−
236−>>> :{
237−let
238− setup :: Definition Schemas Schemas
239− setup = createTableIfNotExists #tab
240− (nullable int `as` #a :* nullable real `as` #b) Nil
241−in printSQL setup
242−:}
243−CREATE TABLE IF NOT EXISTS "tab" ("a" int NULL, "b" real NULL);
244−-}
245−createTableIfNotExists
246− :: ( Has sch schemas schema
247− , Has tab schema ('Table (constraints :=> columns))
248− , SOP.SListI columns
249− , SOP.SListI constraints )
250− => QualifiedAlias sch tab -- ^ the name of the table to add
251− -> NP (Aliased (ColumnTypeExpression schemas)) columns
252− -- ^ the names and datatype of each column
253− -> NP (Aliased (TableConstraintExpression sch tab schemas)) constraints
254− -- ^ constraints that must hold for the table
255− -> Definition schemas schemas
256−createTableIfNotExists tab columns constraints = UnsafeDefinition $
257− "CREATE TABLE IF NOT EXISTS"
258− <+> renderCreation tab columns constraints
259−
260−-- helper function for `createTable` and `createTableIfNotExists`
261−renderCreation
262− :: ( KnownSymbol sch
263− , KnownSymbol tab
264− , SOP.SListI columns
265− , SOP.SListI constraints )
266− => QualifiedAlias sch tab -- ^ the name of the table to add
267− -> NP (Aliased (ColumnTypeExpression schemas0)) columns
268− -- ^ the names and datatype of each column
269− -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints
270− -- ^ constraints that must hold for the table
271− -> ByteString
272−renderCreation tab columns constraints = renderSQL tab
273− <+> parenthesized
274− ( renderCommaSeparated renderColumnDef columns
275− <> ( case constraints of
276− Nil -> ""
277− _ -> ", " <>
278− renderCommaSeparated renderConstraint constraints ) )
279− <> ";"
280− where
281− renderColumnDef :: Aliased (ColumnTypeExpression schemas) x -> ByteString
282− renderColumnDef (ty `As` column) =
283− renderSQL column <+> renderColumnTypeExpression ty
284− renderConstraint
285− :: Aliased (TableConstraintExpression sch tab schemas) constraint
286− -> ByteString
287− renderConstraint (constraint `As` alias) =
288− "CONSTRAINT" <+> renderSQL alias <+> renderSQL constraint
289−
290−-- | Data types are a way to limit the kind of data that can be stored in a
291−-- table. For many applications, however, the constraint they provide is
292−-- too coarse. For example, a column containing a product price should
293−-- probably only accept positive values. But there is no standard data type
294−-- that accepts only positive numbers. Another issue is that you might want
295−-- to constrain column data with respect to other columns or rows.
296−-- For example, in a table containing product information,
297−-- there should be only one row for each product number.
298−-- `TableConstraint`s give you as much control over the data in your tables
299−-- as you wish. If a user attempts to store data in a column that would
300−-- violate a constraint, an error is raised. This applies
301−-- even if the value came from the default value definition.
302−newtype TableConstraintExpression
303− (sch :: Symbol)
304− (tab :: Symbol)
305− (schemas :: SchemasType)
306− (constraint :: TableConstraint)
307− = UnsafeTableConstraintExpression
308− { renderTableConstraintExpression :: ByteString }
309− deriving (GHC.Generic,Show,Eq,Ord,NFData)
310−instance RenderSQL
311− (TableConstraintExpression sch tab schemas constraint) where
312− renderSQL = renderTableConstraintExpression
313−
314−{-| A `check` constraint is the most generic `TableConstraint` type.
315−It allows you to specify that the value in a certain column must satisfy
316−a Boolean (truth-value) expression.
317−
318−>>> :{
319−type Schema = '[
320− "tab" ::: 'Table ('[ "inequality" ::: 'Check '["a","b"]] :=> '[
321− "a" ::: 'NoDef :=> 'NotNull 'PGint4,
322− "b" ::: 'NoDef :=> 'NotNull 'PGint4
323− ])]
324−:}
325−
326−>>> :{
327−let
328− definition :: Definition (Public '[]) (Public Schema)
329− definition = createTable #tab
330− ( (int & notNullable) `as` #a :*
331− (int & notNullable) `as` #b )
332− ( check (#a :* #b) (#a .> #b) `as` #inequality )
333−:}
334−
335−>>> printSQL definition
336−CREATE TABLE "tab" ("a" int NOT NULL, "b" int NOT NULL, CONSTRAINT "inequality" CHECK (("a" > "b")));
337−-}
338−check
339− :: ( Has sch schemas schema
340− , Has tab schema ('Table table)
341− , HasAll aliases (TableToRow table) subcolumns )
342− => NP Alias aliases
343− -- ^ specify the subcolumns which are getting checked
344− -> (forall t. Condition '[] '[] 'Ungrouped schemas '[] '[t ::: subcolumns])
345− -- ^ a closed `Condition` on those subcolumns
346− -> TableConstraintExpression sch tab schemas ('Check aliases)
347−check _cols condition = UnsafeTableConstraintExpression $
348− "CHECK" <+> parenthesized (renderSQL condition)
349−
350−{-| A `unique` constraint ensure that the data contained in a column,
351−or a group of columns, is unique among all the rows in the table.
352−
353−>>> :{
354−type Schema = '[
355− "tab" ::: 'Table( '[ "uq_a_b" ::: 'Unique '["a","b"]] :=> '[
356− "a" ::: 'NoDef :=> 'Null 'PGint4,
357− "b" ::: 'NoDef :=> 'Null 'PGint4
358− ])]
359−:}
360−
361−>>> :{
362−let
363− definition :: Definition (Public '[]) (Public Schema)
364− definition = createTable #tab
365− ( (int & nullable) `as` #a :*
366− (int & nullable) `as` #b )
367− ( unique (#a :* #b) `as` #uq_a_b )
368−:}
369−
370−>>> printSQL definition
371−CREATE TABLE "tab" ("a" int NULL, "b" int NULL, CONSTRAINT "uq_a_b" UNIQUE ("a", "b"));
372−-}
373−unique
374− :: ( Has sch schemas schema
375− , Has tab schema('Table table)
376− , HasAll aliases (TableToRow table) subcolumns )
377− => NP Alias aliases
378− -- ^ specify subcolumns which together are unique for each row
379− -> TableConstraintExpression sch tab schemas ('Unique aliases)
380−unique columns = UnsafeTableConstraintExpression $
381− "UNIQUE" <+> parenthesized (renderSQL columns)
382−
383−{-| A `primaryKey` constraint indicates that a column, or group of columns,
384−can be used as a unique identifier for rows in the table.
385−This requires that the values be both unique and not null.
386−
387−>>> :{
388−type Schema = '[
389− "tab" ::: 'Table ('[ "pk_id" ::: 'PrimaryKey '["id"]] :=> '[
390− "id" ::: 'Def :=> 'NotNull 'PGint4,
391− "name" ::: 'NoDef :=> 'NotNull 'PGtext
392− ])]
393−:}
394−
395−>>> :{
396−let
397− definition :: Definition (Public '[]) (Public Schema)
398− definition = createTable #tab
399− ( serial `as` #id :*
400− (text & notNullable) `as` #name )
401− ( primaryKey #id `as` #pk_id )
402−:}
403−
404−>>> printSQL definition
405−CREATE TABLE "tab" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_id" PRIMARY KEY ("id"));
406−-}
407−primaryKey
408− :: ( Has sch schemas schema
409− , Has tab schema ('Table table)
410− , HasAll aliases (TableToColumns table) subcolumns
411− , AllNotNull subcolumns )
412− => NP Alias aliases
413− -- ^ specify the subcolumns which together form a primary key.
414− -> TableConstraintExpression sch tab schemas ('PrimaryKey aliases)
415−primaryKey columns = UnsafeTableConstraintExpression $
416− "PRIMARY KEY" <+> parenthesized (renderSQL columns)
417−
418−{-| A `foreignKey` specifies that the values in a column
419−(or a group of columns) must match the values appearing in some row of
420−another table. We say this maintains the referential integrity
421−between two related tables.
422−
423−>>> :{
424−type Schema =
425− '[ "users" ::: 'Table (
426− '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
427− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
428− , "name" ::: 'NoDef :=> 'NotNull 'PGtext
429− ])
430− , "emails" ::: 'Table (
431− '[ "pk_emails" ::: 'PrimaryKey '["id"]
432− , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
433− ] :=>
434− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
435− , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
436− , "email" ::: 'NoDef :=> 'Null 'PGtext
437− ])
438− ]
439−:}
440−
441−>>> :{
442−let
443− setup :: Definition (Public '[]) (Public Schema)
444− setup =
445− createTable #users
446− ( serial `as` #id :*
447− (text & notNullable) `as` #name )
448− ( primaryKey #id `as` #pk_users ) >>>
449− createTable #emails
450− ( serial `as` #id :*
451− (int & notNullable) `as` #user_id :*
452− (text & nullable) `as` #email )
453− ( primaryKey #id `as` #pk_emails :*
454− foreignKey #user_id #users #id
455− OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
456−in printSQL setup
457−:}
458−CREATE TABLE "users" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_users" PRIMARY KEY ("id"));
459−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);
460−
461−A `foreignKey` can even be a table self-reference.
462−
463−>>> :{
464−type Schema =
465− '[ "employees" ::: 'Table (
466− '[ "employees_pk" ::: 'PrimaryKey '["id"]
467− , "employees_employer_fk" ::: 'ForeignKey '["employer_id"] "employees" '["id"]
468− ] :=>
469− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
470− , "name" ::: 'NoDef :=> 'NotNull 'PGtext
471− , "employer_id" ::: 'NoDef :=> 'Null 'PGint4
472− ])
473− ]
474−:}
475−
476−>>> :{
477−let
478− setup :: Definition (Public '[]) (Public Schema)
479− setup =
480− createTable #employees
481− ( serial `as` #id :*
482− (text & notNullable) `as` #name :*
483− (integer & nullable) `as` #employer_id )
484− ( primaryKey #id `as` #employees_pk :*
485− foreignKey #employer_id #employees #id
486− OnDeleteCascade OnUpdateCascade `as` #employees_employer_fk )
487−in printSQL setup
488−:}
489−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);
490−-}
491−foreignKey
492− :: (ForeignKeyed schemas sch schema child parent
493− table reftable
494− columns refcolumns
495− constraints cols
496− reftys tys )
497− => NP Alias columns
498− -- ^ column or columns in the table
499− -> Alias parent
500− -- ^ reference table
501− -> NP Alias refcolumns
502− -- ^ reference column or columns in the reference table
503− -> OnDeleteClause
504− -- ^ what to do when reference is deleted
505− -> OnUpdateClause
506− -- ^ what to do when reference is updated
507− -> TableConstraintExpression sch child schemas
508− ('ForeignKey columns parent refcolumns)
509−foreignKey keys parent refs ondel onupd = UnsafeTableConstraintExpression $
510− "FOREIGN KEY" <+> parenthesized (renderSQL keys)
511− <+> "REFERENCES" <+> renderSQL parent
512− <+> parenthesized (renderSQL refs)
513− <+> renderSQL ondel
514− <+> renderSQL onupd
515−
516−-- | A constraint synonym between types involved in a foreign key constraint.
517−type ForeignKeyed schemas
518− sch
519− schema
520− child parent
521− table reftable
522− columns refcolumns
523− constraints cols
524− reftys tys =
525− ( Has sch schemas schema
526− , Has child schema ('Table table)
527− , Has parent schema ('Table reftable)
528− , HasAll columns (TableToColumns table) tys
529− , reftable ~ (constraints :=> cols)
530− , HasAll refcolumns cols reftys
531− , SOP.AllZip SamePGType tys reftys
532− , Uniquely refcolumns constraints )
533−
534−-- | `OnDeleteClause` indicates what to do with rows that reference a deleted row.
535−data OnDeleteClause
536− = OnDeleteNoAction
537− -- ^ if any referencing rows still exist when the constraint is checked,
538− -- an error is raised
539− | OnDeleteRestrict -- ^ prevents deletion of a referenced row
540− | OnDeleteCascade
541− -- ^ specifies that when a referenced row is deleted,
542− -- row(s) referencing it should be automatically deleted as well
543− deriving (GHC.Generic,Show,Eq,Ord)
544−instance NFData OnDeleteClause
545−-- | Render `OnDeleteClause`.
546−instance RenderSQL OnDeleteClause where
547− renderSQL = \case
548− OnDeleteNoAction -> "ON DELETE NO ACTION"
549− OnDeleteRestrict -> "ON DELETE RESTRICT"
550− OnDeleteCascade -> "ON DELETE CASCADE"
551−
552−-- | Analagous to `OnDeleteClause` there is also `OnUpdateClause` which is invoked
553−-- when a referenced column is changed (updated).
554−data OnUpdateClause
555− = OnUpdateNoAction
556− -- ^ if any referencing rows has not changed when the constraint is checked,
557− -- an error is raised
558− | OnUpdateRestrict -- ^ prevents update of a referenced row
559− | OnUpdateCascade
560− -- ^ the updated values of the referenced column(s) should be copied
561− -- into the referencing row(s)
562− deriving (GHC.Generic,Show,Eq,Ord)
563−instance NFData OnUpdateClause
564−
565−-- | Render `OnUpdateClause`.
566−instance RenderSQL OnUpdateClause where
567− renderSQL = \case
568− OnUpdateNoAction -> "ON UPDATE NO ACTION"
569− OnUpdateRestrict -> "ON UPDATE RESTRICT"
570− OnUpdateCascade -> "ON UPDATE CASCADE"
571−
572−{-----------------------------------------
573−DROP statements
574−-----------------------------------------}
575−
576−-- | >>> :{
577−-- let
578−-- definition :: Definition '["muh_schema" ::: schema, "public" ::: public] '["public" ::: public]
579−-- definition = dropSchema #muh_schema
580−-- :}
581−--
582−-- >>> printSQL definition
583−-- DROP SCHEMA "muh_schema";
584−dropSchema
585− :: Has sch schemas schema
586− => Alias sch
587− -> Definition schemas (Drop sch schemas)
588−dropSchema sch = UnsafeDefinition $ "DROP SCHEMA" <+> renderSQL sch <> ";"
589−
590−-- | `dropTable` removes a table from the schema.
591−--
592−-- >>> :{
593−-- let
594−-- definition :: Definition '["public" ::: '["muh_table" ::: 'Table t]] (Public '[])
595−-- definition = dropTable #muh_table
596−-- :}
597−--
598−-- >>> printSQL definition
599−-- DROP TABLE "muh_table";
600−dropTable
601− :: ( Has sch schemas schema
602− , Has tab schema ('Table table))
603− => QualifiedAlias sch tab -- ^ table to remove
604− -> Definition schemas (Alter sch (Drop tab schema) schemas)
605−dropTable tab = UnsafeDefinition $ "DROP TABLE" <+> renderSQL tab <> ";"
606−
607−{-----------------------------------------
608−ALTER statements
609−-----------------------------------------}
610−
611−-- | `alterTable` changes the definition of a table from the schema.
612−alterTable
613− :: (Has sch schemas schema, Has tab schema ('Table table0))
614− => QualifiedAlias sch tab -- ^ table to alter
615− -> AlterTable sch tab schemas table1 -- ^ alteration to perform
616− -> Definition schemas (Alter sch (Alter tab ('Table table1) schema) schemas)
617−alterTable tab alteration = UnsafeDefinition $
618− "ALTER TABLE"
619− <+> renderSQL tab
620− <+> renderAlterTable alteration
621− <> ";"
622−
623−-- | `alterTableRename` changes the name of a table from the schema.
624−--
625−-- >>> printSQL $ alterTableRename #foo #bar
626−-- ALTER TABLE "foo" RENAME TO "bar";
627−alterTableRename
628− :: (KnownSymbol table0, KnownSymbol table1)
629− => Alias table0 -- ^ table to rename
630− -> Alias table1 -- ^ what to rename it
631− -> Definition schema (Rename table0 table1 schema)
632−alterTableRename table0 table1 = UnsafeDefinition $
633− "ALTER TABLE" <+> renderSQL table0
634− <+> "RENAME TO" <+> renderSQL table1 <> ";"
635−
636−-- | An `AlterTable` describes the alteration to perform on the columns
637−-- of a table.
638−newtype AlterTable
639− (sch :: Symbol)
640− (tab :: Symbol)
641− (schemas :: SchemasType)
642− (table :: TableType) =
643− UnsafeAlterTable {renderAlterTable :: ByteString}
644− deriving (GHC.Generic,Show,Eq,Ord,NFData)
645−
646−-- | An `addConstraint` adds a table constraint.
647−--
648−-- >>> :{
649−-- let
650−-- definition :: Definition
651−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
652−-- '["public" ::: '["tab" ::: 'Table ('["positive" ::: 'Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
653−-- definition = alterTable #tab (addConstraint #positive (check #col (#col .> 0)))
654−-- in printSQL definition
655−-- :}
656−-- ALTER TABLE "tab" ADD CONSTRAINT "positive" CHECK (("col" > 0));
657−addConstraint
658− :: ( KnownSymbol alias
659− , Has sch schemas schema
660− , Has tab schema ('Table table0)
661− , table0 ~ (constraints :=> columns)
662− , table1 ~ (Create alias constraint constraints :=> columns) )
663− => Alias alias
664− -> TableConstraintExpression sch tab schemas constraint
665− -- ^ constraint to add
666− -> AlterTable sch tab schemas table1
667−addConstraint alias constraint = UnsafeAlterTable $
668− "ADD" <+> "CONSTRAINT" <+> renderSQL alias
669− <+> renderSQL constraint
670−
671−-- | A `dropConstraint` drops a table constraint.
672−--
673−-- >>> :{
674−-- let
675−-- definition :: Definition
676−-- '["public" ::: '["tab" ::: 'Table ('["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
677−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
678−-- definition = alterTable #tab (dropConstraint #positive)
679−-- in printSQL definition
680−-- :}
681−-- ALTER TABLE "tab" DROP CONSTRAINT "positive";
682−dropConstraint
683− :: ( KnownSymbol constraint
684− , Has sch schemas schema
685− , Has tab schema ('Table table0)
686− , table0 ~ (constraints :=> columns)
687− , table1 ~ (Drop constraint constraints :=> columns) )
688− => Alias constraint
689− -- ^ constraint to drop
690− -> AlterTable sch tab schemas table1
691−dropConstraint constraint = UnsafeAlterTable $
692− "DROP" <+> "CONSTRAINT" <+> renderSQL constraint
693−
694−-- | An `AddColumn` is either @NULL@ or has @DEFAULT@.
695−class AddColumn ty where
696− -- | `addColumn` adds a new column, initially filled with whatever
697− -- default value is given or with @NULL@.
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" ::: 'Def :=> 'Null 'PGtext ])]]
706− -- definition = alterTable #tab (addColumn #col2 (text & nullable & default_ "foo"))
707− -- in printSQL definition
708− -- :}
709− -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL DEFAULT E'foo';
710− --
711− -- >>> :{
712− -- let
713− -- definition :: Definition
714− -- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]
715− -- '["public" ::: '["tab" ::: 'Table ('[] :=>
716− -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
717− -- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]]
718− -- definition = alterTable #tab (addColumn #col2 (text & nullable))
719− -- in printSQL definition
720− -- :}
721− -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL;
722− addColumn
723− :: ( KnownSymbol column
724− , Has sch schemas schema
725− , Has tab schema ('Table table0)
726− , table0 ~ (constraints :=> columns) )
727− => Alias column -- ^ column to add
728− -> ColumnTypeExpression schemas ty -- ^ type of the new column
729− -> AlterTable sch tab schemas (constraints :=> Create column ty columns)
730− addColumn column ty = UnsafeAlterTable $
731− "ADD COLUMN" <+> renderSQL column <+> renderColumnTypeExpression ty
732−instance {-# OVERLAPPING #-} AddColumn ('Def :=> ty)
733−instance {-# OVERLAPPABLE #-} AddColumn ('NoDef :=> 'Null ty)
734−
735−-- | A `dropColumn` removes a column. Whatever data was in the column
736−-- disappears. Table constraints involving the column are dropped, too.
737−-- However, if the column is referenced by a foreign key constraint of
738−-- another table, PostgreSQL will not silently drop that constraint.
739−--
740−-- >>> :{
741−-- let
742−-- definition :: Definition
743−-- '["public" ::: '["tab" ::: 'Table ('[] :=>
744−-- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
745−-- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]]
746−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]
747−-- definition = alterTable #tab (dropColumn #col2)
748−-- in printSQL definition
749−-- :}
750−-- ALTER TABLE "tab" DROP COLUMN "col2";
751−dropColumn
752− :: ( KnownSymbol column
753− , Has sch schemas schema
754− , Has tab schema ('Table table0)
755− , table0 ~ (constraints :=> columns)
756− , table1 ~ (constraints :=> Drop column columns) )
757− => Alias column -- ^ column to remove
758− -> AlterTable sch tab schemas table1
759−dropColumn column = UnsafeAlterTable $
760− "DROP COLUMN" <+> renderSQL column
761−
762−-- | A `renameColumn` renames a column.
763−--
764−-- >>> :{
765−-- let
766−-- definition :: Definition
767−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["foo" ::: 'NoDef :=> 'Null 'PGint4])]]
768−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["bar" ::: 'NoDef :=> 'Null 'PGint4])]]
769−-- definition = alterTable #tab (renameColumn #foo #bar)
770−-- in printSQL definition
771−-- :}
772−-- ALTER TABLE "tab" RENAME COLUMN "foo" TO "bar";
773−renameColumn
774− :: ( KnownSymbol column0
775− , KnownSymbol column1
776− , Has sch schemas schema
777− , Has tab schema ('Table table0)
778− , table0 ~ (constraints :=> columns)
779− , table1 ~ (constraints :=> Rename column0 column1 columns) )
780− => Alias column0 -- ^ column to rename
781− -> Alias column1 -- ^ what to rename the column
782− -> AlterTable sch tab schemas table1
783−renameColumn column0 column1 = UnsafeAlterTable $
784− "RENAME COLUMN" <+> renderSQL column0 <+> "TO" <+> renderSQL column1
785−
786−-- | An `alterColumn` alters a single column.
787−alterColumn
788− :: ( KnownSymbol column
789− , Has sch schemas schema
790− , Has tab schema ('Table table0)
791− , table0 ~ (constraints :=> columns)
792− , Has column columns ty0
793− , table1 ~ (constraints :=> Alter column ty1 columns))
794− => Alias column -- ^ column to alter
795− -> AlterColumn schemas ty0 ty1 -- ^ alteration to perform
796− -> AlterTable sch tab schemas table1
797−alterColumn column alteration = UnsafeAlterTable $
798− "ALTER COLUMN" <+> renderSQL column <+> renderAlterColumn alteration
799−
800−-- | An `AlterColumn` describes the alteration to perform on a single column.
801−newtype AlterColumn (schemas :: SchemasType) (ty0 :: ColumnType) (ty1 :: ColumnType) =
802− UnsafeAlterColumn {renderAlterColumn :: ByteString}
803− deriving (GHC.Generic,Show,Eq,Ord,NFData)
804−
805−-- | A `setDefault` sets a new default for a column. Note that this doesn't
806−-- affect any existing rows in the table, it just changes the default for
807−-- future insert and update commands.
808−--
809−-- >>> :{
810−-- let
811−-- definition :: Definition
812−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
813−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]]
814−-- definition = alterTable #tab (alterColumn #col (setDefault 5))
815−-- in printSQL definition
816−-- :}
817−-- ALTER TABLE "tab" ALTER COLUMN "col" SET DEFAULT 5;
818−setDefault
819− :: Expression '[] '[] 'Ungrouped schemas '[] '[] ty -- ^ default value to set
820− -> AlterColumn schemas (constraint :=> ty) ('Def :=> ty)
821−setDefault expression = UnsafeAlterColumn $
822− "SET DEFAULT" <+> renderExpression expression
823−
824−-- | A `dropDefault` removes any default value for a column.
825−--
826−-- >>> :{
827−-- let
828−-- definition :: Definition
829−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]]
830−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
831−-- definition = alterTable #tab (alterColumn #col dropDefault)
832−-- in printSQL definition
833−-- :}
834−-- ALTER TABLE "tab" ALTER COLUMN "col" DROP DEFAULT;
835−dropDefault :: AlterColumn schemas ('Def :=> ty) ('NoDef :=> ty)
836−dropDefault = UnsafeAlterColumn $ "DROP DEFAULT"
837−
838−-- | A `setNotNull` adds a @NOT NULL@ constraint to a column.
839−-- The constraint will be checked immediately, so the table data must satisfy
840−-- the constraint before it can be added.
841−--
842−-- >>> :{
843−-- let
844−-- definition :: Definition
845−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
846−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
847−-- definition = alterTable #tab (alterColumn #col setNotNull)
848−-- in printSQL definition
849−-- :}
850−-- ALTER TABLE "tab" ALTER COLUMN "col" SET NOT NULL;
851−setNotNull
852− :: AlterColumn schemas (constraint :=> 'Null ty) (constraint :=> 'NotNull ty)
853−setNotNull = UnsafeAlterColumn $ "SET NOT NULL"
854−
855−-- | A `dropNotNull` drops a @NOT NULL@ constraint from a column.
856−--
857−-- >>> :{
858−-- let
859−-- definition :: Definition
860−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
861−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
862−-- definition = alterTable #tab (alterColumn #col dropNotNull)
863−-- in printSQL definition
864−-- :}
865−-- ALTER TABLE "tab" ALTER COLUMN "col" DROP NOT NULL;
866−dropNotNull
867− :: AlterColumn schemas (constraint :=> 'NotNull ty) (constraint :=> 'Null ty)
868−dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL"
869−
870−-- | An `alterType` converts a column to a different data type.
871−-- This will succeed only if each existing entry in the column can be
872−-- converted to the new type by an implicit cast.
873−--
874−-- >>> :{
875−-- let
876−-- definition :: Definition
877−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
878−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGnumeric])]]
879−-- definition =
880−-- alterTable #tab (alterColumn #col (alterType (numeric & notNullable)))
881−-- in printSQL definition
882−-- :}
883−-- ALTER TABLE "tab" ALTER COLUMN "col" TYPE numeric NOT NULL;
884−alterType :: ColumnTypeExpression schemas ty -> AlterColumn schemas ty0 ty
885−alterType ty = UnsafeAlterColumn $ "TYPE" <+> renderColumnTypeExpression ty
886−
887−{- | Create a view.
888−>>> type ABC = '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4]
889−>>> type BC = '["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4]
890−>>> :{
891−let
892− definition :: Definition
893− '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC)]]
894− '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC), "bc" ::: 'View BC]]
895− definition =
896− createView #bc (select_ (#b :* #c) (from (table #abc)))
897−in printSQL definition
898−:}
899−CREATE VIEW "bc" AS SELECT "b" AS "b", "c" AS "c" FROM "abc" AS "abc";
900−-}
901−createView
902− :: (KnownSymbol sch, KnownSymbol vw, Has sch schemas schema)
903− => QualifiedAlias sch vw -- ^ the name of the view to add
904− -> Query '[] '[] schemas '[] view -- ^ query
905− -> Definition schemas (Alter sch (Create vw ('View view) schema) schemas)
906−createView alias query = UnsafeDefinition $
907− "CREATE" <+> "VIEW" <+> renderSQL alias <+> "AS"
908− <+> renderQuery query <> ";"
909−
910−-- | Drop a view.
911−--
912−-- >>> :{
913−-- let
914−-- definition :: Definition
915−-- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])
916−-- , "bc" ::: 'View ('["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4])]]
917−-- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])]]
918−-- definition = dropView #bc
919−-- in printSQL definition
920−-- :}
921−-- DROP VIEW "bc";
922−dropView
923− :: (Has sch schemas schema, Has vw schema ('View view))
924− => QualifiedAlias sch vw -- ^ view to remove
925− -> Definition schemas (Alter sch (Drop vw schema) schemas)
926−dropView vw = UnsafeDefinition $ "DROP VIEW" <+> renderSQL vw <> ";"
927−
928−-- | Enumerated types are created using the `createTypeEnum` command, for example
929−--
930−-- >>> printSQL $ (createTypeEnum #mood (label @"sad" :* label @"ok" :* label @"happy") :: Definition (Public '[]) '["public" ::: '["mood" ::: 'Typedef ('PGenum '["sad","ok","happy"])]])
931−-- CREATE TYPE "mood" AS ENUM ('sad', 'ok', 'happy');
932−createTypeEnum
933− :: (KnownSymbol enum, Has sch schemas schema, SOP.All KnownSymbol labels)
934− => QualifiedAlias sch enum
935− -- ^ name of the user defined enumerated type
936− -> NP PGlabel labels
937− -- ^ labels of the enumerated type
938− -> Definition schemas (Alter sch (Create enum ('Typedef ('PGenum labels)) schema) schemas)
939−createTypeEnum enum labels = UnsafeDefinition $
940− "CREATE" <+> "TYPE" <+> renderSQL enum <+> "AS" <+> "ENUM" <+>
941− parenthesized (renderSQL labels) <> ";"
942−
943−-- | Enumerated types can also be generated from a Haskell type, for example
944−--
945−-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic
946−-- >>> instance SOP.Generic Schwarma
947−-- >>> instance SOP.HasDatatypeInfo Schwarma
948−-- >>> :{
949−-- let
950−-- createSchwarma :: Definition (Public '[]) '["public" ::: '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))]]
951−-- createSchwarma = createTypeEnumFrom @Schwarma #schwarma
952−-- in
953−-- printSQL createSchwarma
954−-- :}
955−-- CREATE TYPE "schwarma" AS ENUM ('Beef', 'Lamb', 'Chicken');
956−createTypeEnumFrom
957− :: forall hask sch enum schemas schema.
958− ( SOP.Generic hask
959− , SOP.All KnownSymbol (LabelsPG hask)
960− , KnownSymbol enum
961− , Has sch schemas schema )
962− => QualifiedAlias sch enum
963− -- ^ name of the user defined enumerated type
964− -> Definition schemas (Alter sch (Create enum ('Typedef (PG (Enumerated hask))) schema) schemas)
965−createTypeEnumFrom enum = createTypeEnum enum
966− (SOP.hpure label :: NP PGlabel (LabelsPG hask))
967−
968−{- | `createTypeComposite` creates a composite type. The composite type is
969−specified by a list of attribute names and data types.
970−
971−>>> :{
972−type PGcomplex = 'PGcomposite
973− '[ "real" ::: 'NotNull 'PGfloat8
974− , "imaginary" ::: 'NotNull 'PGfloat8 ]
975−:}
976−
977−>>> :{
978−let
979− setup :: Definition (Public '[]) '["public" ::: '["complex" ::: 'Typedef PGcomplex]]
980− setup = createTypeComposite #complex
981− (float8 `as` #real :* float8 `as` #imaginary)
982−in printSQL setup
983−:}
984−CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);
985−-}
986−createTypeComposite
987− :: (KnownSymbol ty, Has sch schemas schema, SOP.SListI fields)
988− => QualifiedAlias sch ty
989− -- ^ name of the user defined composite type
990− -> NP (Aliased (TypeExpression schemas)) fields
991− -- ^ list of attribute names and data types
992− -> Definition schemas (Alter sch (Create ty ('Typedef ('PGcomposite fields)) schema) schemas)
993−createTypeComposite ty fields = UnsafeDefinition $
994− "CREATE" <+> "TYPE" <+> renderSQL ty <+> "AS" <+> parenthesized
995− (renderCommaSeparated renderField fields) <> ";"
996− where
997− renderField :: Aliased (TypeExpression schemas) x -> ByteString
998− renderField (typ `As` alias) =
999− renderSQL alias <+> renderSQL typ
1000−
1001−-- | Composite types can also be generated from a Haskell type, for example
1002−--
1003−-- >>> data Complex = Complex {real :: Double, imaginary :: Double} deriving GHC.Generic
1004−-- >>> instance SOP.Generic Complex
1005−-- >>> instance SOP.HasDatatypeInfo Complex
1006−-- >>> type Schema = '["complex" ::: 'Typedef (PG (Composite Complex))]
1007−-- >>> :{
1008−-- let
1009−-- createComplex :: Definition (Public '[]) (Public Schema)
1010−-- createComplex = createTypeCompositeFrom @Complex #complex
1011−-- in
1012−-- printSQL createComplex
1013−-- :}
1014−-- CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);
1015−createTypeCompositeFrom
1016− :: forall hask sch ty schemas schema.
1017− ( SOP.All (FieldTyped schemas) (RowPG hask)
1018− , KnownSymbol ty
1019− , Has sch schemas schema )
1020− => QualifiedAlias sch ty
1021− -- ^ name of the user defined composite type
1022− -> Definition schemas (Alter sch (Create ty ( 'Typedef (PG (Composite hask))) schema) schemas)
1023−createTypeCompositeFrom ty = createTypeComposite ty
1024− (SOP.hcpure (SOP.Proxy :: SOP.Proxy (FieldTyped schemas)) fieldtype
1025− :: NP (Aliased (TypeExpression schemas)) (RowPG hask))
1026−
1027−{-|
1028−`createDomain` creates a new domain. A domain is essentially a data type
1029−with constraints (restrictions on the allowed set of values).
1030−
1031−Domains are useful for abstracting common constraints on fields
1032−into a single location for maintenance. For example, several tables might
1033−contain email address columns, all requiring the same `check` constraint
1034−to verify the address syntax. Define a domain rather than setting up
1035−each table's constraint individually.
1036−
1037−>>> :{
1038−let
1039− createPositive :: Definition (Public '[]) (Public '["positive" ::: 'Typedef 'PGfloat4])
1040− createPositive = createDomain #positive real (#value .> 0 .&& (#value & isNotNull))
1041−in printSQL createPositive
1042−:}
1043−CREATE DOMAIN "positive" AS real CHECK ((("value" > 0) AND "value" IS NOT NULL));
1044−-}
1045−createDomain
1046− :: (Has sch schemas schema, KnownSymbol dom)
1047− => QualifiedAlias sch dom
1048− -> (forall null. TypeExpression schemas (null ty))
1049− -> (forall tab. Condition '[] '[] 'Ungrouped schemas '[] '[tab ::: '["value" ::: 'Null ty]])
1050− -> Definition schemas (Alter sch (Create dom ('Typedef ty) schema) schemas)
1051−createDomain dom ty condition =
1052− UnsafeDefinition $ "CREATE DOMAIN" <+> renderSQL dom
1053− <+> "AS" <+> renderTypeExpression ty
1054− <+> "CHECK" <+> parenthesized (renderSQL condition) <> ";"
1055−
1056−{- |
1057−>>> :{
1058−let
1059− createSmallIntRange :: Definition (Public '[]) (Public '["int2range" ::: 'Typedef ('PGrange 'PGint2)])
1060− createSmallIntRange = createTypeRange #int2range int2
1061−in printSQL createSmallIntRange
1062−:}
1063−CREATE TYPE "int2range" AS RANGE (subtype = int2);
1064−-}
1065−createTypeRange
1066− :: (Has sch schemas schema, KnownSymbol range)
1067− => QualifiedAlias sch range
1068− -> (forall null. TypeExpression schemas (null ty))
1069− -> Definition schemas (Alter sch (Create range ('Typedef ('PGrange ty)) schema) schemas)
1070−createTypeRange range ty = UnsafeDefinition $
1071− "CREATE" <+> "TYPE" <+> renderSQL range <+> "AS" <+> "RANGE" <+>
1072− parenthesized ("subtype" <+> "=" <+> renderTypeExpression ty) <> ";"
1073−
1074−{- |
1075−>>> :{
1076−type Table = '[] :=>
1077− '[ "a" ::: 'NoDef :=> 'Null 'PGint4
1078− , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]
1079−:}
1080−
1081−>>> :{
1082−let
1083− setup :: Definition (Public '[]) (Public '["tab" ::: 'Table Table, "ix" ::: 'Index])
1084− setup =
1085− createTable #tab (nullable int `as` #a :* nullable real `as` #b) Nil >>>
1086− createIndex #ix #tab Btree [#a & AscNullsFirst, #b & AscNullsLast]
1087−in printSQL setup
1088−:}
1089−CREATE TABLE "tab" ("a" int NULL, "b" real NULL);
1090−CREATE INDEX "ix" ON "tab" USING btree (("a") ASC NULLS FIRST, ("b") ASC NULLS LAST);
1091−-}
1092−createIndex
1093− :: (Has sch schemas schema, Has tab schema ('Table table), KnownSymbol ix)
1094− => Alias ix
1095− -> QualifiedAlias sch tab
1096− -> IndexMethod
1097− -> [SortExpression '[] '[] 'Ungrouped schemas '[] '[tab ::: TableToRow table]]
1098− -> Definition schemas (Alter sch (Create ix 'Index schema) schemas)
1099−createIndex ix tab method cols = UnsafeDefinition $
1100− "CREATE" <+> "INDEX" <+> renderSQL ix <+> "ON" <+> renderSQL tab
1101− <+> "USING" <+> renderSQL method
1102− <+> parenthesized (commaSeparated (renderIndex <$> cols))
1103− <> ";"
1104− where
1105− renderIndex = \case
1106− Asc expression -> parenthesized (renderSQL expression) <+> "ASC"
1107− Desc expression -> parenthesized (renderSQL expression) <+> "DESC"
1108− AscNullsFirst expression -> parenthesized (renderSQL expression)
1109− <+> "ASC NULLS FIRST"
1110− DescNullsFirst expression -> parenthesized (renderSQL expression)
1111− <+> "DESC NULLS FIRST"
1112− AscNullsLast expression -> parenthesized (renderSQL expression)
1113− <+> "ASC NULLS LAST"
1114− DescNullsLast expression -> parenthesized (renderSQL expression)
1115− <+> "DESC NULLS LAST"
1116−
1117−data IndexMethod
1118− = Btree
1119− | Hash
1120− | Gist
1121− | Spgist
1122− | Gin
1123− | Brin
1124− deriving stock (Eq, Ord, Show, GHC.Generic)
1125− deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
1126−instance RenderSQL IndexMethod where
1127− renderSQL = \case
1128− Btree -> "btree"
1129− Hash -> "hash"
1130− Gist -> "gist"
1131− Spgist -> "spgist"
1132− Gin -> "gin"
1133− Brin -> "brin"
1134−
1135−createFunction
1136− :: ( Has sch schemas schema
1137− , KnownSymbol fun
1138− , SOP.SListI args )
1139− => QualifiedAlias sch fun
1140− -> NP (TypeExpression schemas) args
1141− -> TypeExpression schemas ret
1142− -> FunctionDefinition schemas args ('Returns ret)
1143− -> Definition schemas (Alter sch (Create fun ('Function args ('Returns ret)) schema) schemas)
1144−createFunction fun args ret fundef = UnsafeDefinition $
1145− "CREATE" <+> "FUNCTION" <+> renderSQL fun
1146− <+> parenthesized (renderCommaSeparated renderSQL args)
1147− <+> "RETURNS" <+> renderSQL ret <+> renderSQL fundef <> ";"
1148−
1149−createOrReplaceFunction
1150− :: ( Has sch schemas schema
1151− , Has fun schema ('Function args0 ret0)
1152− , SOP.SListI args )
1153− => QualifiedAlias sch fun
1154− -> NP (TypeExpression schemas) args
1155− -> TypeExpression schemas ret
1156− -> FunctionDefinition schemas args ('Returns ret)
1157− -> Definition schemas (Alter sch (Alter fun ('Function args ('Returns ret)) schema) schemas)
1158−createOrReplaceFunction fun args ret fundef = UnsafeDefinition $
1159− "CREATE" <+> "OR" <+> "REPLACE" <+> "FUNCTION" <+> renderSQL fun
1160− <+> parenthesized (renderCommaSeparated renderSQL args)
1161− <+> "RETURNS" <+> renderSQL ret <+> renderSQL fundef <> ";"
1162−
1163−languageSql
1164− :: Query '[] '[] schemas args '[col ::: ret]
1165− -> FunctionDefinition schemas args ('Returns ret)
1166−languageSql qry = UnsafeFunctionDefinition $
1167− "language sql as" <+> "$$" <+> renderSQL qry <+> "$$"
1168−
1169−languageSqlSet
1170− :: Query '[] '[] schemas args rets
1171− -> FunctionDefinition schemas args ('ReturnsTable rets)
1172−languageSqlSet qry = UnsafeFunctionDefinition $
1173− "language sql as" <+> "$$" <+> renderSQL qry <+> "$$"
1174−
1175−createSetFunction
1176− :: ( Has sch schemas schema
1177− , KnownSymbol fun
1178− , SOP.SListI args
1179− , SOP.SListI rets )
1180− => QualifiedAlias sch fun
1181− -> NP (TypeExpression schemas) args
1182− -> NP (Aliased (TypeExpression schemas)) rets
1183− -> FunctionDefinition schemas args ('ReturnsTable rets)
1184− -> Definition schemas (Alter sch (Create fun ('Function args ('ReturnsTable rets)) schema) schemas)
1185−createSetFunction fun args rets fundef = UnsafeDefinition $
1186− "CREATE" <+> "FUNCTION" <+> renderSQL fun
1187− <+> parenthesized (renderCommaSeparated renderSQL args)
1188− <+> "RETURNS" <+> "TABLE"
1189− <+> parenthesized (renderCommaSeparated renderRet rets)
1190− <+> renderSQL fundef <> ";"
1191− where
1192− renderRet :: Aliased (TypeExpression s) r -> ByteString
1193− renderRet (ty `As` col) = renderSQL col <+> renderSQL ty
1194−
1195−createOrReplaceSetFunction
1196− :: ( Has sch schemas schema
1197− , Has fun schema ('Function args0 ret0)
1198− , SOP.SListI args
1199− , SOP.SListI rets )
1200− => QualifiedAlias sch fun
1201− -> NP (TypeExpression schemas) args
1202− -> NP (Aliased (TypeExpression schemas)) rets
1203− -> FunctionDefinition schemas args ('ReturnsTable rets)
1204− -> Definition schemas (Alter sch (Alter fun ('Function args ('ReturnsTable rets)) schema) schemas)
1205−createOrReplaceSetFunction fun args rets fundef = UnsafeDefinition $
1206− "CREATE" <+> "OR" <+> "REPLACE" <+> "FUNCTION" <+> renderSQL fun
1207− <+> parenthesized (renderCommaSeparated renderSQL args)
1208− <+> "RETURNS" <+> "TABLE"
1209− <+> parenthesized (renderCommaSeparated renderRet rets)
1210− <+> renderSQL fundef <> ";"
1211− where
1212− renderRet :: Aliased (TypeExpression s) r -> ByteString
1213− renderRet (ty `As` col) = renderSQL col <+> renderSQL ty
1214−
1215−dropFunction
1216− :: (Has sch schemas schema, Has fun schema ('Function args ret))
1217− => QualifiedAlias sch fun
1218− -- ^ name of the user defined function
1219− -> Definition schemas (Alter sch (Drop ix schema) schemas)
1220−dropFunction fun = UnsafeDefinition $
1221− "DROP" <+> "Function" <+> renderSQL fun <> ";"
1222−
1223−newtype FunctionDefinition schemas args ret = UnsafeFunctionDefinition
1224− { renderFunctionDefinition :: ByteString }
1225− deriving (Eq,Show,GHC.Generic,NFData)
1226−instance RenderSQL (FunctionDefinition schemas args ret) where
1227− renderSQL = renderFunctionDefinition
1228−
1229−-- |
1230−-- >>> printSQL (dropIndex #ix :: Definition (Public '["ix" ::: 'Index]) (Public '[]))
1231−-- DROP INDEX "ix";
1232−dropIndex
1233− :: (Has sch schemas schema, Has ix schema 'Index)
1234− => QualifiedAlias sch ix
1235− -- ^ name of the user defined index
1236− -> Definition schemas (Alter sch (Drop ix schema) schemas)
1237−dropIndex ix = UnsafeDefinition $ "DROP" <+> "INDEX" <+> renderSQL ix <> ";"
1238−
1239−-- | Lift `PGTyped` to a field
1240−class FieldTyped schemas ty where
1241− fieldtype :: Aliased (TypeExpression schemas) ty
1242−instance (KnownSymbol alias, PGTyped schemas ty)
1243− => FieldTyped schemas (alias ::: ty) where
1244− fieldtype = pgtype `As` Alias
1245−
1246−-- | Drop a type.
1247−--
1248−-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic
1249−-- >>> instance SOP.Generic Schwarma
1250−-- >>> instance SOP.HasDatatypeInfo Schwarma
1251−-- >>> printSQL (dropType #schwarma :: Definition '["public" ::: '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))]] (Public '[]))
1252−-- DROP TYPE "schwarma";
1253−dropType
1254− :: (Has sch schemas schema, Has td schema ('Typedef ty))
1255− => QualifiedAlias sch td
1256− -- ^ name of the user defined type
1257− -> Definition schemas (Alter sch (Drop td schema) schemas)
1258−dropType tydef = UnsafeDefinition $ "DROP" <+> "TYPE" <+> renderSQL tydef <> ";"
1259−
1260−-- | `ColumnTypeExpression`s are used in `createTable` commands.
1261−newtype ColumnTypeExpression (schemas :: SchemasType) (ty :: ColumnType)
1262− = UnsafeColumnTypeExpression { renderColumnTypeExpression :: ByteString }
1263− deriving (GHC.Generic,Show,Eq,Ord,NFData)
1264−instance RenderSQL (ColumnTypeExpression schemas ty) where
1265− renderSQL = renderColumnTypeExpression
1266−
1267−-- | used in `createTable` commands as a column constraint to note that
1268−-- @NULL@ may be present in a column
1269−nullable
1270− :: TypeExpression schemas (nullity ty)
1271− -> ColumnTypeExpression schemas ('NoDef :=> 'Null ty)
1272−nullable ty = UnsafeColumnTypeExpression $ renderSQL ty <+> "NULL"
1273−
1274−-- | used in `createTable` commands as a column constraint to ensure
1275−-- @NULL@ is not present in a column
1276−notNullable
1277− :: TypeExpression schemas (nullity ty)
1278− -> ColumnTypeExpression schemas ('NoDef :=> 'NotNull ty)
1279−notNullable ty = UnsafeColumnTypeExpression $ renderSQL ty <+> "NOT NULL"
1280−
1281−-- | used in `createTable` commands as a column constraint to give a default
1282−default_
1283− :: Expression '[] '[] 'Ungrouped schemas '[] '[] ty
1284− -> ColumnTypeExpression schemas ('NoDef :=> ty)
1285− -> ColumnTypeExpression schemas ('Def :=> ty)
1286−default_ x ty = UnsafeColumnTypeExpression $
1287− renderSQL ty <+> "DEFAULT" <+> renderExpression x
1288−
1289−-- | not a true type, but merely a notational convenience for creating
1290−-- unique identifier columns with type `PGint2`
1291−serial2, smallserial
1292− :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint2)
1293−serial2 = UnsafeColumnTypeExpression "serial2"
1294−smallserial = UnsafeColumnTypeExpression "smallserial"
1295−-- | not a true type, but merely a notational convenience for creating
1296−-- unique identifier columns with type `PGint4`
1297−serial4, serial
1298− :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint4)
1299−serial4 = UnsafeColumnTypeExpression "serial4"
1300−serial = UnsafeColumnTypeExpression "serial"
1301−-- | not a true type, but merely a notational convenience for creating
1302−-- unique identifier columns with type `PGint8`
1303−serial8, bigserial
1304− :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint8)
1305−serial8 = UnsafeColumnTypeExpression "serial8"
1306−bigserial = UnsafeColumnTypeExpression "bigserial"
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Function.hsnew file+238
@@ -0,0 +1,238 @@
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.hsnew file+159
@@ -0,0 +1,159 @@
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.hsnew file+96
@@ -0,0 +1,96 @@
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.hsnew file+500
@@ -0,0 +1,500 @@
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.hsnew file+339
@@ -0,0 +1,339 @@
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.hsnew file+229
@@ -0,0 +1,229 @@
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.hsnew file+104
@@ -0,0 +1,104 @@
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+63−35
@@ -34,19 +34,22 @@ module Squeal.PostgreSQL.Expression
34 ( -- * Expression
34 ( -- * Expression
35 Expression (..)
35 Expression (..)
36 , Expr
36 , Expr
37− , (:-->)
37+ , type (-->)
38+ , FunctionDB
38 , unsafeFunction
39 , unsafeFunction
39 , function
40 , function
40− , unsafeUnaryOpL
41+ , unsafeLeftOp
41− , unaryOpL
42+ , leftOp
42− , unsafeUnaryOpR
43+ , unsafeRightOp
43− , unaryOpR
44+ , rightOp
44 , Operator
45 , Operator
46+ , OperatorDB
45 , unsafeBinaryOp
47 , unsafeBinaryOp
46 , binaryOp
48 , binaryOp
47 , FunctionVar
49 , FunctionVar
48 , unsafeFunctionVar
50 , unsafeFunctionVar
49− , FunctionN
51+ , type (--->)
52+ , FunctionNDB
50 , unsafeFunctionN
53 , unsafeFunctionN
51 , functionN
54 , functionN
52 , PGSubset (..)
55 , PGSubset (..)
@@ -142,31 +145,54 @@ type Operator x1 x2 y
142 -> Expression outer commons grp schemas params from y
145 -> Expression outer commons grp schemas params from y
143 -- ^ output
146 -- ^ output
144
147
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+
145-- | A @RankNType@ for functions with a single argument.
157-- | A @RankNType@ for functions with a single argument.
146-- These could be either function calls or unary operators.
158-- These could be either function calls or unary operators.
147-- This is a subtype of the usual Haskell function type `Prelude.->`,
159-- This is a subtype of the usual Haskell function type `Prelude.->`,
148-- indeed a subcategory as it is closed under the usual
160-- indeed a subcategory as it is closed under the usual
149-- `Prelude..` and `Prelude.id`.
161-- `Prelude..` and `Prelude.id`.
150−type (:-->) x y
162+type (-->) x y
151 = forall outer commons grp schemas params from
163 = forall outer commons grp schemas params from
152 . Expression outer commons grp schemas params from x
164 . Expression outer commons grp schemas params from x
153 -- ^ input
165 -- ^ input
154 -> Expression outer commons grp schemas params from y
166 -> Expression outer commons grp schemas params from y
155 -- ^ output
167 -- ^ output
156
168
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+
157{- | A @RankNType@ for functions with a fixed-length list of heterogeneous arguments.
176{- | A @RankNType@ for functions with a fixed-length list of heterogeneous arguments.
158Use the `*:` operator to end your argument lists, like so.
177Use the `*:` operator to end your argument lists, like so.
159
178
160>>> printSQL (unsafeFunctionN "fun" (true :* false :* localTime *: true))
179>>> printSQL (unsafeFunctionN "fun" (true :* false :* localTime *: true))
161fun(TRUE, FALSE, LOCALTIME, TRUE)
180fun(TRUE, FALSE, LOCALTIME, TRUE)
162-}
181-}
163−type FunctionN xs y
182+type (--->) xs y
164 = forall outer commons grp schemas params from
183 = forall outer commons grp schemas params from
165 . NP (Expression outer commons grp schemas params from) xs
184 . NP (Expression outer commons grp schemas params from) xs
166 -- ^ inputs
185 -- ^ inputs
167 -> Expression outer commons grp schemas params from y
186 -> Expression outer commons grp schemas params from y
168 -- ^ output
187 -- ^ output
169
188
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+
170{- | A @RankNType@ for functions with a variable-length list of
196{- | A @RankNType@ for functions with a variable-length list of
171homogeneous arguments and at least 1 more argument.
197homogeneous arguments and at least 1 more argument.
172-}
198-}
@@ -293,58 +319,60 @@ unsafeBinaryOp op x y = UnsafeExpression $ parenthesized $
293 renderSQL x <+> op <+> renderSQL y
319 renderSQL x <+> op <+> renderSQL y
294
320
295binaryOp
321binaryOp
322+ :: forall op sch schemas schema x y z.
323+ ( Has sch schemas schema
296− :: (Has sch schemas schema, Has op schema ('Operator ('BinaryOp x1 x2 y)))
324+ , Has op schema ('Operator ('BinaryOp x y z)) )
297− => Alias op -> Operator x1 x2 y
325+ => OperatorDB schemas x y z
298−binaryOp = unsafeBinaryOp . renderSQL
326+binaryOp = unsafeBinaryOp $ renderSymbol @op
299
327
300−-- | >>> printSQL $ unsafeUnaryOpL "NOT" true
328+-- | >>> printSQL $ unsafeLeftOp "NOT" true
301-- (NOT TRUE)
329-- (NOT TRUE)
302−unsafeUnaryOpL :: ByteString -> x :--> y
330+unsafeLeftOp :: ByteString -> x --> y
303−unsafeUnaryOpL op x = UnsafeExpression $ parenthesized $ op <+> renderSQL x
331+unsafeLeftOp op x = UnsafeExpression $ parenthesized $ op <+> renderSQL x
304
332
305−unaryOpL
333+leftOp
334+ :: forall op sch schemas schema x y.
306− :: (Has sch schemas schema, Has op schema ('Operator ('UnaryOpL x y)))
335+ ( Has sch schemas schema
307− => Alias op -> x :--> y
336+ , Has op schema ('Operator ('LeftOp x y)) )
308−unaryOpL = unsafeUnaryOpL . renderSQL
337+ => FunctionDB schemas x y
338+leftOp = unsafeLeftOp $ renderSymbol @op
309
339
310−-- | >>> printSQL $ true & unsafeUnaryOpR "IS NOT TRUE"
340+-- | >>> printSQL $ true & unsafeRightOp "IS NOT TRUE"
311-- (TRUE IS NOT TRUE)
341-- (TRUE IS NOT TRUE)
312−unsafeUnaryOpR :: ByteString -> x :--> y
342+unsafeRightOp :: ByteString -> x --> y
313−unsafeUnaryOpR op x = UnsafeExpression $ parenthesized $ renderSQL x <+> op
343+unsafeRightOp op x = UnsafeExpression $ parenthesized $ renderSQL x <+> op
314
344
315−unaryOpR
345+rightOp
346+ :: forall op sch schemas schema x y.
316− :: (Has sch schemas schema, Has op schema ('Operator ('UnaryOpR x y)))
347+ ( Has sch schemas schema
317− => Alias op -> x :--> y
348+ , Has op schema ('Operator ('RightOp x y)) )
318−unaryOpR = unsafeUnaryOpR . renderSQL
349+ => FunctionDB schemas x y
350+rightOp = unsafeRightOp $ renderSymbol @op
319
351
320-- | >>> printSQL $ unsafeFunction "f" true
352-- | >>> printSQL $ unsafeFunction "f" true
321-- f(TRUE)
353-- f(TRUE)
322−unsafeFunction :: ByteString -> x :--> y
354+unsafeFunction :: ByteString -> x --> y
323unsafeFunction fun x = UnsafeExpression $
355unsafeFunction fun x = UnsafeExpression $
324 fun <> parenthesized (renderSQL x)
356 fun <> parenthesized (renderSQL x)
325
357
326function
358function
327− :: (Has sch schemas schema, Has fun schema ('Function '[x] ('Returns y)))
359+ :: (Has sch schemas schema, Has fun schema ('Function ('[x] :=> 'Returns y)))
328 => QualifiedAlias sch fun
360 => QualifiedAlias sch fun
329− -> ( forall outer commons grp params from
361+ -> FunctionDB schemas x y
330− . Expression outer commons grp schemas params from x
331− -> Expression outer commons grp schemas params from y )
332function = unsafeFunction . renderSQL
362function = unsafeFunction . renderSQL
333
363
334-- | >>> printSQL $ unsafeFunctionN "f" (currentTime :* localTimestamp :* false *: literal 'a')
364-- | >>> printSQL $ unsafeFunctionN "f" (currentTime :* localTimestamp :* false *: literal 'a')
335-- f(CURRENT_TIME, LOCALTIMESTAMP, FALSE, E'a')
365-- f(CURRENT_TIME, LOCALTIMESTAMP, FALSE, E'a')
336−unsafeFunctionN :: SListI xs => ByteString -> FunctionN xs y
366+unsafeFunctionN :: SListI xs => ByteString -> xs ---> y
337unsafeFunctionN fun xs = UnsafeExpression $
367unsafeFunctionN fun xs = UnsafeExpression $
338 fun <> parenthesized (renderCommaSeparated renderSQL xs)
368 fun <> parenthesized (renderCommaSeparated renderSQL xs)
339
369
340functionN
370functionN
341 :: ( Has sch schemas schema
371 :: ( Has sch schemas schema
342− , Has fun schema ('Function xs ('Returns y))
372+ , Has fun schema ('Function (xs :=> 'Returns y))
343 , SListI xs )
373 , SListI xs )
344 => QualifiedAlias sch fun
374 => QualifiedAlias sch fun
345− -> ( forall outer commons grp params from
375+ -> FunctionNDB schemas xs y
346− . NP (Expression outer commons grp schemas params from) xs
347− -> Expression outer commons grp schemas params from y )
348functionN = unsafeFunctionN . renderSQL
376functionN = unsafeFunctionN . renderSQL
349
377
350instance ty `In` PGNum
378instance ty `In` PGNum
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.SetOf
45+import Squeal.PostgreSQL.Expression.Set
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 :: SetOfFunction "unnest" (null ('PGvararray ty)) '["unnest" ::: ty]
126+unnest :: SetFunction "unnest" (null ('PGvararray ty)) '["unnest" ::: ty]
127−unnest = unsafeSetOfFunction
127+unnest = unsafeSetFunction
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 = unsafeUnaryOpR "IS TRUE"
166+isTrue = unsafeRightOp "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 = unsafeUnaryOpR "IS NOT TRUE"
174+isNotTrue = unsafeRightOp "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 = unsafeUnaryOpR "IS FALSE"
182+isFalse = unsafeRightOp "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 = unsafeUnaryOpR "IS NOT FALSE"
190+isNotFalse = unsafeRightOp "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 = unsafeUnaryOpR "IS UNKNOWN"
198+isUnknown = unsafeRightOp "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 = unsafeUnaryOpR "IS NOT UNKNOWN"
206+isNotUnknown = unsafeRightOp "IS NOT UNKNOWN"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Json.hs+40−47
@@ -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.SetOf
84+import Squeal.PostgreSQL.Expression.Set
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 => FunctionN tuple (null 'PGjson)
214+jsonBuildArray :: SOP.SListI tuple => 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 => FunctionN tuple (null 'PGjsonb)
219+jsonbBuildArray :: SOP.SListI tuple => 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 :: FunctionN tys (null 'PGjson)
227+ jsonBuildObject :: tys ---> null 'PGjson
228 jsonBuildObject = unsafeFunctionN "json_build_object"
228 jsonBuildObject = unsafeFunctionN "json_build_object"
229
229
230− jsonbBuildObject :: FunctionN tys (null 'PGjsonb)
230+ jsonbBuildObject :: 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 :: FunctionN
257+jsonZipObject ::
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 :: FunctionN
266+jsonbZipObject ::
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,12 +309,9 @@ 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
315− , null ('PGvararray ('NotNull 'PGtext))
313+ '[ null 'PGjsonb, null ('PGvararray ('NotNull 'PGtext))
316− , null 'PGjsonb
317− , null 'PGbool ] (null 'PGjsonb)
314+ , null 'PGjsonb, null 'PGbool ] ---> null 'PGjsonb
318jsonbSet = unsafeFunctionN "jsonbSet"
315jsonbSet = unsafeFunctionN "jsonbSet"
319
316
320-- | @ jsonbInsert target path new_value insert_after @
317-- | @ jsonbInsert target path new_value insert_after @
@@ -326,27 +323,23 @@ jsonbSet = unsafeFunctionN "jsonbSet"
326-- path is in JSONB object, @new_value@ will be inserted only if target does not
323-- path is in JSONB object, @new_value@ will be inserted only if target does not
327-- exist. As with the path orientated operators, negative integers that appear
324-- exist. As with the path orientated operators, negative integers that appear
328-- in path count from the end of JSON arrays.
325-- in path count from the end of JSON arrays.
329−jsonbInsert
326+jsonbInsert ::
330− :: FunctionN
331− '[ null 'PGjsonb
332− , null ('PGvararray ('NotNull 'PGtext))
327+ '[ null 'PGjsonb, null ('PGvararray ('NotNull 'PGtext))
333− , null 'PGjsonb
334− , null 'PGbool ] (null 'PGjsonb)
328+ , null 'PGjsonb, null 'PGbool ] ---> null 'PGjsonb
335jsonbInsert = unsafeFunctionN "jsonb_insert"
329jsonbInsert = unsafeFunctionN "jsonb_insert"
336
330
337-- | Returns its argument as indented JSON text.
331-- | Returns its argument as indented JSON text.
338−jsonbPretty :: null 'PGjsonb :--> null 'PGtext
332+jsonbPretty :: null 'PGjsonb --> null 'PGtext
339jsonbPretty = unsafeFunction "jsonb_pretty"
333jsonbPretty = unsafeFunction "jsonb_pretty"
340
334
341−
342{- | Expands the outermost JSON object into a set of key/value pairs.
335{- | Expands the outermost JSON object into a set of key/value pairs.
343
336
344>>> printSQL (select Star (from (jsonEach (literal (Json (object ["a" .= "foo", "b" .= "bar"]))))))
337>>> printSQL (select Star (from (jsonEach (literal (Json (object ["a" .= "foo", "b" .= "bar"]))))))
345SELECT * FROM json_each(('{"a":"foo","b":"bar"}' :: json))
338SELECT * FROM json_each(('{"a":"foo","b":"bar"}' :: json))
346-}
339-}
347−jsonEach :: SetOfFunction "json_each" (null 'PGjson)
340+jsonEach :: SetFunction "json_each" (null 'PGjson)
348 '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGjson]
341 '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGjson]
349−jsonEach = unsafeSetOfFunction
342+jsonEach = unsafeSetFunction
350
343
351{- | Expands the outermost binary JSON object into a set of key/value pairs.
344{- | Expands the outermost binary JSON object into a set of key/value pairs.
352
345
@@ -354,9 +347,9 @@ jsonEach = unsafeSetOfFunction
354SELECT * FROM jsonb_each(('{"a":"foo","b":"bar"}' :: jsonb))
347SELECT * FROM jsonb_each(('{"a":"foo","b":"bar"}' :: jsonb))
355-}
348-}
356jsonbEach
349jsonbEach
357− :: SetOfFunction "jsonb_each" (nullity 'PGjsonb)
350+ :: SetFunction "jsonb_each" (nullity 'PGjsonb)
358 '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGjson]
351 '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGjson]
359−jsonbEach = unsafeSetOfFunction
352+jsonbEach = unsafeSetFunction
360
353
361{- | Expands the outermost JSON object into a set of key/value pairs.
354{- | Expands the outermost JSON object into a set of key/value pairs.
362
355
@@ -364,9 +357,9 @@ jsonbEach = unsafeSetOfFunction
364SELECT * FROM json_each_text(('{"a":"foo","b":"bar"}' :: json))
357SELECT * FROM json_each_text(('{"a":"foo","b":"bar"}' :: json))
365-}
358-}
366jsonEachText
359jsonEachText
367− :: SetOfFunction "json_each_text" (null 'PGjson)
360+ :: SetFunction "json_each_text" (null 'PGjson)
368 '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext]
361 '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext]
369−jsonEachText = unsafeSetOfFunction
362+jsonEachText = unsafeSetFunction
370
363
371{- | Expands the outermost binary JSON object into a set of key/value pairs.
364{- | Expands the outermost binary JSON object into a set of key/value pairs.
372
365
@@ -374,9 +367,9 @@ jsonEachText = unsafeSetOfFunction
374SELECT * FROM jsonb_each_text(('{"a":"foo","b":"bar"}' :: jsonb))
367SELECT * FROM jsonb_each_text(('{"a":"foo","b":"bar"}' :: jsonb))
375-}
368-}
376jsonbEachText
369jsonbEachText
377− :: SetOfFunction "jsonb_each_text" (null 'PGjsonb)
370+ :: SetFunction "jsonb_each_text" (null 'PGjsonb)
378 '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext]
371 '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext]
379−jsonbEachText = unsafeSetOfFunction
372+jsonbEachText = unsafeSetFunction
380
373
381{- | Returns set of keys in the outermost JSON object.
374{- | Returns set of keys in the outermost JSON object.
382
375
@@ -384,9 +377,9 @@ jsonbEachText = unsafeSetOfFunction
384json_object_keys(('{"a":"foo","b":"bar"}' :: json))
377json_object_keys(('{"a":"foo","b":"bar"}' :: json))
385-}
378-}
386jsonObjectKeys
379jsonObjectKeys
387− :: SetOfFunction "json_object_keys" (nullity 'PGjson)
380+ :: SetFunction "json_object_keys" (nullity 'PGjson)
388 '["json_object_keys" ::: 'NotNull 'PGtext]
381 '["json_object_keys" ::: 'NotNull 'PGtext]
389−jsonObjectKeys = unsafeSetOfFunction
382+jsonObjectKeys = unsafeSetFunction
390
383
391{- | Returns set of keys in the outermost JSON object.
384{- | Returns set of keys in the outermost JSON object.
392
385
@@ -394,9 +387,9 @@ jsonObjectKeys = unsafeSetOfFunction
394jsonb_object_keys(('{"a":"foo","b":"bar"}' :: jsonb))
387jsonb_object_keys(('{"a":"foo","b":"bar"}' :: jsonb))
395-}
388-}
396jsonbObjectKeys
389jsonbObjectKeys
397− :: SetOfFunction "jsonb_object_keys" (null 'PGjsonb)
390+ :: SetFunction "jsonb_object_keys" (null 'PGjsonb)
398 '["jsonb_object_keys" ::: 'NotNull 'PGtext]
391 '["jsonb_object_keys" ::: 'NotNull 'PGtext]
399−jsonbObjectKeys = unsafeSetOfFunction
392+jsonbObjectKeys = unsafeSetFunction
400
393
401-- | Build rows from Json types.
394-- | Build rows from Json types.
402type JsonPopulateFunction fun json
395type 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_ = unsafeUnaryOpL "NOT"
51+not_ = unsafeLeftOp "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+4−6
@@ -37,9 +37,7 @@ 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
42− => FunctionN '[ null float, null float] (null float)
40+atan2_ :: float `In` PGFloating => '[ null float, null float] ---> null float
43atan2_ = unsafeFunctionN "atan2"
41atan2_ = unsafeFunctionN "atan2"
44
42
45
43
@@ -78,7 +76,7 @@ rem_ = unsafeBinaryOp "%"
78-- in printSQL expression
76-- in printSQL expression
79-- :}
77-- :}
80-- trunc(pi())
78-- trunc(pi())
81−trunc :: frac `In` PGFloating => null frac :--> null frac
79+trunc :: frac `In` PGFloating => null frac --> null frac
82trunc = unsafeFunction "trunc"
80trunc = unsafeFunction "trunc"
83
81
84-- | >>> :{
82-- | >>> :{
@@ -88,7 +86,7 @@ trunc = unsafeFunction "trunc"
88-- in printSQL expression
86-- in printSQL expression
89-- :}
87-- :}
90-- round(pi())
88-- round(pi())
91−round_ :: frac `In` PGFloating => null frac :--> null frac
89+round_ :: frac `In` PGFloating => null frac --> null frac
92round_ = unsafeFunction "round"
90round_ = unsafeFunction "round"
93
91
94-- | >>> :{
92-- | >>> :{
@@ -98,5 +96,5 @@ round_ = unsafeFunction "round"
98-- in printSQL expression
96-- in printSQL expression
99-- :}
97-- :}
100-- ceiling(pi())
98-- ceiling(pi())
101−ceiling_ :: frac `In` PGFloating => null frac :--> null frac
99+ceiling_ :: frac `In` PGFloating => null frac --> null frac
102ceiling_ = unsafeFunction "ceiling"
100ceiling_ = 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 :: FunctionN '[ 'NotNull ty, 'NotNull ty] ('Null ty)
103+nullIf :: '[ 'NotNull ty, 'NotNull ty] ---> 'Null ty
104nullIf = unsafeFunctionN "NULLIF"
104nullIf = unsafeFunctionN "NULLIF"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Range.hs+8−9
@@ -205,27 +205,26 @@ whole = NonEmpty Infinite Infinite
205(@-) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) (null ('PGrange ty))
205(@-) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) (null ('PGrange ty))
206(@-) = unsafeBinaryOp "-"
206(@-) = unsafeBinaryOp "-"
207
207
208−lowerBound :: null ('PGrange ty) :--> 'Null ty
208+lowerBound :: null ('PGrange ty) --> 'Null ty
209lowerBound = unsafeFunction "lower"
209lowerBound = unsafeFunction "lower"
210
210
211−upperBound :: null ('PGrange ty) :--> 'Null ty
211+upperBound :: null ('PGrange ty) --> 'Null ty
212upperBound = unsafeFunction "upper"
212upperBound = unsafeFunction "upper"
213
213
214−isEmpty :: null ('PGrange ty) :--> 'Null 'PGbool
214+isEmpty :: null ('PGrange ty) --> 'Null 'PGbool
215isEmpty = unsafeFunction "isempty"
215isEmpty = unsafeFunction "isempty"
216
216
217−lowerInc :: null ('PGrange ty) :--> 'Null 'PGbool
217+lowerInc :: null ('PGrange ty) --> 'Null 'PGbool
218lowerInc = unsafeFunction "lower_inc"
218lowerInc = unsafeFunction "lower_inc"
219
219
220−lowerInf :: null ('PGrange ty) :--> 'Null 'PGbool
220+lowerInf :: null ('PGrange ty) --> 'Null 'PGbool
221lowerInf = unsafeFunction "lower_inf"
221lowerInf = unsafeFunction "lower_inf"
222
222
223−upperInc :: null ('PGrange ty) :--> 'Null 'PGbool
223+upperInc :: null ('PGrange ty) --> 'Null 'PGbool
224upperInc = unsafeFunction "upper_inc"
224upperInc = unsafeFunction "upper_inc"
225
225
226−upperInf :: null ('PGrange ty) :--> 'Null 'PGbool
226+upperInf :: null ('PGrange ty) --> 'Null 'PGbool
227upperInf = unsafeFunction "upper_inf"
227upperInf = unsafeFunction "upper_inf"
228
228
229−rangeMerge :: FunctionN
230− '[ null ('PGrange ty), null ('PGrange ty)] (null ('PGrange ty))
229+rangeMerge :: '[null ('PGrange ty), null ('PGrange ty)] ---> null ('PGrange ty)
231rangeMerge = unsafeFunctionN "range_merge"
230rangeMerge = unsafeFunctionN "range_merge"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/SetOf.hs → squeal-postgresql/src/Squeal/PostgreSQL/Expression/Set.hsrenamed+52−40
@@ -1,5 +1,5 @@
1{-|
1{-|
2−Module: Squeal.PostgreSQL.Expression.SetOf
2+Module: Squeal.PostgreSQL.Expression.Set
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,16 +20,18 @@ Set returning functions
20 , TypeOperators
20 , TypeOperators
21#-}
21#-}
22
22
23−module Squeal.PostgreSQL.Expression.SetOf
23+module Squeal.PostgreSQL.Expression.Set
24 ( generateSeries
24 ( generateSeries
25 , generateSeriesStep
25 , generateSeriesStep
26 , generateSeriesTimestamp
26 , generateSeriesTimestamp
27− , SetOfFunction
27+ , SetFunction
28− , unsafeSetOfFunction
28+ , unsafeSetFunction
29− , setOfFunction
29+ , SetFunctionDB
30− , SetOfFunctionN
30+ , setFunction
31− , unsafeSetOfFunctionN
31+ , SetFunctionN
32− , setOfFunctionN
32+ , unsafeSetFunctionN
33+ , SetFunctionNDB
34+ , setFunctionN
33 ) where
35 ) where
34
36
35import GHC.TypeLits
37import GHC.TypeLits
@@ -46,55 +48,65 @@ import Squeal.PostgreSQL.Schema
46{- |
48{- |
47A @RankNType@ for set returning functions with 1 argument.
49A @RankNType@ for set returning functions with 1 argument.
48-}
50-}
49−type SetOfFunction fun ty setof
51+type SetFunction fun ty row
50 = forall outer commons schemas params
52 = forall outer commons schemas params
51 . Expression outer commons 'Ungrouped schemas params '[] ty
53 . Expression outer commons 'Ungrouped schemas params '[] ty
52 -- ^ input
54 -- ^ input
53− -> FromClause outer commons schemas params '[fun ::: setof]
55+ -> FromClause outer commons schemas params '[fun ::: row]
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]
54 -- ^ output
63 -- ^ output
55
64
56-- | Escape hatch for a set returning function with 1 argument.
65-- | Escape hatch for a set returning function with 1 argument.
57−unsafeSetOfFunction
66+unsafeSetFunction
58− :: forall fun ty setof. KnownSymbol fun
67+ :: forall fun ty row. KnownSymbol fun
59− => SetOfFunction fun ty setof -- ^ set returning function
68+ => SetFunction fun ty row -- ^ set returning function
60−unsafeSetOfFunction x = UnsafeFromClause $
69+unsafeSetFunction x = UnsafeFromClause $
61 renderSymbol @fun <> parenthesized (renderSQL x)
70 renderSymbol @fun <> parenthesized (renderSQL x)
62
71
63−setOfFunction
72+setFunction
64 :: ( Has sch schemas schema
73 :: ( Has sch schemas schema
65− , Has fun schema ('Function '[ty] ('ReturnsTable setof)) )
74+ , Has fun schema ('Function ('[ty] :=> 'ReturnsTable row)) )
66− => Alias fun
75+ => QualifiedAlias sch fun
67− -> ( forall outer commons params
76+ -> SetFunctionDB fun schemas ty row
68− . Expression outer commons 'Ungrouped schemas params '[] ty
77+setFunction _ = unsafeSetFunction
69− -> FromClause outer commons schemas params '[fun ::: setof] )
70−setOfFunction _ = unsafeSetOfFunction
71
78
72{- |
79{- |
73A @RankNType@ for set returning functions with multiple argument.
80A @RankNType@ for set returning functions with multiple argument.
74-}
81-}
75−type SetOfFunctionN fun tys setof
82+type SetFunctionN fun tys row
76 = forall outer commons schemas params
83 = forall outer commons schemas params
77 . NP (Expression outer commons 'Ungrouped schemas params '[]) tys
84 . NP (Expression outer commons 'Ungrouped schemas params '[]) tys
78 -- ^ inputs
85 -- ^ inputs
79− -> FromClause outer commons schemas params '[fun ::: setof]
86+ -> FromClause outer commons schemas params '[fun ::: row]
80 -- ^ output
87 -- ^ output
81
88
82-- | Escape hatch for a set returning function with multiple argument.
89-- | Escape hatch for a set returning function with multiple argument.
83−unsafeSetOfFunctionN
90+unsafeSetFunctionN
84− :: forall fun tys setof. (SOP.SListI tys, KnownSymbol fun)
91+ :: forall fun tys row. (SOP.SListI tys, KnownSymbol fun)
85− => SetOfFunctionN fun tys setof -- ^ set returning function
92+ => SetFunctionN fun tys row -- ^ set returning function
86−unsafeSetOfFunctionN xs = UnsafeFromClause $
93+unsafeSetFunctionN xs = UnsafeFromClause $
87 renderSymbol @fun <> parenthesized (renderCommaSeparated renderSQL xs)
94 renderSymbol @fun <> parenthesized (renderCommaSeparated renderSQL xs)
88
95
89−setOfFunctionN
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
90 :: ( Has sch schemas schema
104 :: ( Has sch schemas schema
91− , Has fun schema ('Function tys ('ReturnsTable setof))
105+ , Has fun schema ('Function (tys :=> 'ReturnsTable row))
92 , SOP.SListI tys )
106 , SOP.SListI tys )
93− => Alias fun
107+ => QualifiedAlias sch fun
94− -> ( forall outer commons params
108+ -> SetFunctionNDB fun schemas tys row
95− . NP (Expression outer commons 'Ungrouped schemas params '[]) tys
109+setFunctionN _ = unsafeSetFunctionN
96− -> FromClause outer commons schemas params '[fun ::: setof] )
97−setOfFunctionN _ = unsafeSetOfFunctionN
98
110
99{- | @generateSeries (start *: stop)@
111{- | @generateSeries (start *: stop)@
100
112
@@ -102,9 +114,9 @@ Generate a series of values, from @start@ to @stop@ with a step size of one
102-}
114-}
103generateSeries
115generateSeries
104 :: ty `In` '[ 'PGint4, 'PGint8, 'PGnumeric]
116 :: ty `In` '[ 'PGint4, 'PGint8, 'PGnumeric]
105− => SetOfFunctionN "generate_series" '[ null ty, null ty]
117+ => SetFunctionN "generate_series" '[ null ty, null ty]
106 '["generate_series" ::: null ty] -- ^ set returning function
118 '["generate_series" ::: null ty] -- ^ set returning function
107−generateSeries = unsafeSetOfFunctionN
119+generateSeries = unsafeSetFunctionN
108
120
109{- | @generateSeries (start :* stop *: step)@
121{- | @generateSeries (start :* stop *: step)@
110
122
@@ -112,9 +124,9 @@ Generate a series of values, from @start@ to @stop@ with a step size of @step@
112-}
124-}
113generateSeriesStep
125generateSeriesStep
114 :: ty `In` '[ 'PGint4, 'PGint8, 'PGnumeric]
126 :: ty `In` '[ 'PGint4, 'PGint8, 'PGnumeric]
115− => SetOfFunctionN "generate_series" '[null ty, null ty, null ty]
127+ => SetFunctionN "generate_series" '[null ty, null ty, null ty]
116 '["generate_series" ::: null ty] -- ^ set returning function
128 '["generate_series" ::: null ty] -- ^ set returning function
117−generateSeriesStep = unsafeSetOfFunctionN
129+generateSeriesStep = unsafeSetFunctionN
118
130
119{- | @generateSeries (start :* stop *: step)@
131{- | @generateSeries (start :* stop *: step)@
120
132
@@ -122,6 +134,6 @@ Generate a series of values, from @start@ to @stop@ with a step size of @step@
122-}
134-}
123generateSeriesTimestamp
135generateSeriesTimestamp
124 :: ty `In` '[ 'PGtimestamp, 'PGtimestamptz]
136 :: ty `In` '[ 'PGtimestamp, 'PGtimestamptz]
125− => SetOfFunctionN "generate_series" '[null ty, null ty, null 'PGinterval]
137+ => SetFunctionN "generate_series" '[null ty, null ty, null 'PGinterval]
126 '["generate_series" ::: null ty] -- ^ set returning function
138 '["generate_series" ::: null ty] -- ^ set returning function
127−generateSeriesTimestamp = unsafeSetOfFunctionN
139+generateSeriesTimestamp = unsafeSetFunctionN
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+20−21
@@ -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−(.!) = unsafeUnaryOpL "!!"
59+(.!) = unsafeLeftOp "!!"
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,51 +66,50 @@ 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
109− :: FunctionN '[null 'PGtsvector, null ('PGchar 1)] (null 'PGtsvector)
108+setWeight :: '[null 'PGtsvector, null ('PGchar 1)] ---> null 'PGtsvector
110setWeight = unsafeFunctionN "set_weight"
109setWeight = unsafeFunctionN "set_weight"
111
110
112-- | remove positions and weights from `Squeal.PostgreSQL.Expression.Type.tsvector`
111-- | remove positions and weights from `Squeal.PostgreSQL.Expression.Type.tsvector`
113−strip :: null 'PGtsvector :--> null 'PGtsvector
112+strip :: null 'PGtsvector --> null 'PGtsvector
114strip = unsafeFunction "strip"
113strip = unsafeFunction "strip"
115
114
116-- | @jsonToTSvector (document *: filter)@
115-- | @jsonToTSvector (document *: filter)@
@@ -123,7 +122,7 @@ strip = unsafeFunction "strip"
123-- "boolean" (to include all Boolean values in the string format "true"/"false"),
122-- "boolean" (to include all Boolean values in the string format "true"/"false"),
124-- "key" (to include all keys) or "all" (to include all above).
123-- "key" (to include all keys) or "all" (to include all above).
125-- These values can be combined together to include, e.g. all string and numeric values.
124-- These values can be combined together to include, e.g. all string and numeric values.
126−jsonToTSvector :: FunctionN '[null 'PGjson, null 'PGjson] (null 'PGtsvector)
125+jsonToTSvector :: '[null 'PGjson, null 'PGjson] ---> null 'PGtsvector
127jsonToTSvector = unsafeFunctionN "json_to_tsvector"
126jsonToTSvector = unsafeFunctionN "json_to_tsvector"
128
127
129-- | @jsonbToTSvector (document *: filter)@
128-- | @jsonbToTSvector (document *: filter)@
@@ -136,23 +135,23 @@ jsonToTSvector = unsafeFunctionN "json_to_tsvector"
136-- "boolean" (to include all Boolean values in the string format "true"/"false"),
135-- "boolean" (to include all Boolean values in the string format "true"/"false"),
137-- "key" (to include all keys) or "all" (to include all above).
136-- "key" (to include all keys) or "all" (to include all above).
138-- These values can be combined together to include, e.g. all string and numeric values.
137-- These values can be combined together to include, e.g. all string and numeric values.
139−jsonbToTSvector :: FunctionN '[null 'PGjsonb, null 'PGjsonb] (null 'PGtsvector)
138+jsonbToTSvector :: '[null 'PGjsonb, null 'PGjsonb] ---> null 'PGtsvector
140jsonbToTSvector = unsafeFunctionN "jsonb_to_tsvector"
139jsonbToTSvector = unsafeFunctionN "jsonb_to_tsvector"
141
140
142-- | remove given lexeme from `Squeal.PostgreSQL.Expression.Type.tsvector`
141-- | remove given lexeme from `Squeal.PostgreSQL.Expression.Type.tsvector`
143−tsDelete :: FunctionN
142+tsDelete ::
144 '[null 'PGtsvector, null ('PGvararray ('NotNull 'PGtext))]
143 '[null 'PGtsvector, null ('PGvararray ('NotNull 'PGtext))]
145− (null 'PGtsvector)
144+ ---> null 'PGtsvector
146tsDelete = unsafeFunctionN "ts_delete"
145tsDelete = unsafeFunctionN "ts_delete"
147
146
148-- | select only elements with given weights from `Squeal.PostgreSQL.Expression.Type.tsvector`
147-- | select only elements with given weights from `Squeal.PostgreSQL.Expression.Type.tsvector`
149−tsFilter :: FunctionN
148+tsFilter ::
150 '[null 'PGtsvector, null ('PGvararray ('NotNull ('PGchar 1)))]
149 '[null 'PGtsvector, null ('PGvararray ('NotNull ('PGchar 1)))]
151− (null 'PGtsvector)
150+ ---> null 'PGtsvector
152tsFilter = unsafeFunctionN "ts_filter"
151tsFilter = unsafeFunctionN "ts_filter"
153
152
154-- | display a `Squeal.PostgreSQL.Expression.Type.tsquery` match
153-- | display a `Squeal.PostgreSQL.Expression.Type.tsquery` match
155tsHeadline
154tsHeadline
156 :: document `In` '[ 'PGtext, 'PGjson, 'PGjsonb]
155 :: document `In` '[ 'PGtext, 'PGjson, 'PGjsonb]
157− => FunctionN '[null document, null 'PGtsquery] (null 'PGtext)
156+ => '[null document, null 'PGtsquery] ---> null 'PGtext
158tsHeadline = unsafeFunctionN "ts_headline"
157tsHeadline = unsafeFunctionN "ts_headline"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Time.hs+7−12
@@ -17,6 +17,7 @@ Date/Time functions and operators
17 , OverloadedStrings
17 , OverloadedStrings
18 , PolyKinds
18 , PolyKinds
19 , RankNTypes
19 , RankNTypes
20+ , TypeOperators
20#-}
21#-}
21
22
22module Squeal.PostgreSQL.Expression.Time
23module Squeal.PostgreSQL.Expression.Time
@@ -85,9 +86,7 @@ Create date from year, month and day fields
85>>> printSQL (makeDate (1984 :* 7 *: 3))
86>>> printSQL (makeDate (1984 :* 7 *: 3))
86make_date(1984, 7, 3)
87make_date(1984, 7, 3)
87-}
88-}
88−makeDate :: FunctionN
89− '[ null 'PGint4, null 'PGint4, null 'PGint4 ]
89+makeDate :: '[ null 'PGint4, null 'PGint4, null 'PGint4 ] ---> null 'PGdate
90− ( null 'PGdate )
91makeDate = unsafeFunctionN "make_date"
90makeDate = unsafeFunctionN "make_date"
92
91
93{-|
92{-|
@@ -96,9 +95,7 @@ Create time from hour, minute and seconds fields
96>>> printSQL (makeTime (8 :* 15 *: 23.5))
95>>> printSQL (makeTime (8 :* 15 *: 23.5))
97make_time(8, 15, 23.5)
96make_time(8, 15, 23.5)
98-}
97-}
99−makeTime :: FunctionN
100− '[ null 'PGint4, null 'PGint4, null 'PGfloat8 ]
98+makeTime :: '[ null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtime
101− ( null 'PGtime )
102makeTime = unsafeFunctionN "make_time"
99makeTime = unsafeFunctionN "make_time"
103
100
104{-|
101{-|
@@ -107,10 +104,9 @@ Create timestamp from year, month, day, hour, minute and seconds fields
107>>> printSQL (makeTimestamp (2013 :* 7 :* 15 :* 8 :* 15 *: 23.5))
104>>> printSQL (makeTimestamp (2013 :* 7 :* 15 :* 8 :* 15 *: 23.5))
108make_timestamp(2013, 7, 15, 8, 15, 23.5)
105make_timestamp(2013, 7, 15, 8, 15, 23.5)
109-}
106-}
110−makeTimestamp :: FunctionN
107+makeTimestamp ::
111 '[ null 'PGint4, null 'PGint4, null 'PGint4
108 '[ null 'PGint4, null 'PGint4, null 'PGint4
112− , null 'PGint4, null 'PGint4, null 'PGfloat8 ]
109+ , null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtimestamp
113− ( null 'PGtimestamp )
114makeTimestamp = unsafeFunctionN "make_timestamp"
110makeTimestamp = unsafeFunctionN "make_timestamp"
115
111
116{-|
112{-|
@@ -121,10 +117,9 @@ the current time zone is used
121>>> printSQL (makeTimestamptz (2013 :* 7 :* 15 :* 8 :* 15 *: 23.5))
117>>> printSQL (makeTimestamptz (2013 :* 7 :* 15 :* 8 :* 15 *: 23.5))
122make_timestamptz(2013, 7, 15, 8, 15, 23.5)
118make_timestamptz(2013, 7, 15, 8, 15, 23.5)
123-}
119-}
124−makeTimestamptz :: FunctionN
120+makeTimestamptz ::
125 '[ null 'PGint4, null 'PGint4, null 'PGint4
121 '[ null 'PGint4, null 'PGint4, null 'PGint4
126− , null 'PGint4, null 'PGint4, null 'PGfloat8 ]
122+ , null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtimestamptz
127− ( null 'PGtimestamptz )
128makeTimestamptz = unsafeFunctionN "make_timestamptz"
123makeTimestamptz = unsafeFunctionN "make_timestamptz"
129
124
130{-|
125{-|
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Type.hs+108−3
@@ -23,14 +23,16 @@ Type expressions.
23 , ScopedTypeVariables
23 , ScopedTypeVariables
24 , TypeApplications
24 , TypeApplications
25 , TypeOperators
25 , TypeOperators
26+ , UndecidableInstances
26#-}
27#-}
27
28
28module Squeal.PostgreSQL.Expression.Type
29module Squeal.PostgreSQL.Expression.Type
29− ( TypeExpression (..)
30+ ( -- * type casting
30− , cast
31+ cast
31 , astype
32 , astype
32 , inferredtype
33 , inferredtype
33− , PGTyped (..)
34+ -- * type expressions
35+ , TypeExpression (..)
34 , typedef
36 , typedef
35 , typetable
37 , typetable
36 , typeview
38 , typeview
@@ -77,6 +79,22 @@ module Squeal.PostgreSQL.Expression.Type
77 , tsrange
79 , tsrange
78 , tstzrange
80 , tstzrange
79 , daterange
81 , 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 (..)
80 ) where
98 ) where
81
99
82import Control.DeepSeq
100import Control.DeepSeq
@@ -90,6 +108,7 @@ import qualified Generics.SOP as SOP
90
108
91import Squeal.PostgreSQL.Alias
109import Squeal.PostgreSQL.Alias
92import Squeal.PostgreSQL.Expression
110import Squeal.PostgreSQL.Expression
111+import Squeal.PostgreSQL.PG
93import Squeal.PostgreSQL.Render
112import Squeal.PostgreSQL.Render
94import Squeal.PostgreSQL.Schema
113import Squeal.PostgreSQL.Schema
95
114
@@ -131,6 +150,7 @@ astype = cast
131inferredtype
150inferredtype
132 :: PGTyped schemas ty
151 :: PGTyped schemas ty
133 => Expression outer common grp schemas params from ty
152 => Expression outer common grp schemas params from ty
153+ -- ^ value
134 -> Expression outer common grp schemas params from ty
154 -> Expression outer common grp schemas params from ty
135inferredtype = astype pgtype
155inferredtype = astype pgtype
136
156
@@ -150,6 +170,7 @@ instance RenderSQL (TypeExpression schemas ty) where
150typedef
170typedef
151 :: (Has sch schemas schema, Has td schema ('Typedef ty))
171 :: (Has sch schemas schema, Has td schema ('Typedef ty))
152 => QualifiedAlias sch td
172 => QualifiedAlias sch td
173+ -- ^ type alias
153 -> TypeExpression schemas (null ty)
174 -> TypeExpression schemas (null ty)
154typedef = UnsafeTypeExpression . renderSQL
175typedef = UnsafeTypeExpression . renderSQL
155
176
@@ -158,6 +179,7 @@ typedef = UnsafeTypeExpression . renderSQL
158typetable
179typetable
159 :: (Has sch schemas schema, Has tab schema ('Table table))
180 :: (Has sch schemas schema, Has tab schema ('Table table))
160 => QualifiedAlias sch tab
181 => QualifiedAlias sch tab
182+ -- ^ table alias
161 -> TypeExpression schemas (null ('PGcomposite (TableToRow table)))
183 -> TypeExpression schemas (null ('PGcomposite (TableToRow table)))
162typetable = UnsafeTypeExpression . renderSQL
184typetable = UnsafeTypeExpression . renderSQL
163
185
@@ -166,6 +188,7 @@ typetable = UnsafeTypeExpression . renderSQL
166typeview
188typeview
167 :: (Has sch schemas schema, Has vw schema ('View view))
189 :: (Has sch schemas schema, Has vw schema ('View view))
168 => QualifiedAlias sch vw
190 => QualifiedAlias sch vw
191+ -- ^ view alias
169 -> TypeExpression schemas (null ('PGcomposite view))
192 -> TypeExpression schemas (null ('PGcomposite view))
170typeview = UnsafeTypeExpression . renderSQL
193typeview = UnsafeTypeExpression . renderSQL
171
194
@@ -339,3 +362,85 @@ instance (SOP.All KnownNat dims, PGTyped schemas ty)
339instance PGTyped schemas (null 'PGtsvector) where pgtype = tsvector
362instance PGTyped schemas (null 'PGtsvector) where pgtype = tsvector
340instance PGTyped schemas (null 'PGtsquery) where pgtype = tsquery
363instance PGTyped schemas (null 'PGtsquery) where pgtype = tsquery
341instance PGTyped schemas (null 'PGoid) where pgtype = oid
364instance 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+16−45
@@ -33,16 +33,16 @@ module Squeal.PostgreSQL.List
33 , Join
33 , Join
34 , disjoin
34 , disjoin
35 , Additional (..)
35 , Additional (..)
36− , AlignedList (..)
36+ , Path (..)
37− , single
37+ , CFunctor (..)
38− , extractList
38+ , CFoldable (..)
39− , mapAligned
39+ , CFree (..)
40 , Elem
40 , Elem
41 , In
41 , In
42 , Length
42 , Length
43 ) where
43 ) where
44
44
45−import Control.Category
45+import Control.Category.Free
46import Data.Function ((&))
46import Data.Function ((&))
47import Data.Kind
47import Data.Kind
48import Data.Type.Bool
48import Data.Type.Bool
@@ -50,8 +50,6 @@ import GHC.TypeLits
50
50
51import Generics.SOP as SOP
51import Generics.SOP as SOP
52
52
53−import Squeal.PostgreSQL.Render
54−
55-- | `Join` is simply promoted `++` and is used in @JOIN@s in
53-- | `Join` is simply promoted `++` and is used in @JOIN@s in
56-- `Squeal.PostgreSQL.Query.FromClause`s.
54-- `Squeal.PostgreSQL.Query.FromClause`s.
57type family Join xs ys where
55type family Join xs ys where
@@ -78,42 +76,6 @@ instance Additional (NP expr) where
78 Nil -> ys
76 Nil -> ys
79 x :* xs -> x :* (xs & also ys)
77 x :* xs -> x :* (xs & also ys)
80
78
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−
117-- | A useful operator for ending an `NP` list of length at least 2 without `Nil`.
79-- | A useful operator for ending an `NP` list of length at least 2 without `Nil`.
118(*:) :: f x -> f y -> NP f '[x,y]
80(*:) :: f x -> f y -> NP f '[x,y]
119x *: y = x :* y :* Nil
81x *: y = x :* y :* Nil
@@ -122,7 +84,12 @@ infixl 9 *:
122-- | @Elem@ is a promoted `Data.List.elem`.
84-- | @Elem@ is a promoted `Data.List.elem`.
123type family Elem x xs where
85type family Elem x xs where
124 Elem x '[] = 'False
86 Elem x '[] = 'False
125− Elem x (x ': xs) = 'True
87+ Elem x (x ': _) = '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
126 Elem x (_ ': xs) = Elem x xs
93 Elem x (_ ': xs) = Elem x xs
127
94
128-- | @In x xs@ is a constraint that proves that @x@ is in @xs@.
95-- | @In x xs@ is a constraint that proves that @x@ is in @xs@.
@@ -137,5 +104,9 @@ Length '[Char,String,Bool,Double] :: Nat
137= 4
104= 4
138-}
105-}
139type family Length (xs :: [k]) :: Nat where
106type 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
140− Length (x : xs) = 1 + Length xs
111+ Length (_ : xs) = 1 + Length xs
141 Length '[] = 0
112 Length '[] = 0
squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs+1−1
@@ -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" <+> renderSQL ctes <+> renderSQL manip
102+ "WITH" <+> commaSeparated (ctoList 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`,
squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs+14−12
@@ -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 an `AlignedList`.
69+Now that we have a couple migrations we can chain them together into a `Path`.
70
70
71>>> let migrations = makeUsers :>> makeEmails :>> Done
71>>> let migrations = makeUsers :>> makeEmails :>> Done
72
72
@@ -167,6 +167,8 @@ 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
170import Squeal.PostgreSQL.Expression.Comparison
172import Squeal.PostgreSQL.Expression.Comparison
171import Squeal.PostgreSQL.Expression.Parameter
173import Squeal.PostgreSQL.Expression.Parameter
172import Squeal.PostgreSQL.Expression.Time
174import Squeal.PostgreSQL.Expression.Time
@@ -190,34 +192,34 @@ data Migration p schemas0 schemas1 = Migration
190
192
191{- |
193{- |
192A `Migratory` @p@ is a `Category` for which one can execute or rewind
194A `Migratory` @p@ is a `Category` for which one can execute or rewind
193−an `AlignedList` of `Migration`s over @p@. This includes the category of pure
195+a `Path` of `Migration`s over @p@. This includes the category of pure
194SQL `Definition`s and the category of impure `Terminally` `PQ` `IO` actions.
196SQL `Definition`s and the category of impure `Terminally` `PQ` `IO` actions.
195-}
197-}
196class Category p => Migratory p where
198class Category p => Migratory p where
197
199
198 {- |
200 {- |
199− Run an `AlignedList` of `Migration`s.
201+ Run a `Path` of `Migration`s.
200 Create the `MigrationsTable` as @public.schema_migrations@ if it does not already exist.
202 Create the `MigrationsTable` as @public.schema_migrations@ if it does not already exist.
201 In one transaction, for each each `Migration` query to see if the `Migration` has been executed;
203 In one transaction, for each each `Migration` query to see if the `Migration` has been executed;
202 if not, `up` the `Migration` and insert its `name` in the `MigrationsTable`.
204 if not, `up` the `Migration` and insert its `name` in the `MigrationsTable`.
203 -}
205 -}
204 migrateUp
206 migrateUp
205− :: AlignedList (Migration p) schemas0 schemas1
207+ :: Path (Migration p) schemas0 schemas1
206 -> PQ schemas0 schemas1 IO ()
208 -> PQ schemas0 schemas1 IO ()
207
209
208 {- |
210 {- |
209− Rewind an `AlignedList` of `Migration`s.
211+ Rewind a `Path` of `Migration`s.
210 Create the `MigrationsTable` as @public.schema_migrations@ if it does not already exist.
212 Create the `MigrationsTable` as @public.schema_migrations@ if it does not already exist.
211 In one transaction, for each each `Migration` query to see if the `Migration` has been executed;
213 In one transaction, for each each `Migration` query to see if the `Migration` has been executed;
212 if so, `down` the `Migration` and delete its `name` in the `MigrationsTable`.
214 if so, `down` the `Migration` and delete its `name` in the `MigrationsTable`.
213 -}
215 -}
214 migrateDown
216 migrateDown
215− :: AlignedList (Migration p) schemas0 schemas1
217+ :: Path (Migration p) schemas0 schemas1
216 -> PQ schemas1 schemas0 IO ()
218 -> PQ schemas1 schemas0 IO ()
217
219
218instance Migratory Definition where
220instance Migratory Definition where
219− migrateUp = migrateUp . mapAligned pureMigration
221+ migrateUp = migrateUp . cmap pureMigration
220− migrateDown = migrateDown . mapAligned pureMigration
222+ migrateDown = migrateDown . cmap pureMigration
221
223
222{- | `Terminally` turns an indexed monad transformer and the monad it transforms
224{- | `Terminally` turns an indexed monad transformer and the monad it transforms
223into a category by restricting the return type to @()@ and permuting the type variables.
225into a category by restricting the return type to @()@ and permuting the type variables.
@@ -266,7 +268,7 @@ instance Migratory (Terminally PQ IO) where
266 where
268 where
267
269
268 upMigrations
270 upMigrations
269− :: AlignedList (Migration (Terminally PQ IO)) schemas0 schemas1
271+ :: Path (Migration (Terminally PQ IO)) schemas0 schemas1
270 -> PQ MigrationsSchemas MigrationsSchemas IO ()
272 -> PQ MigrationsSchemas MigrationsSchemas IO ()
271 upMigrations = \case
273 upMigrations = \case
272 Done -> return ()
274 Done -> return ()
@@ -295,7 +297,7 @@ instance Migratory (Terminally PQ IO) where
295 where
297 where
296
298
297 downMigrations
299 downMigrations
298− :: AlignedList (Migration (Terminally PQ IO)) schemas0 schemas1
300+ :: Path (Migration (Terminally PQ IO)) schemas0 schemas1
299 -> PQ MigrationsSchemas MigrationsSchemas IO ()
301 -> PQ MigrationsSchemas MigrationsSchemas IO ()
300 downMigrations = \case
302 downMigrations = \case
301 Done -> return ()
303 Done -> return ()
@@ -382,7 +384,7 @@ defaultMain
382 :: Migratory p
384 :: Migratory p
383 => ByteString
385 => ByteString
384 -- ^ connection string
386 -- ^ connection string
385− -> AlignedList (Migration p) db0 db1
387+ -> Path (Migration p) db0 db1
386 -- ^ migrations
388 -- ^ migrations
387 -> IO ()
389 -> IO ()
388defaultMain connectTo migrations = do
390defaultMain connectTo migrations = do
@@ -403,7 +405,7 @@ defaultMain connectTo migrations = do
403 migrateStatus :: PQ schema schema IO ()
405 migrateStatus :: PQ schema schema IO ()
404 migrateStatus = unsafePQ $ do
406 migrateStatus = unsafePQ $ do
405 runNames <- getRunMigrationNames
407 runNames <- getRunMigrationNames
406− let names = extractList name migrations
408+ let names = ctoList name migrations
407 unrunNames = names \\ runNames
409 unrunNames = names \\ runNames
408 liftIO $ displayRunned runNames >> displayUnrunned unrunNames
410 liftIO $ displayRunned runNames >> displayUnrunned unrunNames
409
411
squeal-postgresql/src/Squeal/PostgreSQL/PG.hs+22−12
@@ -47,7 +47,7 @@ module Squeal.PostgreSQL.PG
47 , Enumerated (..)
47 , Enumerated (..)
48 , VarArray (..)
48 , VarArray (..)
49 , FixArray (..)
49 , FixArray (..)
50− , Oid (..)
50+ , LibPQ.Oid (..)
51 -- * Type families
51 -- * Type families
52 , LabelsPG
52 , LabelsPG
53 , DimPG
53 , DimPG
@@ -66,7 +66,6 @@ import Data.Int (Int16, Int32, Int64)
66import Data.Scientific (Scientific)
66import Data.Scientific (Scientific)
67import Data.Time (Day, DiffTime, LocalTime, TimeOfDay, TimeZone, UTCTime)
67import Data.Time (Day, DiffTime, LocalTime, TimeOfDay, TimeZone, UTCTime)
68import Data.Vector (Vector)
68import Data.Vector (Vector)
69−import Data.Word (Word32)
70import Data.UUID.Types (UUID)
69import Data.UUID.Types (UUID)
71import GHC.TypeLits
70import GHC.TypeLits
72import Network.IP.Addr (NetAddr, IP)
71import Network.IP.Addr (NetAddr, IP)
@@ -75,6 +74,7 @@ import qualified Data.ByteString.Lazy as Lazy (ByteString)
75import qualified Data.ByteString as Strict (ByteString)
74import qualified Data.ByteString as Strict (ByteString)
76import qualified Data.Text.Lazy as Lazy (Text)
75import qualified Data.Text.Lazy as Lazy (Text)
77import qualified Data.Text as Strict (Text)
76import qualified Data.Text as Strict (Text)
77+import qualified Database.PostgreSQL.LibPQ as LibPQ
78import qualified GHC.Generics as GHC
78import qualified GHC.Generics as GHC
79import qualified Generics.SOP as SOP
79import qualified Generics.SOP as SOP
80import qualified Generics.SOP.Record as SOP
80import qualified Generics.SOP.Record as SOP
@@ -108,7 +108,7 @@ type instance PG Int32 = 'PGint4
108-- | `PGint8`
108-- | `PGint8`
109type instance PG Int64 = 'PGint8
109type instance PG Int64 = 'PGint8
110-- | `PGint2`
110-- | `PGint2`
111−type instance PG Oid = 'PGoid
111+type instance PG LibPQ.Oid = 'PGoid
112-- | `PGnumeric`
112-- | `PGnumeric`
113type instance PG Scientific = 'PGnumeric
113type instance PG Scientific = 'PGnumeric
114-- | `PGfloat4`
114-- | `PGfloat4`
@@ -178,8 +178,16 @@ type family RowPG (hask :: Type) :: RowType where
178
178
179-- | `RowOf` applies `NullPG` to the fields of a list.
179-- | `RowOf` applies `NullPG` to the fields of a list.
180type family RowOf (record :: [(Symbol, Type)]) :: RowType where
180type family RowOf (record :: [(Symbol, Type)]) :: RowType where
181− RowOf '[] = '[]
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
182 RowOf (col ::: ty ': record) = col ::: NullPG ty ': RowOf record
189 RowOf (col ::: ty ': record) = col ::: NullPG ty ': RowOf record
190+ RowOf '[] = '[]
183
191
184{- | `NullPG` turns a Haskell type into a `NullityType`.
192{- | `NullPG` turns a Haskell type into a `NullityType`.
185
193
@@ -206,8 +214,17 @@ type family TuplePG (hask :: Type) :: [NullityType] where
206
214
207-- | `TupleOf` turns a list of Haskell `Type`s into a list of `NullityType`s.
215-- | `TupleOf` turns a list of Haskell `Type`s into a list of `NullityType`s.
208type family TupleOf (tuple :: [Type]) :: [NullityType] where
216type family TupleOf (tuple :: [Type]) :: [NullityType] where
209− TupleOf '[] = '[]
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
210 TupleOf (hask ': tuple) = NullPG hask ': TupleOf tuple
226 TupleOf (hask ': tuple) = NullPG hask ': TupleOf tuple
227+ TupleOf '[] = '[]
211
228
212-- | `TupleCodeOf` takes the `SOP.Code` of a haskell `Type`
229-- | `TupleCodeOf` takes the `SOP.Code` of a haskell `Type`
213-- and if it's a simple product returns it, otherwise giving a `TypeError`.
230-- and if it's a simple product returns it, otherwise giving a `TypeError`.
@@ -369,10 +386,3 @@ newtype FixArray arr = FixArray {getFixArray :: arr}
369 deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
386 deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
370-- | `PGfixarray` @(@`DimPG` @hask) (@`FixPG` @hask)@
387-- | `PGfixarray` @(@`DimPG` @hask) (@`FixPG` @hask)@
371type instance PG (FixArray hask) = 'PGfixarray (DimPG hask) (FixPG hask)
388type instance PG (FixArray hask) = 'PGfixarray (DimPG hask) (FixPG hask)
372−
373−{- | Object identifiers (`Oid`s) are used internally by PostgreSQL
374−as primary keys for various system tables.
375−-}
376−newtype Oid = Oid { getOid :: Word32 }
377− deriving stock (Eq, Ord, Show, Read, GHC.Generic)
378− deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs+41−17
@@ -78,6 +78,7 @@ 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 ((<&>))
81import Data.Kind
82import Data.Kind
82import Data.Text (pack, Text)
83import Data.Text (pack, Text)
83import Data.Traversable
84import Data.Traversable
@@ -86,6 +87,7 @@ import PostgreSQL.Binary.Encoding (encodingBytes)
86
87
87import qualified Control.Monad.Fail as Fail
88import qualified Control.Monad.Fail as Fail
88import qualified Database.PostgreSQL.LibPQ as LibPQ
89import qualified Database.PostgreSQL.LibPQ as LibPQ
90+import qualified PostgreSQL.Binary.Encoding as Encoding
89
91
90import Squeal.PostgreSQL.Binary
92import Squeal.PostgreSQL.Binary
91import Squeal.PostgreSQL.Definition
93import Squeal.PostgreSQL.Definition
@@ -315,13 +317,13 @@ a default instance.
315-}
317-}
316class Monad pq => MonadPQ schemas pq | pq -> schemas where
318class Monad pq => MonadPQ schemas pq | pq -> schemas where
317 manipulateParams
319 manipulateParams
318− :: ToParams x params
320+ :: (ToParams x params, All OidOfParam params)
319 => Manipulation '[] schemas params ys
321 => Manipulation '[] schemas params ys
320 -- ^ `insertInto`, `update` or `deleteFrom`
322 -- ^ `insertInto`, `update` or `deleteFrom`
321 -> x -> pq (K LibPQ.Result ys)
323 -> x -> pq (K LibPQ.Result ys)
322 default manipulateParams
324 default manipulateParams
323 :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)
325 :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)
324− => ToParams x params
326+ => (ToParams x params, All OidOfParam params)
325 => Manipulation '[] schemas params ys
327 => Manipulation '[] schemas params ys
326 -- ^ `insertInto`, `update` or `deleteFrom`
328 -- ^ `insertInto`, `update` or `deleteFrom`
327 -> x -> pq (K LibPQ.Result ys)
329 -> x -> pq (K LibPQ.Result ys)
@@ -329,7 +331,7 @@ class Monad pq => MonadPQ schemas pq | pq -> schemas where
329 manipulateParams manipulation params
331 manipulateParams manipulation params
330
332
331 manipulateParams_
333 manipulateParams_
332− :: ToParams x params
334+ :: (ToParams x params, All OidOfParam params)
333 => Manipulation '[] schemas params '[]
335 => Manipulation '[] schemas params '[]
334 -- ^ `insertInto`, `update` or `deleteFrom`
336 -- ^ `insertInto`, `update` or `deleteFrom`
335 -> x -> pq ()
337 -> x -> pq ()
@@ -342,7 +344,7 @@ class Monad pq => MonadPQ schemas pq | pq -> schemas where
342 manipulate_ = void . manipulate
344 manipulate_ = void . manipulate
343
345
344 runQueryParams
346 runQueryParams
345− :: ToParams x params
347+ :: (ToParams x params, All OidOfParam params)
346 => Query '[] '[] schemas params ys
348 => Query '[] '[] schemas params ys
347 -- ^ `select` and friends
349 -- ^ `select` and friends
348 -> x -> pq (K LibPQ.Result ys)
350 -> x -> pq (K LibPQ.Result ys)
@@ -355,19 +357,19 @@ class Monad pq => MonadPQ schemas pq | pq -> schemas where
355 runQuery q = runQueryParams q ()
357 runQuery q = runQueryParams q ()
356
358
357 traversePrepared
359 traversePrepared
358− :: (ToParams x params, Traversable list)
360+ :: (ToParams x params, Traversable list, All OidOfParam params)
359 => Manipulation '[] schemas params ys
361 => Manipulation '[] schemas params ys
360 -- ^ `insertInto`, `update`, or `deleteFrom`, and friends
362 -- ^ `insertInto`, `update`, or `deleteFrom`, and friends
361 -> list x -> pq (list (K LibPQ.Result ys))
363 -> list x -> pq (list (K LibPQ.Result ys))
362 default traversePrepared
364 default traversePrepared
363 :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)
365 :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)
364− => (ToParams x params, Traversable list)
366+ => (ToParams x params, Traversable list, All OidOfParam params)
365 => Manipulation '[] schemas params ys -> list x -> pq (list (K LibPQ.Result ys))
367 => Manipulation '[] schemas params ys -> list x -> pq (list (K LibPQ.Result ys))
366 traversePrepared manipulation params = lift $
368 traversePrepared manipulation params = lift $
367 traversePrepared manipulation params
369 traversePrepared manipulation params
368
370
369 forPrepared
371 forPrepared
370− :: (ToParams x params, Traversable list)
372+ :: (ToParams x params, Traversable list, All OidOfParam params)
371 => list x
373 => list x
372 -> Manipulation '[] schemas params ys
374 -> Manipulation '[] schemas params ys
373 -- ^ `insertInto`, `update` or `deleteFrom`
375 -- ^ `insertInto`, `update` or `deleteFrom`
@@ -375,13 +377,13 @@ class Monad pq => MonadPQ schemas pq | pq -> schemas where
375 forPrepared = flip traversePrepared
377 forPrepared = flip traversePrepared
376
378
377 traversePrepared_
379 traversePrepared_
378− :: (ToParams x params, Foldable list)
380+ :: (ToParams x params, Foldable list, All OidOfParam params)
379 => Manipulation '[] schemas params '[]
381 => Manipulation '[] schemas params '[]
380 -- ^ `insertInto`, `update` or `deleteFrom`
382 -- ^ `insertInto`, `update` or `deleteFrom`
381 -> list x -> pq ()
383 -> list x -> pq ()
382 default traversePrepared_
384 default traversePrepared_
383 :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)
385 :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)
384− => (ToParams x params, Foldable list)
386+ => (ToParams x params, Foldable list, All OidOfParam params)
385 => Manipulation '[] schemas params '[]
387 => Manipulation '[] schemas params '[]
386 -- ^ `insertInto`, `update` or `deleteFrom`
388 -- ^ `insertInto`, `update` or `deleteFrom`
387 -> list x -> pq ()
389 -> list x -> pq ()
@@ -389,7 +391,7 @@ class Monad pq => MonadPQ schemas pq | pq -> schemas where
389 traversePrepared_ manipulation params
391 traversePrepared_ manipulation params
390
392
391 forPrepared_
393 forPrepared_
392− :: (ToParams x params, Foldable list)
394+ :: (ToParams x params, Foldable list, All OidOfParam params)
393 => list x
395 => list x
394 -> Manipulation '[] schemas params '[]
396 -> Manipulation '[] schemas params '[]
395 -- ^ `insertInto`, `update` or `deleteFrom`
397 -- ^ `insertInto`, `update` or `deleteFrom`
@@ -409,9 +411,17 @@ instance (MonadIO io, schemas0 ~ schemas, schemas1 ~ schemas)
409 (UnsafeManipulation q :: Manipulation '[] schemas ps ys) (params :: x) =
411 (UnsafeManipulation q :: Manipulation '[] schemas ps ys) (params :: x) =
410 PQ $ \ (K conn) -> do
412 PQ $ \ (K conn) -> do
411 let
413 let
412− toParam' encoding =
414+ paramSet
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 ->
413− (LibPQ.invalidOid, encodingBytes encoding, LibPQ.Binary)
420+ (oidOfParam @param, encodingBytes encoding, LibPQ.Binary)
421+ params'
422+ = hcollapse
423+ . hcmap (Proxy @OidOfParam) paramSet
414− params' = fmap (fmap toParam') (hcollapse (toParams @x @ps params))
424+ $ toParams @x @ps params
415 q' = q <> ";"
425 q' = q <> ";"
416 resultMaybe <- liftIO $ LibPQ.execParams conn q' params' LibPQ.Binary
426 resultMaybe <- liftIO $ LibPQ.execParams conn q' params' LibPQ.Binary
417 case resultMaybe of
427 case resultMaybe of
@@ -424,8 +434,15 @@ instance (MonadIO io, schemas0 ~ schemas, schemas1 ~ schemas)
424 traversePrepared
434 traversePrepared
425 (UnsafeManipulation q :: Manipulation '[] schemas xs ys) (list :: list x) =
435 (UnsafeManipulation q :: Manipulation '[] schemas xs ys) (list :: list x) =
426 PQ $ \ (K conn) -> liftIO $ do
436 PQ $ \ (K conn) -> liftIO $ do
437+ let
427− let temp = "temporary_statement"
438+ 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
428− prepResultMaybe <- LibPQ.prepare conn temp q Nothing
445+ prepResultMaybe <- LibPQ.prepare conn temp q (Just paramOids')
429 case prepResultMaybe of
446 case prepResultMaybe of
430 Nothing -> throw $ ResultException
447 Nothing -> throw $ ResultException
431 "traversePrepared: LibPQ.prepare returned no results"
448 "traversePrepared: LibPQ.prepare returned no results"
@@ -451,8 +468,15 @@ instance (MonadIO io, schemas0 ~ schemas, schemas1 ~ schemas)
451 traversePrepared_
468 traversePrepared_
452 (UnsafeManipulation q :: Manipulation '[] schemas xs '[]) (list :: list x) =
469 (UnsafeManipulation q :: Manipulation '[] schemas xs '[]) (list :: list x) =
453 PQ $ \ (K conn) -> liftIO $ do
470 PQ $ \ (K conn) -> liftIO $ do
471+ let
454− let temp = "temporary_statement"
472+ 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
455− prepResultMaybe <- LibPQ.prepare conn temp q Nothing
479+ prepResultMaybe <- LibPQ.prepare conn temp q (Just paramOids')
456 case prepResultMaybe of
480 case prepResultMaybe of
457 Nothing -> throw $ ResultException
481 Nothing -> throw $ ResultException
458 "traversePrepared_: LibPQ.prepare returned no results"
482 "traversePrepared_: LibPQ.prepare returned no results"
squeal-postgresql/src/Squeal/PostgreSQL/Query.hs+74−22
@@ -39,6 +39,8 @@ module Squeal.PostgreSQL.Query
39 , select_
39 , select_
40 , selectDistinct
40 , selectDistinct
41 , selectDistinct_
41 , selectDistinct_
42+ , selectDistinctOn
43+ , selectDistinctOn_
42 , Selection (..)
44 , Selection (..)
43 -- ** Values
45 -- ** Values
44 , values
46 , values
@@ -552,9 +554,9 @@ select_ = select . List
552-- be subject to the elimination of duplicate rows using `selectDistinct`.
554-- be subject to the elimination of duplicate rows using `selectDistinct`.
553selectDistinct
555selectDistinct
554 :: (SListI columns, columns ~ (col ': cols))
556 :: (SListI columns, columns ~ (col ': cols))
555− => Selection outer commons 'Ungrouped schemas params from columns
557+ => Selection outer commons grp schemas params from columns
556 -- ^ selection
558 -- ^ selection
557− -> TableExpression outer commons 'Ungrouped schemas params from
559+ -> TableExpression outer commons grp schemas params from
558 -- ^ intermediate virtual table
560 -- ^ intermediate virtual table
559 -> Query outer commons schemas params columns
561 -> Query outer commons schemas params columns
560selectDistinct selection tabexpr = UnsafeQuery $
562selectDistinct selection tabexpr = UnsafeQuery $
@@ -566,13 +568,62 @@ selectDistinct selection tabexpr = UnsafeQuery $
566-- of a general `Selection`.
568-- of a general `Selection`.
567selectDistinct_
569selectDistinct_
568 :: (SListI columns, columns ~ (col ': cols))
570 :: (SListI columns, columns ~ (col ': cols))
569− => NP (Aliased (Expression outer commons 'Ungrouped schemas params from)) columns
571+ => NP (Aliased (Expression outer commons grp schemas params from)) columns
570 -- ^ select list
572 -- ^ select list
571− -> TableExpression outer commons 'Ungrouped schemas params from
573+ -> TableExpression outer commons grp schemas params from
572 -- ^ intermediate virtual table
574 -- ^ intermediate virtual table
573 -> Query outer commons schemas params columns
575 -> Query outer commons schemas params columns
574selectDistinct_ = selectDistinct . List
576selectDistinct_ = selectDistinct . List
575
577
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+
576-- | `values` computes a row value or set of row values
627-- | `values` computes a row value or set of row values
577-- specified by value expressions. It is most commonly used
628-- specified by value expressions. It is most commonly used
578-- to generate a “constant table” within a larger command,
629-- to generate a “constant table” within a larger command,
@@ -706,7 +757,7 @@ instance RenderSQL (TableExpression outer commons grp schemas params from) where
706from
757from
707 :: FromClause outer commons schemas params from -- ^ table reference
758 :: FromClause outer commons schemas params from -- ^ table reference
708 -> TableExpression outer commons 'Ungrouped schemas params from
759 -> TableExpression outer commons 'Ungrouped schemas params from
709−from tab = TableExpression tab [] NoGroups NoHaving [] [] []
760+from tab = TableExpression tab [] noGroups NoHaving [] [] []
710
761
711-- | A `where_` is an endomorphism of `TableExpression`s which adds a
762-- | A `where_` is an endomorphism of `TableExpression`s which adds a
712-- search condition to the `whereClause`.
763-- search condition to the `whereClause`.
@@ -727,7 +778,7 @@ groupBy
727groupBy bys rels = TableExpression
778groupBy bys rels = TableExpression
728 { fromClause = fromClause rels
779 { fromClause = fromClause rels
729 , whereClause = whereClause rels
780 , whereClause = whereClause rels
730− , groupByClause = Group bys
781+ , groupByClause = group bys
731 , havingClause = Having []
782 , havingClause = Having []
732 , orderByClause = []
783 , orderByClause = []
733 , limitClause = limitClause rels
784 , limitClause = limitClause rels
@@ -941,19 +992,20 @@ instance (Has rel rels cols, Has col cols ty, bys ~ '[ '(rel, col)])
941-- done on @NoGroups@ while all output `Expression`s must be aggregated
992-- done on @NoGroups@ while all output `Expression`s must be aggregated
942-- in @Group Nil@. In general, all output `Expression`s in the
993-- in @Group Nil@. In general, all output `Expression`s in the
943-- complement of @bys@ must be aggregated in @Group bys@.
994-- complement of @bys@ must be aggregated in @Group bys@.
944−data GroupByClause grp from where
995+newtype GroupByClause grp from = UnsafeGroupByClause
945− NoGroups :: GroupByClause 'Ungrouped from
996+ { renderGroupByClause :: ByteString }
946− Group
997+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
947− :: SListI bys
948− => NP (By from) bys
949− -> GroupByClause ('Grouped bys) from
950−
951−-- | Renders a `GroupByClause`.
952instance RenderSQL (GroupByClause grp from) where
998instance RenderSQL (GroupByClause grp from) where
953− renderSQL = \case
999+ renderSQL = renderGroupByClause
954− NoGroups -> ""
1000+noGroups :: GroupByClause 'Ungrouped from
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
955− Group Nil -> ""
1007+ Nil -> ""
956− Group bys -> " GROUP BY" <+> renderCommaSeparated renderSQL bys
1008+ bys' -> " GROUP BY" <+> renderCommaSeparated renderSQL bys'
957
1009
958-- | A `HavingClause` is used to eliminate groups that are not of interest.
1010-- | A `HavingClause` is used to eliminate groups that are not of interest.
959-- An `Ungrouped` `TableExpression` may only use `NoHaving` while a `Grouped`
1011-- An `Ungrouped` `TableExpression` may only use `NoHaving` while a `Grouped`
@@ -997,8 +1049,8 @@ instance
997 , commons1 ~ (cte ::: common ': commons)
1049 , commons1 ~ (cte ::: common ': commons)
998 ) => Aliasable cte
1050 ) => Aliasable cte
999 (statement commons schemas params common)
1051 (statement commons schemas params common)
1000− (AlignedList (CommonTableExpression statement schemas params) commons commons1) where
1052+ (Path (CommonTableExpression statement schemas params) commons commons1) where
1001− statement `as` cte = single (statement `as` cte)
1053+ statement `as` cte = csingleton (statement `as` cte)
1002
1054
1003instance (forall c s p r. RenderSQL (statement c s p r)) => RenderSQL
1055instance (forall c s p r. RenderSQL (statement c s p r)) => RenderSQL
1004 (CommonTableExpression statement schemas params commons0 commons1) where
1056 (CommonTableExpression statement schemas params commons0 commons1) where
@@ -1010,7 +1062,7 @@ instance (forall c s p r. RenderSQL (statement c s p r)) => RenderSQL
1010-- defining temporary tables that exist just for one query.
1062-- defining temporary tables that exist just for one query.
1011class With statement where
1063class With statement where
1012 with
1064 with
1013− :: AlignedList (CommonTableExpression statement schemas params) commons0 commons1
1065+ :: Path (CommonTableExpression statement schemas params) commons0 commons1
1014 -- ^ common table expressions
1066 -- ^ common table expressions
1015 -> statement commons1 schemas params row
1067 -> statement commons1 schemas params row
1016 -- ^ larger query
1068 -- ^ larger query
@@ -1018,7 +1070,7 @@ class With statement where
1018instance With (Query outer) where
1070instance With (Query outer) where
1019 with Done query = query
1071 with Done query = query
1020 with ctes query = UnsafeQuery $
1072 with ctes query = UnsafeQuery $
1021− "WITH" <+> renderSQL ctes <+> renderSQL query
1073+ "WITH" <+> commaSeparated (ctoList renderSQL ctes) <+> renderSQL query
1022
1074
1023{- |
1075{- |
1024>>> import Data.Monoid (Sum (..))
1076>>> import Data.Monoid (Sum (..))
squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs+143−13
@@ -44,6 +44,8 @@ module Squeal.PostgreSQL.Schema
44 , ColumnsType
44 , ColumnsType
45 , TableType
45 , TableType
46 , SchemumType (..)
46 , SchemumType (..)
47+ , IndexType (..)
48+ , FunctionType
47 , OperatorType (..)
49 , OperatorType (..)
48 , ReturnsType (..)
50 , ReturnsType (..)
49 , SchemaType
51 , SchemaType
@@ -60,9 +62,16 @@ module Squeal.PostgreSQL.Schema
60 , PGlabel (..)
62 , PGlabel (..)
61 -- * Data Definitions
63 -- * Data Definitions
62 , Create
64 , Create
65+ , CreateIfNotExists
66+ , CreateOrReplace
63 , Drop
67 , Drop
68+ , DropSchemum
69+ , DropIfExists
70+ , DropSchemumIfExists
64 , Alter
71 , Alter
72+ , AlterIfExists
65 , Rename
73 , Rename
74+ , RenameIfExists
66 , ConstraintInvolves
75 , ConstraintInvolves
67 , DropIfConstraintsInvolve
76 , DropIfConstraintsInvolve
68 , IsNotElem
77 , IsNotElem
@@ -251,9 +260,19 @@ type FromType = [(Symbol,RowType)]
251
260
252-- | `ColumnsToRow` removes column constraints.
261-- | `ColumnsToRow` removes column constraints.
253type family ColumnsToRow (columns :: ColumnsType) :: RowType where
262type family ColumnsToRow (columns :: ColumnsType) :: RowType where
254− ColumnsToRow '[] = '[]
263+ ColumnsToRow (column ::: _ :=> ty ': column1 ::: _ :=> ty1 ': column2 ::: _ :=> ty2 ': column3 ::: _ :=> ty3 ': column4 ::: _ :=> ty4 ': column5 ::: _ :=> ty5 ': columns) =
255− ColumnsToRow (column ::: constraint :=> ty ': 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) =
256 column ::: ty ': ColumnsToRow columns
274 column ::: ty ': ColumnsToRow columns
275+ ColumnsToRow '[] = '[]
257
276
258-- | `TableToColumns` removes table constraints.
277-- | `TableToColumns` removes table constraints.
259type family TableToColumns (table :: TableType) :: ColumnsType where
278type family TableToColumns (table :: TableType) :: ColumnsType where
@@ -286,14 +305,24 @@ instance ty0 ~ ty1 => SamePGType
286
305
287-- | `AllNotNull` is a constraint that proves a `ColumnsType` has no @NULL@s.
306-- | `AllNotNull` is a constraint that proves a `ColumnsType` has no @NULL@s.
288type family AllNotNull (columns :: ColumnsType) :: Constraint where
307type 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
289 AllNotNull '[] = ()
314 AllNotNull '[] = ()
290− AllNotNull (column ::: def :=> 'NotNull ty ': columns) = AllNotNull columns
291
315
292-- | `NotAllNull` is a constraint that proves a `ColumnsType` has some
316-- | `NotAllNull` is a constraint that proves a `ColumnsType` has some
293-- @NOT NULL@.
317-- @NOT NULL@.
294type family NotAllNull (columns :: ColumnsType) :: Constraint where
318type family NotAllNull (columns :: ColumnsType) :: Constraint where
295− NotAllNull (column ::: def :=> 'NotNull ty ': columns) = ()
319+ NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()
320+ NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()
321+ NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()
322+ NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()
323+ NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()
324+ NotAllNull (_ ::: _ :=> 'NotNull _ ': _) = ()
296− NotAllNull (column ::: def :=> 'Null ty ': columns) = NotAllNull columns
325+ NotAllNull (_ ::: _ :=> 'Null _ ': columns) = NotAllNull columns
297
326
298-- | `NullifyType` is an idempotent that nullifies a `NullityType`.
327-- | `NullifyType` is an idempotent that nullifies a `NullityType`.
299type family NullifyType (ty :: NullityType) :: NullityType where
328type family NullifyType (ty :: NullityType) :: NullityType where
@@ -302,17 +331,37 @@ type family NullifyType (ty :: NullityType) :: NullityType where
302
331
303-- | `NullifyRow` is an idempotent that nullifies a `RowType`.
332-- | `NullifyRow` is an idempotent that nullifies a `RowType`.
304type family NullifyRow (columns :: RowType) :: RowType where
333type family NullifyRow (columns :: RowType) :: RowType where
305− NullifyRow '[] = '[]
334+ NullifyRow (column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': column3 ::: ty3 ': column4 ::: ty4 ': column5 ::: ty5 ': columns) =
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
306 NullifyRow (column ::: ty ': columns) =
344 NullifyRow (column ::: ty ': columns) =
307 column ::: NullifyType ty ': NullifyRow columns
345 column ::: NullifyType ty ': NullifyRow columns
346+ NullifyRow '[] = '[]
308
347
309-- | `NullifyFrom` is an idempotent that nullifies a `FromType`
348-- | `NullifyFrom` is an idempotent that nullifies a `FromType`
310-- used to nullify the left or right hand side of an outer join
349-- used to nullify the left or right hand side of an outer join
311-- in a `Squeal.PostgreSQL.Query.FromClause`.
350-- in a `Squeal.PostgreSQL.Query.FromClause`.
312type family NullifyFrom (tables :: FromType) :: FromType where
351type family NullifyFrom (tables :: FromType) :: FromType where
313− NullifyFrom '[] = '[]
352+ NullifyFrom (table ::: columns ': table1 ::: columns1 ': table2 ::: columns2 ': table3 ::: columns3 ': table4 ::: columns4 ': table5 ::: columns5 ': tables) =
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
314 NullifyFrom (table ::: columns ': tables) =
362 NullifyFrom (table ::: columns ': tables) =
315 table ::: NullifyRow columns ': NullifyFrom tables
363 table ::: NullifyRow columns ': NullifyFrom tables
364+ NullifyFrom '[] = '[]
316
365
317-- | @Create alias x xs@ adds @alias ::: x@ to the end of @xs@ and is used in
366-- | @Create alias x xs@ adds @alias ::: x@ to the end of @xs@ and is used in
318-- `Squeal.PostgreSQL.Definition.createTable` statements and in @ALTER TABLE@
367-- `Squeal.PostgreSQL.Definition.createTable` statements and in @ALTER TABLE@
@@ -322,30 +371,101 @@ type family Create alias x xs where
322 Create alias x (alias ::: y ': xs) = TypeError
371 Create alias x (alias ::: y ': xs) = TypeError
323 ('Text "Create: alias "
372 ('Text "Create: alias "
324 ':<>: 'ShowType alias
373 ':<>: 'ShowType alias
325− ':<>: 'Text "already in use")
374+ ':<>: 'Text "already exists")
326 Create alias y (x ': xs) = x ': Create alias y xs
375 Create alias y (x ': xs) = x ': Create alias y xs
327
376
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+
328-- | @Drop alias xs@ removes the type associated with @alias@ in @xs@
394-- | @Drop alias xs@ removes the type associated with @alias@ in @xs@
329-- and is used in `Squeal.PostgreSQL.Definition.dropTable` statements
395-- and is used in `Squeal.PostgreSQL.Definition.dropTable` statements
330-- and in @ALTER TABLE@ `Squeal.PostgreSQL.Definition.dropColumn` statements.
396-- and in @ALTER TABLE@ `Squeal.PostgreSQL.Definition.dropColumn` statements.
331type family Drop alias xs where
397type family Drop alias xs where
398+ Drop alias '[] = TypeError
399+ ('Text "Drop: alias "
400+ ':<>: 'ShowType alias
401+ ':<>: 'Text " does not exist" )
332− Drop alias ((alias ::: x) ': xs) = xs
402+ Drop alias (alias ::: x ': xs) = xs
333 Drop alias (x ': xs) = x ': Drop alias xs
403 Drop alias (x ': xs) = x ': Drop alias xs
334
404
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+
335-- | @Alter alias x xs@ replaces the type associated with an @alias@ in @xs@
437-- | @Alter alias x xs@ replaces the type associated with an @alias@ in @xs@
336-- with the type @x@ and is used in `Squeal.PostgreSQL.Definition.alterTable`
438-- with the type @x@ and is used in `Squeal.PostgreSQL.Definition.alterTable`
337-- and `Squeal.PostgreSQL.Definition.alterColumn`.
439-- and `Squeal.PostgreSQL.Definition.alterColumn`.
338type family Alter alias x xs where
440type family Alter alias x xs where
441+ Alter alias x '[] = TypeError
442+ ('Text "Alter: alias "
443+ ':<>: 'ShowType alias
444+ ':<>: 'Text " does not exist" )
339 Alter alias x1 (alias ::: x0 ': xs) = alias ::: x1 ': xs
445 Alter alias x1 (alias ::: x0 ': xs) = alias ::: x1 ': xs
340 Alter alias x1 (x0 ': xs) = x0 ': Alter alias x1 xs
446 Alter alias x1 (x0 ': xs) = x0 ': Alter alias x1 xs
341
447
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+
342-- | @Rename alias0 alias1 xs@ replaces the alias @alias0@ by @alias1@ in @xs@
453-- | @Rename alias0 alias1 xs@ replaces the alias @alias0@ by @alias1@ in @xs@
343-- and is used in `Squeal.PostgreSQL.Definition.alterTableRename` and
454-- and is used in `Squeal.PostgreSQL.Definition.alterTableRename` and
344-- `Squeal.PostgreSQL.Definition.renameColumn`.
455-- `Squeal.PostgreSQL.Definition.renameColumn`.
345type family Rename alias0 alias1 xs where
456type family Rename alias0 alias1 xs where
457+ Rename alias0 alias1 '[] = TypeError
458+ ('Text "Rename: alias "
459+ ':<>: 'ShowType alias0
460+ ':<>: 'Text " does not exist" )
346 Rename alias0 alias1 ((alias0 ::: x0) ': xs) = (alias1 ::: x0) ': xs
461 Rename alias0 alias1 ((alias0 ::: x0) ': xs) = (alias1 ::: x0) ': xs
347 Rename alias0 alias1 (x ': xs) = x ': Rename alias0 alias1 xs
462 Rename alias0 alias1 (x ': xs) = x ': Rename alias0 alias1 xs
348
463
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+
349-- | Check if a `TableConstraint` involves a column
469-- | Check if a `TableConstraint` involves a column
350type family ConstraintInvolves column constraint where
470type family ConstraintInvolves column constraint where
351 ConstraintInvolves column ('Check columns) = column `Elem` columns
471 ConstraintInvolves column ('Check columns) = column `Elem` columns
@@ -368,19 +488,29 @@ data SchemumType
368 = Table TableType
488 = Table TableType
369 | View RowType
489 | View RowType
370 | Typedef PGType
490 | Typedef PGType
371− | Index
491+ | Index IndexType
372− | Function [NullityType] ReturnsType
492+ | Function FunctionType
373 | Operator OperatorType
493 | Operator OperatorType
374 | UnsafeSchemum Symbol
494 | UnsafeSchemum Symbol
375
495
496+type FunctionType = ([NullityType], ReturnsType)
497+
498+data IndexType
499+ = Btree
500+ | Hash
501+ | Gist
502+ | Spgist
503+ | Gin
504+ | Brin
505+
376data ReturnsType
506data ReturnsType
377 = Returns NullityType
507 = Returns NullityType
378 | ReturnsTable RowType
508 | ReturnsTable RowType
379
509
380data OperatorType
510data OperatorType
381 = BinaryOp NullityType NullityType NullityType
511 = BinaryOp NullityType NullityType NullityType
382− | UnaryOpL NullityType NullityType
512+ | LeftOp NullityType NullityType
383− | UnaryOpR NullityType NullityType
513+ | RightOp NullityType NullityType
384
514
385{- | The schema of a database consists of a list of aliased,
515{- | The schema of a database consists of a list of aliased,
386user-defined `SchemumType`s.
516user-defined `SchemumType`s.
squeal-postgresql/test/Property.hs+2−2
@@ -92,14 +92,14 @@ roundtrips = Group "roundtrips"
92 -- genTimeWithZone = (,) <$> genTimeOfDay <*> genTimeZone
92 -- genTimeWithZone = (,) <$> genTimeOfDay <*> genTimeZone
93
93
94roundtrip
94roundtrip
95− :: (ToParam x ty, FromValue ty x, Show x, Eq x)
95+ :: (OidOf ty, ToParam x ty, FromValue ty x, Show x, Eq x)
96 => TypeExpression schemas ('NotNull ty)
96 => TypeExpression schemas ('NotNull ty)
97 -> Gen x
97 -> Gen x
98 -> (PropertyName, Property)
98 -> (PropertyName, Property)
99roundtrip = roundtripOn id
99roundtrip = roundtripOn id
100
100
101roundtripOn
101roundtripOn
102− :: (ToParam x ty, FromValue ty x, Show x, Eq x)
102+ :: (OidOf ty, ToParam x ty, FromValue ty x, Show x, Eq x)
103 => (x -> x)
103 => (x -> x)
104 -> TypeExpression schemas ('NotNull ty)
104 -> TypeExpression schemas ('NotNull ty)
105 -> Gen x
105 -> Gen x
squeal-postgresql/test/Spec.hs+11
@@ -123,3 +123,14 @@ spec = before_ setupDB . after_ dropDB $ do
123 getRows =<< runQuery query
123 getRows =<< runQuery query
124 (fromOnly <$> rangesOut :: [Range Int32]) `shouldBe`
124 (fromOnly <$> rangesOut :: [Range Int32]) `shouldBe`
125 [ atLeast 3, 3 <=..< 5, Empty, whole ]
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
stack.yaml+2
@@ -4,3 +4,5 @@ packages:
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