git.iko.soy/squeal
on 60bc8ac help sign in
ddc9847
swap
0 ahead, 124 behind
44 files changed+1726−3410
since splitsnapshots
unifiedsplit
.circleci/config.yml+1−1 README.md+6−6 RELEASE NOTES.md+6−63 squeal-postgresql/exe/Example.hs+3−6 squeal-postgresql/squeal-postgresql.cabal+13−38 squeal-postgresql/src/Squeal/PostgreSQL.hs+3−12 squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs+92−186 squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs+1030−12 squeal-postgresql/src/Squeal/PostgreSQL/Definition/Function.hs−238 squeal-postgresql/src/Squeal/PostgreSQL/Definition/Index.hs−159 squeal-postgresql/src/Squeal/PostgreSQL/Definition/Schema.hs−96 squeal-postgresql/src/Squeal/PostgreSQL/Definition/Table.hs−500 squeal-postgresql/src/Squeal/PostgreSQL/Definition/Table/Constraint.hs−339 squeal-postgresql/src/Squeal/PostgreSQL/Definition/Type.hs−229 squeal-postgresql/src/Squeal/PostgreSQL/Definition/View.hs−104 squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs+17−91 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Aggregate.hs+3−18 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Collection.hs+5−5 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Comparison.hs+12−12 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Json.hs+47−40 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Logic.hs+2−2 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Math.hs+6−4 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Null.hs+4−4 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Range.hs−230 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Set.hs → squeal-postgresql/src/Squeal/PostgreSQL/Expression/SetOf.hs+24−57 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Text.hs+3−3 squeal-postgresql/src/Squeal/PostgreSQL/Expression/TextSearch.hs+21−20 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Time.hs+12−7 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Type.hs+5−156 squeal-postgresql/src/Squeal/PostgreSQL/List.hs+46−17 squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs+26−34 squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs+12−14 squeal-postgresql/src/Squeal/PostgreSQL/PG.hs+17−39 squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs+19−51 squeal-postgresql/src/Squeal/PostgreSQL/Pool.hs+99−67 squeal-postgresql/src/Squeal/PostgreSQL/Query.hs+31−82 squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs+10−157 squeal-postgresql/test/Doc.hs−6 squeal-postgresql/test/DocTest.hs+18 squeal-postgresql/test/Property.hs−166 squeal-postgresql/test/Spec.hs−136 squeal-postgresql/test/Specs/ExceptionHandling.hs+125 squeal-postgresql/test/Specs/Specs.hs+7 stack.yaml+1−3
.circleci/config.yml+1−1
@@ -2,7 +2,7 @@ version: 2
22jobs:
33 build:
44 docker:
5− - image: haskell:8.6.5
5+ - image: haskell:8.6.3
66 - image: circleci/postgres:latest
77 environment:
88 POSTGRES_USER: root
README.md+6−6
@@ -121,7 +121,7 @@ type Schemas = Public Schema
121121
122122Notice the use of type operators.
123123
124−`:::` is used to pair an alias `Symbol` with a `SchemumType`,
124+`:::` is used to pair an alias `GHC.TypeLits.Symbol` with a `SchemumType`,
125125a `TableConstraint` or a `ColumnType`. It is intended to connote Haskell's `::`
126126operator.
127127
@@ -180,8 +180,8 @@ DROP TABLE "emails";
180180DROP TABLE "users";
181181```
182182
183−We'll need a Haskell type for `User`s. We give the type `SOP.Generic` and
184−`SOP.HasDatatypeInfo` instances so that we can encode and decode `User`s.
183+We'll need a Haskell type for @User@s. We give the type `Generics.SOP.Generic` and
184+`Generics.SOP.HasDatatypeInfo` instances so that we can encode and decode @User@s.
185185
186186```Haskell
187187>>> data User = User { userName :: Text, userEmail :: Maybe Text } deriving (Show, GHC.Generic)
@@ -189,12 +189,12 @@ We'll need a Haskell type for `User`s. We give the type `SOP.Generic` and
189189>>> instance SOP.HasDatatypeInfo User
190190```
191191
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.
193193A `Manipulation_` like `insertInto`, `update` or `deleteFrom`
194194has three type parameters, the schemas it refers to, input parameters
195195and an output row. When
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
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
198198value. However, since the emails table refers to the users table, we will
199199need to retrieve the user id that the insert generates and insert it into
200200the emails table. We can do this in a single `Manipulation_` by using a
RELEASE NOTES.md+6−63
@@ -3,8 +3,6 @@
33### Version 0.5
44
55Version 0.5 makes a number of large changes and additions to Squeal.
6−I want to thank folks who contributed issues and pull requests;
7−Raveline, rimmington, ilyakooo0, chshersh, reygoch, and more.
86
97**Multi-schema support**
108
@@ -138,11 +136,11 @@ type Expr x
138136 . Expression outer commons grp schemas params from x
139137```
140138
141−There is also a function type `(-->)`, which is a subtype of the usual Haskell function
139+There is also a function type `(:-->)`, which is a subtype of the usual Haskell function
142140type `(->)`.
143141
144142```Haskell
145−type (-->) x y
143+type (:-->) x y
146144 = forall outer commons grp schemas params from
147145 . Expression outer commons grp schemas params from x
148146 -> Expression outer commons grp schemas params from y
@@ -220,23 +218,6 @@ automatically applies it, so to upgrade from Squeal 0.4, replace `select`
220218with `select_`. There are also independent `selectDistinct` and `selectDistinct_`
221219functions to filter out duplicate rows.
222220
223−**Query clauses**
224−
225−Previously, Squeal provided a couple versions of `INSERT` depending
226−on whether you wanted to insert `VALUES` or a query.
227−
228−Squeal 0.5 refactors this pattern into a `QueryClause` GADT.
229−
230−```
231−-- Squeal 0.4
232−insertRow_ #tab (Set 2 `as` #col1 :* Default `as` #col2)
233−insertQuery_ #tab (selectStar (from (table #other_tab)))
234−
235−-- Squeal 0.5
236−insertInto_ #tab (Values_ (Set 2 `as` #col1 :* Default `as` #col2))
237−insertInto_ #tab (Subquery (select Star (from (table #other_tab))))
238−```
239−
240221**Window functions and aggregation**
241222
242223Previous versions of Squeal provided no support for window functions.
@@ -348,57 +329,19 @@ to make them easier to compose with other `PQ` actions.
348329
349330**Transactions**
350331
351−You can now run transactions `ephemerally`, guaranteed to roll back,
352−but return the result or throw the exception that the transaction
353−would have generated. This is useful for testing. You can also
354−`transactionallyRetry` computations, retrying the transaction if
355−a [serialization failure](https://www.postgresql.org/docs/11/transaction-iso.html#XACT-REPEATABLE-READ) occurs.
356−
357−**Types**
332+**Money**
358333
359−Squeal now supports money via a `Money` Haskell `Type` and a `'PGmoney`
360−`PGType`. Squeal 0.5 also adds support for creating domain types
361−with `createDomain`.
334+**Domains**
362335
363−**Time**
364−
365−Squeal 0.5 adds support for new functions; `now`, `makeDate`, `makeTime`,
366−, `makeTimestamp`, and `makeTimestamptz`, a function `interval_` for
367−constructing time intervals out multiples of `TimeUnit`s, and a new
368−`TimeOp` class, defining affine space operators for time types and their
369−differences.
336+**Time operations**
370337
371338**Literals**
372339
373−Squeal allows you to include Haskell values in your statements using
374−out of line `parameter`s, but often you want to include them inline,
375−as a SQL `literal`. Squeal 0.5 enables this using the `Literal` class.
376−
377340**Set returning functions**
378341
379−Squeal 0.5 adds support for set returning functions such as `unnest`,
380−with the `RankNType` `SetOfFunction`, which can be used as as a `FromClause`.
381−
382342**Text search**
383343
384−Squeal 0.5 adds extensive support for text search types, functions and operators.
385−
386−**Much more**
387−
388−Lots more changes went into and under the hood of the new version.
389−The `Expression` module was split into coherent submodules since it
390−had grown to immense proportions. New modules `Alias`, `PG` and `List`
391−were added to relieve some of the burden that the `Schema` module
392−had been carrying. Rendering has been better unified with a new
393−`RenderSQL` typeclass. Type level list concatenation with the `Additional`
394−typeclass has been added. `Manipulation`s `update` and `delete`
395−were upgraded, so you can leave out fields you don't want to update and
396−use `USING` clauses in deletes. Upserts which were previously broken
397−now work. The `IO` typeclass hierarchy was changed from `MonadBase`
398−and `MonadBaseControl` to `MonadIO` and `MonadUnliftIO`. A new
399−`withRecursive` `Manipulation` was added. `SquealException`s were
400−refactored and a `trySqueal` function added. Arrays were refactored.
401−And there was probably more I've forgotten.
344+**Lists**
402345
403346### Version 0.4
404347
squeal-postgresql/exe/Example.hs+3−6
@@ -38,7 +38,6 @@ type Schema =
3838 , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
3939 , "email" ::: 'NoDef :=> 'Null 'PGtext
4040 ])
41− , "positive" ::: 'Typedef 'PGfloat4
4241 ]
4342
4443type Schemas = Public Schema
@@ -53,16 +52,14 @@ setup =
5352 >>>
5453 createTable #emails
5554 ( serial `as` #id :*
56− hask @Int32 `as` #user_id :*
57− hask @(Maybe Text) `as` #email )
55+ (int & notNullable) `as` #user_id :*
56+ (text & nullable) `as` #email )
5857 ( primaryKey #id `as` #pk_emails :*
5958 foreignKey #user_id #users #id
6059 OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
61− >>>
62− createDomain #positive real (#value .> 0 .&& (#value & isNotNull))
6360
6461teardown :: Definition Schemas (Public '[])
65−teardown = dropType #positive >>> dropTable #emails >>> dropTable #users
62+teardown = dropTable #emails >>> dropTable #users
6663
6764insertUser :: Manipulation_ Schemas (Text, VarArray (Vector (Maybe Int16))) (Only Int32)
6865insertUser = insertInto #users
squeal-postgresql/squeal-postgresql.cabal+13−38
@@ -1,5 +1,5 @@
11name: squeal-postgresql
2−version: 0.5.1.0
2+version: 0.4.9.0
33synopsis: Squeal PostgreSQL Library
44description: Squeal is a type-safe embedding of PostgreSQL in Haskell
55homepage: https://github.com/morphismtech/squeal
@@ -25,13 +25,6 @@ library
2525 Squeal.PostgreSQL.Alias
2626 Squeal.PostgreSQL.Binary
2727 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
3528 Squeal.PostgreSQL.Expression
3629 Squeal.PostgreSQL.Expression.Aggregate
3730 Squeal.PostgreSQL.Expression.Collection
@@ -42,8 +35,7 @@ library
4235 Squeal.PostgreSQL.Expression.Math
4336 Squeal.PostgreSQL.Expression.Null
4437 Squeal.PostgreSQL.Expression.Parameter
45− Squeal.PostgreSQL.Expression.Range
46− Squeal.PostgreSQL.Expression.Set
38+ Squeal.PostgreSQL.Expression.SetOf
4739 Squeal.PostgreSQL.Expression.Sort
4840 Squeal.PostgreSQL.Expression.Subquery
4941 Squeal.PostgreSQL.Expression.Text
@@ -62,7 +54,7 @@ library
6254 Squeal.PostgreSQL.Schema
6355 Squeal.PostgreSQL.Transaction
6456 default-language: Haskell2010
65− ghc-options: -Wall
57+ ghc-options: -Wall -Werror
6658 build-depends:
6759 aeson >= 1.2.4.0
6860 , base >= 4.11.1.0 && < 5.0
@@ -70,8 +62,7 @@ library
7062 , bytestring >= 0.10.8.2
7163 , bytestring-strict-builder >= 0.4.5
7264 , deepseq >= 1.4.3.0
73− , free-categories >= 0.1.0.0
74− , generics-sop >= 0.3.2.0 && < 0.5.0.0
65+ , generics-sop >= 0.3.2.0
7566 , mmorph >= 1.1.1
7667 , mtl >= 2.2.2
7768 , network-ip >= 0.3.0.2
@@ -88,50 +79,34 @@ library
8879 , uuid-types >= 1.0.3
8980 , vector >= 0.12.0.1
9081
91−test-suite doctest
82+test-suite squeal-postgresql-doctest
9283 default-language: Haskell2010
9384 type: exitcode-stdio-1.0
9485 hs-source-dirs: test
9586 ghc-options: -Wall
96− main-is: Doc.hs
87+ main-is: DocTest.hs
9788 build-depends:
9889 base >= 4.10.0.0
9990 , doctest >= 0.11.4
100− , squeal-postgresql
101−
102−test-suite properties
103− default-language: Haskell2010
104− type: exitcode-stdio-1.0
105− hs-source-dirs: test
106− ghc-options: -Wall
107− main-is: Property.hs
108− build-depends:
109− base >= 4.10.0.0
110− , bytestring >= 0.10.8.2
111− , hedgehog >= 1.0
112− , mtl >= 2.2.2
113− , scientific >= 0.3.5.3
114− , squeal-postgresql
115− , time >= 1.8.0.2
11691
117−test-suite spec
92+test-suite squeal-postgresql-specs
11893 default-language: Haskell2010
11994 type: exitcode-stdio-1.0
120− hs-source-dirs: test
121− ghc-options: -Wall
122− main-is: Spec.hs
95+ hs-source-dirs: test/Specs
96+ ghc-options: -Wall -main-is Specs
97+ main-is: Specs.hs
98+ other-modules: ExceptionHandling
12399 build-depends:
124100 base >= 4.10.0.0
125− , async >= 2.2.2
126101 , bytestring >= 0.10.8.2
127102 , generics-sop >= 0.3.1.0
128103 , hspec >= 2.4.8
129− , mtl >= 2.2.2
130104 , squeal-postgresql
131105 , text >= 1.2.2.2
106+ , transformers >= 0.5.2.0
132107 , vector >= 0.12.0.1
133108
134−executable example
109+executable squeal-postgresql-example
135110 default-language: Haskell2010
136111 hs-source-dirs: exe
137112 ghc-options: -Wall
squeal-postgresql/src/Squeal/PostgreSQL.hs+3−12
@@ -190,18 +190,11 @@ in
190190:}
191191[User {userName = "Alice", userEmail = Just "alice@gmail.com"},User {userName = "Bob", userEmail = Nothing},User {userName = "Carole", userEmail = Just "carole@hotmail.com"}]
192192-}
193−module Squeal.PostgreSQL (module X, RenderSQL(..), printSQL) where
193+module Squeal.PostgreSQL (module X) where
194194
195195import Squeal.PostgreSQL.Alias as X
196196import Squeal.PostgreSQL.Binary as X
197197import 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
205198import Squeal.PostgreSQL.Expression as X
206199import Squeal.PostgreSQL.Expression.Aggregate as X
207200import Squeal.PostgreSQL.Expression.Collection as X
@@ -212,8 +205,7 @@ import Squeal.PostgreSQL.Expression.Logic as X
212205import Squeal.PostgreSQL.Expression.Math as X
213206import Squeal.PostgreSQL.Expression.Null as X
214207import Squeal.PostgreSQL.Expression.Parameter as X
215−import Squeal.PostgreSQL.Expression.Range as X
216−import Squeal.PostgreSQL.Expression.Set as X
208+import Squeal.PostgreSQL.Expression.SetOf as X
217209import Squeal.PostgreSQL.Expression.Sort as X
218210import Squeal.PostgreSQL.Expression.Subquery as X
219211import Squeal.PostgreSQL.Expression.Text as X
@@ -225,9 +217,8 @@ import Squeal.PostgreSQL.List as X
225217import Squeal.PostgreSQL.Manipulation as X
226218import Squeal.PostgreSQL.Migration as X
227219import Squeal.PostgreSQL.PG as X
228−import Squeal.PostgreSQL.Pool as X
229220import Squeal.PostgreSQL.PQ as X
230221import Squeal.PostgreSQL.Query as X
231−import Squeal.PostgreSQL.Render (RenderSQL(..), printSQL)
222+import Squeal.PostgreSQL.Render as X
232223import Squeal.PostgreSQL.Schema as X
233224import Squeal.PostgreSQL.Transaction as X
squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs+92−186
@@ -216,9 +216,8 @@ module Squeal.PostgreSQL.Binary
216216 -- * Only
217217 , Only (..)
218218 -- * Oid
219− , OidOf (..)
220− , OidOfParam (..)
221− , OidOfField (..)
219+ , HasOid (..)
220+ , HasAliasedOid (..)
222221 ) where
223222
224223import BinaryParser
@@ -232,7 +231,6 @@ import Data.Time
232231import Data.UUID.Types
233232import Data.Vector (Vector)
234233import Data.Word
235−import Foreign.C.Types (CUInt(CUInt))
236234import Generics.SOP
237235import Generics.SOP.Record
238236import GHC.TypeLits
@@ -246,7 +244,6 @@ import qualified Data.Text.Lazy as Lazy (Text)
246244import qualified Data.Text as Strict (Text)
247245import qualified Data.Text as Strict.Text
248246import qualified Data.Vector as Vector
249−import qualified Database.PostgreSQL.LibPQ as LibPQ
250247import qualified GHC.Generics as GHC
251248import qualified PostgreSQL.Binary.Decoding as Decoding
252249import qualified PostgreSQL.Binary.Encoding as Encoding
@@ -277,9 +274,11 @@ class ToParam (x :: Type) (pg :: PGType) where
277274 toParam :: x -> K Encoding.Encoding pg
278275instance ToParam Bool 'PGbool where toParam = K . Encoding.bool
279276instance ToParam Int16 'PGint2 where toParam = K . Encoding.int2_int16
277+instance ToParam Word16 'PGint2 where toParam = K . Encoding.int2_word16
280278instance ToParam Int32 'PGint4 where toParam = K . Encoding.int4_int32
279+instance ToParam Word32 'PGint4 where toParam = K . Encoding.int4_word32
281280instance ToParam Int64 'PGint8 where toParam = K . Encoding.int8_int64
282−instance ToParam Oid 'PGoid where toParam = K . Encoding.int4_word32 . getOid
281+instance ToParam Word64 'PGint8 where toParam = K . Encoding.int8_word64
283282instance ToParam Float 'PGfloat4 where toParam = K . Encoding.float4
284283instance ToParam Double 'PGfloat8 where toParam = K . Encoding.float8
285284instance ToParam Scientific 'PGnumeric where toParam = K . Encoding.numeric
@@ -312,26 +311,24 @@ instance Aeson.ToJSON x => ToParam (Json x) 'PGjson where
312311instance Aeson.ToJSON x => ToParam (Jsonb x) 'PGjsonb where
313312 toParam = K . Encoding.jsonb_bytes
314313 . Lazy.ByteString.toStrict . Aeson.encode . getJsonb
315−instance (ToNullityParam x ty, ty ~ nullity pg, OidOf pg)
314+instance (ToNullityParam x ty, ty ~ nullity pg, HasOid pg)
316315 => ToParam (VarArray [x]) ('PGvararray ty) where
317316 toParam = K
318− . Encoding.array_foldable
319− (getOid (oidOf @pg)) (unK . toNullityParam @x @ty)
317+ . Encoding.array_foldable (oid @pg) (unK . toNullityParam @x @ty)
320318 . getVarArray
321−instance (ToParam x pg, OidOf pg)
319+instance (ToParam x pg, HasOid pg)
322320 => ToParam (VarArray (Vector x)) ('PGvararray ('NotNull pg)) where
323321 toParam = K
324− . Encoding.array_vector (getOid (oidOf @pg)) (unK . toParam @x @pg)
322+ . Encoding.array_vector (oid @pg) (unK . toParam @x @pg)
325323 . getVarArray
326−instance (ToParam x pg, OidOf pg)
324+instance (ToParam x pg, HasOid pg)
327325 => ToParam (VarArray (Vector (Maybe x))) ('PGvararray ('Null pg)) where
328326 toParam = K
329− . Encoding.nullableArray_vector
330− (getOid (oidOf @pg)) (unK . toParam @x @pg)
327+ . Encoding.nullableArray_vector (oid @pg) (unK . toParam @x @pg)
331328 . getVarArray
332−instance (ToFixArray x dims ty, ty ~ nullity pg, OidOf pg)
329+instance (ToFixArray x dims ty, ty ~ nullity pg, HasOid pg)
333330 => ToParam (FixArray x) ('PGfixarray dims ty) where
334− toParam = K . Encoding.array (getOid (oidOf @pg))
331+ toParam = K . Encoding.array (oid @pg)
335332 . unK . unK . toFixArray @x @dims @ty . getFixArray
336333instance
337334 ( IsEnumType x
@@ -356,7 +353,7 @@ instance
356353 ( SListI fields
357354 , IsRecord x xs
358355 , AllZip ToField xs fields
359− , All OidOfField fields
356+ , All HasAliasedOid fields
360357 ) => ToParam (Composite x) ('PGcomposite fields) where
361358 toParam =
362359 let
@@ -364,7 +361,7 @@ instance
364361 encoders = htrans (Proxy @ToField) toField
365362
366363 composite
367− :: All OidOfField row
364+ :: All HasAliasedOid row
368365 => NP (K (Maybe Encoding.Encoding)) row
369366 -> K Encoding.Encoding ('PGcomposite row)
370367 composite fields = K $
@@ -381,18 +378,18 @@ instance
381378 int32BE (fromIntegral (lengthSList (Proxy @xs))) <>
382379 let
383380 each
384− :: OidOfField field
381+ :: HasAliasedOid field
385382 => K (Maybe Encoding.Encoding) field
386383 -> Encoding.Encoding
387384 each (K field :: K (Maybe Encoding.Encoding) field) =
388− word32BE (getOid (oidOfField @field))
385+ word32BE (aliasedOid @field)
389386 <> case field of
390387 Nothing -> int64BE (-1)
391388 Just value ->
392389 int32BE (fromIntegral (builderLength value))
393390 <> value
394391 in
395− hcfoldMap (Proxy @OidOfField) each fields
392+ hcfoldMap (Proxy @HasAliasedOid) each fields
396393
397394 in
398395 composite . encoders . toRecord . getComposite
@@ -400,120 +397,36 @@ instance
400397-- | The object identifier of a `PGType`.
401398--
402399-- >>> :set -XTypeApplications
403−-- >>> oidOf @'PGbool
404−-- Oid 16
405−class OidOf (ty :: PGType) where oidOf :: LibPQ.Oid
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
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
412−instance OidOf 'PGint4 where oidOf = LibPQ.Oid 23
413−instance OidOf ('PGfixarray ns (null 'PGint4)) where oidOf = LibPQ.Oid 1007
414−instance OidOf ('PGvararray (null 'PGint4)) where oidOf = LibPQ.Oid 1007
415−instance OidOf 'PGint8 where oidOf = LibPQ.Oid 20
416−instance OidOf ('PGfixarray ns (null 'PGint8)) where oidOf = LibPQ.Oid 1016
417−instance OidOf ('PGvararray (null 'PGint8)) where oidOf = LibPQ.Oid 1016
418−instance OidOf 'PGnumeric where oidOf = LibPQ.Oid 1700
419−instance OidOf ('PGfixarray ns (null 'PGnumeric)) where oidOf = LibPQ.Oid 1231
420−instance OidOf ('PGvararray (null 'PGnumeric)) where oidOf = LibPQ.Oid 1231
421−instance OidOf 'PGfloat4 where oidOf = LibPQ.Oid 700
422−instance OidOf ('PGfixarray ns (null 'PGfloat4)) where oidOf = LibPQ.Oid 1021
423−instance OidOf ('PGvararray (null 'PGfloat4)) where oidOf = LibPQ.Oid 1021
424−instance OidOf 'PGfloat8 where oidOf = LibPQ.Oid 701
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
430−instance OidOf ('PGchar n) where oidOf = LibPQ.Oid 18
431−instance OidOf ('PGfixarray ns (null ('PGchar n))) where oidOf = LibPQ.Oid 1002
432−instance OidOf ('PGvararray (null ('PGchar n))) where oidOf = LibPQ.Oid 1002
433−instance OidOf ('PGvarchar n) where oidOf = LibPQ.Oid 1043
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
436−instance OidOf 'PGtext where oidOf = LibPQ.Oid 25
437−instance OidOf ('PGfixarray ns (null 'PGtext)) where oidOf = LibPQ.Oid 1009
438−instance OidOf ('PGvararray (null 'PGtext)) where oidOf = LibPQ.Oid 1009
439−instance OidOf 'PGbytea where oidOf = LibPQ.Oid 17
440−instance OidOf ('PGfixarray ns (null 'PGbytea)) where oidOf = LibPQ.Oid 1001
441−instance OidOf ('PGvararray (null 'PGbytea)) where oidOf = LibPQ.Oid 1001
442−instance OidOf 'PGtimestamp where oidOf = LibPQ.Oid 1114
443−instance OidOf ('PGfixarray ns (null 'PGtimestamp)) where oidOf = LibPQ.Oid 1115
444−instance OidOf ('PGvararray (null 'PGtimestamp)) where oidOf = LibPQ.Oid 1115
445−instance OidOf 'PGtimestamptz where oidOf = LibPQ.Oid 1184
446−instance OidOf ('PGfixarray ns (null 'PGtimestamptz)) where oidOf = LibPQ.Oid 1185
447−instance OidOf ('PGvararray (null 'PGtimestamptz)) where oidOf = LibPQ.Oid 1185
448−instance OidOf 'PGdate where oidOf = LibPQ.Oid 1082
449−instance OidOf ('PGfixarray ns (null 'PGdate)) where oidOf = LibPQ.Oid 1182
450−instance OidOf ('PGvararray (null 'PGdate)) where oidOf = LibPQ.Oid 1182
451−instance OidOf 'PGtime where oidOf = LibPQ.Oid 1083
452−instance OidOf ('PGfixarray ns (null 'PGtime)) where oidOf = LibPQ.Oid 1183
453−instance OidOf ('PGvararray (null 'PGtime)) where oidOf = LibPQ.Oid 1183
454−instance OidOf 'PGtimetz where oidOf = LibPQ.Oid 1266
455−instance OidOf ('PGfixarray ns (null 'PGtimetz)) where oidOf = LibPQ.Oid 1270
456−instance OidOf ('PGvararray (null 'PGtimetz)) where oidOf = LibPQ.Oid 1270
457−instance OidOf 'PGinterval where oidOf = LibPQ.Oid 1186
458−instance OidOf ('PGfixarray ns (null 'PGinterval)) where oidOf = LibPQ.Oid 1187
459−instance OidOf ('PGvararray (null 'PGinterval)) where oidOf = LibPQ.Oid 1187
460−instance OidOf 'PGuuid where oidOf = LibPQ.Oid 2950
461−instance OidOf ('PGfixarray ns (null 'PGuuid)) where oidOf = LibPQ.Oid 2951
462−instance OidOf ('PGvararray (null 'PGuuid)) where oidOf = LibPQ.Oid 2951
463−instance OidOf 'PGinet where oidOf = LibPQ.Oid 869
464−instance OidOf ('PGfixarray ns (null 'PGinet)) where oidOf = LibPQ.Oid 1041
465−instance OidOf ('PGvararray (null 'PGinet)) where oidOf = LibPQ.Oid 1041
466−instance OidOf 'PGjson where oidOf = LibPQ.Oid 114
467−instance OidOf ('PGfixarray ns (null 'PGjson)) where oidOf = LibPQ.Oid 199
468−instance OidOf ('PGvararray (null 'PGjson)) where oidOf = LibPQ.Oid 199
469−instance OidOf 'PGjsonb where oidOf = LibPQ.Oid 3802
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−
512−-- | Lifts a `OidOf` constraint to a field.
513−class OidOfField (field :: (Symbol, NullityType)) where
514− oidOfField :: Oid
515−instance OidOf ty => OidOfField (alias ::: nullity ty) where
516− oidOfField = oidOf @ty
400+-- >>> oid @'PGbool
401+-- 16
402+class HasOid (ty :: PGType) where oid :: Word32
403+instance HasOid 'PGbool where oid = 16
404+instance HasOid 'PGint2 where oid = 21
405+instance HasOid 'PGint4 where oid = 23
406+instance HasOid 'PGint8 where oid = 20
407+instance HasOid 'PGnumeric where oid = 1700
408+instance HasOid 'PGfloat4 where oid = 700
409+instance HasOid 'PGfloat8 where oid = 701
410+instance HasOid ('PGchar n) where oid = 18
411+instance HasOid ('PGvarchar n) where oid = 1043
412+instance HasOid 'PGtext where oid = 25
413+instance HasOid 'PGbytea where oid = 17
414+instance HasOid 'PGtimestamp where oid = 1114
415+instance HasOid 'PGtimestamptz where oid = 1184
416+instance HasOid 'PGdate where oid = 1082
417+instance HasOid 'PGtime where oid = 1083
418+instance HasOid 'PGtimetz where oid = 1266
419+instance HasOid 'PGinterval where oid = 1186
420+instance HasOid 'PGuuid where oid = 2950
421+instance HasOid 'PGinet where oid = 869
422+instance HasOid 'PGjson where oid = 114
423+instance HasOid 'PGjsonb where oid = 3802
424+
425+-- | Lifts a `HasOid` constraint to a field.
426+class HasAliasedOid (field :: (Symbol, NullityType)) where
427+ aliasedOid :: Word32
428+instance HasOid ty => HasAliasedOid (alias ::: nullity ty) where
429+ aliasedOid = oid @ty
517430
518431-- | A `ToNullityParam` constraint gives an encoding of a Haskell `Type` into
519432-- into the binary format of a PostgreSQL `NullityType`.
@@ -582,7 +495,6 @@ instance FromValue 'PGbool Bool where fromValue = Decoding.bool
582495instance FromValue 'PGint2 Int16 where fromValue = Decoding.int
583496instance FromValue 'PGint4 Int32 where fromValue = Decoding.int
584497instance FromValue 'PGint8 Int64 where fromValue = Decoding.int
585−instance FromValue 'PGoid Word32 where fromValue = Decoding.int
586498instance FromValue 'PGfloat4 Float where fromValue = Decoding.float4
587499instance FromValue 'PGfloat8 Double where fromValue = Decoding.float8
588500instance FromValue 'PGnumeric Scientific where fromValue = Decoding.numeric
@@ -769,53 +681,50 @@ instance
769681 = fmap fromRecord
770682 . hsequence'
771683 . htrans (Proxy @FromField) fromField
772−------------------------------------------------------
773−-- P records
774−------------------------------------------------------
775−-- instance (FromField (col ::: pg) (col ::: hask))
776−-- => FromRow '[col ::: pg] (P (col ::: hask)) where
777−-- fromRow (pg :* Nil) = (unComp . fromField) pg
778−-- instance
779−-- ( row ~ Join row1 row2
780−-- , FromRow row1 hask1
781−-- , FromRow row2 hask2
782−-- , SListI row
783−-- ) => FromRow row (hask1, hask2) where
784−-- fromRow row = case disjoin @row1 @row2 row of
785−-- (row1, row2) -> (,) <$> fromRow row1 <*> fromRow row2
786−-- instance
787−-- ( row ~ Join row1 row23
788−-- , FromRow row1 hask1
789−-- , FromRow row23 (hask2, hask3)
790−-- , SListI row
791−-- ) => FromRow row (hask1, hask2, hask3) where
792−-- fromRow row = case disjoin @row1 @row23 row of
793−-- (row1, row23) -> do
794−-- hask1 <- fromRow row1
795−-- (hask2, hask3) <- fromRow row23
796−-- return (hask1, hask2, hask3)
797−-- instance
798−-- ( row ~ Join row1 row234
799−-- , FromRow row1 hask1
800−-- , FromRow row234 (hask2, hask3, hask4)
801−-- , SListI row
802−-- ) => FromRow row (hask1, hask2, hask3, hask4) where
803−-- fromRow row = case disjoin @row1 @row234 row of
804−-- (row1, row234) -> do
805−-- hask1 <- fromRow row1
806−-- (hask2, hask3, hask4) <- fromRow row234
807−-- return (hask1, hask2, hask3, hask4)
808−-- instance
809−-- ( row ~ Join row1 row2345
810−-- , FromRow row1 hask1
811−-- , FromRow row2345 (hask2, hask3, hask4, hask5)
812−-- , SListI row
813−-- ) => FromRow row (hask1, hask2, hask3, hask4, hask5) where
814−-- fromRow row = case disjoin @row1 @row2345 row of
815−-- (row1, row2345) -> do
816−-- hask1 <- fromRow row1
817−-- (hask2, hask3, hask4, hask5) <- fromRow row2345
818−-- return (hask1, hask2, hask3, hask4, hask5)
684+instance (FromField (col ::: pg) (col ::: hask))
685+ => FromRow '[col ::: pg] (P (col ::: hask)) where
686+ fromRow (pg :* Nil) = (unComp . fromField) pg
687+instance
688+ ( row ~ Join row1 row2
689+ , FromRow row1 hask1
690+ , FromRow row2 hask2
691+ , SListI row
692+ ) => FromRow row (hask1, hask2) where
693+ fromRow row = case disjoin @row1 @row2 row of
694+ (row1, row2) -> (,) <$> fromRow row1 <*> fromRow row2
695+instance
696+ ( row ~ Join row1 row23
697+ , FromRow row1 hask1
698+ , FromRow row23 (hask2, hask3)
699+ , SListI row
700+ ) => FromRow row (hask1, hask2, hask3) where
701+ fromRow row = case disjoin @row1 @row23 row of
702+ (row1, row23) -> do
703+ hask1 <- fromRow row1
704+ (hask2, hask3) <- fromRow row23
705+ return (hask1, hask2, hask3)
706+instance
707+ ( row ~ Join row1 row234
708+ , FromRow row1 hask1
709+ , FromRow row234 (hask2, hask3, hask4)
710+ , SListI row
711+ ) => FromRow row (hask1, hask2, hask3, hask4) where
712+ fromRow row = case disjoin @row1 @row234 row of
713+ (row1, row234) -> do
714+ hask1 <- fromRow row1
715+ (hask2, hask3, hask4) <- fromRow row234
716+ return (hask1, hask2, hask3, hask4)
717+instance
718+ ( row ~ Join row1 row2345
719+ , FromRow row1 hask1
720+ , FromRow row2345 (hask2, hask3, hask4, hask5)
721+ , SListI row
722+ ) => FromRow row (hask1, hask2, hask3, hask4, hask5) where
723+ fromRow row = case disjoin @row1 @row2345 row of
724+ (row1, row2345) -> do
725+ hask1 <- fromRow row1
726+ (hask2, hask3, hask4, hask5) <- fromRow row2345
727+ return (hask1, hask2, hask3, hask4, hask5)
819728
820729-- | `Only` is a 1-tuple type, useful for encoding a single parameter with
821730-- `toParams` or decoding a single value with `fromRow`.
@@ -843,6 +752,3 @@ replicateMN
843752 => m x -> m (NP I xs)
844753replicateMN mx = hsequence' $
845754 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+1030−12
@@ -11,15 +11,13 @@ Squeal data definition language.
1111{-# LANGUAGE
1212 AllowAmbiguousTypes
1313 , ConstraintKinds
14− , DeriveAnyClass
1514 , DeriveGeneric
16− , DerivingStrategies
1715 , FlexibleContexts
1816 , FlexibleInstances
1917 , GADTs
18+ , GeneralizedNewtypeDeriving
2019 , LambdaCase
2120 , MultiParamTypeClasses
22− , OverloadedLabels
2321 , OverloadedStrings
2422 , RankNTypes
2523 , ScopedTypeVariables
@@ -27,25 +25,84 @@ Squeal data definition language.
2725 , TypeInType
2826 , TypeOperators
2927 , UndecidableSuperClasses
30− , UndecidableInstances
3128#-}
3229
3330module Squeal.PostgreSQL.Definition
3431 ( -- * Definition
3532 Definition (..)
3633 , (>>>)
37− , manipDefinition
34+ -- * Tables
35+ -- ** Create
36+ , createSchema
37+ , createSchemaIfNotExists
38+ , createTable
39+ , createTableIfNotExists
40+ , createView
41+ , createTypeEnum
42+ , createTypeEnumFrom
43+ , createTypeComposite
44+ , createTypeCompositeFrom
45+ , FieldTyped (..)
46+ , createDomain
47+ , TableConstraintExpression (..)
48+ , check
49+ , unique
50+ , primaryKey
51+ , foreignKey
52+ , ForeignKeyed
53+ , OnDeleteClause (..)
54+ , OnUpdateClause (..)
55+ -- ** Drop
56+ , dropSchema
57+ , dropTable
58+ , dropView
59+ , dropType
60+ -- ** Alter
61+ , alterTable
62+ , alterTableRename
63+ , AlterTable (..)
64+ , addConstraint
65+ , dropConstraint
66+ , AddColumn (..)
67+ , dropColumn
68+ , renameColumn
69+ , alterColumn
70+ , AlterColumn (..)
71+ , setDefault
72+ , dropDefault
73+ , setNotNull
74+ , dropNotNull
75+ , alterType
76+ -- * Columns
77+ , ColumnTypeExpression (..)
78+ , nullable
79+ , notNullable
80+ , default_
81+ , serial2
82+ , smallserial
83+ , serial4
84+ , serial
85+ , serial8
86+ , bigserial
3887 ) where
3988
4089import Control.Category
4190import Control.DeepSeq
4291import Data.ByteString
4392import Data.Monoid
93+import GHC.TypeLits
4494import Prelude hiding ((.), id)
4595
96+import qualified Generics.SOP as SOP
4697import qualified GHC.Generics as GHC
4798
48−import Squeal.PostgreSQL.Manipulation
99+import Squeal.PostgreSQL.Alias
100+import Squeal.PostgreSQL.Expression
101+import Squeal.PostgreSQL.Expression.Logic
102+import Squeal.PostgreSQL.Expression.Type
103+import Squeal.PostgreSQL.List
104+import Squeal.PostgreSQL.PG
105+import Squeal.PostgreSQL.Query
49106import Squeal.PostgreSQL.Render
50107import Squeal.PostgreSQL.Schema
51108
@@ -73,10 +130,971 @@ instance Category Definition where
73130 ddl1 . ddl0 = UnsafeDefinition $
74131 renderSQL ddl0 <> "\n" <> renderSQL ddl1
75132
76−-- | A `Manipulation` without input or output can be run as a statement
77−-- along with other `Definition`s, by embedding it using `manipDefinition`.
78−manipDefinition
79− :: Manipulation '[] schemas '[] '[]
80− -- ^ no input or output
133+{-----------------------------------------
134+CREATE statements
135+-----------------------------------------}
136+
137+{- |
138+`createSchema` enters a new schema into the current database.
139+The schema name must be distinct from the name of any existing schema
140+in the current database.
141+
142+A schema is essentially a namespace: it contains named objects
143+(tables, data types, functions, and operators) whose names
144+can duplicate those of other objects existing in other schemas.
145+Named objects are accessed by `QualifiedAlias`es with the schema
146+name as a prefix.
147+-}
148+createSchema
149+ :: KnownSymbol sch
150+ => Alias sch
151+ -> Definition schemas (Create sch '[] schemas)
152+createSchema sch = UnsafeDefinition $
153+ "CREATE" <+> "SCHEMA" <+> renderSQL sch <> ";"
154+
155+{- | Idempotent version of `createSchema`. -}
156+createSchemaIfNotExists
157+ :: (KnownSymbol sch, Has sch schemas schema)
158+ => Alias sch
81159 -> Definition schemas schemas
82−manipDefinition = UnsafeDefinition . (<> ";") . renderSQL
160+createSchemaIfNotExists sch = UnsafeDefinition $
161+ "CREATE" <+> "SCHEMA" <+> "IF" <+> "NOT" <+> "EXISTS"
162+ <+> renderSQL sch <> ";"
163+
164+{- | `createTable` adds a table to the schema.
165+
166+>>> :set -XOverloadedLabels
167+>>> :{
168+type Table = '[] :=>
169+ '[ "a" ::: 'NoDef :=> 'Null 'PGint4
170+ , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]
171+:}
172+
173+>>> :{
174+let
175+ setup :: Definition (Public '[]) (Public '["tab" ::: 'Table Table])
176+ setup = createTable #tab
177+ (nullable int `as` #a :* nullable real `as` #b) Nil
178+in printSQL setup
179+:}
180+CREATE TABLE "tab" ("a" int NULL, "b" real NULL);
181+-}
182+createTable
183+ :: ( KnownSymbol sch
184+ , KnownSymbol tab
185+ , columns ~ (col ': cols)
186+ , SOP.SListI columns
187+ , SOP.SListI constraints
188+ , Has sch schemas0 schema0
189+ , schemas1 ~ Alter sch (Create tab ('Table (constraints :=> columns)) schema0) schemas0 )
190+ => QualifiedAlias sch tab -- ^ the name of the table to add
191+ -> NP (Aliased (ColumnTypeExpression schemas0)) columns
192+ -- ^ the names and datatype of each column
193+ -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints
194+ -- ^ constraints that must hold for the table
195+ -> Definition schemas0 schemas1
196+createTable tab columns constraints = UnsafeDefinition $
197+ "CREATE TABLE" <+> renderCreation tab columns constraints
198+
199+{-| `createTableIfNotExists` creates a table if it doesn't exist, but does not add it to the schema.
200+Instead, the schema already has the table so if the table did not yet exist, the schema was wrong.
201+`createTableIfNotExists` fixes this. Interestingly, this property makes it an idempotent in
202+the `Category` of `Definition`s.
203+
204+>>> :set -XOverloadedLabels -XTypeApplications
205+>>> :{
206+type Table = '[] :=>
207+ '[ "a" ::: 'NoDef :=> 'Null 'PGint4
208+ , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]
209+:}
210+
211+>>> type Schemas = Public '["tab" ::: 'Table Table]
212+
213+>>> :{
214+let
215+ setup :: Definition Schemas Schemas
216+ setup = createTableIfNotExists #tab
217+ (nullable int `as` #a :* nullable real `as` #b) Nil
218+in printSQL setup
219+:}
220+CREATE TABLE IF NOT EXISTS "tab" ("a" int NULL, "b" real NULL);
221+-}
222+createTableIfNotExists
223+ :: ( Has sch schemas schema
224+ , Has tab schema ('Table (constraints :=> columns))
225+ , SOP.SListI columns
226+ , SOP.SListI constraints )
227+ => QualifiedAlias sch tab -- ^ the name of the table to add
228+ -> NP (Aliased (ColumnTypeExpression schemas)) columns
229+ -- ^ the names and datatype of each column
230+ -> NP (Aliased (TableConstraintExpression sch tab schemas)) constraints
231+ -- ^ constraints that must hold for the table
232+ -> Definition schemas schemas
233+createTableIfNotExists tab columns constraints = UnsafeDefinition $
234+ "CREATE TABLE IF NOT EXISTS"
235+ <+> renderCreation tab columns constraints
236+
237+-- helper function for `createTable` and `createTableIfNotExists`
238+renderCreation
239+ :: ( KnownSymbol sch
240+ , KnownSymbol tab
241+ , SOP.SListI columns
242+ , SOP.SListI constraints )
243+ => QualifiedAlias sch tab -- ^ the name of the table to add
244+ -> NP (Aliased (ColumnTypeExpression schemas0)) columns
245+ -- ^ the names and datatype of each column
246+ -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints
247+ -- ^ constraints that must hold for the table
248+ -> ByteString
249+renderCreation tab columns constraints = renderSQL tab
250+ <+> parenthesized
251+ ( renderCommaSeparated renderColumnDef columns
252+ <> ( case constraints of
253+ Nil -> ""
254+ _ -> ", " <>
255+ renderCommaSeparated renderConstraint constraints ) )
256+ <> ";"
257+ where
258+ renderColumnDef :: Aliased (ColumnTypeExpression schemas) x -> ByteString
259+ renderColumnDef (ty `As` column) =
260+ renderSQL column <+> renderColumnTypeExpression ty
261+ renderConstraint
262+ :: Aliased (TableConstraintExpression sch tab schemas) constraint
263+ -> ByteString
264+ renderConstraint (constraint `As` alias) =
265+ "CONSTRAINT" <+> renderSQL alias <+> renderSQL constraint
266+
267+-- | Data types are a way to limit the kind of data that can be stored in a
268+-- table. For many applications, however, the constraint they provide is
269+-- too coarse. For example, a column containing a product price should
270+-- probably only accept positive values. But there is no standard data type
271+-- that accepts only positive numbers. Another issue is that you might want
272+-- to constrain column data with respect to other columns or rows.
273+-- For example, in a table containing product information,
274+-- there should be only one row for each product number.
275+-- `TableConstraint`s give you as much control over the data in your tables
276+-- as you wish. If a user attempts to store data in a column that would
277+-- violate a constraint, an error is raised. This applies
278+-- even if the value came from the default value definition.
279+newtype TableConstraintExpression
280+ (sch :: Symbol)
281+ (tab :: Symbol)
282+ (schemas :: SchemasType)
283+ (constraint :: TableConstraint)
284+ = UnsafeTableConstraintExpression
285+ { renderTableConstraintExpression :: ByteString }
286+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
287+instance RenderSQL
288+ (TableConstraintExpression sch tab schemas constraint) where
289+ renderSQL = renderTableConstraintExpression
290+
291+{-| A `check` constraint is the most generic `TableConstraint` type.
292+It allows you to specify that the value in a certain column must satisfy
293+a Boolean (truth-value) expression.
294+
295+>>> :{
296+type Schema = '[
297+ "tab" ::: 'Table ('[ "inequality" ::: 'Check '["a","b"]] :=> '[
298+ "a" ::: 'NoDef :=> 'NotNull 'PGint4,
299+ "b" ::: 'NoDef :=> 'NotNull 'PGint4
300+ ])]
301+:}
302+
303+>>> :{
304+let
305+ definition :: Definition (Public '[]) (Public Schema)
306+ definition = createTable #tab
307+ ( (int & notNullable) `as` #a :*
308+ (int & notNullable) `as` #b )
309+ ( check (#a :* #b) (#a .> #b) `as` #inequality )
310+:}
311+
312+>>> printSQL definition
313+CREATE TABLE "tab" ("a" int NOT NULL, "b" int NOT NULL, CONSTRAINT "inequality" CHECK (("a" > "b")));
314+-}
315+check
316+ :: ( Has sch schemas schema
317+ , Has tab schema ('Table table)
318+ , HasAll aliases (TableToRow table) subcolumns )
319+ => NP Alias aliases
320+ -- ^ specify the subcolumns which are getting checked
321+ -> (forall t. Condition '[] '[] 'Ungrouped schemas '[] '[t ::: subcolumns])
322+ -- ^ a closed `Condition` on those subcolumns
323+ -> TableConstraintExpression sch tab schemas ('Check aliases)
324+check _cols condition = UnsafeTableConstraintExpression $
325+ "CHECK" <+> parenthesized (renderSQL condition)
326+
327+{-| A `unique` constraint ensure that the data contained in a column,
328+or a group of columns, is unique among all the rows in the table.
329+
330+>>> :{
331+type Schema = '[
332+ "tab" ::: 'Table( '[ "uq_a_b" ::: 'Unique '["a","b"]] :=> '[
333+ "a" ::: 'NoDef :=> 'Null 'PGint4,
334+ "b" ::: 'NoDef :=> 'Null 'PGint4
335+ ])]
336+:}
337+
338+>>> :{
339+let
340+ definition :: Definition (Public '[]) (Public Schema)
341+ definition = createTable #tab
342+ ( (int & nullable) `as` #a :*
343+ (int & nullable) `as` #b )
344+ ( unique (#a :* #b) `as` #uq_a_b )
345+:}
346+
347+>>> printSQL definition
348+CREATE TABLE "tab" ("a" int NULL, "b" int NULL, CONSTRAINT "uq_a_b" UNIQUE ("a", "b"));
349+-}
350+unique
351+ :: ( Has sch schemas schema
352+ , Has tab schema('Table table)
353+ , HasAll aliases (TableToRow table) subcolumns )
354+ => NP Alias aliases
355+ -- ^ specify subcolumns which together are unique for each row
356+ -> TableConstraintExpression sch tab schemas ('Unique aliases)
357+unique columns = UnsafeTableConstraintExpression $
358+ "UNIQUE" <+> parenthesized (renderSQL columns)
359+
360+{-| A `primaryKey` constraint indicates that a column, or group of columns,
361+can be used as a unique identifier for rows in the table.
362+This requires that the values be both unique and not null.
363+
364+>>> :{
365+type Schema = '[
366+ "tab" ::: 'Table ('[ "pk_id" ::: 'PrimaryKey '["id"]] :=> '[
367+ "id" ::: 'Def :=> 'NotNull 'PGint4,
368+ "name" ::: 'NoDef :=> 'NotNull 'PGtext
369+ ])]
370+:}
371+
372+>>> :{
373+let
374+ definition :: Definition (Public '[]) (Public Schema)
375+ definition = createTable #tab
376+ ( serial `as` #id :*
377+ (text & notNullable) `as` #name )
378+ ( primaryKey #id `as` #pk_id )
379+:}
380+
381+>>> printSQL definition
382+CREATE TABLE "tab" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_id" PRIMARY KEY ("id"));
383+-}
384+primaryKey
385+ :: ( Has sch schemas schema
386+ , Has tab schema ('Table table)
387+ , HasAll aliases (TableToColumns table) subcolumns
388+ , AllNotNull subcolumns )
389+ => NP Alias aliases
390+ -- ^ specify the subcolumns which together form a primary key.
391+ -> TableConstraintExpression sch tab schemas ('PrimaryKey aliases)
392+primaryKey columns = UnsafeTableConstraintExpression $
393+ "PRIMARY KEY" <+> parenthesized (renderSQL columns)
394+
395+{-| A `foreignKey` specifies that the values in a column
396+(or a group of columns) must match the values appearing in some row of
397+another table. We say this maintains the referential integrity
398+between two related tables.
399+
400+>>> :{
401+type Schema =
402+ '[ "users" ::: 'Table (
403+ '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
404+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
405+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext
406+ ])
407+ , "emails" ::: 'Table (
408+ '[ "pk_emails" ::: 'PrimaryKey '["id"]
409+ , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
410+ ] :=>
411+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
412+ , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
413+ , "email" ::: 'NoDef :=> 'Null 'PGtext
414+ ])
415+ ]
416+:}
417+
418+>>> :{
419+let
420+ setup :: Definition (Public '[]) (Public Schema)
421+ setup =
422+ createTable #users
423+ ( serial `as` #id :*
424+ (text & notNullable) `as` #name )
425+ ( primaryKey #id `as` #pk_users ) >>>
426+ createTable #emails
427+ ( serial `as` #id :*
428+ (int & notNullable) `as` #user_id :*
429+ (text & nullable) `as` #email )
430+ ( primaryKey #id `as` #pk_emails :*
431+ foreignKey #user_id #users #id
432+ OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
433+in printSQL setup
434+:}
435+CREATE TABLE "users" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_users" PRIMARY KEY ("id"));
436+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);
437+
438+A `foreignKey` can even be a table self-reference.
439+
440+>>> :{
441+type Schema =
442+ '[ "employees" ::: 'Table (
443+ '[ "employees_pk" ::: 'PrimaryKey '["id"]
444+ , "employees_employer_fk" ::: 'ForeignKey '["employer_id"] "employees" '["id"]
445+ ] :=>
446+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
447+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext
448+ , "employer_id" ::: 'NoDef :=> 'Null 'PGint4
449+ ])
450+ ]
451+:}
452+
453+>>> :{
454+let
455+ setup :: Definition (Public '[]) (Public Schema)
456+ setup =
457+ createTable #employees
458+ ( serial `as` #id :*
459+ (text & notNullable) `as` #name :*
460+ (integer & nullable) `as` #employer_id )
461+ ( primaryKey #id `as` #employees_pk :*
462+ foreignKey #employer_id #employees #id
463+ OnDeleteCascade OnUpdateCascade `as` #employees_employer_fk )
464+in printSQL setup
465+:}
466+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);
467+-}
468+foreignKey
469+ :: (ForeignKeyed schemas sch schema child parent
470+ table reftable
471+ columns refcolumns
472+ constraints cols
473+ reftys tys )
474+ => NP Alias columns
475+ -- ^ column or columns in the table
476+ -> Alias parent
477+ -- ^ reference table
478+ -> NP Alias refcolumns
479+ -- ^ reference column or columns in the reference table
480+ -> OnDeleteClause
481+ -- ^ what to do when reference is deleted
482+ -> OnUpdateClause
483+ -- ^ what to do when reference is updated
484+ -> TableConstraintExpression sch child schemas
485+ ('ForeignKey columns parent refcolumns)
486+foreignKey keys parent refs ondel onupd = UnsafeTableConstraintExpression $
487+ "FOREIGN KEY" <+> parenthesized (renderSQL keys)
488+ <+> "REFERENCES" <+> renderSQL parent
489+ <+> parenthesized (renderSQL refs)
490+ <+> renderSQL ondel
491+ <+> renderSQL onupd
492+
493+-- | A constraint synonym between types involved in a foreign key constraint.
494+type ForeignKeyed schemas
495+ sch
496+ schema
497+ child parent
498+ table reftable
499+ columns refcolumns
500+ constraints cols
501+ reftys tys =
502+ ( Has sch schemas schema
503+ , Has child schema ('Table table)
504+ , Has parent schema ('Table reftable)
505+ , HasAll columns (TableToColumns table) tys
506+ , reftable ~ (constraints :=> cols)
507+ , HasAll refcolumns cols reftys
508+ , SOP.AllZip SamePGType tys reftys
509+ , Uniquely refcolumns constraints )
510+
511+-- | `OnDeleteClause` indicates what to do with rows that reference a deleted row.
512+data OnDeleteClause
513+ = OnDeleteNoAction
514+ -- ^ if any referencing rows still exist when the constraint is checked,
515+ -- an error is raised
516+ | OnDeleteRestrict -- ^ prevents deletion of a referenced row
517+ | OnDeleteCascade
518+ -- ^ specifies that when a referenced row is deleted,
519+ -- row(s) referencing it should be automatically deleted as well
520+ deriving (GHC.Generic,Show,Eq,Ord)
521+instance NFData OnDeleteClause
522+-- | Render `OnDeleteClause`.
523+instance RenderSQL OnDeleteClause where
524+ renderSQL = \case
525+ OnDeleteNoAction -> "ON DELETE NO ACTION"
526+ OnDeleteRestrict -> "ON DELETE RESTRICT"
527+ OnDeleteCascade -> "ON DELETE CASCADE"
528+
529+-- | Analagous to `OnDeleteClause` there is also `OnUpdateClause` which is invoked
530+-- when a referenced column is changed (updated).
531+data OnUpdateClause
532+ = OnUpdateNoAction
533+ -- ^ if any referencing rows has not changed when the constraint is checked,
534+ -- an error is raised
535+ | OnUpdateRestrict -- ^ prevents update of a referenced row
536+ | OnUpdateCascade
537+ -- ^ the updated values of the referenced column(s) should be copied
538+ -- into the referencing row(s)
539+ deriving (GHC.Generic,Show,Eq,Ord)
540+instance NFData OnUpdateClause
541+
542+-- | Render `OnUpdateClause`.
543+instance RenderSQL OnUpdateClause where
544+ renderSQL = \case
545+ OnUpdateNoAction -> "ON UPDATE NO ACTION"
546+ OnUpdateRestrict -> "ON UPDATE RESTRICT"
547+ OnUpdateCascade -> "ON UPDATE CASCADE"
548+
549+{-----------------------------------------
550+DROP statements
551+-----------------------------------------}
552+
553+-- | >>> :{
554+-- let
555+-- definition :: Definition '["muh_schema" ::: schema, "public" ::: public] '["public" ::: public]
556+-- definition = dropSchema #muh_schema
557+-- :}
558+--
559+-- >>> printSQL definition
560+-- DROP SCHEMA "muh_schema";
561+dropSchema
562+ :: Has sch schemas schema
563+ => Alias sch
564+ -> Definition schemas (Drop sch schemas)
565+dropSchema sch = UnsafeDefinition $ "DROP SCHEMA" <+> renderSQL sch <> ";"
566+
567+-- | `dropTable` removes a table from the schema.
568+--
569+-- >>> :{
570+-- let
571+-- definition :: Definition '["public" ::: '["muh_table" ::: 'Table t]] (Public '[])
572+-- definition = dropTable #muh_table
573+-- :}
574+--
575+-- >>> printSQL definition
576+-- DROP TABLE "muh_table";
577+dropTable
578+ :: ( Has sch schemas schema
579+ , Has tab schema ('Table table))
580+ => QualifiedAlias sch tab -- ^ table to remove
581+ -> Definition schemas (Alter sch (Drop tab schema) schemas)
582+dropTable tab = UnsafeDefinition $ "DROP TABLE" <+> renderSQL tab <> ";"
583+
584+{-----------------------------------------
585+ALTER statements
586+-----------------------------------------}
587+
588+-- | `alterTable` changes the definition of a table from the schema.
589+alterTable
590+ :: (Has sch schemas schema, Has tab schema ('Table table0))
591+ => QualifiedAlias sch tab -- ^ table to alter
592+ -> AlterTable sch tab schemas table1 -- ^ alteration to perform
593+ -> Definition schemas (Alter sch (Alter tab ('Table table1) schema) schemas)
594+alterTable tab alteration = UnsafeDefinition $
595+ "ALTER TABLE"
596+ <+> renderSQL tab
597+ <+> renderAlterTable alteration
598+ <> ";"
599+
600+-- | `alterTableRename` changes the name of a table from the schema.
601+--
602+-- >>> printSQL $ alterTableRename #foo #bar
603+-- ALTER TABLE "foo" RENAME TO "bar";
604+alterTableRename
605+ :: (KnownSymbol table0, KnownSymbol table1)
606+ => Alias table0 -- ^ table to rename
607+ -> Alias table1 -- ^ what to rename it
608+ -> Definition schema (Rename table0 table1 schema)
609+alterTableRename table0 table1 = UnsafeDefinition $
610+ "ALTER TABLE" <+> renderSQL table0
611+ <+> "RENAME TO" <+> renderSQL table1 <> ";"
612+
613+-- | An `AlterTable` describes the alteration to perform on the columns
614+-- of a table.
615+newtype AlterTable
616+ (sch :: Symbol)
617+ (tab :: Symbol)
618+ (schemas :: SchemasType)
619+ (table :: TableType) =
620+ UnsafeAlterTable {renderAlterTable :: ByteString}
621+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
622+
623+-- | An `addConstraint` adds a table constraint.
624+--
625+-- >>> :{
626+-- let
627+-- definition :: Definition
628+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
629+-- '["public" ::: '["tab" ::: 'Table ('["positive" ::: 'Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
630+-- definition = alterTable #tab (addConstraint #positive (check #col (#col .> 0)))
631+-- in printSQL definition
632+-- :}
633+-- ALTER TABLE "tab" ADD CONSTRAINT "positive" CHECK (("col" > 0));
634+addConstraint
635+ :: ( KnownSymbol alias
636+ , Has sch schemas schema
637+ , Has tab schema ('Table table0)
638+ , table0 ~ (constraints :=> columns)
639+ , table1 ~ (Create alias constraint constraints :=> columns) )
640+ => Alias alias
641+ -> TableConstraintExpression sch tab schemas constraint
642+ -- ^ constraint to add
643+ -> AlterTable sch tab schemas table1
644+addConstraint alias constraint = UnsafeAlterTable $
645+ "ADD" <+> "CONSTRAINT" <+> renderSQL alias
646+ <+> renderSQL constraint
647+
648+-- | A `dropConstraint` drops a table constraint.
649+--
650+-- >>> :{
651+-- let
652+-- definition :: Definition
653+-- '["public" ::: '["tab" ::: 'Table ('["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
654+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
655+-- definition = alterTable #tab (dropConstraint #positive)
656+-- in printSQL definition
657+-- :}
658+-- ALTER TABLE "tab" DROP CONSTRAINT "positive";
659+dropConstraint
660+ :: ( KnownSymbol constraint
661+ , Has sch schemas schema
662+ , Has tab schema ('Table table0)
663+ , table0 ~ (constraints :=> columns)
664+ , table1 ~ (Drop constraint constraints :=> columns) )
665+ => Alias constraint
666+ -- ^ constraint to drop
667+ -> AlterTable sch tab schemas table1
668+dropConstraint constraint = UnsafeAlterTable $
669+ "DROP" <+> "CONSTRAINT" <+> renderSQL constraint
670+
671+-- | An `AddColumn` is either @NULL@ or has @DEFAULT@.
672+class AddColumn ty where
673+ -- | `addColumn` adds a new column, initially filled with whatever
674+ -- default value is given or with @NULL@.
675+ --
676+ -- >>> :{
677+ -- let
678+ -- definition :: Definition
679+ -- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]
680+ -- '["public" ::: '["tab" ::: 'Table ('[] :=>
681+ -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
682+ -- , "col2" ::: 'Def :=> 'Null 'PGtext ])]]
683+ -- definition = alterTable #tab (addColumn #col2 (text & nullable & default_ "foo"))
684+ -- in printSQL definition
685+ -- :}
686+ -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL DEFAULT E'foo';
687+ --
688+ -- >>> :{
689+ -- let
690+ -- definition :: Definition
691+ -- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]
692+ -- '["public" ::: '["tab" ::: 'Table ('[] :=>
693+ -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
694+ -- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]]
695+ -- definition = alterTable #tab (addColumn #col2 (text & nullable))
696+ -- in printSQL definition
697+ -- :}
698+ -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL;
699+ addColumn
700+ :: ( KnownSymbol column
701+ , Has sch schemas schema
702+ , Has tab schema ('Table table0)
703+ , table0 ~ (constraints :=> columns) )
704+ => Alias column -- ^ column to add
705+ -> ColumnTypeExpression schemas ty -- ^ type of the new column
706+ -> AlterTable sch tab schemas (constraints :=> Create column ty columns)
707+ addColumn column ty = UnsafeAlterTable $
708+ "ADD COLUMN" <+> renderSQL column <+> renderColumnTypeExpression ty
709+instance {-# OVERLAPPING #-} AddColumn ('Def :=> ty)
710+instance {-# OVERLAPPABLE #-} AddColumn ('NoDef :=> 'Null ty)
711+
712+-- | A `dropColumn` removes a column. Whatever data was in the column
713+-- disappears. Table constraints involving the column are dropped, too.
714+-- However, if the column is referenced by a foreign key constraint of
715+-- another table, PostgreSQL will not silently drop that constraint.
716+--
717+-- >>> :{
718+-- let
719+-- definition :: Definition
720+-- '["public" ::: '["tab" ::: 'Table ('[] :=>
721+-- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
722+-- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]]
723+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]
724+-- definition = alterTable #tab (dropColumn #col2)
725+-- in printSQL definition
726+-- :}
727+-- ALTER TABLE "tab" DROP COLUMN "col2";
728+dropColumn
729+ :: ( KnownSymbol column
730+ , Has sch schemas schema
731+ , Has tab schema ('Table table0)
732+ , table0 ~ (constraints :=> columns)
733+ , table1 ~ (constraints :=> Drop column columns) )
734+ => Alias column -- ^ column to remove
735+ -> AlterTable sch tab schemas table1
736+dropColumn column = UnsafeAlterTable $
737+ "DROP COLUMN" <+> renderSQL column
738+
739+-- | A `renameColumn` renames a column.
740+--
741+-- >>> :{
742+-- let
743+-- definition :: Definition
744+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["foo" ::: 'NoDef :=> 'Null 'PGint4])]]
745+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["bar" ::: 'NoDef :=> 'Null 'PGint4])]]
746+-- definition = alterTable #tab (renameColumn #foo #bar)
747+-- in printSQL definition
748+-- :}
749+-- ALTER TABLE "tab" RENAME COLUMN "foo" TO "bar";
750+renameColumn
751+ :: ( KnownSymbol column0
752+ , KnownSymbol column1
753+ , Has sch schemas schema
754+ , Has tab schema ('Table table0)
755+ , table0 ~ (constraints :=> columns)
756+ , table1 ~ (constraints :=> Rename column0 column1 columns) )
757+ => Alias column0 -- ^ column to rename
758+ -> Alias column1 -- ^ what to rename the column
759+ -> AlterTable sch tab schemas table1
760+renameColumn column0 column1 = UnsafeAlterTable $
761+ "RENAME COLUMN" <+> renderSQL column0 <+> "TO" <+> renderSQL column1
762+
763+-- | An `alterColumn` alters a single column.
764+alterColumn
765+ :: ( KnownSymbol column
766+ , Has sch schemas schema
767+ , Has tab schema ('Table table0)
768+ , table0 ~ (constraints :=> columns)
769+ , Has column columns ty0
770+ , table1 ~ (constraints :=> Alter column ty1 columns))
771+ => Alias column -- ^ column to alter
772+ -> AlterColumn schemas ty0 ty1 -- ^ alteration to perform
773+ -> AlterTable sch tab schemas table1
774+alterColumn column alteration = UnsafeAlterTable $
775+ "ALTER COLUMN" <+> renderSQL column <+> renderAlterColumn alteration
776+
777+-- | An `AlterColumn` describes the alteration to perform on a single column.
778+newtype AlterColumn (schemas :: SchemasType) (ty0 :: ColumnType) (ty1 :: ColumnType) =
779+ UnsafeAlterColumn {renderAlterColumn :: ByteString}
780+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
781+
782+-- | A `setDefault` sets a new default for a column. Note that this doesn't
783+-- affect any existing rows in the table, it just changes the default for
784+-- future insert and update commands.
785+--
786+-- >>> :{
787+-- let
788+-- definition :: Definition
789+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
790+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]]
791+-- definition = alterTable #tab (alterColumn #col (setDefault 5))
792+-- in printSQL definition
793+-- :}
794+-- ALTER TABLE "tab" ALTER COLUMN "col" SET DEFAULT 5;
795+setDefault
796+ :: Expression '[] '[] 'Ungrouped schemas '[] '[] ty -- ^ default value to set
797+ -> AlterColumn schemas (constraint :=> ty) ('Def :=> ty)
798+setDefault expression = UnsafeAlterColumn $
799+ "SET DEFAULT" <+> renderExpression expression
800+
801+-- | A `dropDefault` removes any default value for a column.
802+--
803+-- >>> :{
804+-- let
805+-- definition :: Definition
806+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]]
807+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
808+-- definition = alterTable #tab (alterColumn #col dropDefault)
809+-- in printSQL definition
810+-- :}
811+-- ALTER TABLE "tab" ALTER COLUMN "col" DROP DEFAULT;
812+dropDefault :: AlterColumn schemas ('Def :=> ty) ('NoDef :=> ty)
813+dropDefault = UnsafeAlterColumn $ "DROP DEFAULT"
814+
815+-- | A `setNotNull` adds a @NOT NULL@ constraint to a column.
816+-- The constraint will be checked immediately, so the table data must satisfy
817+-- the constraint before it can be added.
818+--
819+-- >>> :{
820+-- let
821+-- definition :: Definition
822+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
823+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
824+-- definition = alterTable #tab (alterColumn #col setNotNull)
825+-- in printSQL definition
826+-- :}
827+-- ALTER TABLE "tab" ALTER COLUMN "col" SET NOT NULL;
828+setNotNull
829+ :: AlterColumn schemas (constraint :=> 'Null ty) (constraint :=> 'NotNull ty)
830+setNotNull = UnsafeAlterColumn $ "SET NOT NULL"
831+
832+-- | A `dropNotNull` drops a @NOT NULL@ constraint from a column.
833+--
834+-- >>> :{
835+-- let
836+-- definition :: Definition
837+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
838+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
839+-- definition = alterTable #tab (alterColumn #col dropNotNull)
840+-- in printSQL definition
841+-- :}
842+-- ALTER TABLE "tab" ALTER COLUMN "col" DROP NOT NULL;
843+dropNotNull
844+ :: AlterColumn schemas (constraint :=> 'NotNull ty) (constraint :=> 'Null ty)
845+dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL"
846+
847+-- | An `alterType` converts a column to a different data type.
848+-- This will succeed only if each existing entry in the column can be
849+-- converted to the new type by an implicit cast.
850+--
851+-- >>> :{
852+-- let
853+-- definition :: Definition
854+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
855+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGnumeric])]]
856+-- definition =
857+-- alterTable #tab (alterColumn #col (alterType (numeric & notNullable)))
858+-- in printSQL definition
859+-- :}
860+-- ALTER TABLE "tab" ALTER COLUMN "col" TYPE numeric NOT NULL;
861+alterType :: ColumnTypeExpression schemas ty -> AlterColumn schemas ty0 ty
862+alterType ty = UnsafeAlterColumn $ "TYPE" <+> renderColumnTypeExpression ty
863+
864+{- | Create a view.
865+>>> type ABC = '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4]
866+>>> type BC = '["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4]
867+>>> :{
868+let
869+ definition :: Definition
870+ '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC)]]
871+ '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC), "bc" ::: 'View BC]]
872+ definition =
873+ createView #bc (select_ (#b :* #c) (from (table #abc)))
874+in printSQL definition
875+:}
876+CREATE VIEW "bc" AS SELECT "b" AS "b", "c" AS "c" FROM "abc" AS "abc";
877+-}
878+createView
879+ :: (KnownSymbol sch, KnownSymbol vw, Has sch schemas schema)
880+ => QualifiedAlias sch vw -- ^ the name of the view to add
881+ -> Query '[] '[] schemas '[] view -- ^ query
882+ -> Definition schemas (Alter sch (Create vw ('View view) schema) schemas)
883+createView alias query = UnsafeDefinition $
884+ "CREATE" <+> "VIEW" <+> renderSQL alias <+> "AS"
885+ <+> renderQuery query <> ";"
886+
887+-- | Drop a view.
888+--
889+-- >>> :{
890+-- let
891+-- definition :: Definition
892+-- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])
893+-- , "bc" ::: 'View ('["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4])]]
894+-- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])]]
895+-- definition = dropView #bc
896+-- in printSQL definition
897+-- :}
898+-- DROP VIEW "bc";
899+dropView
900+ :: (Has sch schemas schema, Has vw schema ('View view))
901+ => QualifiedAlias sch vw -- ^ view to remove
902+ -> Definition schemas (Alter sch (Drop vw schema) schemas)
903+dropView vw = UnsafeDefinition $ "DROP VIEW" <+> renderSQL vw <> ";"
904+
905+-- | Enumerated types are created using the `createTypeEnum` command, for example
906+--
907+-- >>> printSQL $ (createTypeEnum #mood (label @"sad" :* label @"ok" :* label @"happy") :: Definition (Public '[]) '["public" ::: '["mood" ::: 'Typedef ('PGenum '["sad","ok","happy"])]])
908+-- CREATE TYPE "mood" AS ENUM ('sad', 'ok', 'happy');
909+createTypeEnum
910+ :: (KnownSymbol enum, Has sch schemas schema, SOP.All KnownSymbol labels)
911+ => QualifiedAlias sch enum
912+ -- ^ name of the user defined enumerated type
913+ -> NP PGlabel labels
914+ -- ^ labels of the enumerated type
915+ -> Definition schemas (Alter sch (Create enum ('Typedef ('PGenum labels)) schema) schemas)
916+createTypeEnum enum labels = UnsafeDefinition $
917+ "CREATE" <+> "TYPE" <+> renderSQL enum <+> "AS" <+> "ENUM" <+>
918+ parenthesized (renderSQL labels) <> ";"
919+
920+-- | Enumerated types can also be generated from a Haskell type, for example
921+--
922+-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic
923+-- >>> instance SOP.Generic Schwarma
924+-- >>> instance SOP.HasDatatypeInfo Schwarma
925+-- >>> :{
926+-- let
927+-- createSchwarma :: Definition (Public '[]) '["public" ::: '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))]]
928+-- createSchwarma = createTypeEnumFrom @Schwarma #schwarma
929+-- in
930+-- printSQL createSchwarma
931+-- :}
932+-- CREATE TYPE "schwarma" AS ENUM ('Beef', 'Lamb', 'Chicken');
933+createTypeEnumFrom
934+ :: forall hask sch enum schemas schema.
935+ ( SOP.Generic hask
936+ , SOP.All KnownSymbol (LabelsPG hask)
937+ , KnownSymbol enum
938+ , Has sch schemas schema )
939+ => QualifiedAlias sch enum
940+ -- ^ name of the user defined enumerated type
941+ -> Definition schemas (Alter sch (Create enum ('Typedef (PG (Enumerated hask))) schema) schemas)
942+createTypeEnumFrom enum = createTypeEnum enum
943+ (SOP.hpure label :: NP PGlabel (LabelsPG hask))
944+
945+{- | `createTypeComposite` creates a composite type. The composite type is
946+specified by a list of attribute names and data types.
947+
948+>>> :{
949+type PGcomplex = 'PGcomposite
950+ '[ "real" ::: 'NotNull 'PGfloat8
951+ , "imaginary" ::: 'NotNull 'PGfloat8 ]
952+:}
953+
954+>>> :{
955+let
956+ setup :: Definition (Public '[]) '["public" ::: '["complex" ::: 'Typedef PGcomplex]]
957+ setup = createTypeComposite #complex
958+ (float8 `as` #real :* float8 `as` #imaginary)
959+in printSQL setup
960+:}
961+CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);
962+-}
963+createTypeComposite
964+ :: (KnownSymbol ty, Has sch schemas schema, SOP.SListI fields)
965+ => QualifiedAlias sch ty
966+ -- ^ name of the user defined composite type
967+ -> NP (Aliased (TypeExpression schemas)) fields
968+ -- ^ list of attribute names and data types
969+ -> Definition schemas (Alter sch (Create ty ('Typedef ('PGcomposite fields)) schema) schemas)
970+createTypeComposite ty fields = UnsafeDefinition $
971+ "CREATE" <+> "TYPE" <+> renderSQL ty <+> "AS" <+> parenthesized
972+ (renderCommaSeparated renderField fields) <> ";"
973+ where
974+ renderField :: Aliased (TypeExpression schemas) x -> ByteString
975+ renderField (typ `As` alias) =
976+ renderSQL alias <+> renderSQL typ
977+
978+-- | Composite types can also be generated from a Haskell type, for example
979+--
980+-- >>> data Complex = Complex {real :: Double, imaginary :: Double} deriving GHC.Generic
981+-- >>> instance SOP.Generic Complex
982+-- >>> instance SOP.HasDatatypeInfo Complex
983+-- >>> type Schema = '["complex" ::: 'Typedef (PG (Composite Complex))]
984+-- >>> :{
985+-- let
986+-- createComplex :: Definition (Public '[]) (Public Schema)
987+-- createComplex = createTypeCompositeFrom @Complex #complex
988+-- in
989+-- printSQL createComplex
990+-- :}
991+-- CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);
992+createTypeCompositeFrom
993+ :: forall hask sch ty schemas schema.
994+ ( SOP.All (FieldTyped schemas) (RowPG hask)
995+ , KnownSymbol ty
996+ , Has sch schemas schema )
997+ => QualifiedAlias sch ty
998+ -- ^ name of the user defined composite type
999+ -> Definition schemas (Alter sch (Create ty ( 'Typedef (PG (Composite hask))) schema) schemas)
1000+createTypeCompositeFrom ty = createTypeComposite ty
1001+ (SOP.hcpure (SOP.Proxy :: SOP.Proxy (FieldTyped schemas)) fieldtype
1002+ :: NP (Aliased (TypeExpression schemas)) (RowPG hask))
1003+
1004+{-|
1005+`createDomain` creates a new domain. A domain is essentially a data type
1006+with constraints (restrictions on the allowed set of values).
1007+
1008+Domains are useful for abstracting common constraints on fields
1009+into a single location for maintenance. For example, several tables might
1010+contain email address columns, all requiring the same `check` constraint
1011+to verify the address syntax. Define a domain rather than setting up
1012+each table's constraint individually.
1013+
1014+>>> :{
1015+let
1016+ createPositive :: Definition (Public '[]) (Public '["positive" ::: 'Typedef 'PGfloat4])
1017+ createPositive = createDomain #positive real (#value .> 0 .&& (#value & isNotNull))
1018+in printSQL createPositive
1019+:}
1020+CREATE DOMAIN "positive" AS real CHECK ((("value" > 0) AND "value" IS NOT NULL));
1021+-}
1022+createDomain
1023+ :: (Has sch schemas schema, KnownSymbol dom)
1024+ => QualifiedAlias sch dom
1025+ -> (forall nullity. TypeExpression schemas (nullity ty))
1026+ -> (forall tab. Condition '[] '[] 'Ungrouped schemas '[] '[tab ::: '["value" ::: 'Null ty]])
1027+ -> Definition schemas (Alter sch (Create alias ('Typedef ty) schema) schemas)
1028+createDomain dom ty condition =
1029+ UnsafeDefinition $ "CREATE DOMAIN" <+> renderSQL dom
1030+ <+> "AS" <+> renderTypeExpression ty
1031+ <+> "CHECK" <+> parenthesized (renderSQL condition) <> ";"
1032+
1033+-- | Lift `PGTyped` to a field
1034+class FieldTyped schemas ty where
1035+ fieldtype :: Aliased (TypeExpression schemas) ty
1036+instance (KnownSymbol alias, PGTyped schemas ty)
1037+ => FieldTyped schemas (alias ::: ty) where
1038+ fieldtype = pgtype `As` Alias
1039+
1040+-- | Drop a type.
1041+--
1042+-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic
1043+-- >>> instance SOP.Generic Schwarma
1044+-- >>> instance SOP.HasDatatypeInfo Schwarma
1045+-- >>> printSQL (dropType #schwarma :: Definition '["public" ::: '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))]] (Public '[]))
1046+-- DROP TYPE "schwarma";
1047+dropType
1048+ :: (Has sch schemas schema, Has td schema ('Typedef ty))
1049+ => QualifiedAlias sch td
1050+ -- ^ name of the user defined type
1051+ -> Definition schemas (Alter sch (Drop td schema) schemas)
1052+dropType tydef = UnsafeDefinition $ "DROP" <+> "TYPE" <+> renderSQL tydef <> ";"
1053+
1054+-- | `ColumnTypeExpression`s are used in `createTable` commands.
1055+newtype ColumnTypeExpression (schemas :: SchemasType) (ty :: ColumnType)
1056+ = UnsafeColumnTypeExpression { renderColumnTypeExpression :: ByteString }
1057+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
1058+instance RenderSQL (ColumnTypeExpression schemas ty) where
1059+ renderSQL = renderColumnTypeExpression
1060+
1061+-- | used in `createTable` commands as a column constraint to note that
1062+-- @NULL@ may be present in a column
1063+nullable
1064+ :: TypeExpression schemas (nullity ty)
1065+ -> ColumnTypeExpression schemas ('NoDef :=> 'Null ty)
1066+nullable ty = UnsafeColumnTypeExpression $ renderSQL ty <+> "NULL"
1067+
1068+-- | used in `createTable` commands as a column constraint to ensure
1069+-- @NULL@ is not present in a column
1070+notNullable
1071+ :: TypeExpression schemas (nullity ty)
1072+ -> ColumnTypeExpression schemas ('NoDef :=> 'NotNull ty)
1073+notNullable ty = UnsafeColumnTypeExpression $ renderSQL ty <+> "NOT NULL"
1074+
1075+-- | used in `createTable` commands as a column constraint to give a default
1076+default_
1077+ :: Expression '[] '[] 'Ungrouped schemas '[] '[] ty
1078+ -> ColumnTypeExpression schemas ('NoDef :=> ty)
1079+ -> ColumnTypeExpression schemas ('Def :=> ty)
1080+default_ x ty = UnsafeColumnTypeExpression $
1081+ renderSQL ty <+> "DEFAULT" <+> renderExpression x
1082+
1083+-- | not a true type, but merely a notational convenience for creating
1084+-- unique identifier columns with type `PGint2`
1085+serial2, smallserial
1086+ :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint2)
1087+serial2 = UnsafeColumnTypeExpression "serial2"
1088+smallserial = UnsafeColumnTypeExpression "smallserial"
1089+-- | not a true type, but merely a notational convenience for creating
1090+-- unique identifier columns with type `PGint4`
1091+serial4, serial
1092+ :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint4)
1093+serial4 = UnsafeColumnTypeExpression "serial4"
1094+serial = UnsafeColumnTypeExpression "serial"
1095+-- | not a true type, but merely a notational convenience for creating
1096+-- unique identifier columns with type `PGint8`
1097+serial8, bigserial
1098+ :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint8)
1099+serial8 = UnsafeColumnTypeExpression "serial8"
1100+bigserial = UnsafeColumnTypeExpression "bigserial"
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Function.hsdeleted−238
@@ -1,238 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Definition.Function
3−Description: Create and drop function and operator definitions
4−Copyright: (c) Eitan Chatav, 2017
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Create and drop function and operator definitions.
9−-}
10−
11−{-# LANGUAGE
12− AllowAmbiguousTypes
13− , ConstraintKinds
14− , DeriveAnyClass
15− , DeriveGeneric
16− , DerivingStrategies
17− , FlexibleContexts
18− , FlexibleInstances
19− , GADTs
20− , LambdaCase
21− , MultiParamTypeClasses
22− , OverloadedLabels
23− , OverloadedStrings
24− , RankNTypes
25− , ScopedTypeVariables
26− , TypeApplications
27− , TypeInType
28− , TypeOperators
29− , UndecidableSuperClasses
30−#-}
31−
32−module Squeal.PostgreSQL.Definition.Function
33− ( createFunction
34− , createOrReplaceFunction
35− , createSetFunction
36− , createOrReplaceSetFunction
37− , createBinaryOp
38− , createLeftOp
39− , createRightOp
40− , dropFunction
41− , dropFunctionIfExists
42− , dropOperator
43− , dropOperatorIfExists
44− , FunctionDefinition(..)
45− , languageSqlExpr
46− , languageSqlQuery
47− ) where
48−
49−import Control.DeepSeq
50−import Data.ByteString
51−import GHC.TypeLits
52−
53−import qualified Generics.SOP as SOP
54−import qualified GHC.Generics as GHC
55−
56−import Squeal.PostgreSQL.Alias
57−import Squeal.PostgreSQL.Definition
58−import Squeal.PostgreSQL.Expression
59−import Squeal.PostgreSQL.Expression.Type
60−import Squeal.PostgreSQL.List
61−import Squeal.PostgreSQL.Query
62−import Squeal.PostgreSQL.Render
63−import Squeal.PostgreSQL.Schema
64−
65−-- $setup
66−-- >>> import Squeal.PostgreSQL
67−
68−createFunction
69− :: ( Has sch schemas schema
70− , KnownSymbol fun
71− , SOP.SListI args )
72− => QualifiedAlias sch fun
73− -> NP (TypeExpression schemas) args
74− -> TypeExpression schemas ret
75− -> FunctionDefinition schemas args ('Returns ret)
76− -> Definition schemas (Alter sch (Create fun ('Function (args :=> 'Returns ret)) schema) schemas)
77−createFunction fun args ret fundef = UnsafeDefinition $
78− "CREATE" <+> "FUNCTION" <+> renderSQL fun
79− <+> parenthesized (renderCommaSeparated renderSQL args)
80− <+> "RETURNS" <+> renderSQL ret <+> renderSQL fundef <> ";"
81−
82−createOrReplaceFunction
83− :: ( Has sch schemas schema
84− , KnownSymbol fun
85− , SOP.SListI args )
86− => QualifiedAlias sch fun
87− -> NP (TypeExpression schemas) args
88− -> TypeExpression schemas ret
89− -> FunctionDefinition schemas args ('Returns ret)
90− -> Definition schemas (Alter sch (CreateOrReplace fun ('Function (args :=> 'Returns ret)) schema) schemas)
91−createOrReplaceFunction fun args ret fundef = UnsafeDefinition $
92− "CREATE" <+> "OR" <+> "REPLACE" <+> "FUNCTION" <+> renderSQL fun
93− <+> parenthesized (renderCommaSeparated renderSQL args)
94− <+> "RETURNS" <+> renderSQL ret <+> renderSQL fundef <> ";"
95−
96−languageSqlExpr
97− :: Expression '[] '[] 'Ungrouped schemas args '[] ret
98− -> FunctionDefinition schemas args ('Returns ret)
99−languageSqlExpr expr = UnsafeFunctionDefinition $
100− "language sql as"
101− <+> "$$" <+> renderSQL (values_ (expr `as` #ret)) <+> "$$"
102−
103−languageSqlQuery
104− :: Query '[] '[] schemas args rets
105− -> FunctionDefinition schemas args ('ReturnsTable rets)
106−languageSqlQuery qry = UnsafeFunctionDefinition $
107− "language sql as" <+> "$$" <+> renderSQL qry <+> "$$"
108−
109−createSetFunction
110− :: ( Has sch schemas schema
111− , KnownSymbol fun
112− , SOP.SListI args
113− , SOP.SListI rets )
114− => QualifiedAlias sch fun
115− -> NP (TypeExpression schemas) args
116− -> NP (Aliased (TypeExpression schemas)) rets
117− -> FunctionDefinition schemas args ('ReturnsTable rets)
118− -> Definition schemas (Alter sch (Create fun ('Function (args :=> 'ReturnsTable rets)) schema) schemas)
119−createSetFunction fun args rets fundef = UnsafeDefinition $
120− "CREATE" <+> "FUNCTION" <+> renderSQL fun
121− <+> parenthesized (renderCommaSeparated renderSQL args)
122− <+> "RETURNS" <+> "TABLE"
123− <+> parenthesized (renderCommaSeparated renderRet rets)
124− <+> renderSQL fundef <> ";"
125− where
126− renderRet :: Aliased (TypeExpression s) r -> ByteString
127− renderRet (ty `As` col) = renderSQL col <+> renderSQL ty
128−
129−createOrReplaceSetFunction
130− :: ( Has sch schemas schema
131− , KnownSymbol fun
132− , SOP.SListI args
133− , SOP.SListI rets )
134− => QualifiedAlias sch fun
135− -> NP (TypeExpression schemas) args
136− -> NP (Aliased (TypeExpression schemas)) rets
137− -> FunctionDefinition schemas args ('ReturnsTable rets)
138− -> Definition schemas (Alter sch (CreateOrReplace fun ('Function (args :=> 'ReturnsTable rets)) schema) schemas)
139−createOrReplaceSetFunction fun args rets fundef = UnsafeDefinition $
140− "CREATE" <+> "OR" <+> "REPLACE" <+> "FUNCTION" <+> renderSQL fun
141− <+> parenthesized (renderCommaSeparated renderSQL args)
142− <+> "RETURNS" <+> "TABLE"
143− <+> parenthesized (renderCommaSeparated renderRet rets)
144− <+> renderSQL fundef <> ";"
145− where
146− renderRet :: Aliased (TypeExpression s) r -> ByteString
147− renderRet (ty `As` col) = renderSQL col <+> renderSQL ty
148−
149−createBinaryOp
150− :: forall op fun sch schemas schema x y z.
151− ( Has sch schemas schema
152− , Has fun schema ('Function ('[x,y] :=> 'Returns z))
153− , KnownSymbol op )
154− => QualifiedAlias sch fun
155− -> TypeExpression schemas x
156− -> TypeExpression schemas y
157− -> Definition schemas
158− (Alter sch (Create op ('Operator ('BinaryOp x y z)) schema) schemas)
159−createBinaryOp fun x y = UnsafeDefinition $
160− "CREATE" <+> "OPERATOR" <+> renderSymbol @op
161− <+> parenthesized (commaSeparated opdef)
162− where
163− opdef =
164− [ "FUNCTION" <+> "=" <+> renderSQL fun
165− , "LEFTARG" <+> "=" <+> renderSQL x
166− , "RIGHTARG" <+> "=" <+> renderSQL y ]
167−
168−createLeftOp
169− :: forall op fun sch schemas schema x y.
170− ( Has sch schemas schema
171− , Has fun schema ('Function ('[x] :=> 'Returns y))
172− , KnownSymbol op )
173− => QualifiedAlias sch fun
174− -> TypeExpression schemas x
175− -> Definition schemas
176− (Alter sch (Create op ('Operator ('LeftOp x y)) schema) schemas)
177−createLeftOp fun x = UnsafeDefinition $
178− "CREATE" <+> "OPERATOR" <+> renderSymbol @op
179− <+> parenthesized (commaSeparated opdef)
180− where
181− opdef =
182− [ "FUNCTION" <+> "=" <+> renderSQL fun
183− , "RIGHTARG" <+> "=" <+> renderSQL x ]
184−
185−createRightOp
186− :: forall op fun sch schemas schema x y.
187− ( Has sch schemas schema
188− , Has fun schema ('Function ('[x] :=> 'Returns y))
189− , KnownSymbol op )
190− => QualifiedAlias sch fun
191− -> TypeExpression schemas x
192− -> Definition schemas
193− (Alter sch (Create op ('Operator ('RightOp x y)) schema) schemas)
194−createRightOp fun x = UnsafeDefinition $
195− "CREATE" <+> "OPERATOR" <+> renderSymbol @op
196− <+> parenthesized (commaSeparated opdef)
197− where
198− opdef =
199− [ "FUNCTION" <+> "=" <+> renderSQL fun
200− , "LEFTARG" <+> "=" <+> renderSQL x ]
201−
202−dropFunction
203− :: (Has sch schemas schema, KnownSymbol fun)
204− => QualifiedAlias sch fun
205− -- ^ name of the user defined function
206− -> Definition schemas (Alter sch (DropSchemum fun 'Function schema) schemas)
207−dropFunction fun = UnsafeDefinition $
208− "DROP" <+> "FUNCTION" <+> renderSQL fun <> ";"
209−
210−dropFunctionIfExists
211− :: (Has sch schemas schema, KnownSymbol fun)
212− => QualifiedAlias sch fun
213− -- ^ name of the user defined function
214− -> Definition schemas (Alter sch (DropSchemumIfExists fun 'Function schema) schemas)
215−dropFunctionIfExists fun = UnsafeDefinition $
216− "DROP FUNCTION IF EXISTS" <+> renderSQL fun <> ";"
217−
218−dropOperator
219− :: (Has sch schemas schema, KnownSymbol op)
220− => QualifiedAlias sch op
221− -- ^ name of the user defined operator
222− -> Definition schemas (Alter sch (DropSchemum op 'Operator schema) schemas)
223−dropOperator op = UnsafeDefinition $
224− "DROP" <+> "OPERATOR" <+> renderSQL op <> ";"
225−
226−dropOperatorIfExists
227− :: (Has sch schemas schema, KnownSymbol op)
228− => QualifiedAlias sch op
229− -- ^ name of the user defined operator
230− -> Definition schemas (Alter sch (DropSchemumIfExists op 'Operator schema) schemas)
231−dropOperatorIfExists op = UnsafeDefinition $
232− "DROP OPERATOR IF EXISTS" <+> renderSQL op <> ";"
233−
234−newtype FunctionDefinition schemas args ret = UnsafeFunctionDefinition
235− { renderFunctionDefinition :: ByteString }
236− deriving (Eq,Show,GHC.Generic,NFData)
237−instance RenderSQL (FunctionDefinition schemas args ret) where
238− renderSQL = renderFunctionDefinition
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Index.hsdeleted−159
@@ -1,159 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Definition.Index
3−Description: Create and drop index definitions
4−Copyright: (c) Eitan Chatav, 2017
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Create and drop index definitions.
9−-}
10−
11−{-# LANGUAGE
12− AllowAmbiguousTypes
13− , ConstraintKinds
14− , DeriveAnyClass
15− , DeriveGeneric
16− , DerivingStrategies
17− , FlexibleContexts
18− , FlexibleInstances
19− , GADTs
20− , LambdaCase
21− , MultiParamTypeClasses
22− , OverloadedLabels
23− , OverloadedStrings
24− , RankNTypes
25− , ScopedTypeVariables
26− , TypeApplications
27− , TypeInType
28− , TypeOperators
29− , UndecidableSuperClasses
30−#-}
31−
32−module Squeal.PostgreSQL.Definition.Index
33− ( createIndex
34− , createIndexIfNotExists
35− , dropIndex
36− , dropIndexIfExists
37− , IndexMethod (..)
38− , btree
39− , hash
40− , gist
41− , spgist
42− , gin
43− , brin
44− ) where
45−
46−import Data.ByteString
47−import GHC.TypeLits
48−
49−import qualified GHC.Generics as GHC
50−
51−import Squeal.PostgreSQL.Alias
52−import Squeal.PostgreSQL.Definition
53−import Squeal.PostgreSQL.Expression.Sort
54−import Squeal.PostgreSQL.Render
55−import Squeal.PostgreSQL.Schema
56−
57−-- $setup
58−-- >>> import Squeal.PostgreSQL
59−
60−{- |
61−>>> :{
62−type Table = '[] :=>
63− '[ "a" ::: 'NoDef :=> 'Null 'PGint4
64− , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]
65−:}
66−
67−>>> :{
68−let
69− setup :: Definition (Public '[]) (Public '["tab" ::: 'Table Table, "ix" ::: 'Index 'Btree])
70− setup =
71− createTable #tab (nullable int `as` #a :* nullable real `as` #b) Nil >>>
72− createIndex #ix #tab btree [#a & AscNullsFirst, #b & AscNullsLast]
73−in printSQL setup
74−:}
75−CREATE TABLE "tab" ("a" int NULL, "b" real NULL);
76−CREATE INDEX "ix" ON "tab" USING btree (("a") ASC NULLS FIRST, ("b") ASC NULLS LAST);
77−-}
78−createIndex
79− :: (Has sch schemas schema, Has tab schema ('Table table), KnownSymbol ix)
80− => Alias ix
81− -> QualifiedAlias sch tab
82− -> IndexMethod method
83− -> [SortExpression '[] '[] 'Ungrouped schemas '[] '[tab ::: TableToRow table]]
84− -> Definition schemas (Alter sch (Create ix ('Index method) schema) schemas)
85−createIndex ix tab method cols = UnsafeDefinition $
86− "CREATE" <+> "INDEX" <+> renderSQL ix <+> "ON" <+> renderSQL tab
87− <+> "USING" <+> renderSQL method
88− <+> parenthesized (commaSeparated (renderIndex <$> cols))
89− <> ";"
90− where
91− renderIndex = \case
92− Asc expression -> parenthesized (renderSQL expression) <+> "ASC"
93− Desc expression -> parenthesized (renderSQL expression) <+> "DESC"
94− AscNullsFirst expression -> parenthesized (renderSQL expression)
95− <+> "ASC NULLS FIRST"
96− DescNullsFirst expression -> parenthesized (renderSQL expression)
97− <+> "DESC NULLS FIRST"
98− AscNullsLast expression -> parenthesized (renderSQL expression)
99− <+> "ASC NULLS LAST"
100− DescNullsLast expression -> parenthesized (renderSQL expression)
101− <+> "DESC NULLS LAST"
102−
103−createIndexIfNotExists
104− :: (Has sch schemas schema, Has tab schema ('Table table), KnownSymbol ix)
105− => Alias ix
106− -> QualifiedAlias sch tab
107− -> IndexMethod method
108− -> [SortExpression '[] '[] 'Ungrouped schemas '[] '[tab ::: TableToRow table]]
109− -> Definition schemas (Alter sch (CreateIfNotExists ix ('Index method) schema) schemas)
110−createIndexIfNotExists ix tab method cols = UnsafeDefinition $
111− "CREATE INDEX IF NOT EXISTS" <+> renderSQL ix <+> "ON" <+> renderSQL tab
112− <+> "USING" <+> renderSQL method
113− <+> parenthesized (commaSeparated (renderIndex <$> cols))
114− <> ";"
115− where
116− renderIndex = \case
117− Asc expression -> parenthesized (renderSQL expression) <+> "ASC"
118− Desc expression -> parenthesized (renderSQL expression) <+> "DESC"
119− AscNullsFirst expression -> parenthesized (renderSQL expression)
120− <+> "ASC NULLS FIRST"
121− DescNullsFirst expression -> parenthesized (renderSQL expression)
122− <+> "DESC NULLS FIRST"
123− AscNullsLast expression -> parenthesized (renderSQL expression)
124− <+> "ASC NULLS LAST"
125− DescNullsLast expression -> parenthesized (renderSQL expression)
126− <+> "DESC NULLS LAST"
127−
128−newtype IndexMethod ty = UnsafeIndexMethod {renderIndexMethod :: ByteString}
129− deriving stock (Eq, Ord, Show, GHC.Generic)
130−instance RenderSQL (IndexMethod ty) where renderSQL = renderIndexMethod
131−btree :: IndexMethod 'Btree
132−btree = UnsafeIndexMethod "btree"
133−hash :: IndexMethod 'Hash
134−hash = UnsafeIndexMethod "hash"
135−gist :: IndexMethod 'Gist
136−gist = UnsafeIndexMethod "gist"
137−spgist :: IndexMethod 'Spgist
138−spgist = UnsafeIndexMethod "spgist"
139−gin :: IndexMethod 'Gin
140−gin = UnsafeIndexMethod "gin"
141−brin :: IndexMethod 'Brin
142−brin = UnsafeIndexMethod "brin"
143−
144−-- |
145−-- >>> printSQL (dropIndex #ix :: Definition (Public '["ix" ::: 'Index 'Btree]) (Public '[]))
146−-- DROP INDEX "ix";
147−dropIndex
148− :: (Has sch schemas schema, KnownSymbol ix)
149− => QualifiedAlias sch ix
150− -- ^ name of the user defined index
151− -> Definition schemas (Alter sch (DropSchemum ix 'Index schema) schemas)
152−dropIndex ix = UnsafeDefinition $ "DROP" <+> "INDEX" <+> renderSQL ix <> ";"
153−
154−dropIndexIfExists
155− :: (Has sch schemas schema, KnownSymbol ix)
156− => QualifiedAlias sch ix
157− -- ^ name of the user defined index
158− -> Definition schemas (Alter sch (DropSchemumIfExists ix 'Index schema) schemas)
159−dropIndexIfExists ix = UnsafeDefinition $ "DROP INDEX IF EXISTS" <+> renderSQL ix <> ";"
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Schema.hsdeleted−96
@@ -1,96 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Definition.Schema
3−Description: Create and drop schema definitions
4−Copyright: (c) Eitan Chatav, 2017
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Create and drop schema definitions.
9−-}
10−
11−{-# LANGUAGE
12− AllowAmbiguousTypes
13− , ConstraintKinds
14− , DeriveAnyClass
15− , DeriveGeneric
16− , DerivingStrategies
17− , FlexibleContexts
18− , FlexibleInstances
19− , GADTs
20− , LambdaCase
21− , MultiParamTypeClasses
22− , OverloadedLabels
23− , OverloadedStrings
24− , RankNTypes
25− , ScopedTypeVariables
26− , TypeApplications
27− , TypeInType
28− , TypeOperators
29− , UndecidableSuperClasses
30−#-}
31−
32−module Squeal.PostgreSQL.Definition.Schema
33− ( createSchema
34− , createSchemaIfNotExists
35− , dropSchema
36− , dropSchemaIfExists
37− ) where
38−
39−import GHC.TypeLits
40−
41−import Squeal.PostgreSQL.Alias
42−import Squeal.PostgreSQL.Definition
43−import Squeal.PostgreSQL.Render
44−import Squeal.PostgreSQL.Schema
45−
46−-- $setup
47−-- >>> import Squeal.PostgreSQL
48−
49−{- |
50−`createSchema` enters a new schema into the current database.
51−The schema name must be distinct from the name of any existing schema
52−in the current database.
53−
54−A schema is essentially a namespace: it contains named objects
55−(tables, data types, functions, and operators) whose names
56−can duplicate those of other objects existing in other schemas.
57−Named objects are accessed by `QualifiedAlias`es with the schema
58−name as a prefix.
59−-}
60−createSchema
61− :: KnownSymbol sch
62− => Alias sch
63− -> Definition schemas (Create sch '[] schemas)
64−createSchema sch = UnsafeDefinition $
65− "CREATE" <+> "SCHEMA" <+> renderSQL sch <> ";"
66−
67−{- | Idempotent version of `createSchema`. -}
68−createSchemaIfNotExists
69− :: (KnownSymbol sch, Has sch schemas schema)
70− => Alias sch
71− -> Definition schemas (CreateIfNotExists sch '[] schemas)
72−createSchemaIfNotExists sch = UnsafeDefinition $
73− "CREATE" <+> "SCHEMA" <+> "IF" <+> "NOT" <+> "EXISTS"
74− <+> renderSQL sch <> ";"
75−
76−-- | >>> :{
77−-- let
78−-- definition :: Definition '["muh_schema" ::: schema, "public" ::: public] '["public" ::: public]
79−-- definition = dropSchema #muh_schema
80−-- :}
81−--
82−-- >>> printSQL definition
83−-- DROP SCHEMA "muh_schema";
84−dropSchema
85− :: KnownSymbol sch
86− => Alias sch
87− -- ^ user defined schema
88− -> Definition schemas (Drop sch schemas)
89−dropSchema sch = UnsafeDefinition $ "DROP SCHEMA" <+> renderSQL sch <> ";"
90−
91−dropSchemaIfExists
92− :: KnownSymbol sch
93− => Alias sch
94− -- ^ user defined schema
95− -> Definition schemas (DropIfExists sch schemas)
96−dropSchemaIfExists sch = UnsafeDefinition $ "DROP SCHEMA" <+> renderSQL sch <> ";"
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Table.hsdeleted−500
@@ -1,500 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Definition.Table
3−Description: Create, drop and alter table definitions
4−Copyright: (c) Eitan Chatav, 2017
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Create, drop and alter table definitions.
9−-}
10−
11−{-# LANGUAGE
12− AllowAmbiguousTypes
13− , ConstraintKinds
14− , DeriveAnyClass
15− , DeriveGeneric
16− , DerivingStrategies
17− , FlexibleContexts
18− , FlexibleInstances
19− , GADTs
20− , LambdaCase
21− , MultiParamTypeClasses
22− , OverloadedLabels
23− , OverloadedStrings
24− , RankNTypes
25− , ScopedTypeVariables
26− , TypeApplications
27− , TypeInType
28− , TypeOperators
29− , UndecidableSuperClasses
30−#-}
31−
32−module Squeal.PostgreSQL.Definition.Table
33− ( createTable
34− , createTableIfNotExists
35− , dropTable
36− , dropTableIfExists
37− , alterTable
38− , alterTableIfExists
39− , alterTableRename
40− , alterTableIfExistsRename
41− , AlterTable (..)
42− , addConstraint
43− , dropConstraint
44− , AddColumn (..)
45− , dropColumn
46− , renameColumn
47− , alterColumn
48− , AlterColumn (..)
49− , setDefault
50− , dropDefault
51− , setNotNull
52− , dropNotNull
53− , alterType
54− ) where
55−
56−import Control.DeepSeq
57−import Data.ByteString
58−import GHC.TypeLits
59−
60−import qualified Generics.SOP as SOP
61−import qualified GHC.Generics as GHC
62−
63−import Squeal.PostgreSQL.Alias
64−import Squeal.PostgreSQL.Definition
65−import Squeal.PostgreSQL.Definition.Table.Constraint
66−import Squeal.PostgreSQL.Expression
67−import Squeal.PostgreSQL.Expression.Type
68−import Squeal.PostgreSQL.List
69−import Squeal.PostgreSQL.Render
70−import Squeal.PostgreSQL.Schema
71−
72−-- $setup
73−-- >>> import Squeal.PostgreSQL
74−
75−{- | `createTable` adds a table to the schema.
76−
77−>>> :set -XOverloadedLabels
78−>>> :{
79−type Table = '[] :=>
80− '[ "a" ::: 'NoDef :=> 'Null 'PGint4
81− , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]
82−:}
83−
84−>>> :{
85−let
86− setup :: Definition (Public '[]) (Public '["tab" ::: 'Table Table])
87− setup = createTable #tab
88− (nullable int `as` #a :* nullable real `as` #b) Nil
89−in printSQL setup
90−:}
91−CREATE TABLE "tab" ("a" int NULL, "b" real NULL);
92−-}
93−createTable
94− :: ( KnownSymbol sch
95− , KnownSymbol tab
96− , columns ~ (col ': cols)
97− , SOP.SListI columns
98− , SOP.SListI constraints
99− , Has sch schemas0 schema0
100− , schemas1 ~ Alter sch (Create tab ('Table (constraints :=> columns)) schema0) schemas0 )
101− => QualifiedAlias sch tab -- ^ the name of the table to add
102− -> NP (Aliased (ColumnTypeExpression schemas0)) columns
103− -- ^ the names and datatype of each column
104− -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints
105− -- ^ constraints that must hold for the table
106− -> Definition schemas0 schemas1
107−createTable tab columns constraints = UnsafeDefinition $
108− "CREATE TABLE" <+> renderCreation tab columns constraints
109−
110−{-| `createTableIfNotExists` creates a table if it doesn't exist, but does not add it to the schema.
111−Instead, the schema already has the table so if the table did not yet exist, the schema was wrong.
112−`createTableIfNotExists` fixes this. Interestingly, this property makes it an idempotent in
113−the `Category` of `Definition`s.
114−
115−>>> :set -XOverloadedLabels -XTypeApplications
116−>>> :{
117−type Table = '[] :=>
118− '[ "a" ::: 'NoDef :=> 'Null 'PGint4
119− , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]
120−:}
121−
122−>>> type Schemas = Public '["tab" ::: 'Table Table]
123−
124−>>> :{
125−let
126− setup :: Definition Schemas Schemas
127− setup = createTableIfNotExists #tab
128− (nullable int `as` #a :* nullable real `as` #b) Nil
129−in printSQL setup
130−:}
131−CREATE TABLE IF NOT EXISTS "tab" ("a" int NULL, "b" real NULL);
132−-}
133−createTableIfNotExists
134− :: ( KnownSymbol sch
135− , KnownSymbol tab
136− , columns ~ (col ': cols)
137− , SOP.SListI columns
138− , SOP.SListI constraints
139− , Has sch schemas0 schema0
140− , schemas1 ~ Alter sch (CreateIfNotExists tab ('Table (constraints :=> columns)) schema0) schemas0 )
141− => QualifiedAlias sch tab -- ^ the name of the table to add
142− -> NP (Aliased (ColumnTypeExpression schemas0)) columns
143− -- ^ the names and datatype of each column
144− -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints
145− -- ^ constraints that must hold for the table
146− -> Definition schemas0 schemas1
147−createTableIfNotExists tab columns constraints = UnsafeDefinition $
148− "CREATE TABLE IF NOT EXISTS"
149− <+> renderCreation tab columns constraints
150−
151−-- helper function for `createTable` and `createTableIfNotExists`
152−renderCreation
153− :: ( KnownSymbol sch
154− , KnownSymbol tab
155− , SOP.SListI columns
156− , SOP.SListI constraints )
157− => QualifiedAlias sch tab -- ^ the name of the table to add
158− -> NP (Aliased (ColumnTypeExpression schemas0)) columns
159− -- ^ the names and datatype of each column
160− -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints
161− -- ^ constraints that must hold for the table
162− -> ByteString
163−renderCreation tab columns constraints = renderSQL tab
164− <+> parenthesized
165− ( renderCommaSeparated renderColumnDef columns
166− <> ( case constraints of
167− Nil -> ""
168− _ -> ", " <>
169− renderCommaSeparated renderConstraint constraints ) )
170− <> ";"
171− where
172− renderColumnDef :: Aliased (ColumnTypeExpression schemas) x -> ByteString
173− renderColumnDef (ty `As` column) =
174− renderSQL column <+> renderColumnTypeExpression ty
175− renderConstraint
176− :: Aliased (TableConstraintExpression sch tab schemas) constraint
177− -> ByteString
178− renderConstraint (constraint `As` alias) =
179− "CONSTRAINT" <+> renderSQL alias <+> renderSQL constraint
180−
181−-- | `dropTable` removes a table from the schema.
182−--
183−-- >>> :{
184−-- let
185−-- definition :: Definition '["public" ::: '["muh_table" ::: 'Table t]] (Public '[])
186−-- definition = dropTable #muh_table
187−-- :}
188−--
189−-- >>> printSQL definition
190−-- DROP TABLE "muh_table";
191−dropTable
192− :: ( Has sch schemas schema
193− , KnownSymbol tab )
194− => QualifiedAlias sch tab -- ^ table to remove
195− -> Definition schemas (Alter sch (DropSchemum tab 'Table schema) schemas)
196−dropTable tab = UnsafeDefinition $ "DROP TABLE" <+> renderSQL tab <> ";"
197−
198−dropTableIfExists
199− :: ( Has sch schemas schema
200− , KnownSymbol tab)
201− => QualifiedAlias sch tab -- ^ table to remove
202− -> Definition schemas (Alter sch (DropSchemumIfExists tab 'Table schema) schemas)
203−dropTableIfExists tab = UnsafeDefinition $ "DROP TABLE IF EXISTS" <+> renderSQL tab <> ";"
204−
205−-- | `alterTable` changes the definition of a table from the schema.
206−alterTable
207− :: (Has sch schemas schema, KnownSymbol tab)
208− => QualifiedAlias sch tab -- ^ table to alter
209− -> AlterTable sch tab schemas table -- ^ alteration to perform
210− -> Definition schemas (Alter sch (Alter tab ('Table table) schema) schemas)
211−alterTable tab alteration = UnsafeDefinition $
212− "ALTER TABLE"
213− <+> renderSQL tab
214− <+> renderAlterTable alteration
215− <> ";"
216−
217−-- | `alterTable` changes the definition of a table from the schema.
218−alterTableIfExists
219− :: (Has sch schemas schema, KnownSymbol tab)
220− => QualifiedAlias sch tab -- ^ table to alter
221− -> AlterTable sch tab schemas table -- ^ alteration to perform
222− -> Definition schemas (Alter sch (AlterIfExists tab ('Table table) schema) schemas)
223−alterTableIfExists tab alteration = UnsafeDefinition $
224− "ALTER TABLE IF EXISTS"
225− <+> renderSQL tab
226− <+> renderAlterTable alteration
227− <> ";"
228−
229−-- | `alterTableRename` changes the name of a table from the schema.
230−--
231−-- >>> printSQL $ alterTableRename #foo #bar
232−-- ALTER TABLE "foo" RENAME TO "bar";
233−alterTableRename
234− :: (KnownSymbol tab0, KnownSymbol tab1)
235− => Alias tab0 -- ^ table to rename
236− -> Alias tab1 -- ^ what to rename it
237− -> Definition schema (Rename tab0 tab1 schema)
238−alterTableRename tab0 tab1 = UnsafeDefinition $
239− "ALTER TABLE" <+> renderSQL tab0
240− <+> "RENAME TO" <+> renderSQL tab1 <> ";"
241−
242−alterTableIfExistsRename
243− :: (KnownSymbol tab0, KnownSymbol tab1)
244− => Alias tab0 -- ^ table to rename
245− -> Alias tab1 -- ^ what to rename it
246− -> Definition schema (RenameIfExists tab0 tab1 schema)
247−alterTableIfExistsRename tab0 tab1 = UnsafeDefinition $
248− "ALTER TABLE IF EXISTS" <+> renderSQL tab0
249− <+> "RENAME TO" <+> renderSQL tab1 <> ";"
250−
251−-- | An `AlterTable` describes the alteration to perform on the columns
252−-- of a table.
253−newtype AlterTable
254− (sch :: Symbol)
255− (tab :: Symbol)
256− (schemas :: SchemasType)
257− (table :: TableType) =
258− UnsafeAlterTable {renderAlterTable :: ByteString}
259− deriving (GHC.Generic,Show,Eq,Ord,NFData)
260−
261−-- | An `addConstraint` adds a table constraint.
262−--
263−-- >>> :{
264−-- let
265−-- definition :: Definition
266−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
267−-- '["public" ::: '["tab" ::: 'Table ('["positive" ::: 'Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
268−-- definition = alterTable #tab (addConstraint #positive (check #col (#col .> 0)))
269−-- in printSQL definition
270−-- :}
271−-- ALTER TABLE "tab" ADD CONSTRAINT "positive" CHECK (("col" > 0));
272−addConstraint
273− :: ( KnownSymbol alias
274− , Has sch schemas schema
275− , Has tab schema ('Table table0)
276− , table0 ~ (constraints :=> columns)
277− , table1 ~ (Create alias constraint constraints :=> columns) )
278− => Alias alias
279− -> TableConstraintExpression sch tab schemas constraint
280− -- ^ constraint to add
281− -> AlterTable sch tab schemas table1
282−addConstraint alias constraint = UnsafeAlterTable $
283− "ADD" <+> "CONSTRAINT" <+> renderSQL alias
284− <+> renderSQL constraint
285−
286−-- | A `dropConstraint` drops a table constraint.
287−--
288−-- >>> :{
289−-- let
290−-- definition :: Definition
291−-- '["public" ::: '["tab" ::: 'Table ('["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
292−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
293−-- definition = alterTable #tab (dropConstraint #positive)
294−-- in printSQL definition
295−-- :}
296−-- ALTER TABLE "tab" DROP CONSTRAINT "positive";
297−dropConstraint
298− :: ( KnownSymbol constraint
299− , Has sch schemas schema
300− , Has tab schema ('Table table0)
301− , table0 ~ (constraints :=> columns)
302− , table1 ~ (Drop constraint constraints :=> columns) )
303− => Alias constraint
304− -- ^ constraint to drop
305− -> AlterTable sch tab schemas table1
306−dropConstraint constraint = UnsafeAlterTable $
307− "DROP" <+> "CONSTRAINT" <+> renderSQL constraint
308−
309−-- | An `AddColumn` is either @NULL@ or has @DEFAULT@.
310−class AddColumn ty where
311− -- | `addColumn` adds a new column, initially filled with whatever
312− -- default value is given or with @NULL@.
313− --
314− -- >>> :{
315− -- let
316− -- definition :: Definition
317− -- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]
318− -- '["public" ::: '["tab" ::: 'Table ('[] :=>
319− -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
320− -- , "col2" ::: 'Def :=> 'Null 'PGtext ])]]
321− -- definition = alterTable #tab (addColumn #col2 (text & nullable & default_ "foo"))
322− -- in printSQL definition
323− -- :}
324− -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL DEFAULT E'foo';
325− --
326− -- >>> :{
327− -- let
328− -- definition :: Definition
329− -- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]
330− -- '["public" ::: '["tab" ::: 'Table ('[] :=>
331− -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
332− -- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]]
333− -- definition = alterTable #tab (addColumn #col2 (text & nullable))
334− -- in printSQL definition
335− -- :}
336− -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL;
337− addColumn
338− :: ( KnownSymbol column
339− , Has sch schemas schema
340− , Has tab schema ('Table table0)
341− , table0 ~ (constraints :=> columns) )
342− => Alias column -- ^ column to add
343− -> ColumnTypeExpression schemas ty -- ^ type of the new column
344− -> AlterTable sch tab schemas (constraints :=> Create column ty columns)
345− addColumn column ty = UnsafeAlterTable $
346− "ADD COLUMN" <+> renderSQL column <+> renderColumnTypeExpression ty
347−instance {-# OVERLAPPING #-} AddColumn ('Def :=> ty)
348−instance {-# OVERLAPPABLE #-} AddColumn ('NoDef :=> 'Null ty)
349−
350−-- | A `dropColumn` removes a column. Whatever data was in the column
351−-- disappears. Table constraints involving the column are dropped, too.
352−-- However, if the column is referenced by a foreign key constraint of
353−-- another table, PostgreSQL will not silently drop that constraint.
354−--
355−-- >>> :{
356−-- let
357−-- definition :: Definition
358−-- '["public" ::: '["tab" ::: 'Table ('[] :=>
359−-- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
360−-- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]]
361−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]
362−-- definition = alterTable #tab (dropColumn #col2)
363−-- in printSQL definition
364−-- :}
365−-- ALTER TABLE "tab" DROP COLUMN "col2";
366−dropColumn
367− :: ( KnownSymbol column
368− , Has sch schemas schema
369− , Has tab schema ('Table table0)
370− , table0 ~ (constraints :=> columns)
371− , table1 ~ (constraints :=> Drop column columns) )
372− => Alias column -- ^ column to remove
373− -> AlterTable sch tab schemas table1
374−dropColumn column = UnsafeAlterTable $
375− "DROP COLUMN" <+> renderSQL column
376−
377−-- | A `renameColumn` renames a column.
378−--
379−-- >>> :{
380−-- let
381−-- definition :: Definition
382−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["foo" ::: 'NoDef :=> 'Null 'PGint4])]]
383−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["bar" ::: 'NoDef :=> 'Null 'PGint4])]]
384−-- definition = alterTable #tab (renameColumn #foo #bar)
385−-- in printSQL definition
386−-- :}
387−-- ALTER TABLE "tab" RENAME COLUMN "foo" TO "bar";
388−renameColumn
389− :: ( KnownSymbol column0
390− , KnownSymbol column1
391− , Has sch schemas schema
392− , Has tab schema ('Table table0)
393− , table0 ~ (constraints :=> columns)
394− , table1 ~ (constraints :=> Rename column0 column1 columns) )
395− => Alias column0 -- ^ column to rename
396− -> Alias column1 -- ^ what to rename the column
397− -> AlterTable sch tab schemas table1
398−renameColumn column0 column1 = UnsafeAlterTable $
399− "RENAME COLUMN" <+> renderSQL column0 <+> "TO" <+> renderSQL column1
400−
401−-- | An `alterColumn` alters a single column.
402−alterColumn
403− :: ( KnownSymbol column
404− , Has sch schemas schema
405− , Has tab schema ('Table table0)
406− , table0 ~ (constraints :=> columns)
407− , Has column columns ty0
408− , table1 ~ (constraints :=> Alter column ty1 columns))
409− => Alias column -- ^ column to alter
410− -> AlterColumn schemas ty0 ty1 -- ^ alteration to perform
411− -> AlterTable sch tab schemas table1
412−alterColumn column alteration = UnsafeAlterTable $
413− "ALTER COLUMN" <+> renderSQL column <+> renderAlterColumn alteration
414−
415−-- | An `AlterColumn` describes the alteration to perform on a single column.
416−newtype AlterColumn (schemas :: SchemasType) (ty0 :: ColumnType) (ty1 :: ColumnType) =
417− UnsafeAlterColumn {renderAlterColumn :: ByteString}
418− deriving (GHC.Generic,Show,Eq,Ord,NFData)
419−
420−-- | A `setDefault` sets a new default for a column. Note that this doesn't
421−-- affect any existing rows in the table, it just changes the default for
422−-- future insert and update commands.
423−--
424−-- >>> :{
425−-- let
426−-- definition :: Definition
427−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
428−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]]
429−-- definition = alterTable #tab (alterColumn #col (setDefault 5))
430−-- in printSQL definition
431−-- :}
432−-- ALTER TABLE "tab" ALTER COLUMN "col" SET DEFAULT 5;
433−setDefault
434− :: Expression '[] '[] 'Ungrouped schemas '[] '[] ty -- ^ default value to set
435− -> AlterColumn schemas (constraint :=> ty) ('Def :=> ty)
436−setDefault expression = UnsafeAlterColumn $
437− "SET DEFAULT" <+> renderExpression expression
438−
439−-- | A `dropDefault` removes any default value for a column.
440−--
441−-- >>> :{
442−-- let
443−-- definition :: Definition
444−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]]
445−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
446−-- definition = alterTable #tab (alterColumn #col dropDefault)
447−-- in printSQL definition
448−-- :}
449−-- ALTER TABLE "tab" ALTER COLUMN "col" DROP DEFAULT;
450−dropDefault :: AlterColumn schemas ('Def :=> ty) ('NoDef :=> ty)
451−dropDefault = UnsafeAlterColumn $ "DROP DEFAULT"
452−
453−-- | A `setNotNull` adds a @NOT NULL@ constraint to a column.
454−-- The constraint will be checked immediately, so the table data must satisfy
455−-- the constraint before it can be added.
456−--
457−-- >>> :{
458−-- let
459−-- definition :: Definition
460−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
461−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
462−-- definition = alterTable #tab (alterColumn #col setNotNull)
463−-- in printSQL definition
464−-- :}
465−-- ALTER TABLE "tab" ALTER COLUMN "col" SET NOT NULL;
466−setNotNull
467− :: AlterColumn schemas (constraint :=> 'Null ty) (constraint :=> 'NotNull ty)
468−setNotNull = UnsafeAlterColumn $ "SET NOT NULL"
469−
470−-- | A `dropNotNull` drops a @NOT NULL@ constraint from a column.
471−--
472−-- >>> :{
473−-- let
474−-- definition :: Definition
475−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
476−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
477−-- definition = alterTable #tab (alterColumn #col dropNotNull)
478−-- in printSQL definition
479−-- :}
480−-- ALTER TABLE "tab" ALTER COLUMN "col" DROP NOT NULL;
481−dropNotNull
482− :: AlterColumn schemas (constraint :=> 'NotNull ty) (constraint :=> 'Null ty)
483−dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL"
484−
485−-- | An `alterType` converts a column to a different data type.
486−-- This will succeed only if each existing entry in the column can be
487−-- converted to the new type by an implicit cast.
488−--
489−-- >>> :{
490−-- let
491−-- definition :: Definition
492−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
493−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGnumeric])]]
494−-- definition =
495−-- alterTable #tab (alterColumn #col (alterType (numeric & notNullable)))
496−-- in printSQL definition
497−-- :}
498−-- ALTER TABLE "tab" ALTER COLUMN "col" TYPE numeric NOT NULL;
499−alterType :: ColumnTypeExpression schemas ty -> AlterColumn schemas ty0 ty
500−alterType ty = UnsafeAlterColumn $ "TYPE" <+> renderColumnTypeExpression ty
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Table/Constraint.hsdeleted−339
@@ -1,339 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Definition.Table.Constraint
3−Description: Table constraint expressions
4−Copyright: (c) Eitan Chatav, 2017
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Table constraint expressions.
9−-}
10−
11−{-# LANGUAGE
12− AllowAmbiguousTypes
13− , ConstraintKinds
14− , DeriveAnyClass
15− , DeriveGeneric
16− , DerivingStrategies
17− , FlexibleContexts
18− , FlexibleInstances
19− , GADTs
20− , LambdaCase
21− , MultiParamTypeClasses
22− , OverloadedLabels
23− , OverloadedStrings
24− , RankNTypes
25− , ScopedTypeVariables
26− , TypeApplications
27− , TypeInType
28− , TypeOperators
29− , UndecidableSuperClasses
30−#-}
31−
32−module Squeal.PostgreSQL.Definition.Table.Constraint
33− ( TableConstraintExpression (..)
34− , check
35− , unique
36− , primaryKey
37− , foreignKey
38− , ForeignKeyed
39− , OnDeleteClause (..)
40− , OnUpdateClause (..)
41− ) where
42−
43−import Control.DeepSeq
44−import Data.ByteString
45−import GHC.TypeLits
46−
47−import qualified Generics.SOP as SOP
48−import qualified GHC.Generics as GHC
49−
50−import Squeal.PostgreSQL.Alias
51−import Squeal.PostgreSQL.Expression.Logic
52−import Squeal.PostgreSQL.List
53−import Squeal.PostgreSQL.Render
54−import Squeal.PostgreSQL.Schema
55−
56−-- $setup
57−-- >>> import Squeal.PostgreSQL
58−
59−-- | Data types are a way to limit the kind of data that can be stored in a
60−-- table. For many applications, however, the constraint they provide is
61−-- too coarse. For example, a column containing a product price should
62−-- probably only accept positive values. But there is no standard data type
63−-- that accepts only positive numbers. Another issue is that you might want
64−-- to constrain column data with respect to other columns or rows.
65−-- For example, in a table containing product information,
66−-- there should be only one row for each product number.
67−-- `TableConstraint`s give you as much control over the data in your tables
68−-- as you wish. If a user attempts to store data in a column that would
69−-- violate a constraint, an error is raised. This applies
70−-- even if the value came from the default value definition.
71−newtype TableConstraintExpression
72− (sch :: Symbol)
73− (tab :: Symbol)
74− (schemas :: SchemasType)
75− (constraint :: TableConstraint)
76− = UnsafeTableConstraintExpression
77− { renderTableConstraintExpression :: ByteString }
78− deriving (GHC.Generic,Show,Eq,Ord,NFData)
79−instance RenderSQL
80− (TableConstraintExpression sch tab schemas constraint) where
81− renderSQL = renderTableConstraintExpression
82−
83−{-| A `check` constraint is the most generic `TableConstraint` type.
84−It allows you to specify that the value in a certain column must satisfy
85−a Boolean (truth-value) expression.
86−
87−>>> :{
88−type Schema = '[
89− "tab" ::: 'Table ('[ "inequality" ::: 'Check '["a","b"]] :=> '[
90− "a" ::: 'NoDef :=> 'NotNull 'PGint4,
91− "b" ::: 'NoDef :=> 'NotNull 'PGint4
92− ])]
93−:}
94−
95−>>> :{
96−let
97− definition :: Definition (Public '[]) (Public Schema)
98− definition = createTable #tab
99− ( (int & notNullable) `as` #a :*
100− (int & notNullable) `as` #b )
101− ( check (#a :* #b) (#a .> #b) `as` #inequality )
102−:}
103−
104−>>> printSQL definition
105−CREATE TABLE "tab" ("a" int NOT NULL, "b" int NOT NULL, CONSTRAINT "inequality" CHECK (("a" > "b")));
106−-}
107−check
108− :: ( Has sch schemas schema
109− , Has tab schema ('Table table)
110− , HasAll aliases (TableToRow table) subcolumns )
111− => NP Alias aliases
112− -- ^ specify the subcolumns which are getting checked
113− -> (forall t. Condition '[] '[] 'Ungrouped schemas '[] '[t ::: subcolumns])
114− -- ^ a closed `Condition` on those subcolumns
115− -> TableConstraintExpression sch tab schemas ('Check aliases)
116−check _cols condition = UnsafeTableConstraintExpression $
117− "CHECK" <+> parenthesized (renderSQL condition)
118−
119−{-| A `unique` constraint ensure that the data contained in a column,
120−or a group of columns, is unique among all the rows in the table.
121−
122−>>> :{
123−type Schema = '[
124− "tab" ::: 'Table( '[ "uq_a_b" ::: 'Unique '["a","b"]] :=> '[
125− "a" ::: 'NoDef :=> 'Null 'PGint4,
126− "b" ::: 'NoDef :=> 'Null 'PGint4
127− ])]
128−:}
129−
130−>>> :{
131−let
132− definition :: Definition (Public '[]) (Public Schema)
133− definition = createTable #tab
134− ( (int & nullable) `as` #a :*
135− (int & nullable) `as` #b )
136− ( unique (#a :* #b) `as` #uq_a_b )
137−:}
138−
139−>>> printSQL definition
140−CREATE TABLE "tab" ("a" int NULL, "b" int NULL, CONSTRAINT "uq_a_b" UNIQUE ("a", "b"));
141−-}
142−unique
143− :: ( Has sch schemas schema
144− , Has tab schema('Table table)
145− , HasAll aliases (TableToRow table) subcolumns )
146− => NP Alias aliases
147− -- ^ specify subcolumns which together are unique for each row
148− -> TableConstraintExpression sch tab schemas ('Unique aliases)
149−unique columns = UnsafeTableConstraintExpression $
150− "UNIQUE" <+> parenthesized (renderSQL columns)
151−
152−{-| A `primaryKey` constraint indicates that a column, or group of columns,
153−can be used as a unique identifier for rows in the table.
154−This requires that the values be both unique and not null.
155−
156−>>> :{
157−type Schema = '[
158− "tab" ::: 'Table ('[ "pk_id" ::: 'PrimaryKey '["id"]] :=> '[
159− "id" ::: 'Def :=> 'NotNull 'PGint4,
160− "name" ::: 'NoDef :=> 'NotNull 'PGtext
161− ])]
162−:}
163−
164−>>> :{
165−let
166− definition :: Definition (Public '[]) (Public Schema)
167− definition = createTable #tab
168− ( serial `as` #id :*
169− (text & notNullable) `as` #name )
170− ( primaryKey #id `as` #pk_id )
171−:}
172−
173−>>> printSQL definition
174−CREATE TABLE "tab" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_id" PRIMARY KEY ("id"));
175−-}
176−primaryKey
177− :: ( Has sch schemas schema
178− , Has tab schema ('Table table)
179− , HasAll aliases (TableToColumns table) subcolumns
180− , AllNotNull subcolumns )
181− => NP Alias aliases
182− -- ^ specify the subcolumns which together form a primary key.
183− -> TableConstraintExpression sch tab schemas ('PrimaryKey aliases)
184−primaryKey columns = UnsafeTableConstraintExpression $
185− "PRIMARY KEY" <+> parenthesized (renderSQL columns)
186−
187−{-| A `foreignKey` specifies that the values in a column
188−(or a group of columns) must match the values appearing in some row of
189−another table. We say this maintains the referential integrity
190−between two related tables.
191−
192−>>> :{
193−type Schema =
194− '[ "users" ::: 'Table (
195− '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
196− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
197− , "name" ::: 'NoDef :=> 'NotNull 'PGtext
198− ])
199− , "emails" ::: 'Table (
200− '[ "pk_emails" ::: 'PrimaryKey '["id"]
201− , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
202− ] :=>
203− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
204− , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
205− , "email" ::: 'NoDef :=> 'Null 'PGtext
206− ])
207− ]
208−:}
209−
210−>>> :{
211−let
212− setup :: Definition (Public '[]) (Public Schema)
213− setup =
214− createTable #users
215− ( serial `as` #id :*
216− (text & notNullable) `as` #name )
217− ( primaryKey #id `as` #pk_users ) >>>
218− createTable #emails
219− ( serial `as` #id :*
220− (int & notNullable) `as` #user_id :*
221− (text & nullable) `as` #email )
222− ( primaryKey #id `as` #pk_emails :*
223− foreignKey #user_id #users #id
224− OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
225−in printSQL setup
226−:}
227−CREATE TABLE "users" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_users" PRIMARY KEY ("id"));
228−CREATE TABLE "emails" ("id" serial, "user_id" int NOT NULL, "email" text NULL, CONSTRAINT "pk_emails" PRIMARY KEY ("id"), CONSTRAINT "fk_user_id" FOREIGN KEY ("user_id") REFERENCES "users" ("id") ON DELETE CASCADE ON UPDATE CASCADE);
229−
230−A `foreignKey` can even be a table self-reference.
231−
232−>>> :{
233−type Schema =
234− '[ "employees" ::: 'Table (
235− '[ "employees_pk" ::: 'PrimaryKey '["id"]
236− , "employees_employer_fk" ::: 'ForeignKey '["employer_id"] "employees" '["id"]
237− ] :=>
238− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
239− , "name" ::: 'NoDef :=> 'NotNull 'PGtext
240− , "employer_id" ::: 'NoDef :=> 'Null 'PGint4
241− ])
242− ]
243−:}
244−
245−>>> :{
246−let
247− setup :: Definition (Public '[]) (Public Schema)
248− setup =
249− createTable #employees
250− ( serial `as` #id :*
251− (text & notNullable) `as` #name :*
252− (integer & nullable) `as` #employer_id )
253− ( primaryKey #id `as` #employees_pk :*
254− foreignKey #employer_id #employees #id
255− OnDeleteCascade OnUpdateCascade `as` #employees_employer_fk )
256−in printSQL setup
257−:}
258−CREATE TABLE "employees" ("id" serial, "name" text NOT NULL, "employer_id" integer NULL, CONSTRAINT "employees_pk" PRIMARY KEY ("id"), CONSTRAINT "employees_employer_fk" FOREIGN KEY ("employer_id") REFERENCES "employees" ("id") ON DELETE CASCADE ON UPDATE CASCADE);
259−-}
260−foreignKey
261− :: (ForeignKeyed schemas sch schema child parent
262− table reftable
263− columns refcolumns
264− constraints cols
265− reftys tys )
266− => NP Alias columns
267− -- ^ column or columns in the table
268− -> Alias parent
269− -- ^ reference table
270− -> NP Alias refcolumns
271− -- ^ reference column or columns in the reference table
272− -> OnDeleteClause
273− -- ^ what to do when reference is deleted
274− -> OnUpdateClause
275− -- ^ what to do when reference is updated
276− -> TableConstraintExpression sch child schemas
277− ('ForeignKey columns parent refcolumns)
278−foreignKey keys parent refs ondel onupd = UnsafeTableConstraintExpression $
279− "FOREIGN KEY" <+> parenthesized (renderSQL keys)
280− <+> "REFERENCES" <+> renderSQL parent
281− <+> parenthesized (renderSQL refs)
282− <+> renderSQL ondel
283− <+> renderSQL onupd
284−
285−-- | A constraint synonym between types involved in a foreign key constraint.
286−type ForeignKeyed schemas
287− sch
288− schema
289− child parent
290− table reftable
291− columns refcolumns
292− constraints cols
293− reftys tys =
294− ( Has sch schemas schema
295− , Has child schema ('Table table)
296− , Has parent schema ('Table reftable)
297− , HasAll columns (TableToColumns table) tys
298− , reftable ~ (constraints :=> cols)
299− , HasAll refcolumns cols reftys
300− , SOP.AllZip SamePGType tys reftys
301− , Uniquely refcolumns constraints )
302−
303−-- | `OnDeleteClause` indicates what to do with rows that reference a deleted row.
304−data OnDeleteClause
305− = OnDeleteNoAction
306− -- ^ if any referencing rows still exist when the constraint is checked,
307− -- an error is raised
308− | OnDeleteRestrict -- ^ prevents deletion of a referenced row
309− | OnDeleteCascade
310− -- ^ specifies that when a referenced row is deleted,
311− -- row(s) referencing it should be automatically deleted as well
312− deriving (GHC.Generic,Show,Eq,Ord)
313−instance NFData OnDeleteClause
314−-- | Render `OnDeleteClause`.
315−instance RenderSQL OnDeleteClause where
316− renderSQL = \case
317− OnDeleteNoAction -> "ON DELETE NO ACTION"
318− OnDeleteRestrict -> "ON DELETE RESTRICT"
319− OnDeleteCascade -> "ON DELETE CASCADE"
320−
321−-- | Analagous to `OnDeleteClause` there is also `OnUpdateClause` which is invoked
322−-- when a referenced column is changed (updated).
323−data OnUpdateClause
324− = OnUpdateNoAction
325− -- ^ if any referencing rows has not changed when the constraint is checked,
326− -- an error is raised
327− | OnUpdateRestrict -- ^ prevents update of a referenced row
328− | OnUpdateCascade
329− -- ^ the updated values of the referenced column(s) should be copied
330− -- into the referencing row(s)
331− deriving (GHC.Generic,Show,Eq,Ord)
332−instance NFData OnUpdateClause
333−
334−-- | Render `OnUpdateClause`.
335−instance RenderSQL OnUpdateClause where
336− renderSQL = \case
337− OnUpdateNoAction -> "ON UPDATE NO ACTION"
338− OnUpdateRestrict -> "ON UPDATE RESTRICT"
339− OnUpdateCascade -> "ON UPDATE CASCADE"
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Type.hsdeleted−229
@@ -1,229 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Definition.Type
3−Description: Create and drop type definitions
4−Copyright: (c) Eitan Chatav, 2017
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Create and drop type definitions.
9−-}
10−
11−{-# LANGUAGE
12− AllowAmbiguousTypes
13− , ConstraintKinds
14− , DeriveAnyClass
15− , DeriveGeneric
16− , DerivingStrategies
17− , FlexibleContexts
18− , FlexibleInstances
19− , GADTs
20− , LambdaCase
21− , MultiParamTypeClasses
22− , OverloadedLabels
23− , OverloadedStrings
24− , RankNTypes
25− , ScopedTypeVariables
26− , TypeApplications
27− , TypeInType
28− , TypeOperators
29− , UndecidableSuperClasses
30−#-}
31−
32−module Squeal.PostgreSQL.Definition.Type
33− ( createTypeEnum
34− , createTypeEnumFrom
35− , createTypeComposite
36− , createTypeCompositeFrom
37− , createTypeRange
38− , createDomain
39− , dropType
40− , dropTypeIfExists
41− ) where
42−
43−import Data.ByteString
44−import Data.Monoid
45−import GHC.TypeLits
46−import Prelude hiding ((.), id)
47−
48−import qualified Generics.SOP as SOP
49−
50−import Squeal.PostgreSQL.Alias
51−import Squeal.PostgreSQL.Expression.Logic
52−import Squeal.PostgreSQL.Expression.Type
53−import Squeal.PostgreSQL.Definition
54−import Squeal.PostgreSQL.List
55−import Squeal.PostgreSQL.PG
56−import Squeal.PostgreSQL.Render
57−import Squeal.PostgreSQL.Schema
58−
59−-- $setup
60−-- >>> import Squeal.PostgreSQL
61−-- >>> import qualified GHC.Generics as GHC
62−-- >>> import qualified Generics.SOP as SOP
63−
64−-- | Enumerated types are created using the `createTypeEnum` command, for example
65−--
66−-- >>> printSQL $ (createTypeEnum #mood (label @"sad" :* label @"ok" :* label @"happy") :: Definition (Public '[]) '["public" ::: '["mood" ::: 'Typedef ('PGenum '["sad","ok","happy"])]])
67−-- CREATE TYPE "mood" AS ENUM ('sad', 'ok', 'happy');
68−createTypeEnum
69− :: (KnownSymbol enum, Has sch schemas schema, SOP.All KnownSymbol labels)
70− => QualifiedAlias sch enum
71− -- ^ name of the user defined enumerated type
72− -> NP PGlabel labels
73− -- ^ labels of the enumerated type
74− -> Definition schemas (Alter sch (Create enum ('Typedef ('PGenum labels)) schema) schemas)
75−createTypeEnum enum labels = UnsafeDefinition $
76− "CREATE" <+> "TYPE" <+> renderSQL enum <+> "AS" <+> "ENUM" <+>
77− parenthesized (renderSQL labels) <> ";"
78−
79−-- | Enumerated types can also be generated from a Haskell type, for example
80−--
81−-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic
82−-- >>> instance SOP.Generic Schwarma
83−-- >>> instance SOP.HasDatatypeInfo Schwarma
84−-- >>> :{
85−-- let
86−-- createSchwarma :: Definition (Public '[]) '["public" ::: '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))]]
87−-- createSchwarma = createTypeEnumFrom @Schwarma #schwarma
88−-- in
89−-- printSQL createSchwarma
90−-- :}
91−-- CREATE TYPE "schwarma" AS ENUM ('Beef', 'Lamb', 'Chicken');
92−createTypeEnumFrom
93− :: forall hask sch enum schemas schema.
94− ( SOP.Generic hask
95− , SOP.All KnownSymbol (LabelsPG hask)
96− , KnownSymbol enum
97− , Has sch schemas schema )
98− => QualifiedAlias sch enum
99− -- ^ name of the user defined enumerated type
100− -> Definition schemas (Alter sch (Create enum ('Typedef (PG (Enumerated hask))) schema) schemas)
101−createTypeEnumFrom enum = createTypeEnum enum
102− (SOP.hpure label :: NP PGlabel (LabelsPG hask))
103−
104−{- | `createTypeComposite` creates a composite type. The composite type is
105−specified by a list of attribute names and data types.
106−
107−>>> :{
108−type PGcomplex = 'PGcomposite
109− '[ "real" ::: 'NotNull 'PGfloat8
110− , "imaginary" ::: 'NotNull 'PGfloat8 ]
111−:}
112−
113−>>> :{
114−let
115− setup :: Definition (Public '[]) '["public" ::: '["complex" ::: 'Typedef PGcomplex]]
116− setup = createTypeComposite #complex
117− (float8 `as` #real :* float8 `as` #imaginary)
118−in printSQL setup
119−:}
120−CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);
121−-}
122−createTypeComposite
123− :: (KnownSymbol ty, Has sch schemas schema, SOP.SListI fields)
124− => QualifiedAlias sch ty
125− -- ^ name of the user defined composite type
126− -> NP (Aliased (TypeExpression schemas)) fields
127− -- ^ list of attribute names and data types
128− -> Definition schemas (Alter sch (Create ty ('Typedef ('PGcomposite fields)) schema) schemas)
129−createTypeComposite ty fields = UnsafeDefinition $
130− "CREATE" <+> "TYPE" <+> renderSQL ty <+> "AS" <+> parenthesized
131− (renderCommaSeparated renderField fields) <> ";"
132− where
133− renderField :: Aliased (TypeExpression schemas) x -> ByteString
134− renderField (typ `As` alias) =
135− renderSQL alias <+> renderSQL typ
136−
137−-- | Composite types can also be generated from a Haskell type, for example
138−--
139−-- >>> data Complex = Complex {real :: Double, imaginary :: Double} deriving GHC.Generic
140−-- >>> instance SOP.Generic Complex
141−-- >>> instance SOP.HasDatatypeInfo Complex
142−-- >>> type Schema = '["complex" ::: 'Typedef (PG (Composite Complex))]
143−-- >>> :{
144−-- let
145−-- createComplex :: Definition (Public '[]) (Public Schema)
146−-- createComplex = createTypeCompositeFrom @Complex #complex
147−-- in
148−-- printSQL createComplex
149−-- :}
150−-- CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);
151−createTypeCompositeFrom
152− :: forall hask sch ty schemas schema.
153− ( SOP.All (FieldTyped schemas) (RowPG hask)
154− , KnownSymbol ty
155− , Has sch schemas schema )
156− => QualifiedAlias sch ty
157− -- ^ name of the user defined composite type
158− -> Definition schemas (Alter sch (Create ty ( 'Typedef (PG (Composite hask))) schema) schemas)
159−createTypeCompositeFrom ty = createTypeComposite ty
160− (SOP.hcpure (SOP.Proxy :: SOP.Proxy (FieldTyped schemas)) fieldtype
161− :: NP (Aliased (TypeExpression schemas)) (RowPG hask))
162−
163−{-|
164−`createDomain` creates a new domain. A domain is essentially a data type
165−with constraints (restrictions on the allowed set of values).
166−
167−Domains are useful for abstracting common constraints on fields
168−into a single location for maintenance. For example, several tables might
169−contain email address columns, all requiring the same `check` constraint
170−to verify the address syntax. Define a domain rather than setting up
171−each table's constraint individually.
172−
173−>>> :{
174−let
175− createPositive :: Definition (Public '[]) (Public '["positive" ::: 'Typedef 'PGfloat4])
176− createPositive = createDomain #positive real (#value .> 0 .&& (#value & isNotNull))
177−in printSQL createPositive
178−:}
179−CREATE DOMAIN "positive" AS real CHECK ((("value" > 0) AND "value" IS NOT NULL));
180−-}
181−createDomain
182− :: (Has sch schemas schema, KnownSymbol dom)
183− => QualifiedAlias sch dom
184− -> (forall null. TypeExpression schemas (null ty))
185− -> (forall tab. Condition '[] '[] 'Ungrouped schemas '[] '[tab ::: '["value" ::: 'Null ty]])
186− -> Definition schemas (Alter sch (Create dom ('Typedef ty) schema) schemas)
187−createDomain dom ty condition =
188− UnsafeDefinition $ "CREATE DOMAIN" <+> renderSQL dom
189− <+> "AS" <+> renderTypeExpression ty
190− <+> "CHECK" <+> parenthesized (renderSQL condition) <> ";"
191−
192−{- |
193−>>> :{
194−let
195− createSmallIntRange :: Definition (Public '[]) (Public '["int2range" ::: 'Typedef ('PGrange 'PGint2)])
196− createSmallIntRange = createTypeRange #int2range int2
197−in printSQL createSmallIntRange
198−:}
199−CREATE TYPE "int2range" AS RANGE (subtype = int2);
200−-}
201−createTypeRange
202− :: (Has sch schemas schema, KnownSymbol range)
203− => QualifiedAlias sch range
204− -> (forall null. TypeExpression schemas (null ty))
205− -> Definition schemas (Alter sch (Create range ('Typedef ('PGrange ty)) schema) schemas)
206−createTypeRange range ty = UnsafeDefinition $
207− "CREATE" <+> "TYPE" <+> renderSQL range <+> "AS" <+> "RANGE" <+>
208− parenthesized ("subtype" <+> "=" <+> renderTypeExpression ty) <> ";"
209−
210−-- | Drop a type.
211−--
212−-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic
213−-- >>> instance SOP.Generic Schwarma
214−-- >>> instance SOP.HasDatatypeInfo Schwarma
215−-- >>> printSQL (dropType #schwarma :: Definition '["public" ::: '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))]] (Public '[]))
216−-- DROP TYPE "schwarma";
217−dropType
218− :: (Has sch schemas schema, KnownSymbol td)
219− => QualifiedAlias sch td
220− -- ^ name of the user defined type
221− -> Definition schemas (Alter sch (DropSchemum td 'Typedef schema) schemas)
222−dropType tydef = UnsafeDefinition $ "DROP" <+> "TYPE" <+> renderSQL tydef <> ";"
223−
224−dropTypeIfExists
225− :: (Has sch schemas schema, KnownSymbol td)
226− => QualifiedAlias sch td
227− -- ^ name of the user defined type
228− -> Definition schemas (Alter sch (DropSchemumIfExists td 'Typedef schema) schemas)
229−dropTypeIfExists tydef = UnsafeDefinition $ "DROP" <+> "TYPE" <+> renderSQL tydef <> ";"
squeal-postgresql/src/Squeal/PostgreSQL/Definition/View.hsdeleted−104
@@ -1,104 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Definition.View
3−Description: Create and drop view definitions
4−Copyright: (c) Eitan Chatav, 2017
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Create and drop view definitions.
9−-}
10−
11−{-# LANGUAGE
12− AllowAmbiguousTypes
13− , ConstraintKinds
14− , DeriveAnyClass
15− , DeriveGeneric
16− , DerivingStrategies
17− , FlexibleContexts
18− , FlexibleInstances
19− , GADTs
20− , LambdaCase
21− , MultiParamTypeClasses
22− , OverloadedLabels
23− , OverloadedStrings
24− , RankNTypes
25− , ScopedTypeVariables
26− , TypeApplications
27− , TypeInType
28− , TypeOperators
29− , UndecidableSuperClasses
30−#-}
31−
32−module Squeal.PostgreSQL.Definition.View
33− ( createView
34− , createOrReplaceView
35− , dropView
36− , dropViewIfExists
37− ) where
38−
39−import GHC.TypeLits
40−
41−import Squeal.PostgreSQL.Alias
42−import Squeal.PostgreSQL.Definition
43−import Squeal.PostgreSQL.Query
44−import Squeal.PostgreSQL.Render
45−import Squeal.PostgreSQL.Schema
46−
47−-- $setup
48−-- >>> import Squeal.PostgreSQL
49−
50−{- | Create a view.
51−>>> type ABC = '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4]
52−>>> type BC = '["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4]
53−>>> :{
54−let
55− definition :: Definition
56− '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC)]]
57− '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC), "bc" ::: 'View BC]]
58− definition =
59− createView #bc (select_ (#b :* #c) (from (table #abc)))
60−in printSQL definition
61−:}
62−CREATE VIEW "bc" AS SELECT "b" AS "b", "c" AS "c" FROM "abc" AS "abc";
63−-}
64−createView
65− :: (Has sch schemas schema, KnownSymbol vw)
66− => QualifiedAlias sch vw -- ^ the name of the view to add
67− -> Query '[] '[] schemas '[] view -- ^ query
68− -> Definition schemas (Alter sch (Create vw ('View view) schema) schemas)
69−createView alias query = UnsafeDefinition $
70− "CREATE" <+> "VIEW" <+> renderSQL alias <+> "AS"
71− <+> renderQuery query <> ";"
72−
73−createOrReplaceView
74− :: (Has sch schemas schema, KnownSymbol vw)
75− => QualifiedAlias sch vw -- ^ the name of the view to add
76− -> Query '[] '[] schemas '[] view -- ^ query
77− -> Definition schemas (Alter sch (CreateOrReplace vw ('View view) schema) schemas)
78−createOrReplaceView alias query = UnsafeDefinition $
79− "CREATE OR REPLACE VIEW" <+> renderSQL alias <+> "AS"
80− <+> renderQuery query <> ";"
81−
82−-- | Drop a view.
83−--
84−-- >>> :{
85−-- let
86−-- definition :: Definition
87−-- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])
88−-- , "bc" ::: 'View ('["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4])]]
89−-- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])]]
90−-- definition = dropView #bc
91−-- in printSQL definition
92−-- :}
93−-- DROP VIEW "bc";
94−dropView
95− :: (Has sch schemas schema, KnownSymbol vw)
96− => QualifiedAlias sch vw -- ^ view to remove
97− -> Definition schemas (Alter sch (DropSchemum vw 'View schema) schemas)
98−dropView vw = UnsafeDefinition $ "DROP VIEW" <+> renderSQL vw <> ";"
99−
100−dropViewIfExists
101− :: (Has sch schemas schema, KnownSymbol vw)
102− => QualifiedAlias sch vw -- ^ view to remove
103− -> Definition schemas (Alter sch (DropIfExists vw schema) schemas)
104−dropViewIfExists vw = UnsafeDefinition $ "DROP VIEW IF EXISTS" <+> renderSQL vw <> ";"
squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs+17−91
@@ -34,26 +34,17 @@ module Squeal.PostgreSQL.Expression
3434 ( -- * Expression
3535 Expression (..)
3636 , Expr
37− , type (-->)
38− , FunctionDB
37+ , (:-->)
3938 , unsafeFunction
40− , function
41− , unsafeLeftOp
42− , leftOp
43− , unsafeRightOp
44− , rightOp
39+ , unsafeUnaryOpL
40+ , unsafeUnaryOpR
4541 , Operator
46− , OperatorDB
4742 , unsafeBinaryOp
48− , binaryOp
4943 , FunctionVar
5044 , unsafeFunctionVar
51− , type (--->)
52− , FunctionNDB
45+ , FunctionN
5346 , unsafeFunctionN
54− , functionN
5547 , PGSubset (..)
56− , PGIntersect (..)
5748 -- * Re-export
5849 , (&)
5950 , K (..)
@@ -145,54 +136,31 @@ type Operator x1 x2 y
145136 -> Expression outer commons grp schemas params from y
146137 -- ^ output
147138
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−
157139-- | A @RankNType@ for functions with a single argument.
158140-- These could be either function calls or unary operators.
159141-- This is a subtype of the usual Haskell function type `Prelude.->`,
160142-- indeed a subcategory as it is closed under the usual
161143-- `Prelude..` and `Prelude.id`.
162−type (-->) x y
144+type (:-->) x y
163145 = forall outer commons grp schemas params from
164146 . Expression outer commons grp schemas params from x
165147 -- ^ input
166148 -> Expression outer commons grp schemas params from y
167149 -- ^ output
168150
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−
176151{- | A @RankNType@ for functions with a fixed-length list of heterogeneous arguments.
177152Use the `*:` operator to end your argument lists, like so.
178153
179154>>> printSQL (unsafeFunctionN "fun" (true :* false :* localTime *: true))
180155fun(TRUE, FALSE, LOCALTIME, TRUE)
181156-}
182−type (--->) xs y
157+type FunctionN xs y
183158 = forall outer commons grp schemas params from
184159 . NP (Expression outer commons grp schemas params from) xs
185160 -- ^ inputs
186161 -> Expression outer commons grp schemas params from y
187162 -- ^ output
188163
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−
196164{- | A @RankNType@ for functions with a variable-length list of
197165homogeneous arguments and at least 1 more argument.
198166-}
@@ -318,63 +286,28 @@ unsafeBinaryOp :: ByteString -> Operator ty0 ty1 ty2
318286unsafeBinaryOp op x y = UnsafeExpression $ parenthesized $
319287 renderSQL x <+> op <+> renderSQL y
320288
321−binaryOp
322− :: forall op sch schemas schema x y z.
323− ( Has sch schemas schema
324− , Has op schema ('Operator ('BinaryOp x y z)) )
325− => OperatorDB schemas x y z
326−binaryOp = unsafeBinaryOp $ renderSymbol @op
327−
328−-- | >>> printSQL $ unsafeLeftOp "NOT" true
289+-- | >>> printSQL $ unsafeUnaryOpL "NOT" true
329290-- (NOT TRUE)
330−unsafeLeftOp :: ByteString -> x --> y
331−unsafeLeftOp op x = UnsafeExpression $ parenthesized $ op <+> renderSQL x
291+unsafeUnaryOpL :: ByteString -> x :--> y
292+unsafeUnaryOpL op x = UnsafeExpression $ parenthesized $ op <+> renderSQL x
332293
333−leftOp
334− :: forall op sch schemas schema x y.
335− ( Has sch schemas schema
336− , Has op schema ('Operator ('LeftOp x y)) )
337− => FunctionDB schemas x y
338−leftOp = unsafeLeftOp $ renderSymbol @op
339−
340−-- | >>> printSQL $ true & unsafeRightOp "IS NOT TRUE"
294+-- | >>> printSQL $ true & unsafeUnaryOpR "IS NOT TRUE"
341295-- (TRUE IS NOT TRUE)
342−unsafeRightOp :: ByteString -> x --> y
343−unsafeRightOp op x = UnsafeExpression $ parenthesized $ renderSQL x <+> op
344−
345−rightOp
346− :: forall op sch schemas schema x y.
347− ( Has sch schemas schema
348− , Has op schema ('Operator ('RightOp x y)) )
349− => FunctionDB schemas x y
350−rightOp = unsafeRightOp $ renderSymbol @op
296+unsafeUnaryOpR :: ByteString -> x :--> y
297+unsafeUnaryOpR op x = UnsafeExpression $ parenthesized $ renderSQL x <+> op
351298
352299-- | >>> printSQL $ unsafeFunction "f" true
353300-- f(TRUE)
354−unsafeFunction :: ByteString -> x --> y
301+unsafeFunction :: ByteString -> x :--> y
355302unsafeFunction fun x = UnsafeExpression $
356303 fun <> parenthesized (renderSQL x)
357304
358−function
359− :: (Has sch schemas schema, Has fun schema ('Function ('[x] :=> 'Returns y)))
360− => QualifiedAlias sch fun
361− -> FunctionDB schemas x y
362−function = unsafeFunction . renderSQL
363−
364305-- | >>> printSQL $ unsafeFunctionN "f" (currentTime :* localTimestamp :* false *: literal 'a')
365306-- f(CURRENT_TIME, LOCALTIMESTAMP, FALSE, E'a')
366−unsafeFunctionN :: SListI xs => ByteString -> xs ---> y
307+unsafeFunctionN :: SListI xs => ByteString -> FunctionN xs y
367308unsafeFunctionN fun xs = UnsafeExpression $
368309 fun <> parenthesized (renderCommaSeparated renderSQL xs)
369310
370−functionN
371− :: ( Has sch schemas schema
372− , Has fun schema ('Function (xs :=> 'Returns y))
373− , SListI xs )
374− => QualifiedAlias sch fun
375− -> FunctionNDB schemas xs y
376−functionN = unsafeFunctionN . renderSQL
377−
378311instance ty `In` PGNum
379312 => Num (Expression outer commons grp schemas params from (null ty)) where
380313 (+) = unsafeBinaryOp "+"
@@ -420,21 +353,14 @@ instance (ty `In` PGNum, ty `In` PGFloating) => Floating
420353 atanh x = log ((1 + x) / (1 - x)) / 2
421354
422355-- | Contained by operators
423−class PGSubset ty where
424− (@>) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
356+class PGSubset container where
357+ (@>) :: Operator (null0 container) (null1 container) ('Null 'PGbool)
425358 (@>) = unsafeBinaryOp "@>"
426− (<@) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
359+ (<@) :: Operator (null0 container) (null1 container) ('Null 'PGbool)
427360 (<@) = unsafeBinaryOp "<@"
428361instance PGSubset 'PGjsonb
429362instance PGSubset 'PGtsquery
430363instance PGSubset ('PGvararray ty)
431−instance PGSubset ('PGrange ty)
432−
433−class PGIntersect ty where
434− (@&&) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
435− (@&&) = unsafeBinaryOp "&&"
436−instance PGIntersect ('PGvararray ty)
437−instance PGIntersect ('PGrange ty)
438364
439365instance IsString
440366 (Expression outer commons grp schemas params from (null 'PGtext)) where
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Aggregate.hs+3−18
@@ -26,7 +26,6 @@ Aggregate functions
2626module Squeal.PostgreSQL.Expression.Aggregate
2727 ( Aggregate (..)
2828 , Distinction (..)
29− , PGSum
3029 , PGAvg
3130 ) where
3231
@@ -86,8 +85,9 @@ class Aggregate expr1 exprN aggr
8685 -- :}
8786 -- sum(DISTINCT "col")
8887 sum_
89− :: expr1 (null ty)
90− -> aggr ('Null (PGSum ty))
88+ :: ty `In` PGNum
89+ => expr1 (null ty)
90+ -> aggr ('Null ty)
9191
9292 -- | input values, including nulls, concatenated into an array
9393 arrayAgg
@@ -434,21 +434,6 @@ unsafeAggregateN
434434 -> Expression outer commons ('Grouped bys) schemas params from y
435435unsafeAggregateN fun xs = UnsafeExpression $ fun <> parenthesized (renderSQL xs)
436436
437−-- | A type family that calculates `PGSum``PGType` of
438−-- a given argument `PGType`.
439−type family PGSum ty where
440− PGSum 'PGint2 = 'PGint8
441− PGSum 'PGint4 = 'PGint8
442− PGSum 'PGint8 = 'PGnumeric
443− PGSum 'PGfloat4 = 'PGfloat4
444− PGSum 'PGfloat8 = 'PGfloat8
445− PGSum 'PGnumeric = 'PGnumeric
446− PGSum 'PGinterval = 'PGinterval
447− PGSum 'PGmoney = 'PGmoney
448− PGSum pg = TypeError
449− ( 'Text "Squeal type error: Cannot sum with argument type "
450− ':<>: 'ShowType pg )
451−
452437-- | A type family that calculates `PGAvg` type of a `PGType`.
453438type family PGAvg ty where
454439 PGAvg 'PGint2 = 'PGnumeric
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Collection.hs+5−5
@@ -42,7 +42,7 @@ import qualified Generics.SOP as SOP
4242
4343import Squeal.PostgreSQL.Alias
4444import Squeal.PostgreSQL.Expression
45−import Squeal.PostgreSQL.Expression.Set
45+import Squeal.PostgreSQL.Expression.SetOf
4646import Squeal.PostgreSQL.List
4747import Squeal.PostgreSQL.Render
4848import Squeal.PostgreSQL.Schema
@@ -111,20 +111,20 @@ array2 xss = UnsafeExpression $ "ARRAY" <>
111111
112112-- | >>> printSQL $ cardinality (array [null_, false, true])
113113-- cardinality(ARRAY[NULL, FALSE, TRUE])
114−cardinality :: null ('PGvararray ty) --> null 'PGint8
114+cardinality :: null ('PGvararray ty) :--> null 'PGint8
115115cardinality = unsafeFunction "cardinality"
116116
117117-- | >>> printSQL $ array [null_, false, true] & index 2
118118-- (ARRAY[NULL, FALSE, TRUE])[2]
119119index
120120 :: Word64 -- ^ index
121− -> null ('PGvararray ty) --> NullifyType ty
121+ -> null ('PGvararray ty) :--> NullifyType ty
122122index n expr = UnsafeExpression $
123123 parenthesized (renderSQL expr) <> "[" <> fromString (show n) <> "]"
124124
125125-- | Expand an array to a set of rows
126−unnest :: SetFunction "unnest" (null ('PGvararray ty)) '["unnest" ::: ty]
127−unnest = unsafeSetFunction
126+unnest :: SetOfFunction "unnest" (null ('PGvararray ty)) '["unnest" ::: ty]
127+unnest = unsafeSetOfFunction
128128
129129-- | A row constructor is an expression that builds a row value
130130-- (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"
162162>>> printSQL $ true & isTrue
163163(TRUE IS TRUE)
164164-}
165−isTrue :: null0 'PGbool --> null1 'PGbool
166−isTrue = unsafeRightOp "IS TRUE"
165+isTrue :: null0 'PGbool :--> null1 'PGbool
166+isTrue = unsafeUnaryOpR "IS TRUE"
167167
168168{- | is false or unknown
169169
170170>>> printSQL $ true & isNotTrue
171171(TRUE IS NOT TRUE)
172172-}
173−isNotTrue :: null0 'PGbool --> null1 'PGbool
174−isNotTrue = unsafeRightOp "IS NOT TRUE"
173+isNotTrue :: null0 'PGbool :--> null1 'PGbool
174+isNotTrue = unsafeUnaryOpR "IS NOT TRUE"
175175
176176{- | is false
177177
178178>>> printSQL $ true & isFalse
179179(TRUE IS FALSE)
180180-}
181−isFalse :: null0 'PGbool --> null1 'PGbool
182−isFalse = unsafeRightOp "IS FALSE"
181+isFalse :: null0 'PGbool :--> null1 'PGbool
182+isFalse = unsafeUnaryOpR "IS FALSE"
183183
184184{- | is true or unknown
185185
186186>>> printSQL $ true & isNotFalse
187187(TRUE IS NOT FALSE)
188188-}
189−isNotFalse :: null0 'PGbool --> null1 'PGbool
190−isNotFalse = unsafeRightOp "IS NOT FALSE"
189+isNotFalse :: null0 'PGbool :--> null1 'PGbool
190+isNotFalse = unsafeUnaryOpR "IS NOT FALSE"
191191
192192{- | is unknown
193193
194194>>> printSQL $ true & isUnknown
195195(TRUE IS UNKNOWN)
196196-}
197−isUnknown :: null0 'PGbool --> null1 'PGbool
198−isUnknown = unsafeRightOp "IS UNKNOWN"
197+isUnknown :: null0 'PGbool :--> null1 'PGbool
198+isUnknown = unsafeUnaryOpR "IS UNKNOWN"
199199
200200{- | is true or false
201201
202202>>> printSQL $ true & isNotUnknown
203203(TRUE IS NOT UNKNOWN)
204204-}
205−isNotUnknown :: null0 'PGbool --> null1 'PGbool
206−isNotUnknown = unsafeRightOp "IS NOT UNKNOWN"
205+isNotUnknown :: null0 'PGbool :--> null1 'PGbool
206+isNotUnknown = unsafeUnaryOpR "IS NOT UNKNOWN"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Json.hs+47−40
@@ -81,7 +81,7 @@ import GHC.TypeLits
8181
8282import Squeal.PostgreSQL.Alias
8383import Squeal.PostgreSQL.Expression
84−import Squeal.PostgreSQL.Expression.Set
84+import Squeal.PostgreSQL.Expression.SetOf
8585import Squeal.PostgreSQL.Expression.Type
8686import Squeal.PostgreSQL.List
8787import Squeal.PostgreSQL.Query
@@ -188,7 +188,7 @@ Table 9.45: JSON creation functions
188188-- otherwise, a scalar value is produced. For any scalar type other than a
189189-- number, a Boolean, or a null value, the text representation will be used, in
190190-- such a fashion that it is a valid json value.
191−toJson :: null ty --> null 'PGjson
191+toJson :: null ty :--> null 'PGjson
192192toJson = unsafeFunction "to_json"
193193
194194-- | Returns the value as jsonb. Arrays and composites are converted
@@ -197,26 +197,26 @@ toJson = unsafeFunction "to_json"
197197-- otherwise, a scalar value is produced. For any scalar type other than a
198198-- number, a Boolean, or a null value, the text representation will be used, in
199199-- such a fashion that it is a valid jsonb value.
200−toJsonb :: null ty --> null 'PGjsonb
200+toJsonb :: null ty :--> null 'PGjsonb
201201toJsonb = unsafeFunction "to_jsonb"
202202
203203-- | Returns the array as a JSON array. A PostgreSQL multidimensional array
204204-- becomes a JSON array of arrays.
205−arrayToJson :: null ('PGvararray ty) --> null 'PGjson
205+arrayToJson :: null ('PGvararray ty) :--> null 'PGjson
206206arrayToJson = unsafeFunction "array_to_json"
207207
208208-- | Returns the row as a JSON object.
209−rowToJson :: null ('PGcomposite ty) --> null 'PGjson
209+rowToJson :: null ('PGcomposite ty) :--> null 'PGjson
210210rowToJson = unsafeFunction "row_to_json"
211211
212212-- | Builds a possibly-heterogeneously-typed JSON array out of a variadic
213213-- argument list.
214−jsonBuildArray :: SOP.SListI tuple => tuple ---> null 'PGjson
214+jsonBuildArray :: SOP.SListI tuple => FunctionN tuple (null 'PGjson)
215215jsonBuildArray = unsafeFunctionN "json_build_array"
216216
217217-- | Builds a possibly-heterogeneously-typed (binary) JSON array out of a
218218-- variadic argument list.
219−jsonbBuildArray :: SOP.SListI tuple => tuple ---> null 'PGjsonb
219+jsonbBuildArray :: SOP.SListI tuple => FunctionN tuple (null 'PGjsonb)
220220jsonbBuildArray = unsafeFunctionN "jsonb_build_array"
221221
222222-- | Builds a possibly-heterogeneously-typed JSON object out of a variadic
@@ -224,10 +224,10 @@ jsonbBuildArray = unsafeFunctionN "jsonb_build_array"
224224-- and values.
225225class SOP.SListI tys => JsonBuildObject tys where
226226
227− jsonBuildObject :: tys ---> null 'PGjson
227+ jsonBuildObject :: FunctionN tys (null 'PGjson)
228228 jsonBuildObject = unsafeFunctionN "json_build_object"
229229
230− jsonbBuildObject :: tys ---> null 'PGjsonb
230+ jsonbBuildObject :: FunctionN tys (null 'PGjsonb)
231231 jsonbBuildObject = unsafeFunctionN "jsonb_build_object"
232232
233233instance JsonBuildObject '[]
@@ -240,7 +240,7 @@ instance (JsonBuildObject tys, key `In` PGJsonKey)
240240-- which are taken as a key/value pair.
241241jsonObject
242242 :: null ('PGfixarray '[n,2] ('NotNull 'PGtext))
243− --> null 'PGjson
243+ :--> null 'PGjson
244244jsonObject = unsafeFunction "json_object"
245245
246246-- | Builds a binary JSON object out of a text array.
@@ -249,24 +249,24 @@ jsonObject = unsafeFunction "json_object"
249249-- which are taken as a key/value pair.
250250jsonbObject
251251 :: null ('PGfixarray '[n,2] ('NotNull 'PGtext))
252− --> null 'PGjsonb
252+ :--> null 'PGjsonb
253253jsonbObject = unsafeFunction "jsonb_object"
254254
255255-- | This is an alternate form of 'jsonObject' that takes two arrays; one for
256256-- keys and one for values, that are zipped pairwise to create a JSON object.
257−jsonZipObject ::
257+jsonZipObject :: FunctionN
258258 '[ null ('PGvararray ('NotNull 'PGtext))
259259 , null ('PGvararray ('NotNull 'PGtext)) ]
260− ---> null 'PGjson
260+ ( null 'PGjson )
261261jsonZipObject = unsafeFunctionN "json_object"
262262
263263-- | This is an alternate form of 'jsonbObject' that takes two arrays; one for
264264-- keys and one for values, that are zipped pairwise to create a binary JSON
265265-- object.
266−jsonbZipObject ::
266+jsonbZipObject :: FunctionN
267267 '[ null ('PGvararray ('NotNull 'PGtext))
268268 , null ('PGvararray ('NotNull 'PGtext)) ]
269− ---> null 'PGjsonb
269+ ( null 'PGjsonb )
270270jsonbZipObject = unsafeFunctionN "jsonb_object"
271271
272272{-----------------------------------------
@@ -274,31 +274,31 @@ Table 9.46: JSON processing functions
274274-----------------------------------------}
275275
276276-- | Returns the number of elements in the outermost JSON array.
277−jsonArrayLength :: null 'PGjson --> null 'PGint4
277+jsonArrayLength :: null 'PGjson :--> null 'PGint4
278278jsonArrayLength = unsafeFunction "json_array_length"
279279
280280-- | Returns the number of elements in the outermost binary JSON array.
281−jsonbArrayLength :: null 'PGjsonb --> null 'PGint4
281+jsonbArrayLength :: null 'PGjsonb :--> null 'PGint4
282282jsonbArrayLength = unsafeFunction "jsonb_array_length"
283283
284284-- | Returns the type of the outermost JSON value as a text string. Possible
285285-- types are object, array, string, number, boolean, and null.
286−jsonTypeof :: null 'PGjson --> null 'PGtext
286+jsonTypeof :: null 'PGjson :--> null 'PGtext
287287jsonTypeof = unsafeFunction "json_typeof"
288288
289289-- | Returns the type of the outermost binary JSON value as a text string.
290290-- Possible types are object, array, string, number, boolean, and null.
291−jsonbTypeof :: null 'PGjsonb --> null 'PGtext
291+jsonbTypeof :: null 'PGjsonb :--> null 'PGtext
292292jsonbTypeof = unsafeFunction "jsonb_typeof"
293293
294294-- | Returns its argument with all object fields that have null values omitted.
295295-- Other null values are untouched.
296−jsonStripNulls :: null 'PGjson --> null 'PGjson
296+jsonStripNulls :: null 'PGjson :--> null 'PGjson
297297jsonStripNulls = unsafeFunction "json_strip_nulls"
298298
299299-- | Returns its argument with all object fields that have null values omitted.
300300-- Other null values are untouched.
301−jsonbStripNulls :: null 'PGjsonb --> null 'PGjsonb
301+jsonbStripNulls :: null 'PGjsonb :--> null 'PGjsonb
302302jsonbStripNulls = unsafeFunction "jsonb_strip_nulls"
303303
304304-- | @ jsonbSet target path new_value create_missing @
@@ -309,9 +309,12 @@ jsonbStripNulls = unsafeFunction "jsonb_strip_nulls"
309309-- item designated by path does not exist. As with the path orientated
310310-- operators, negative integers that appear in path count from the end of JSON
311311-- arrays.
312−jsonbSet ::
313− '[ null 'PGjsonb, null ('PGvararray ('NotNull 'PGtext))
314− , null 'PGjsonb, null 'PGbool ] ---> null 'PGjsonb
312+jsonbSet
313+ :: FunctionN
314+ '[ null 'PGjsonb
315+ , null ('PGvararray ('NotNull 'PGtext))
316+ , null 'PGjsonb
317+ , null 'PGbool ] (null 'PGjsonb)
315318jsonbSet = unsafeFunctionN "jsonbSet"
316319
317320-- | @ jsonbInsert target path new_value insert_after @
@@ -323,23 +326,27 @@ jsonbSet = unsafeFunctionN "jsonbSet"
323326-- path is in JSONB object, @new_value@ will be inserted only if target does not
324327-- exist. As with the path orientated operators, negative integers that appear
325328-- in path count from the end of JSON arrays.
326−jsonbInsert ::
327− '[ null 'PGjsonb, null ('PGvararray ('NotNull 'PGtext))
328− , null 'PGjsonb, null 'PGbool ] ---> null 'PGjsonb
329+jsonbInsert
330+ :: FunctionN
331+ '[ null 'PGjsonb
332+ , null ('PGvararray ('NotNull 'PGtext))
333+ , null 'PGjsonb
334+ , null 'PGbool ] (null 'PGjsonb)
329335jsonbInsert = unsafeFunctionN "jsonb_insert"
330336
331337-- | Returns its argument as indented JSON text.
332−jsonbPretty :: null 'PGjsonb --> null 'PGtext
338+jsonbPretty :: null 'PGjsonb :--> null 'PGtext
333339jsonbPretty = unsafeFunction "jsonb_pretty"
334340
341+
335342{- | Expands the outermost JSON object into a set of key/value pairs.
336343
337344>>> printSQL (select Star (from (jsonEach (literal (Json (object ["a" .= "foo", "b" .= "bar"]))))))
338345SELECT * FROM json_each(('{"a":"foo","b":"bar"}' :: json))
339346-}
340−jsonEach :: SetFunction "json_each" (null 'PGjson)
347+jsonEach :: SetOfFunction "json_each" (null 'PGjson)
341348 '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGjson]
342−jsonEach = unsafeSetFunction
349+jsonEach = unsafeSetOfFunction
343350
344351{- | Expands the outermost binary JSON object into a set of key/value pairs.
345352
@@ -347,9 +354,9 @@ jsonEach = unsafeSetFunction
347354SELECT * FROM jsonb_each(('{"a":"foo","b":"bar"}' :: jsonb))
348355-}
349356jsonbEach
350− :: SetFunction "jsonb_each" (nullity 'PGjsonb)
357+ :: SetOfFunction "jsonb_each" (nullity 'PGjsonb)
351358 '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGjson]
352−jsonbEach = unsafeSetFunction
359+jsonbEach = unsafeSetOfFunction
353360
354361{- | Expands the outermost JSON object into a set of key/value pairs.
355362
@@ -357,9 +364,9 @@ jsonbEach = unsafeSetFunction
357364SELECT * FROM json_each_text(('{"a":"foo","b":"bar"}' :: json))
358365-}
359366jsonEachText
360− :: SetFunction "json_each_text" (null 'PGjson)
367+ :: SetOfFunction "json_each_text" (null 'PGjson)
361368 '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext]
362−jsonEachText = unsafeSetFunction
369+jsonEachText = unsafeSetOfFunction
363370
364371{- | Expands the outermost binary JSON object into a set of key/value pairs.
365372
@@ -367,9 +374,9 @@ jsonEachText = unsafeSetFunction
367374SELECT * FROM jsonb_each_text(('{"a":"foo","b":"bar"}' :: jsonb))
368375-}
369376jsonbEachText
370− :: SetFunction "jsonb_each_text" (null 'PGjsonb)
377+ :: SetOfFunction "jsonb_each_text" (null 'PGjsonb)
371378 '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext]
372−jsonbEachText = unsafeSetFunction
379+jsonbEachText = unsafeSetOfFunction
373380
374381{- | Returns set of keys in the outermost JSON object.
375382
@@ -377,9 +384,9 @@ jsonbEachText = unsafeSetFunction
377384json_object_keys(('{"a":"foo","b":"bar"}' :: json))
378385-}
379386jsonObjectKeys
380− :: SetFunction "json_object_keys" (nullity 'PGjson)
387+ :: SetOfFunction "json_object_keys" (nullity 'PGjson)
381388 '["json_object_keys" ::: 'NotNull 'PGtext]
382−jsonObjectKeys = unsafeSetFunction
389+jsonObjectKeys = unsafeSetOfFunction
383390
384391{- | Returns set of keys in the outermost JSON object.
385392
@@ -387,9 +394,9 @@ jsonObjectKeys = unsafeSetFunction
387394jsonb_object_keys(('{"a":"foo","b":"bar"}' :: jsonb))
388395-}
389396jsonbObjectKeys
390− :: SetFunction "jsonb_object_keys" (null 'PGjsonb)
397+ :: SetOfFunction "jsonb_object_keys" (null 'PGjsonb)
391398 '["jsonb_object_keys" ::: 'NotNull 'PGtext]
392−jsonbObjectKeys = unsafeSetFunction
399+jsonbObjectKeys = unsafeSetOfFunction
393400
394401-- | Build rows from Json types.
395402type JsonPopulateFunction fun json
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Logic.hs+2−2
@@ -47,8 +47,8 @@ false = UnsafeExpression "FALSE"
4747
4848-- | >>> printSQL $ not_ true
4949-- (NOT TRUE)
50−not_ :: null 'PGbool --> null 'PGbool
51−not_ = unsafeLeftOp "NOT"
50+not_ :: null 'PGbool :--> null 'PGbool
51+not_ = unsafeUnaryOpL "NOT"
5252
5353-- | >>> printSQL $ true .&& false
5454-- (TRUE AND FALSE)
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Math.hs+6−4
@@ -37,7 +37,9 @@ import Squeal.PostgreSQL.Schema
3737-- in printSQL expression
3838-- :}
3939-- atan2(pi(), 2)
40−atan2_ :: float `In` PGFloating => '[ null float, null float] ---> null float
40+atan2_
41+ :: float `In` PGFloating
42+ => FunctionN '[ null float, null float] (null float)
4143atan2_ = unsafeFunctionN "atan2"
4244
4345
@@ -76,7 +78,7 @@ rem_ = unsafeBinaryOp "%"
7678-- in printSQL expression
7779-- :}
7880-- trunc(pi())
79−trunc :: frac `In` PGFloating => null frac --> null frac
81+trunc :: frac `In` PGFloating => null frac :--> null frac
8082trunc = unsafeFunction "trunc"
8183
8284-- | >>> :{
@@ -86,7 +88,7 @@ trunc = unsafeFunction "trunc"
8688-- in printSQL expression
8789-- :}
8890-- round(pi())
89−round_ :: frac `In` PGFloating => null frac --> null frac
91+round_ :: frac `In` PGFloating => null frac :--> null frac
9092round_ = unsafeFunction "round"
9193
9294-- | >>> :{
@@ -96,5 +98,5 @@ round_ = unsafeFunction "round"
9698-- in printSQL expression
9799-- :}
98100-- ceiling(pi())
99−ceiling_ :: frac `In` PGFloating => null frac --> null frac
101+ceiling_ :: frac `In` PGFloating => null frac :--> null frac
100102ceiling_ = unsafeFunction "ceiling"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Null.hs+4−4
@@ -44,7 +44,7 @@ null_ = UnsafeExpression "NULL"
4444--
4545-- >>> printSQL $ notNull true
4646-- TRUE
47−notNull :: 'NotNull ty --> 'Null ty
47+notNull :: 'NotNull ty :--> 'Null ty
4848notNull = UnsafeExpression . renderSQL
4949
5050-- | return the leftmost value which is not NULL
@@ -69,12 +69,12 @@ fromNull notNullx nullx = coalesce [nullx] notNullx
6969
7070-- | >>> printSQL $ null_ & isNull
7171-- NULL IS NULL
72−isNull :: 'Null ty --> null 'PGbool
72+isNull :: 'Null ty :--> null 'PGbool
7373isNull x = UnsafeExpression $ renderSQL x <+> "IS NULL"
7474
7575-- | >>> printSQL $ null_ & isNotNull
7676-- NULL IS NOT NULL
77−isNotNull :: 'Null ty --> null 'PGbool
77+isNotNull :: 'Null ty :--> null 'PGbool
7878isNotNull x = UnsafeExpression $ renderSQL x <+> "IS NOT NULL"
7979
8080-- | analagous to `maybe` using @IS NULL@
@@ -100,5 +100,5 @@ matchNull y f x = ifThenElse (isNull x) y
100100>>> printSQL expr
101101NULLIF(FALSE, ($1 :: bool))
102102-}
103−nullIf :: '[ 'NotNull ty, 'NotNull ty] ---> 'Null ty
103+nullIf :: FunctionN '[ 'NotNull ty, 'NotNull ty] ('Null ty)
104104nullIf = unsafeFunctionN "NULLIF"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Range.hsdeleted−230
@@ -1,230 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Expression.Range
3−Description: range types and functions
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Range types and functions
9−-}
10−
11−{-# LANGUAGE
12− AllowAmbiguousTypes
13− , DataKinds
14− , DeriveAnyClass
15− , DeriveGeneric
16− , DeriveFoldable
17− , DerivingStrategies
18− , DeriveTraversable
19− , FlexibleContexts
20− , FlexibleInstances
21− , LambdaCase
22− , MultiParamTypeClasses
23− , OverloadedLabels
24− , OverloadedStrings
25− , PatternSynonyms
26− , RankNTypes
27− , ScopedTypeVariables
28− , TypeApplications
29− , TypeFamilies
30− , TypeOperators
31− , UndecidableInstances
32−#-}
33−
34−module Squeal.PostgreSQL.Expression.Range
35− ( range
36− , Range (..)
37− , (<=..<=), (<..<), (<=..<), (<..<=)
38− , moreThan, atLeast, lessThan, atMost
39− , singleton, whole
40− , Bound (..)
41− , (.<@)
42− , (@>.)
43− , (<<@)
44− , (@>>)
45− , (&<)
46− , (&>)
47− , (-|-)
48− , (@+)
49− , (@*)
50− , (@-)
51− , lowerBound
52− , upperBound
53− , isEmpty
54− , lowerInc
55− , lowerInf
56− , upperInc
57− , upperInf
58− , rangeMerge
59− ) where
60−
61−import BinaryParser
62−import ByteString.StrictBuilder
63−import Data.Bits
64−import qualified GHC.Generics as GHC
65−import qualified Generics.SOP as SOP
66−import qualified PostgreSQL.Binary.Decoding as Decoding
67−
68−import Squeal.PostgreSQL.Binary
69−import Squeal.PostgreSQL.Expression
70−import Squeal.PostgreSQL.Expression.Type hiding (bool)
71−import Squeal.PostgreSQL.PG
72−import Squeal.PostgreSQL.Render
73−import Squeal.PostgreSQL.Schema
74−
75−-- $setup
76−-- >>> import Squeal.PostgreSQL
77−
78−-- | Construct a `range`
79−--
80−-- >>> printSQL $ range tstzrange (atLeast now)
81−-- tstzrange(now(), NULL, '[)')
82−-- >>> printSQL $ range numrange (0 <=..< 2*pi)
83−-- numrange(0, (2 * pi()), '[)')
84−-- >>> printSQL $ range int4range Empty
85−-- ('empty' :: int4range)
86−range
87− :: TypeExpression schemas (null ('PGrange ty))
88− -> Range (Expression outer commons grp schemas params from ('NotNull ty))
89− -> Expression outer commons grp schemas params from (null ('PGrange ty))
90−range ty = \case
91− Empty -> UnsafeExpression $ parenthesized
92− (emp <+> "::" <+> renderSQL ty)
93− NonEmpty l u -> UnsafeExpression $ renderSQL ty <> parenthesized
94− (commaSeparated (args l u))
95− where
96− emp = singleQuote <> "empty" <> singleQuote
97− args l u = [arg l, arg u, singleQuote <> bra l <> ket u <> singleQuote]
98− singleQuote = "\'"
99− arg = \case
100− Infinite -> "NULL"; Closed x -> renderSQL x; Open x -> renderSQL x
101− bra = \case Infinite -> "("; Closed _ -> "["; Open _ -> "("
102− ket = \case Infinite -> ")"; Closed _ -> "]"; Open _ -> ")"
103−
104−data Bound x = Infinite | Closed x | Open x
105− deriving
106− ( Eq, Ord, Show, Read, GHC.Generic
107− , Functor, Foldable, Traversable )
108−
109−data Range x = Empty | NonEmpty (Bound x) (Bound x)
110− deriving
111− ( Eq, Ord, Show, Read, GHC.Generic
112− , Functor, Foldable, Traversable )
113− deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
114−type instance PG (Range x) = 'PGrange (PG x)
115−instance ToParam x pg => ToParam (Range x) ('PGrange pg) where
116− toParam rng = K $
117− word8 (setFlags rng 0) <>
118− case rng of
119− Empty -> mempty
120− NonEmpty lower upper -> putBound lower <> putBound upper
121− where
122− putBound = \case
123− Infinite -> mempty
124− Closed value -> putValue (unK (toParam @x @pg value))
125− Open value -> putValue (unK (toParam @x @pg value))
126− putValue value = int32BE (fromIntegral (builderLength value)) <> value
127− setFlags = \case
128− Empty -> (`setBit` 0)
129− NonEmpty lower upper ->
130− setLowerFlags lower . setUpperFlags upper
131− setLowerFlags = \case
132− Infinite -> (`setBit` 3)
133− Closed _ -> (`setBit` 1)
134− Open _ -> id
135− setUpperFlags = \case
136− Infinite -> (`setBit` 4)
137− Closed _ -> (`setBit` 2)
138− Open _ -> id
139−instance FromValue pg y => FromValue ('PGrange pg) (Range y) where
140− fromValue = do
141− flag <- byte
142− if testBit flag 0 then return Empty else do
143− lower <-
144− if testBit flag 3
145− then return Infinite
146− else do
147− len <- sized 4 Decoding.int
148− l <- sized len (fromValue @pg)
149− return $ if testBit flag 1 then Closed l else Open l
150− upper <-
151− if testBit flag 4
152− then return Infinite
153− else do
154− len <- sized 4 Decoding.int
155− l <- sized len (fromValue @pg)
156− return $ if testBit flag 2 then Closed l else Open l
157− return $ NonEmpty lower upper
158−
159−(<=..<=), (<..<), (<=..<), (<..<=) :: x -> x -> Range x
160−infix 4 <=..<=, <..<, <=..<, <..<=
161−x <=..<= y = NonEmpty (Closed x) (Closed y)
162−x <..< y = NonEmpty (Open x) (Open y)
163−x <=..< y = NonEmpty (Closed x) (Open y)
164−x <..<= y = NonEmpty (Open x) (Closed y)
165−
166−moreThan, atLeast, lessThan, atMost :: x -> Range x
167−moreThan x = NonEmpty (Open x) Infinite
168−atLeast x = NonEmpty (Closed x) Infinite
169−lessThan x = NonEmpty Infinite (Open x)
170−atMost x = NonEmpty Infinite (Closed x)
171−
172−singleton :: x -> Range x
173−singleton x = x <=..<= x
174−
175−whole :: Range x
176−whole = NonEmpty Infinite Infinite
177−
178−(.<@) :: Operator ('NotNull ty) (null ('PGrange ty)) ('Null 'PGbool)
179−(.<@) = unsafeBinaryOp "<@"
180−
181−(@>.) :: Operator (null ('PGrange ty)) ('NotNull ty) ('Null 'PGbool)
182−(@>.) = unsafeBinaryOp "<@"
183−
184−(<<@) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)
185−(<<@) = unsafeBinaryOp "<<"
186−
187−(@>>) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)
188−(@>>) = unsafeBinaryOp ">>"
189−
190−(&<) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)
191−(&<) = unsafeBinaryOp "&<"
192−
193−(&>) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)
194−(&>) = unsafeBinaryOp "&>"
195−
196−(-|-) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)
197−(-|-) = unsafeBinaryOp "-|-"
198−
199−(@+) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) (null ('PGrange ty))
200−(@+) = unsafeBinaryOp "+"
201−
202−(@*) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) (null ('PGrange ty))
203−(@*) = unsafeBinaryOp "*"
204−
205−(@-) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) (null ('PGrange ty))
206−(@-) = unsafeBinaryOp "-"
207−
208−lowerBound :: null ('PGrange ty) --> 'Null ty
209−lowerBound = unsafeFunction "lower"
210−
211−upperBound :: null ('PGrange ty) --> 'Null ty
212−upperBound = unsafeFunction "upper"
213−
214−isEmpty :: null ('PGrange ty) --> 'Null 'PGbool
215−isEmpty = unsafeFunction "isempty"
216−
217−lowerInc :: null ('PGrange ty) --> 'Null 'PGbool
218−lowerInc = unsafeFunction "lower_inc"
219−
220−lowerInf :: null ('PGrange ty) --> 'Null 'PGbool
221−lowerInf = unsafeFunction "lower_inf"
222−
223−upperInc :: null ('PGrange ty) --> 'Null 'PGbool
224−upperInc = unsafeFunction "upper_inc"
225−
226−upperInf :: null ('PGrange ty) --> 'Null 'PGbool
227−upperInf = unsafeFunction "upper_inf"
228−
229−rangeMerge :: '[null ('PGrange ty), null ('PGrange ty)] ---> null ('PGrange ty)
230−rangeMerge = unsafeFunctionN "range_merge"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Set.hs → squeal-postgresql/src/Squeal/PostgreSQL/Expression/SetOf.hsrenamed+24−57
@@ -1,5 +1,5 @@
11{-|
2−Module: Squeal.PostgreSQL.Expression.Set
2+Module: Squeal.PostgreSQL.Expression.SetOf
33Description: Set returning functions
44Copyright: (c) Eitan Chatav, 2019
55Maintainer: eitan@morphism.tech
@@ -20,18 +20,14 @@ Set returning functions
2020 , TypeOperators
2121#-}
2222
23−module Squeal.PostgreSQL.Expression.Set
23+module Squeal.PostgreSQL.Expression.SetOf
2424 ( generateSeries
2525 , generateSeriesStep
2626 , generateSeriesTimestamp
27− , SetFunction
28− , unsafeSetFunction
29− , SetFunctionDB
30− , setFunction
31− , SetFunctionN
32− , unsafeSetFunctionN
33− , SetFunctionNDB
34− , setFunctionN
27+ , SetOfFunction
28+ , unsafeSetOfFunction
29+ , SetOfFunctionN
30+ , unsafeSetOfFunctionN
3531 ) where
3632
3733import GHC.TypeLits
@@ -48,75 +44,46 @@ import Squeal.PostgreSQL.Schema
4844{- |
4945A @RankNType@ for set returning functions with 1 argument.
5046-}
51−type SetFunction fun ty row
47+type SetOfFunction fun ty setof
5248 = forall outer commons schemas params
5349 . Expression outer commons 'Ungrouped schemas params '[] ty
5450 -- ^ input
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]
51+ -> FromClause outer commons schemas params '[fun ::: setof]
6352 -- ^ output
6453
6554-- | Escape hatch for a set returning function with 1 argument.
66−unsafeSetFunction
67− :: forall fun ty row. KnownSymbol fun
68− => SetFunction fun ty row -- ^ set returning function
69−unsafeSetFunction x = UnsafeFromClause $
55+unsafeSetOfFunction
56+ :: forall fun ty setof. KnownSymbol fun
57+ => SetOfFunction fun ty setof -- ^ set returning function
58+unsafeSetOfFunction x = UnsafeFromClause $
7059 renderSymbol @fun <> parenthesized (renderSQL x)
7160
72−setFunction
73− :: ( Has sch schemas schema
74− , Has fun schema ('Function ('[ty] :=> 'ReturnsTable row)) )
75− => QualifiedAlias sch fun
76− -> SetFunctionDB fun schemas ty row
77−setFunction _ = unsafeSetFunction
78−
7961{- |
8062A @RankNType@ for set returning functions with multiple argument.
8163-}
82−type SetFunctionN fun tys row
64+type SetOfFunctionN fun tys setof
8365 = forall outer commons schemas params
8466 . NP (Expression outer commons 'Ungrouped schemas params '[]) tys
8567 -- ^ inputs
86− -> FromClause outer commons schemas params '[fun ::: row]
68+ -> FromClause outer commons schemas params '[fun ::: setof]
8769 -- ^ output
8870
8971-- | Escape hatch for a set returning function with multiple argument.
90−unsafeSetFunctionN
91− :: forall fun tys row. (SOP.SListI tys, KnownSymbol fun)
92− => SetFunctionN fun tys row -- ^ set returning function
93−unsafeSetFunctionN xs = UnsafeFromClause $
72+unsafeSetOfFunctionN
73+ :: forall fun tys setof. (SOP.SListI tys, KnownSymbol fun)
74+ => SetOfFunctionN fun tys setof -- ^ set returning function
75+unsafeSetOfFunctionN xs = UnsafeFromClause $
9476 renderSymbol @fun <> parenthesized (renderCommaSeparated renderSQL xs)
9577
96−type SetFunctionNDB fun schemas tys row
97− = forall outer commons params
98− . NP (Expression outer commons 'Ungrouped schemas params '[]) tys
99− -- ^ inputs
100− -> FromClause outer commons schemas params '[fun ::: row]
101− -- ^ output
102−
103−setFunctionN
104− :: ( Has sch schemas schema
105− , Has fun schema ('Function (tys :=> 'ReturnsTable row))
106− , SOP.SListI tys )
107− => QualifiedAlias sch fun
108− -> SetFunctionNDB fun schemas tys row
109−setFunctionN _ = unsafeSetFunctionN
110−
11178{- | @generateSeries (start *: stop)@
11279
11380Generate a series of values, from @start@ to @stop@ with a step size of one
11481-}
11582generateSeries
11683 :: ty `In` '[ 'PGint4, 'PGint8, 'PGnumeric]
117− => SetFunctionN "generate_series" '[ null ty, null ty]
84+ => SetOfFunctionN "generate_series" '[ null ty, null ty]
11885 '["generate_series" ::: null ty] -- ^ set returning function
119−generateSeries = unsafeSetFunctionN
86+generateSeries = unsafeSetOfFunctionN
12087
12188{- | @generateSeries (start :* stop *: step)@
12289
@@ -124,9 +91,9 @@ Generate a series of values, from @start@ to @stop@ with a step size of @step@
12491-}
12592generateSeriesStep
12693 :: ty `In` '[ 'PGint4, 'PGint8, 'PGnumeric]
127− => SetFunctionN "generate_series" '[null ty, null ty, null ty]
94+ => SetOfFunctionN "generate_series" '[null ty, null ty, null ty]
12895 '["generate_series" ::: null ty] -- ^ set returning function
129−generateSeriesStep = unsafeSetFunctionN
96+generateSeriesStep = unsafeSetOfFunctionN
13097
13198{- | @generateSeries (start :* stop *: step)@
13299
@@ -134,6 +101,6 @@ Generate a series of values, from @start@ to @stop@ with a step size of @step@
134101-}
135102generateSeriesTimestamp
136103 :: ty `In` '[ 'PGtimestamp, 'PGtimestamptz]
137− => SetFunctionN "generate_series" '[null ty, null ty, null 'PGinterval]
104+ => SetOfFunctionN "generate_series" '[null ty, null ty, null 'PGinterval]
138105 '["generate_series" ::: null ty] -- ^ set returning function
139−generateSeriesTimestamp = unsafeSetFunctionN
106+generateSeriesTimestamp = unsafeSetOfFunctionN
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Text.hs+3−3
@@ -30,17 +30,17 @@ import Squeal.PostgreSQL.Schema
3030
3131-- | >>> printSQL $ lower "ARRRGGG"
3232-- lower(E'ARRRGGG')
33−lower :: null 'PGtext --> null 'PGtext
33+lower :: null 'PGtext :--> null 'PGtext
3434lower = unsafeFunction "lower"
3535
3636-- | >>> printSQL $ upper "eeee"
3737-- upper(E'eeee')
38−upper :: null 'PGtext --> null 'PGtext
38+upper :: null 'PGtext :--> null 'PGtext
3939upper = unsafeFunction "upper"
4040
4141-- | >>> printSQL $ charLength "four"
4242-- char_length(E'four')
43−charLength :: null 'PGtext --> null 'PGint4
43+charLength :: null 'PGtext :--> null 'PGint4
4444charLength = unsafeFunction "char_length"
4545
4646-- | The `like` expression returns true if the @string@ matches
squeal-postgresql/src/Squeal/PostgreSQL/Expression/TextSearch.hs+21−20
@@ -55,8 +55,8 @@ import Squeal.PostgreSQL.Schema
5555(.|) = unsafeBinaryOp "||"
5656
5757-- | negate a `Squeal.PostgreSQL.Expression.Type.tsquery`
58−(.!) :: null 'PGtsquery --> null 'PGtsquery
59−(.!) = unsafeLeftOp "!!"
58+(.!) :: null 'PGtsquery :--> null 'PGtsquery
59+(.!) = unsafeUnaryOpL "!!"
6060
6161-- | `Squeal.PostgreSQL.Expression.Type.tsquery` followed by
6262-- `Squeal.PostgreSQL.Expression.Type.tsquery`
@@ -66,50 +66,51 @@ import Squeal.PostgreSQL.Schema
6666-- | convert array of lexemes to `Squeal.PostgreSQL.Expression.Type.tsvector`
6767arrayToTSvector
6868 :: null ('PGvararray ('NotNull 'PGtext))
69− --> null 'PGtsvector
69+ :--> null 'PGtsvector
7070arrayToTSvector = unsafeFunction "array_to_tsvector"
7171
7272-- | number of lexemes in `Squeal.PostgreSQL.Expression.Type.tsvector`
73−tsvectorLength :: null 'PGtsvector --> null 'PGint4
73+tsvectorLength :: null 'PGtsvector :--> null 'PGint4
7474tsvectorLength = unsafeFunction "length"
7575
7676-- | number of lexemes plus operators in `Squeal.PostgreSQL.Expression.Type.tsquery`
77−numnode :: null 'PGtsquery --> null 'PGint4
77+numnode :: null 'PGtsquery :--> null 'PGint4
7878numnode = unsafeFunction "numnode"
7979
8080-- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` ignoring punctuation
81−plainToTSquery :: null 'PGtext --> null 'PGtsquery
81+plainToTSquery :: null 'PGtext :--> null 'PGtsquery
8282plainToTSquery = unsafeFunction "plainto_tsquery"
8383
8484-- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` that searches for a phrase,
8585-- ignoring punctuation
86−phraseToTSquery :: null 'PGtext --> null 'PGtsquery
86+phraseToTSquery :: null 'PGtext :--> null 'PGtsquery
8787phraseToTSquery = unsafeFunction "phraseto_tsquery"
8888
8989-- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` from a web search style query
90−websearchToTSquery :: null 'PGtext --> null 'PGtsquery
90+websearchToTSquery :: null 'PGtext :--> null 'PGtsquery
9191websearchToTSquery = unsafeFunction "websearch_to_tsquery"
9292
9393-- | get indexable part of a `Squeal.PostgreSQL.Expression.Type.tsquery`
94−queryTree :: null 'PGtsquery --> null 'PGtext
94+queryTree :: null 'PGtsquery :--> null 'PGtext
9595queryTree = unsafeFunction "query_tree"
9696
9797-- | normalize words and convert to `Squeal.PostgreSQL.Expression.Type.tsquery`
98−toTSquery :: null 'PGtext --> null 'PGtsquery
98+toTSquery :: null 'PGtext :--> null 'PGtsquery
9999toTSquery = unsafeFunction "to_tsquery"
100100
101101-- | reduce document text to `Squeal.PostgreSQL.Expression.Type.tsvector`
102102toTSvector
103103 :: ty `In` '[ 'PGtext, 'PGjson, 'PGjsonb]
104− => null ty --> null 'PGtsvector
104+ => null ty :--> null 'PGtsvector
105105toTSvector = unsafeFunction "to_tsvector"
106106
107107-- | assign weight to each element of `Squeal.PostgreSQL.Expression.Type.tsvector`
108−setWeight :: '[null 'PGtsvector, null ('PGchar 1)] ---> null 'PGtsvector
108+setWeight
109+ :: FunctionN '[null 'PGtsvector, null ('PGchar 1)] (null 'PGtsvector)
109110setWeight = unsafeFunctionN "set_weight"
110111
111112-- | remove positions and weights from `Squeal.PostgreSQL.Expression.Type.tsvector`
112−strip :: null 'PGtsvector --> null 'PGtsvector
113+strip :: null 'PGtsvector :--> null 'PGtsvector
113114strip = unsafeFunction "strip"
114115
115116-- | @jsonToTSvector (document *: filter)@
@@ -122,7 +123,7 @@ strip = unsafeFunction "strip"
122123-- "boolean" (to include all Boolean values in the string format "true"/"false"),
123124-- "key" (to include all keys) or "all" (to include all above).
124125-- These values can be combined together to include, e.g. all string and numeric values.
125−jsonToTSvector :: '[null 'PGjson, null 'PGjson] ---> null 'PGtsvector
126+jsonToTSvector :: FunctionN '[null 'PGjson, null 'PGjson] (null 'PGtsvector)
126127jsonToTSvector = unsafeFunctionN "json_to_tsvector"
127128
128129-- | @jsonbToTSvector (document *: filter)@
@@ -135,23 +136,23 @@ jsonToTSvector = unsafeFunctionN "json_to_tsvector"
135136-- "boolean" (to include all Boolean values in the string format "true"/"false"),
136137-- "key" (to include all keys) or "all" (to include all above).
137138-- These values can be combined together to include, e.g. all string and numeric values.
138−jsonbToTSvector :: '[null 'PGjsonb, null 'PGjsonb] ---> null 'PGtsvector
139+jsonbToTSvector :: FunctionN '[null 'PGjsonb, null 'PGjsonb] (null 'PGtsvector)
139140jsonbToTSvector = unsafeFunctionN "jsonb_to_tsvector"
140141
141142-- | remove given lexeme from `Squeal.PostgreSQL.Expression.Type.tsvector`
142−tsDelete ::
143+tsDelete :: FunctionN
143144 '[null 'PGtsvector, null ('PGvararray ('NotNull 'PGtext))]
144− ---> null 'PGtsvector
145+ (null 'PGtsvector)
145146tsDelete = unsafeFunctionN "ts_delete"
146147
147148-- | select only elements with given weights from `Squeal.PostgreSQL.Expression.Type.tsvector`
148−tsFilter ::
149+tsFilter :: FunctionN
149150 '[null 'PGtsvector, null ('PGvararray ('NotNull ('PGchar 1)))]
150− ---> null 'PGtsvector
151+ (null 'PGtsvector)
151152tsFilter = unsafeFunctionN "ts_filter"
152153
153154-- | display a `Squeal.PostgreSQL.Expression.Type.tsquery` match
154155tsHeadline
155156 :: document `In` '[ 'PGtext, 'PGjson, 'PGjsonb]
156− => '[null document, null 'PGtsquery] ---> null 'PGtext
157+ => FunctionN '[null document, null 'PGtsquery] (null 'PGtext)
157158tsHeadline = unsafeFunctionN "ts_headline"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Time.hs+12−7
@@ -17,7 +17,6 @@ Date/Time functions and operators
1717 , OverloadedStrings
1818 , PolyKinds
1919 , RankNTypes
20− , TypeOperators
2120#-}
2221
2322module Squeal.PostgreSQL.Expression.Time
@@ -86,7 +85,9 @@ Create date from year, month and day fields
8685>>> printSQL (makeDate (1984 :* 7 *: 3))
8786make_date(1984, 7, 3)
8887-}
89−makeDate :: '[ null 'PGint4, null 'PGint4, null 'PGint4 ] ---> null 'PGdate
88+makeDate :: FunctionN
89+ '[ null 'PGint4, null 'PGint4, null 'PGint4 ]
90+ ( null 'PGdate )
9091makeDate = unsafeFunctionN "make_date"
9192
9293{-|
@@ -95,7 +96,9 @@ Create time from hour, minute and seconds fields
9596>>> printSQL (makeTime (8 :* 15 *: 23.5))
9697make_time(8, 15, 23.5)
9798-}
98−makeTime :: '[ null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtime
99+makeTime :: FunctionN
100+ '[ null 'PGint4, null 'PGint4, null 'PGfloat8 ]
101+ ( null 'PGtime )
99102makeTime = unsafeFunctionN "make_time"
100103
101104{-|
@@ -104,9 +107,10 @@ Create timestamp from year, month, day, hour, minute and seconds fields
104107>>> printSQL (makeTimestamp (2013 :* 7 :* 15 :* 8 :* 15 *: 23.5))
105108make_timestamp(2013, 7, 15, 8, 15, 23.5)
106109-}
107−makeTimestamp ::
110+makeTimestamp :: FunctionN
108111 '[ null 'PGint4, null 'PGint4, null 'PGint4
109− , null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtimestamp
112+ , null 'PGint4, null 'PGint4, null 'PGfloat8 ]
113+ ( null 'PGtimestamp )
110114makeTimestamp = unsafeFunctionN "make_timestamp"
111115
112116{-|
@@ -117,9 +121,10 @@ the current time zone is used
117121>>> printSQL (makeTimestamptz (2013 :* 7 :* 15 :* 8 :* 15 *: 23.5))
118122make_timestamptz(2013, 7, 15, 8, 15, 23.5)
119123-}
120−makeTimestamptz ::
124+makeTimestamptz :: FunctionN
121125 '[ null 'PGint4, null 'PGint4, null 'PGint4
122− , null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtimestamptz
126+ , null 'PGint4, null 'PGint4, null 'PGfloat8 ]
127+ ( null 'PGtimestamptz )
123128makeTimestamptz = unsafeFunctionN "make_timestamptz"
124129
125130{-|
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Type.hs+5−156
@@ -23,16 +23,13 @@ Type expressions.
2323 , ScopedTypeVariables
2424 , TypeApplications
2525 , TypeOperators
26− , UndecidableInstances
2726#-}
2827
2928module Squeal.PostgreSQL.Expression.Type
30− ( -- * type casting
31− cast
29+ ( TypeExpression (..)
30+ , cast
3231 , astype
33− , inferredtype
34− -- * type expressions
35− , TypeExpression (..)
32+ , PGTyped (..)
3633 , typedef
3734 , typetable
3835 , typeview
@@ -58,11 +55,9 @@ module Squeal.PostgreSQL.Expression.Type
5855 , bytea
5956 , timestamp
6057 , timestampWithTimeZone
61− , timestamptz
6258 , date
6359 , time
6460 , timeWithTimeZone
65− , timetz
6661 , interval
6762 , uuid
6863 , inet
@@ -72,29 +67,6 @@ module Squeal.PostgreSQL.Expression.Type
7267 , fixarray
7368 , tsvector
7469 , tsquery
75− , oid
76− , int4range
77− , int8range
78− , numrange
79− , tsrange
80− , tstzrange
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 (..)
9870 ) where
9971
10072import Control.DeepSeq
@@ -108,7 +80,6 @@ import qualified Generics.SOP as SOP
10880
10981import Squeal.PostgreSQL.Alias
11082import Squeal.PostgreSQL.Expression
111−import Squeal.PostgreSQL.PG
11283import Squeal.PostgreSQL.Render
11384import Squeal.PostgreSQL.Schema
11485
@@ -142,18 +113,6 @@ astype
142113 -> Expression outer commons grp schemas params from ty
143114astype = cast
144115
145−-- | `inferredtype` will add a type annotation to an `Expression`
146−-- which can be useful for fixing the storage type of a value.
147−--
148−-- >>> printSQL (inferredtype true)
149−-- (TRUE :: bool)
150−inferredtype
151− :: PGTyped schemas ty
152− => Expression outer common grp schemas params from ty
153− -- ^ value
154− -> Expression outer common grp schemas params from ty
155−inferredtype = astype pgtype
156−
157116{-----------------------------------------
158117type expressions
159118-----------------------------------------}
@@ -170,7 +129,6 @@ instance RenderSQL (TypeExpression schemas ty) where
170129typedef
171130 :: (Has sch schemas schema, Has td schema ('Typedef ty))
172131 => QualifiedAlias sch td
173− -- ^ type alias
174132 -> TypeExpression schemas (null ty)
175133typedef = UnsafeTypeExpression . renderSQL
176134
@@ -179,7 +137,6 @@ typedef = UnsafeTypeExpression . renderSQL
179137typetable
180138 :: (Has sch schemas schema, Has tab schema ('Table table))
181139 => QualifiedAlias sch tab
182− -- ^ table alias
183140 -> TypeExpression schemas (null ('PGcomposite (TableToRow table)))
184141typetable = UnsafeTypeExpression . renderSQL
185142
@@ -188,7 +145,6 @@ typetable = UnsafeTypeExpression . renderSQL
188145typeview
189146 :: (Has sch schemas schema, Has vw schema ('View view))
190147 => QualifiedAlias sch vw
191− -- ^ view alias
192148 -> TypeExpression schemas (null ('PGcomposite view))
193149typeview = UnsafeTypeExpression . renderSQL
194150
@@ -245,9 +201,8 @@ bytea = UnsafeTypeExpression "bytea"
245201timestamp :: TypeExpression schemas (null 'PGtimestamp)
246202timestamp = UnsafeTypeExpression "timestamp"
247203-- | date and time, including time zone
248−timestampWithTimeZone, timestamptz :: TypeExpression schemas (null 'PGtimestamptz)
204+timestampWithTimeZone :: TypeExpression schemas (null 'PGtimestamptz)
249205timestampWithTimeZone = UnsafeTypeExpression "timestamp with time zone"
250−timestamptz = UnsafeTypeExpression "timestamptz"
251206-- | calendar date (year, month, day)
252207date :: TypeExpression schemas (null 'PGdate)
253208date = UnsafeTypeExpression "date"
@@ -255,9 +210,8 @@ date = UnsafeTypeExpression "date"
255210time :: TypeExpression schemas (null 'PGtime)
256211time = UnsafeTypeExpression "time"
257212-- | time of day, including time zone
258−timeWithTimeZone, timetz :: TypeExpression schemas (null 'PGtimetz)
213+timeWithTimeZone :: TypeExpression schemas (null 'PGtimetz)
259214timeWithTimeZone = UnsafeTypeExpression "time with time zone"
260−timetz = UnsafeTypeExpression "timetz"
261215-- | time span
262216interval :: TypeExpression schemas (null 'PGinterval)
263217interval = UnsafeTypeExpression "interval"
@@ -304,28 +258,6 @@ tsvector = UnsafeTypeExpression "tsvector"
304258-- | text search document
305259tsquery :: TypeExpression schemas (null 'PGtsquery)
306260tsquery = UnsafeTypeExpression "tsquery"
307−-- | Object identifiers (OIDs) are used internally by PostgreSQL
308−-- as primary keys for various system tables.
309−oid :: TypeExpression schemas (null 'PGoid)
310−oid = UnsafeTypeExpression "oid"
311−-- | Range of integer
312−int4range :: TypeExpression schemas (null ('PGrange 'PGint4))
313−int4range = UnsafeTypeExpression "int4range"
314−-- | Range of bigint
315−int8range :: TypeExpression schemas (null ('PGrange 'PGint8))
316−int8range = UnsafeTypeExpression "int8range"
317−-- | Range of numeric
318−numrange :: TypeExpression schemas (null ('PGrange 'PGnumeric))
319−numrange = UnsafeTypeExpression "numrange"
320−-- | Range of timestamp without time zone
321−tsrange :: TypeExpression schemas (null ('PGrange 'PGtimestamp))
322−tsrange = UnsafeTypeExpression "tsrange"
323−-- | Range of timestamp with time zone
324−tstzrange :: TypeExpression schemas (null ('PGrange 'PGtimestamptz))
325−tstzrange = UnsafeTypeExpression "tstzrange"
326−-- | Range of date
327−daterange :: TypeExpression schemas (null ('PGrange 'PGdate))
328−daterange = UnsafeTypeExpression "daterange"
329261
330262-- | `pgtype` is a demoted version of a `PGType`
331263class PGTyped schemas (ty :: NullityType) where
@@ -361,86 +293,3 @@ instance (SOP.All KnownNat dims, PGTyped schemas ty)
361293 pgtype = fixarray @dims (pgtype @schemas @ty)
362294instance PGTyped schemas (null 'PGtsvector) where pgtype = tsvector
363295instance PGTyped schemas (null 'PGtsquery) where pgtype = tsquery
364−instance PGTyped schemas (null 'PGoid) where pgtype = oid
365−instance PGTyped schemas (null ('PGrange 'PGint4)) where pgtype = int4range
366−instance PGTyped schemas (null ('PGrange 'PGint8)) where pgtype = int8range
367−instance PGTyped schemas (null ('PGrange 'PGnumeric)) where pgtype = numrange
368−instance PGTyped schemas (null ('PGrange 'PGtimestamp)) where pgtype = tsrange
369−instance PGTyped schemas (null ('PGrange 'PGtimestamptz)) where pgtype = tstzrange
370−instance PGTyped schemas (null ('PGrange 'PGdate)) where pgtype = daterange
371−
372−-- | Lift `PGTyped` to a field
373−class FieldTyped schemas ty where
374− fieldtype :: Aliased (TypeExpression schemas) ty
375−instance (KnownSymbol alias, PGTyped schemas ty)
376− => FieldTyped schemas (alias ::: ty) where
377− fieldtype = pgtype `As` Alias
378−
379−-- | `ColumnTypeExpression`s are used in `createTable` commands.
380−newtype ColumnTypeExpression (schemas :: SchemasType) (ty :: ColumnType)
381− = UnsafeColumnTypeExpression { renderColumnTypeExpression :: ByteString }
382− deriving (GHC.Generic,Show,Eq,Ord,NFData)
383−instance RenderSQL (ColumnTypeExpression schemas ty) where
384− renderSQL = renderColumnTypeExpression
385−
386−-- | used in `createTable` commands as a column constraint to note that
387−-- @NULL@ may be present in a column
388−nullable
389− :: TypeExpression schemas (nullity ty)
390− -> ColumnTypeExpression schemas ('NoDef :=> 'Null ty)
391−nullable ty = UnsafeColumnTypeExpression $ renderSQL ty <+> "NULL"
392−
393−-- | used in `createTable` commands as a column constraint to ensure
394−-- @NULL@ is not present in a column
395−notNullable
396− :: TypeExpression schemas (nullity ty)
397− -> ColumnTypeExpression schemas ('NoDef :=> 'NotNull ty)
398−notNullable ty = UnsafeColumnTypeExpression $ renderSQL ty <+> "NOT NULL"
399−
400−-- | used in `createTable` commands as a column constraint to give a default
401−default_
402− :: Expression '[] '[] 'Ungrouped schemas '[] '[] ty
403− -> ColumnTypeExpression schemas ('NoDef :=> ty)
404− -> ColumnTypeExpression schemas ('Def :=> ty)
405−default_ x ty = UnsafeColumnTypeExpression $
406− renderSQL ty <+> "DEFAULT" <+> renderExpression x
407−
408−-- | not a true type, but merely a notational convenience for creating
409−-- unique identifier columns with type `PGint2`
410−serial2, smallserial
411− :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint2)
412−serial2 = UnsafeColumnTypeExpression "serial2"
413−smallserial = UnsafeColumnTypeExpression "smallserial"
414−-- | not a true type, but merely a notational convenience for creating
415−-- unique identifier columns with type `PGint4`
416−serial4, serial
417− :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint4)
418−serial4 = UnsafeColumnTypeExpression "serial4"
419−serial = UnsafeColumnTypeExpression "serial"
420−-- | not a true type, but merely a notational convenience for creating
421−-- unique identifier columns with type `PGint8`
422−serial8, bigserial
423− :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint8)
424−serial8 = UnsafeColumnTypeExpression "serial8"
425−bigserial = UnsafeColumnTypeExpression "bigserial"
426−
427−-- | Like @PGTyped@ but also accounts for nullity.
428−class PGNullityTyped schemas (nullty :: NullityType) where
429− pgNullityType :: ColumnTypeExpression schemas ('NoDef :=> nullty)
430−
431−instance PGTyped schemas ('Null ty) => PGNullityTyped schemas ('Null ty) where
432− pgNullityType = nullable (pgtype @_ @('Null ty))
433−
434−instance PGTyped schemas ('NotNull ty) => PGNullityTyped schemas ('NotNull ty) where
435− pgNullityType = notNullable (pgtype @_ @('NotNull ty))
436−
437−-- | Allow you to specify pg column types in relation to haskell types.
438−-- >>> printSQL $ hask @(Maybe String)
439−-- text NULL
440−--
441−-- >>> printSQL $ hask @Double
442−-- float8 NOT NULL
443−hask
444− :: forall hask schemas. PGNullityTyped schemas (NullPG hask)
445− => ColumnTypeExpression schemas ('NoDef :=> NullPG hask)
446−hask = pgNullityType
squeal-postgresql/src/Squeal/PostgreSQL/List.hs+46−17
@@ -33,16 +33,16 @@ module Squeal.PostgreSQL.List
3333 , Join
3434 , disjoin
3535 , Additional (..)
36− , Path (..)
37− , CFunctor (..)
38− , CFoldable (..)
39− , CFree (..)
36+ , AlignedList (..)
37+ , single
38+ , extractList
39+ , mapAligned
4040 , Elem
4141 , In
4242 , Length
4343 ) where
4444
45−import Control.Category.Free
45+import Control.Category
4646import Data.Function ((&))
4747import Data.Kind
4848import Data.Type.Bool
@@ -50,6 +50,8 @@ import GHC.TypeLits
5050
5151import Generics.SOP as SOP
5252
53+import Squeal.PostgreSQL.Render
54+
5355-- | `Join` is simply promoted `++` and is used in @JOIN@s in
5456-- `Squeal.PostgreSQL.Query.FromClause`s.
5557type family Join xs ys where
@@ -76,6 +78,42 @@ instance Additional (NP expr) where
7678 Nil -> ys
7779 x :* xs -> x :* (xs & also ys)
7880
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+
79117-- | A useful operator for ending an `NP` list of length at least 2 without `Nil`.
80118(*:) :: f x -> f y -> NP f '[x,y]
81119x *: y = x :* y :* Nil
@@ -84,18 +122,13 @@ infixl 9 *:
84122-- | @Elem@ is a promoted `Data.List.elem`.
85123type family Elem x xs where
86124 Elem x '[] = 'False
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
125+ Elem x (x ': xs) = 'True
93126 Elem x (_ ': xs) = Elem x xs
94127
95128-- | @In x xs@ is a constraint that proves that @x@ is in @xs@.
96129type family In x xs :: Constraint where
97130 In x xs = If (Elem x xs) (() :: Constraint)
98− (TypeError ('ShowType x ':<>: 'Text " is not in " ':<>: 'ShowType xs))
131+ (TypeError ('ShowType x ':<>: 'Text "is not in " ':<>: 'ShowType xs))
99132
100133{- | Calculate the `Length` of a type level list
101134
@@ -104,9 +137,5 @@ Length '[Char,String,Bool,Double] :: Nat
104137= 4
105138-}
106139type family Length (xs :: [k]) :: Nat where
107− Length (_ ': _ ': _ ': _ ': _ : xs) = 5 + Length xs
108− Length (_ ': _ ': _ ': _ : xs) = 4 + Length xs
109− Length (_ ': _ ': _ : xs) = 3 + Length xs
110− Length (_ ': _ : xs) = 2 + Length xs
111− Length (_ : xs) = 1 + Length xs
140+ Length (x : xs) = 1 + Length xs
112141 Length '[] = 0
squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs+26−34
@@ -99,7 +99,7 @@ instance RenderSQL (Manipulation commons schemas params columns) where
9999instance With Manipulation where
100100 with Done manip = manip
101101 with ctes manip = UnsafeManipulation $
102− "WITH" <+> commaSeparated (ctoList renderSQL ctes) <+> renderSQL manip
102+ "WITH" <+> renderSQL ctes <+> renderSQL manip
103103
104104{- |
105105The top level `Manipulation_` type is parameterized by a @schemas@ `SchemasType`,
@@ -113,7 +113,8 @@ using `Squeal.PostgreSQL.PQ.manipulate`.
113113Generally, @parameters@ will be a Haskell tuple or record whose entries
114114may be referenced using positional
115115`Squeal.PostgreSQL.Expression.Parameter.parameter`s and @row@ will be a
116−Haskell record, whose entries will be targeted using overloaded labels.
116+Haskell record or a generalized record using tuples of `P` types and normal Haskell
117+records, whose entries will be targeted using overloaded labels.
117118
118119>>> :set -XDeriveAnyClass -XDerivingStrategies
119120>>> :{
@@ -249,7 +250,6 @@ type family Manipulation_ (schemas :: SchemasType) (params :: Type) (row :: Type
249250-- | Convert a `Query` into a `Manipulation`.
250251queryStatement
251252 :: Query '[] commons schemas params columns
252− -- ^ `Query` to embed as a `Manipulation`
253253 -> Manipulation commons schemas params columns
254254queryStatement q = UnsafeManipulation $ renderSQL q
255255
@@ -272,13 +272,9 @@ insertInto
272272 , SOP.SListI columns
273273 , SOP.SListI row1 )
274274 => QualifiedAlias sch tab
275− -- ^ table
276275 -> QueryClause commons schemas params columns
277− -- ^ what to insert
278276 -> ConflictClause tab commons schemas params table
279− -- ^ what to do in case of conflict
280277 -> ReturningClause commons schemas params '[tab ::: row0] row1
281− -- ^ what to return
282278 -> Manipulation commons schemas params row1
283279insertInto tab qry conflict ret = UnsafeManipulation $
284280 "INSERT" <+> "INTO" <+> renderSQL tab
@@ -286,7 +282,7 @@ insertInto tab qry conflict ret = UnsafeManipulation $
286282 <> renderSQL conflict
287283 <> renderSQL ret
288284
289−-- | Like `insertInto` but with `OnConflictDoRaise` and `no` `ReturningClause`.
285+-- | Like `insertInto` but with `OnConflictDoRaise` and no `ReturningClause`.
290286insertInto_
291287 :: ( Has sch schemas schema
292288 , Has tab schema ('Table table)
@@ -294,33 +290,30 @@ insertInto_
294290 , row ~ TableToRow table
295291 , SOP.SListI columns )
296292 => QualifiedAlias sch tab
297− -- ^ table
298293 -> QueryClause commons schemas params columns
299− -- ^ what to insert
300294 -> Manipulation commons schemas params '[]
301295insertInto_ tab qry =
302296 insertInto tab qry OnConflictDoRaise (Returning_ Nil)
303297
304298-- | A `QueryClause` describes what to `insertInto` a table.
305299data QueryClause commons schemas params columns where
300+ -- | `Values` describes `NP` lists of `Aliased` `Optional` `Expression`s
301+ -- whose `ColumnsType` must match the tables'.
306302 Values
307303 :: SOP.SListI columns
308304 => NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[]))) columns
309− -- ^ row of values
310305 -> [NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[]))) columns]
311− -- ^ additional rows of values
312306 -> QueryClause commons schemas params columns
307+ -- | `Select` describes a subquery that permits use of `Optional` `Expression`s.
313308 Select
314309 :: SOP.SListI columns
315310 => NP (Aliased (Optional (Expression '[] commons grp schemas params from))) columns
316− -- ^ row of values
317311 -> TableExpression '[] commons grp schemas params from
318− -- ^ from a table expression
319312 -> QueryClause commons schemas params columns
313+ -- | `Subquery` describes a subquery whose `RowType` must match the tables'.
320314 Subquery
321315 :: ColumnsToRow columns ~ row
322316 => Query '[] commons schemas params row
323− -- ^ subquery to insert
324317 -> QueryClause commons schemas params columns
325318
326319instance RenderSQL (QueryClause commons schemas params columns) where
@@ -358,7 +351,6 @@ instance RenderSQL (QueryClause commons schemas params columns) where
358351pattern Values_
359352 :: SOP.SListI columns
360353 => NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[]))) columns
361− -- ^ row of values
362354 -> QueryClause commons schemas params columns
363355pattern Values_ vals = Values vals []
364356
@@ -383,7 +375,7 @@ instance (forall x. RenderSQL (expr x)) => RenderSQL (Optional expr ty) where
383375-- deleted will be returned. For example, if a row was locked
384376-- but not updated because an `OnConflict` `DoUpdate` condition was not satisfied,
385377-- the row will not be returned. `Returning` `Star` will return all columns
386−-- in the row. Use `Returning` `Nil` in the common case where no return
378+-- in the row. Use @Returning Nil@ in the common case where no return
387379-- values are desired.
388380newtype ReturningClause commons schemas params from row =
389381 Returning (Selection '[] commons 'Ungrouped schemas params from row)
@@ -397,7 +389,6 @@ instance RenderSQL (ReturningClause commons schemas params from row) where
397389pattern Returning_
398390 :: SOP.SListI row
399391 => NP (Aliased (Expression '[] commons 'Ungrouped schemas params from)) row
400− -- ^ row of values
401392 -> ReturningClause commons schemas params from row
402393pattern Returning_ list = Returning (List list)
403394
@@ -410,9 +401,7 @@ data ConflictClause tab commons schemas params table where
410401 OnConflictDoRaise :: ConflictClause tab commons schemas params table
411402 OnConflict
412403 :: ConflictTarget constraints
413− -- ^ conflict target
414404 -> ConflictAction tab commons schemas params columns
415− -- ^ conflict action
416405 -> ConflictClause tab commons schemas params (constraints :=> columns)
417406
418407-- | Render a `ConflictClause`.
@@ -430,12 +419,12 @@ the exact details of the `update` action to be performed in case of a conflict.
430419The `Set` and WHERE `Condition`s in `OnConflict` `DoUpdate` have access to the
431420existing row using the table's name (or an alias), and to rows proposed
432421for insertion using the special @#excluded@ table.
433−`OnConflict` `DoNothing` simply avoids inserting a row as its alternative action.
434−`OnConflict` `DoUpdate` updates the existing row that conflicts
435−with the row proposed for insertion as its alternative action.
436422-}
437423data ConflictAction tab commons schemas params columns where
424+ -- | `OnConflict` `DoNothing` simply avoids inserting a row as its alternative action.
438425 DoNothing :: ConflictAction tab commons schemas params columns
426+ -- | `OnConflict` `DoUpdate` updates the existing row that conflicts
427+ -- with the row proposed for insertion as its alternative action.
439428 DoUpdate
440429 :: ( row ~ ColumnsToRow columns
441430 , SOP.SListI columns
@@ -485,6 +474,7 @@ UPDATE statements
485474update
486475 :: ( SOP.SListI columns
487476 , SOP.SListI row1
477+ , db ~ (commons :=> schemas)
488478 , Has sch schemas schema
489479 , Has tab schema ('Table table)
490480 , row0 ~ TableToRow table
@@ -509,6 +499,7 @@ update tab columns wh returning = UnsafeManipulation $
509499-- | Update a row returning `Nil`.
510500update_
511501 :: ( SOP.SListI columns
502+ , db ~ (commons :=> schemas)
512503 , Has sch schemas schema
513504 , Has tab schema ('Table table)
514505 , row ~ TableToRow table
@@ -527,25 +518,25 @@ update_ tab columns wh = update tab columns wh (Returning_ Nil)
527518DELETE statements
528519-----------------------------------------}
529520
530−-- | Specify additional tables with `Using`
531−-- an `also` list of table expressions, allowing columns
532−-- from other tables to appear in the WHERE condition.
533−-- This is similar to the list of tables that can be specified
534−-- in the FROM Clause of a SELECT statement;
535−-- for example, an alias for the table name can be specified.
536−-- Do not repeat the target table in the `Using` list,
537−-- unless you wish to set up a self-join.
538−-- `NoUsing` if no additional tables are to be used.
521+-- | Specify additional tables.
539522data UsingClause commons schemas params from where
523+ -- | No `UsingClause`
540524 NoUsing :: UsingClause commons schemas params '[]
525+ -- | An `also` list of table expressions, allowing columns
526+ -- from other tables to appear in the WHERE condition.
527+ -- This is similar to the list of tables that can be specified
528+ -- in the FROM Clause of a SELECT statement;
529+ -- for example, an alias for the table name can be specified.
530+ -- Do not repeat the target table in the `Using` list,
531+ -- unless you wish to set up a self-join.
541532 Using
542533 :: FromClause '[] commons schemas params from
543− -- ^ what to use
544534 -> UsingClause commons schemas params from
545535
546536-- | Delete rows from a table.
547537deleteFrom
548538 :: ( SOP.SListI row1
539+ , db ~ (commons :=> schemas)
549540 , Has sch schemas schema
550541 , Has tab schema ('Table table)
551542 , row0 ~ TableToRow table
@@ -567,7 +558,8 @@ deleteFrom tab using wh returning = UnsafeManipulation $
567558
568559-- | Delete rows returning `Nil`.
569560deleteFrom_
570− :: ( Has sch schemas schema
561+ :: ( db ~ (commons :=> schemas)
562+ , Has sch schemas schema
571563 , Has tab schema ('Table table)
572564 , row ~ TableToRow table
573565 , columns ~ TableToColumns table )
squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs+12−14
@@ -66,7 +66,7 @@ let
6666 }
6767:}
6868
69−Now that we have a couple migrations we can chain them together into a `Path`.
69+Now that we have a couple migrations we can chain them together into an `AlignedList`.
7070
7171>>> let migrations = makeUsers :>> makeEmails :>> Done
7272
@@ -167,8 +167,6 @@ import qualified GHC.Generics as GHC
167167import Squeal.PostgreSQL.Alias
168168import Squeal.PostgreSQL.Binary
169169import Squeal.PostgreSQL.Definition
170−import Squeal.PostgreSQL.Definition.Table
171−import Squeal.PostgreSQL.Definition.Table.Constraint
172170import Squeal.PostgreSQL.Expression.Comparison
173171import Squeal.PostgreSQL.Expression.Parameter
174172import Squeal.PostgreSQL.Expression.Time
@@ -192,34 +190,34 @@ data Migration p schemas0 schemas1 = Migration
192190
193191{- |
194192A `Migratory` @p@ is a `Category` for which one can execute or rewind
195−a `Path` of `Migration`s over @p@. This includes the category of pure
193+an `AlignedList` of `Migration`s over @p@. This includes the category of pure
196194SQL `Definition`s and the category of impure `Terminally` `PQ` `IO` actions.
197195-}
198196class Category p => Migratory p where
199197
200198 {- |
201− Run a `Path` of `Migration`s.
199+ Run an `AlignedList` of `Migration`s.
202200 Create the `MigrationsTable` as @public.schema_migrations@ if it does not already exist.
203201 In one transaction, for each each `Migration` query to see if the `Migration` has been executed;
204202 if not, `up` the `Migration` and insert its `name` in the `MigrationsTable`.
205203 -}
206204 migrateUp
207− :: Path (Migration p) schemas0 schemas1
205+ :: AlignedList (Migration p) schemas0 schemas1
208206 -> PQ schemas0 schemas1 IO ()
209207
210208 {- |
211− Rewind a `Path` of `Migration`s.
209+ Rewind an `AlignedList` of `Migration`s.
212210 Create the `MigrationsTable` as @public.schema_migrations@ if it does not already exist.
213211 In one transaction, for each each `Migration` query to see if the `Migration` has been executed;
214212 if so, `down` the `Migration` and delete its `name` in the `MigrationsTable`.
215213 -}
216214 migrateDown
217− :: Path (Migration p) schemas0 schemas1
215+ :: AlignedList (Migration p) schemas0 schemas1
218216 -> PQ schemas1 schemas0 IO ()
219217
220218instance Migratory Definition where
221− migrateUp = migrateUp . cmap pureMigration
222− migrateDown = migrateDown . cmap pureMigration
219+ migrateUp = migrateUp . mapAligned pureMigration
220+ migrateDown = migrateDown . mapAligned pureMigration
223221
224222{- | `Terminally` turns an indexed monad transformer and the monad it transforms
225223into a category by restricting the return type to @()@ and permuting the type variables.
@@ -268,7 +266,7 @@ instance Migratory (Terminally PQ IO) where
268266 where
269267
270268 upMigrations
271− :: Path (Migration (Terminally PQ IO)) schemas0 schemas1
269+ :: AlignedList (Migration (Terminally PQ IO)) schemas0 schemas1
272270 -> PQ MigrationsSchemas MigrationsSchemas IO ()
273271 upMigrations = \case
274272 Done -> return ()
@@ -297,7 +295,7 @@ instance Migratory (Terminally PQ IO) where
297295 where
298296
299297 downMigrations
300− :: Path (Migration (Terminally PQ IO)) schemas0 schemas1
298+ :: AlignedList (Migration (Terminally PQ IO)) schemas0 schemas1
301299 -> PQ MigrationsSchemas MigrationsSchemas IO ()
302300 downMigrations = \case
303301 Done -> return ()
@@ -384,7 +382,7 @@ defaultMain
384382 :: Migratory p
385383 => ByteString
386384 -- ^ connection string
387− -> Path (Migration p) db0 db1
385+ -> AlignedList (Migration p) db0 db1
388386 -- ^ migrations
389387 -> IO ()
390388defaultMain connectTo migrations = do
@@ -405,7 +403,7 @@ defaultMain connectTo migrations = do
405403 migrateStatus :: PQ schema schema IO ()
406404 migrateStatus = unsafePQ $ do
407405 runNames <- getRunMigrationNames
408− let names = ctoList name migrations
406+ let names = extractList name migrations
409407 unrunNames = names \\ runNames
410408 liftIO $ displayRunned runNames >> displayUnrunned unrunNames
411409
squeal-postgresql/src/Squeal/PostgreSQL/PG.hs+17−39
@@ -10,20 +10,18 @@ Stability: experimental
1010-}
1111{-# LANGUAGE
1212 AllowAmbiguousTypes
13− , DeriveAnyClass
1413 , DeriveFoldable
1514 , DeriveFunctor
1615 , DeriveGeneric
1716 , DeriveTraversable
18− , DerivingStrategies
1917 , DefaultSignatures
2018 , FlexibleContexts
2119 , FlexibleInstances
2220 , FunctionalDependencies
2321 , GADTs
2422 , LambdaCase
25− , MultiParamTypeClasses
2623 , OverloadedStrings
24+ , MultiParamTypeClasses
2725 , ScopedTypeVariables
2826 , TypeApplications
2927 , TypeFamilies
@@ -47,7 +45,7 @@ module Squeal.PostgreSQL.PG
4745 , Enumerated (..)
4846 , VarArray (..)
4947 , FixArray (..)
50− , LibPQ.Oid (..)
48+ , SOP.P (..)
5149 -- * Type families
5250 , LabelsPG
5351 , DimPG
@@ -66,6 +64,7 @@ import Data.Int (Int16, Int32, Int64)
6664import Data.Scientific (Scientific)
6765import Data.Time (Day, DiffTime, LocalTime, TimeOfDay, TimeZone, UTCTime)
6866import Data.Vector (Vector)
67+import Data.Word (Word16, Word32, Word64)
6968import Data.UUID.Types (UUID)
7069import GHC.TypeLits
7170import Network.IP.Addr (NetAddr, IP)
@@ -74,7 +73,6 @@ import qualified Data.ByteString.Lazy as Lazy (ByteString)
7473import qualified Data.ByteString as Strict (ByteString)
7574import qualified Data.Text.Lazy as Lazy (Text)
7675import qualified Data.Text as Strict (Text)
77−import qualified Database.PostgreSQL.LibPQ as LibPQ
7876import qualified GHC.Generics as GHC
7977import qualified Generics.SOP as SOP
8078import qualified Generics.SOP.Record as SOP
@@ -108,7 +106,11 @@ type instance PG Int32 = 'PGint4
108106-- | `PGint8`
109107type instance PG Int64 = 'PGint8
110108-- | `PGint2`
111−type instance PG LibPQ.Oid = 'PGoid
109+type instance PG Word16 = 'PGint2
110+-- | `PGint4`
111+type instance PG Word32 = 'PGint4
112+-- | `PGint8`
113+type instance PG Word64 = 'PGint8
112114-- | `PGnumeric`
113115type instance PG Scientific = 'PGnumeric
114116-- | `PGfloat4`
@@ -178,16 +180,8 @@ type family RowPG (hask :: Type) :: RowType where
178180
179181-- | `RowOf` applies `NullPG` to the fields of a list.
180182type family RowOf (record :: [(Symbol, Type)]) :: RowType where
181− RowOf (col ::: ty ': col1 ::: ty1 ': col2 ::: ty2 ': col3 ::: ty3 ': col4 ::: ty4 ': record) =
182− col ::: NullPG ty ': col1 ::: NullPG ty1 ': col2 ::: NullPG ty2 ': col3 ::: NullPG ty3 ': col4 ::: NullPG ty4 ': RowOf record
183− RowOf (col ::: ty ': col1 ::: ty1 ': col2 ::: ty2 ': col3 ::: ty3 ': record) =
184− col ::: NullPG ty ': col1 ::: NullPG ty1 ': col2 ::: NullPG ty2 ': col3 ::: NullPG ty3 ': RowOf record
185− RowOf (col ::: ty ': col1 ::: ty1 ': col2 ::: ty2 ': record) =
186− col ::: NullPG ty ': col1 ::: NullPG ty1 ': col2 ::: NullPG ty2 ': RowOf record
187− RowOf (col ::: ty ': col1 ::: ty1 ': record) =
188− col ::: NullPG ty ': col1::: NullPG ty1 ': RowOf record
189− RowOf (col ::: ty ': record) = col ::: NullPG ty ': RowOf record
190183 RowOf '[] = '[]
184+ RowOf (col ::: ty ': record) = col ::: NullPG ty ': RowOf record
191185
192186{- | `NullPG` turns a Haskell type into a `NullityType`.
193187
@@ -214,17 +208,8 @@ type family TuplePG (hask :: Type) :: [NullityType] where
214208
215209-- | `TupleOf` turns a list of Haskell `Type`s into a list of `NullityType`s.
216210type family TupleOf (tuple :: [Type]) :: [NullityType] where
217− TupleOf (hask ': hask1 ': hask2 ': hask3 ': hask4 ': hask5 ': tuple) =
218− NullPG hask ': NullPG hask1 ': NullPG hask2 ': NullPG hask3 ': NullPG hask4 ': NullPG hask5 ': TupleOf tuple
219− TupleOf (hask ': hask1 ': hask2 ': hask3 ': hask4 ': tuple) =
220− NullPG hask ': NullPG hask1 ': NullPG hask2 ': NullPG hask3 ': NullPG hask4 ': TupleOf tuple
221− TupleOf (hask ': hask1 ': hask2 ': hask3 ': tuple) =
222− NullPG hask ': NullPG hask1 ': NullPG hask2 ': NullPG hask3 ': TupleOf tuple
223− TupleOf (hask ': hask1 ': hask2 ': tuple) =
224− NullPG hask ': NullPG hask1 ': NullPG hask2 ': TupleOf tuple
225− TupleOf (hask ': hask1 ': tuple) = NullPG hask ': NullPG hask1 ': TupleOf tuple
226− TupleOf (hask ': tuple) = NullPG hask ': TupleOf tuple
227211 TupleOf '[] = '[]
212+ TupleOf (hask ': tuple) = NullPG hask ': TupleOf tuple
228213
229214-- | `TupleCodeOf` takes the `SOP.Code` of a haskell `Type`
230215-- and if it's a simple product returns it, otherwise giving a `TypeError`.
@@ -319,8 +304,7 @@ withConnection "host=localhost port=5432 dbname=exampledb" $ do
319304True
320305-}
321306newtype Money = Money { cents :: Int64 }
322− deriving stock (Eq, Ord, Show, Read, GHC.Generic)
323− deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
307+ deriving (Eq, Ord, Show, Read, GHC.Generic)
324308-- | `PGmoney`
325309type instance PG Money = 'PGmoney
326310
@@ -328,8 +312,7 @@ type instance PG Money = 'PGmoney
328312type it's applied to should be stored as a `PGjson`.
329313-}
330314newtype Json hask = Json {getJson :: hask}
331− deriving stock (Eq, Ord, Show, Read, GHC.Generic)
332− deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
315+ deriving (Eq, Ord, Show, Read, GHC.Generic)
333316-- | `PGjson`
334317type instance PG (Json hask) = 'PGjson
335318
@@ -337,8 +320,7 @@ type instance PG (Json hask) = 'PGjson
337320type it's applied to should be stored as a `PGjsonb`.
338321-}
339322newtype Jsonb hask = Jsonb {getJsonb :: hask}
340− deriving stock (Eq, Ord, Show, Read, GHC.Generic)
341− deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
323+ deriving (Eq, Ord, Show, Read, GHC.Generic)
342324-- | `PGjsonb`
343325type instance PG (Jsonb hask) = 'PGjsonb
344326
@@ -346,8 +328,7 @@ type instance PG (Jsonb hask) = 'PGjsonb
346328type it's applied to should be stored as a `PGcomposite`.
347329-}
348330newtype Composite record = Composite {getComposite :: record}
349− deriving stock (Eq, Ord, Show, Read, GHC.Generic)
350− deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
331+ deriving (Eq, Ord, Show, Read, GHC.Generic)
351332-- | `PGcomposite` @(@`RowPG` @hask)@
352333type instance PG (Composite hask) = 'PGcomposite (RowPG hask)
353334
@@ -355,8 +336,7 @@ type instance PG (Composite hask) = 'PGcomposite (RowPG hask)
355336type it's applied to should be stored as a `PGenum`.
356337-}
357338newtype Enumerated enum = Enumerated {getEnumerated :: enum}
358− deriving stock (Eq, Ord, Show, Read, GHC.Generic)
359− deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
339+ deriving (Eq, Ord, Show, Read, GHC.Generic)
360340-- | `PGenum` @(@`LabelsPG` @hask)@
361341type instance PG (Enumerated hask) = 'PGenum (LabelsPG hask)
362342
@@ -368,8 +348,7 @@ PG (VarArray (Vector Double)) :: PGType
368348= 'PGvararray ('NotNull 'PGfloat8)
369349-}
370350newtype VarArray arr = VarArray {getVarArray :: arr}
371− deriving stock (Eq, Ord, Show, Read, GHC.Generic)
372− deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
351+ deriving (Eq, Ord, Show, Read, GHC.Generic)
373352-- | `PGvararray` @(@`NullPG` @hask)@
374353type instance PG (VarArray (Vector hask)) = 'PGvararray (NullPG hask)
375354type instance PG (VarArray [hask]) = 'PGvararray (NullPG hask)
@@ -382,7 +361,6 @@ PG (FixArray ((Double, Double), (Double, Double))) :: PGType
382361= 'PGfixarray '[2, 2] ('NotNull 'PGfloat8)
383362-}
384363newtype FixArray arr = FixArray {getFixArray :: arr}
385− deriving stock (Eq, Ord, Show, Read, GHC.Generic)
386− deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
364+ deriving (Eq, Ord, Show, Read, GHC.Generic)
387365-- | `PGfixarray` @(@`DimPG` @hask) (@`FixPG` @hask)@
388366type instance PG (FixArray hask) = 'PGfixarray (DimPG hask) (FixPG hask)
squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs+19−51
@@ -68,17 +68,15 @@ module Squeal.PostgreSQL.PQ
6868 , okResult
6969 , catchSqueal
7070 , handleSqueal
71− , trySqueal
7271 ) where
7372
7473import Control.Exception (Exception, throw)
7574import Control.Monad.Except
7675import Control.Monad.Morph
77−import UnliftIO (MonadUnliftIO (..), bracket, catch, handle, try)
76+import UnliftIO (MonadUnliftIO (..), bracket, catch, handle)
7877import Data.ByteString (ByteString)
7978import Data.Foldable
8079import Data.Function ((&))
81−import Data.Functor ((<&>))
8280import Data.Kind
8381import Data.Text (pack, Text)
8482import Data.Traversable
@@ -87,7 +85,6 @@ import PostgreSQL.Binary.Encoding (encodingBytes)
8785
8886import qualified Control.Monad.Fail as Fail
8987import qualified Database.PostgreSQL.LibPQ as LibPQ
90−import qualified PostgreSQL.Binary.Encoding as Encoding
9188
9289import Squeal.PostgreSQL.Binary
9390import Squeal.PostgreSQL.Definition
@@ -317,13 +314,13 @@ a default instance.
317314-}
318315class Monad pq => MonadPQ schemas pq | pq -> schemas where
319316 manipulateParams
320− :: (ToParams x params, All OidOfParam params)
317+ :: ToParams x params
321318 => Manipulation '[] schemas params ys
322319 -- ^ `insertInto`, `update` or `deleteFrom`
323320 -> x -> pq (K LibPQ.Result ys)
324321 default manipulateParams
325322 :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)
326− => (ToParams x params, All OidOfParam params)
323+ => ToParams x params
327324 => Manipulation '[] schemas params ys
328325 -- ^ `insertInto`, `update` or `deleteFrom`
329326 -> x -> pq (K LibPQ.Result ys)
@@ -331,7 +328,7 @@ class Monad pq => MonadPQ schemas pq | pq -> schemas where
331328 manipulateParams manipulation params
332329
333330 manipulateParams_
334− :: (ToParams x params, All OidOfParam params)
331+ :: ToParams x params
335332 => Manipulation '[] schemas params '[]
336333 -- ^ `insertInto`, `update` or `deleteFrom`
337334 -> x -> pq ()
@@ -344,7 +341,7 @@ class Monad pq => MonadPQ schemas pq | pq -> schemas where
344341 manipulate_ = void . manipulate
345342
346343 runQueryParams
347− :: (ToParams x params, All OidOfParam params)
344+ :: ToParams x params
348345 => Query '[] '[] schemas params ys
349346 -- ^ `select` and friends
350347 -> x -> pq (K LibPQ.Result ys)
@@ -357,19 +354,19 @@ class Monad pq => MonadPQ schemas pq | pq -> schemas where
357354 runQuery q = runQueryParams q ()
358355
359356 traversePrepared
360− :: (ToParams x params, Traversable list, All OidOfParam params)
357+ :: (ToParams x params, Traversable list)
361358 => Manipulation '[] schemas params ys
362359 -- ^ `insertInto`, `update`, or `deleteFrom`, and friends
363360 -> list x -> pq (list (K LibPQ.Result ys))
364361 default traversePrepared
365362 :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)
366− => (ToParams x params, Traversable list, All OidOfParam params)
363+ => (ToParams x params, Traversable list)
367364 => Manipulation '[] schemas params ys -> list x -> pq (list (K LibPQ.Result ys))
368365 traversePrepared manipulation params = lift $
369366 traversePrepared manipulation params
370367
371368 forPrepared
372− :: (ToParams x params, Traversable list, All OidOfParam params)
369+ :: (ToParams x params, Traversable list)
373370 => list x
374371 -> Manipulation '[] schemas params ys
375372 -- ^ `insertInto`, `update` or `deleteFrom`
@@ -377,13 +374,13 @@ class Monad pq => MonadPQ schemas pq | pq -> schemas where
377374 forPrepared = flip traversePrepared
378375
379376 traversePrepared_
380− :: (ToParams x params, Foldable list, All OidOfParam params)
377+ :: (ToParams x params, Foldable list)
381378 => Manipulation '[] schemas params '[]
382379 -- ^ `insertInto`, `update` or `deleteFrom`
383380 -> list x -> pq ()
384381 default traversePrepared_
385382 :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)
386− => (ToParams x params, Foldable list, All OidOfParam params)
383+ => (ToParams x params, Foldable list)
387384 => Manipulation '[] schemas params '[]
388385 -- ^ `insertInto`, `update` or `deleteFrom`
389386 -> list x -> pq ()
@@ -391,7 +388,7 @@ class Monad pq => MonadPQ schemas pq | pq -> schemas where
391388 traversePrepared_ manipulation params
392389
393390 forPrepared_
394− :: (ToParams x params, Foldable list, All OidOfParam params)
391+ :: (ToParams x params, Foldable list)
395392 => list x
396393 -> Manipulation '[] schemas params '[]
397394 -- ^ `insertInto`, `update` or `deleteFrom`
@@ -411,17 +408,9 @@ instance (MonadIO io, schemas0 ~ schemas, schemas1 ~ schemas)
411408 (UnsafeManipulation q :: Manipulation '[] schemas ps ys) (params :: x) =
412409 PQ $ \ (K conn) -> do
413410 let
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 ->
420− (oidOfParam @param, encodingBytes encoding, LibPQ.Binary)
421− params'
422− = hcollapse
423− . hcmap (Proxy @OidOfParam) paramSet
424− $ toParams @x @ps params
411+ toParam' encoding =
412+ (LibPQ.invalidOid, encodingBytes encoding, LibPQ.Binary)
413+ params' = fmap (fmap toParam') (hcollapse (toParams @x @ps params))
425414 q' = q <> ";"
426415 resultMaybe <- liftIO $ LibPQ.execParams conn q' params' LibPQ.Binary
427416 case resultMaybe of
@@ -434,22 +423,15 @@ instance (MonadIO io, schemas0 ~ schemas, schemas1 ~ schemas)
434423 traversePrepared
435424 (UnsafeManipulation q :: Manipulation '[] schemas xs ys) (list :: list x) =
436425 PQ $ \ (K conn) -> liftIO $ do
437− let
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
445− prepResultMaybe <- LibPQ.prepare conn temp q (Just paramOids')
426+ let temp = "temporary_statement"
427+ prepResultMaybe <- LibPQ.prepare conn temp q Nothing
446428 case prepResultMaybe of
447429 Nothing -> throw $ ResultException
448430 "traversePrepared: LibPQ.prepare returned no results"
449431 Just prepResult -> okResult_ prepResult
450432 results <- for list $ \ params -> do
451433 let
452− toParam' encoding = (encodingBytes encoding, LibPQ.Binary)
434+ toParam' encoding = (encodingBytes encoding,LibPQ.Binary)
453435 params' = fmap (fmap toParam') (hcollapse (toParams @x @xs params))
454436 resultMaybe <- LibPQ.execPrepared conn temp params' LibPQ.Binary
455437 case resultMaybe of
@@ -468,15 +450,8 @@ instance (MonadIO io, schemas0 ~ schemas, schemas1 ~ schemas)
468450 traversePrepared_
469451 (UnsafeManipulation q :: Manipulation '[] schemas xs '[]) (list :: list x) =
470452 PQ $ \ (K conn) -> liftIO $ do
471− let
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
479− prepResultMaybe <- LibPQ.prepare conn temp q (Just paramOids')
453+ let temp = "temporary_statement"
454+ prepResultMaybe <- LibPQ.prepare conn temp q Nothing
480455 case prepResultMaybe of
481456 Nothing -> throw $ ResultException
482457 "traversePrepared_: LibPQ.prepare returned no results"
@@ -703,10 +678,3 @@ handleSqueal
703678 => (SquealException -> io a) -- ^ handler
704679 -> io a -> io a
705680handleSqueal = handle
706−
707−-- | `Either` return a `SquealException` or a result.
708−trySqueal
709− :: MonadUnliftIO io
710− => io a
711− -> io (Either SquealException a)
712−trySqueal = try
squeal-postgresql/src/Squeal/PostgreSQL/Pool.hs+99−67
@@ -1,33 +1,11 @@
11{-|
2−Module: Squeal.PostgreSQL.Pool
3−Description: Connection pools
2+Module: Squeal.PostgreSQL.Definition
3+Description: Pooled connections
44Copyright: (c) Eitan Chatav, 2017
55Maintainer: eitan@morphism.tech
66Stability: experimental
77
8−Connection pools.
9−
10−Typical use case would be to create your pool using `createConnectionPool`
11−and run anything that requires the pool connection with `usingConnectionPool`.
12−
13−Here's a simplified example:
14−
15−>>> import Squeal.PostgreSQL
16−
17−>>> :{
18−do
19− let
20− query :: Query_ (Public '[]) () (Only Char)
21− query = values_ (literal 'a' `as` #fromOnly)
22− pool <- createConnectionPool "host=localhost port=5432 dbname=exampledb" 1 0.5 10
23− chr <- usingConnectionPool pool $ do
24− result <- runQuery query
25− Just (Only a) <- firstRow result
26− return a
27− destroyConnectionPool pool
28− putChar chr
29−:}
30−a
8+A `MonadPQ` for pooled connections.
319-}
3210
3311{-# LANGUAGE
@@ -45,19 +23,51 @@ a
4523
4624module Squeal.PostgreSQL.Pool
4725 ( -- * Pools
48− Pool
26+ PoolPQ (..)
4927 , createConnectionPool
50− , usingConnectionPool
51− , destroyConnectionPool
28+ , Pool
29+ , destroyAllResources
5230 ) where
5331
32+import Control.Monad.Trans
5433import Data.ByteString
5534import Data.Time
56−import Generics.SOP (K(..), unK)
35+import Generics.SOP (K(..))
5736import UnliftIO (MonadUnliftIO (..))
5837import UnliftIO.Pool (Pool, createPool, destroyAllResources, withResource)
5938
39+import qualified Control.Monad.Fail as Fail
40+
6041import Squeal.PostgreSQL.PQ
42+import Squeal.PostgreSQL.Schema
43+
44+{- | `PoolPQ` @schemas@ should be a drop-in replacement for `PQ` @schemas schemas@.
45+
46+Typical use case would be to create your pool using `createConnectionPool` and run anything that requires the pool connection with it.
47+
48+Here's a simplified example:
49+
50+>>> import Squeal.PostgreSQL
51+>>> :{
52+do
53+ let
54+ query :: Query_ (Public '[]) () (Only Char)
55+ query = values_ $ literal 'a' `as` #fromOnly
56+ session :: PoolPQ (Public '[]) IO Char
57+ session = do
58+ result <- runQuery query
59+ Just (Only chr) <- firstRow result
60+ return chr
61+ pool <- createConnectionPool "host=localhost port=5432 dbname=exampledb" 1 0.5 10
62+ chr <- runPoolPQ session pool
63+ destroyAllResources pool
64+ putChar chr
65+:}
66+a
67+-}
68+newtype PoolPQ (schemas :: SchemasType) m x =
69+ PoolPQ { runPoolPQ :: Pool (K Connection schemas) -> m x }
70+ deriving Functor
6171
6272-- | Create a striped pool of connections.
6373-- Although the garbage collector will destroy all idle connections when the pool is garbage collected it's recommended to manually `destroyAllResources` when you're done with the pool so that the connections are freed up as soon as possible.
@@ -82,41 +92,63 @@ createConnectionPool
8292createConnectionPool conninfo stripes idle maxResrc =
8393 createPool (connectdb conninfo) finish stripes idle maxResrc
8494
85−{-|
86−Temporarily take a connection from a `Pool`, perform an action with it,
87−and return it to the pool afterwards.
88−
89−If the pool has an idle connection available, it is used immediately.
90−Otherwise, if the maximum number of connections has not yet been reached,
91−a new connection is created and used.
92−If the maximum number of connections has been reached, this function blocks
93−until a connection becomes available.
94−-}
95−usingConnectionPool
96− :: MonadUnliftIO io
97− => Pool (K Connection schemas) -- ^ pool
98− -> PQ schemas schemas io x -- ^ session
99− -> io x
100−usingConnectionPool pool (PQ session) = unK <$> withResource pool session
101−
102−{- |
103−Destroy all connections in all stripes in the pool.
104−Note that this will ignore any exceptions in the destroy function.
105−
106−This function is useful when you detect that all connections
107−in the pool are broken. For example after a database has been
108−restarted all connections opened before the restart will be broken.
109−In that case it's better to close those connections so that
110−`usingConnectionPool` won't take a broken connection from the pool
111−but will open a new connection instead.
112−
113−Another use-case for this function is that when you know you are done
114−with the pool you can destroy all idle connections immediately
115−instead of waiting on the garbage collector to destroy them,
116−thus freeing up those connections sooner.
117−-}
118−destroyConnectionPool
119− :: MonadUnliftIO io
120− => Pool (K Connection schemas) -- ^ pool
121− -> io ()
122−destroyConnectionPool = destroyAllResources
95+-- | `Applicative` instance for `PoolPQ`.
96+instance Monad m => Applicative (PoolPQ schemas m) where
97+ pure x = PoolPQ $ \ _ -> pure x
98+ PoolPQ f <*> PoolPQ x = PoolPQ $ \ pool -> do
99+ f' <- f pool
100+ x' <- x pool
101+ return $ f' x'
102+
103+-- | `Monad` instance for `PoolPQ`.
104+instance Monad m => Monad (PoolPQ schemas m) where
105+ return = pure
106+ PoolPQ x >>= f = PoolPQ $ \ pool -> do
107+ x' <- x pool
108+ runPoolPQ (f x') pool
109+
110+-- | `Fail.MonadFail` instance for `PoolPQ`.
111+instance Monad m => Fail.MonadFail (PoolPQ schemas m) where
112+ fail = Fail.fail
113+
114+-- | `MonadTrans` instance for `PoolPQ`.
115+instance MonadTrans (PoolPQ schemas) where
116+ lift m = PoolPQ $ \ _pool -> m
117+
118+-- | `MonadPQ` instance for `PoolPQ`.
119+instance MonadUnliftIO io => MonadPQ schemas (PoolPQ schemas io) where
120+ manipulateParams manipulation params = PoolPQ $ \ pool -> do
121+ withResource pool $ \ conn -> do
122+ (K result :: K (K Result ys) schemas) <- flip unPQ conn $
123+ manipulateParams manipulation params
124+ return result
125+ traversePrepared manipulation params = PoolPQ $ \ pool ->
126+ withResource pool $ \ conn -> do
127+ (K result :: K (list (K Result ys)) schemas) <- flip unPQ conn $
128+ traversePrepared manipulation params
129+ return result
130+ traversePrepared_ manipulation params = PoolPQ $ \ pool -> do
131+ withResource pool $ \ conn -> do
132+ (_ :: K () schemas) <- flip unPQ conn $
133+ traversePrepared_ manipulation params
134+ return ()
135+ liftPQ m = PoolPQ $ \ pool ->
136+ withResource pool $ \ conn -> do
137+ (K result :: K result schemas) <- flip unPQ conn $
138+ liftPQ m
139+ return result
140+
141+-- | 'MonadIO' instance for 'PoolPQ'.
142+instance (MonadIO m)
143+ => MonadIO (PoolPQ schemas m) where
144+ liftIO = lift . liftIO
145+
146+-- | 'MonadUnliftIO' instance for 'PoolPQ'.
147+instance (MonadUnliftIO m)
148+ => MonadUnliftIO (PoolPQ schemas m) where
149+ withRunInIO
150+ :: ((forall a . PoolPQ schemas m a -> IO a) -> IO b)
151+ -> PoolPQ schemas m b
152+ withRunInIO inner = PoolPQ $ \pool ->
153+ withRunInIO $ \(run :: (forall x . m x -> IO x)) ->
154+ inner (\poolpq -> run $ runPoolPQ poolpq pool)
squeal-postgresql/src/Squeal/PostgreSQL/Query.hs+31−82
@@ -39,8 +39,6 @@ module Squeal.PostgreSQL.Query
3939 , select_
4040 , selectDistinct
4141 , selectDistinct_
42− , selectDistinctOn
43− , selectDistinctOn_
4442 , Selection (..)
4543 -- ** Values
4644 , values
@@ -142,7 +140,8 @@ using `Squeal.PostgreSQL.PQ.runQuery`.
142140Generally, @parameters@ will be a Haskell tuple or record whose entries
143141may be referenced using positional
144142`Squeal.PostgreSQL.Expression.Parameter.parameter`s and @row@ will be a
145−Haskell record, whose entries will be targeted using overloaded labels.
143+Haskell record or a generalized record using tuples of `P` types and normal Haskell
144+records, whose entries will be targeted using overloaded labels.
146145
147146Let's see some examples of queries.
148147
@@ -213,15 +212,15 @@ aggregation query:
213212
214213>>> :{
215214let
216− query :: Query_ (Public Schema) () (Row Int64 Int32)
215+ query :: Query_ (Public Schema) () (Row Int32 Int32)
217216 query =
218217 select_ ((fromNull 0 (sum_ (All #col2))) `as` #col1 :* #col1 `as` #col2)
219218 ( from (table (#tab `as` #table1))
220219 & groupBy #col1
221− & having (sum_ (Distinct #col2) .> 1) )
220+ & having (#col1 + (fromNull 0 (sum_ (Distinct #col2))) .> 1) )
222221in printSQL query
223222:}
224−SELECT COALESCE(sum(ALL "col2"), 0) AS "col1", "col1" AS "col2" FROM "tab" AS "table1" GROUP BY "col1" HAVING (sum(DISTINCT "col2") > 1)
223+SELECT COALESCE(sum(ALL "col2"), 0) AS "col1", "col1" AS "col2" FROM "tab" AS "table1" GROUP BY "col1" HAVING (("col1" + COALESCE(sum(DISTINCT "col2"), 0)) > 1)
225224
226225sorted query:
227226
@@ -554,9 +553,9 @@ select_ = select . List
554553-- be subject to the elimination of duplicate rows using `selectDistinct`.
555554selectDistinct
556555 :: (SListI columns, columns ~ (col ': cols))
557− => Selection outer commons grp schemas params from columns
556+ => Selection outer commons 'Ungrouped schemas params from columns
558557 -- ^ selection
559− -> TableExpression outer commons grp schemas params from
558+ -> TableExpression outer commons 'Ungrouped schemas params from
560559 -- ^ intermediate virtual table
561560 -> Query outer commons schemas params columns
562561selectDistinct selection tabexpr = UnsafeQuery $
@@ -568,62 +567,13 @@ selectDistinct selection tabexpr = UnsafeQuery $
568567-- of a general `Selection`.
569568selectDistinct_
570569 :: (SListI columns, columns ~ (col ': cols))
571− => NP (Aliased (Expression outer commons grp schemas params from)) columns
570+ => NP (Aliased (Expression outer commons 'Ungrouped schemas params from)) columns
572571 -- ^ select list
573− -> TableExpression outer commons grp schemas params from
572+ -> TableExpression outer commons 'Ungrouped schemas params from
574573 -- ^ intermediate virtual table
575574 -> Query outer commons schemas params columns
576575selectDistinct_ = selectDistinct . List
577576
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−
627577-- | `values` computes a row value or set of row values
628578-- specified by value expressions. It is most commonly used
629579-- to generate a “constant table” within a larger command,
@@ -757,7 +707,7 @@ instance RenderSQL (TableExpression outer commons grp schemas params from) where
757707from
758708 :: FromClause outer commons schemas params from -- ^ table reference
759709 -> TableExpression outer commons 'Ungrouped schemas params from
760−from tab = TableExpression tab [] noGroups NoHaving [] [] []
710+from tab = TableExpression tab [] NoGroups NoHaving [] [] []
761711
762712-- | A `where_` is an endomorphism of `TableExpression`s which adds a
763713-- search condition to the `whereClause`.
@@ -778,7 +728,7 @@ groupBy
778728groupBy bys rels = TableExpression
779729 { fromClause = fromClause rels
780730 , whereClause = whereClause rels
781− , groupByClause = group bys
731+ , groupByClause = Group bys
782732 , havingClause = Having []
783733 , orderByClause = []
784734 , limitClause = limitClause rels
@@ -992,20 +942,19 @@ instance (Has rel rels cols, Has col cols ty, bys ~ '[ '(rel, col)])
992942-- done on @NoGroups@ while all output `Expression`s must be aggregated
993943-- in @Group Nil@. In general, all output `Expression`s in the
994944-- complement of @bys@ must be aggregated in @Group bys@.
995−newtype GroupByClause grp from = UnsafeGroupByClause
996− { renderGroupByClause :: ByteString }
997− deriving (GHC.Generic,Show,Eq,Ord,NFData)
945+data GroupByClause grp from where
946+ NoGroups :: GroupByClause 'Ungrouped from
947+ Group
948+ :: SListI bys
949+ => NP (By from) bys
950+ -> GroupByClause ('Grouped bys) from
951+
952+-- | Renders a `GroupByClause`.
998953instance RenderSQL (GroupByClause grp from) where
999− renderSQL = renderGroupByClause
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
1007− Nil -> ""
1008− bys' -> " GROUP BY" <+> renderCommaSeparated renderSQL bys'
954+ renderSQL = \case
955+ NoGroups -> ""
956+ Group Nil -> ""
957+ Group bys -> " GROUP BY" <+> renderCommaSeparated renderSQL bys
1009958
1010959-- | A `HavingClause` is used to eliminate groups that are not of interest.
1011960-- An `Ungrouped` `TableExpression` may only use `NoHaving` while a `Grouped`
@@ -1049,8 +998,8 @@ instance
1049998 , commons1 ~ (cte ::: common ': commons)
1050999 ) => Aliasable cte
10511000 (statement commons schemas params common)
1052− (Path (CommonTableExpression statement schemas params) commons commons1) where
1053− statement `as` cte = csingleton (statement `as` cte)
1001+ (AlignedList (CommonTableExpression statement schemas params) commons commons1) where
1002+ statement `as` cte = single (statement `as` cte)
10541003
10551004instance (forall c s p r. RenderSQL (statement c s p r)) => RenderSQL
10561005 (CommonTableExpression statement schemas params commons0 commons1) where
@@ -1062,7 +1011,7 @@ instance (forall c s p r. RenderSQL (statement c s p r)) => RenderSQL
10621011-- defining temporary tables that exist just for one query.
10631012class With statement where
10641013 with
1065− :: Path (CommonTableExpression statement schemas params) commons0 commons1
1014+ :: AlignedList (CommonTableExpression statement schemas params) commons0 commons1
10661015 -- ^ common table expressions
10671016 -> statement commons1 schemas params row
10681017 -- ^ larger query
@@ -1070,23 +1019,23 @@ class With statement where
10701019instance With (Query outer) where
10711020 with Done query = query
10721021 with ctes query = UnsafeQuery $
1073− "WITH" <+> commaSeparated (ctoList renderSQL ctes) <+> renderSQL query
1022+ "WITH" <+> renderSQL ctes <+> renderSQL query
10741023
10751024{- |
10761025>>> import Data.Monoid (Sum (..))
1077−>>> import Data.Int (Int64)
1026+>>> import Data.Int (Int32)
10781027>>> :{
10791028 let
1080− query :: Query_ schema () (Sum Int64)
1029+ query :: Query_ schema () (Sum Int32)
10811030 query = withRecursive
1082− ( values_ ((1 & astype int) `as` #n)
1031+ ( values_ (1 `as` #n)
10831032 `unionAll`
10841033 select_ ((#n + 1) `as` #n)
10851034 (from (common #t) & where_ (#n .< 100)) `as` #t )
10861035 ( select_ (fromNull 0 (sum_ (All #n)) `as` #getSum) (from (common #t) & groupBy Nil))
10871036 in printSQL query
10881037:}
1089−WITH RECURSIVE "t" AS ((SELECT * FROM (VALUES ((1 :: int))) AS t ("n")) UNION ALL (SELECT ("n" + 1) AS "n" FROM "t" AS "t" WHERE ("n" < 100))) SELECT COALESCE(sum(ALL "n"), 0) AS "getSum" FROM "t" AS "t"
1038+WITH RECURSIVE "t" AS ((SELECT * FROM (VALUES (1)) AS t ("n")) UNION ALL (SELECT ("n" + 1) AS "n" FROM "t" AS "t" WHERE ("n" < 100))) SELECT COALESCE(sum(ALL "n"), 0) AS "getSum" FROM "t" AS "t"
10901039-}
10911040withRecursive
10921041 :: Aliased (Query outer (recursive ': commons) schemas params) recursive
squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs+10−157
@@ -44,10 +44,6 @@ module Squeal.PostgreSQL.Schema
4444 , ColumnsType
4545 , TableType
4646 , SchemumType (..)
47− , IndexType (..)
48− , FunctionType
49− , OperatorType (..)
50− , ReturnsType (..)
5147 , SchemaType
5248 , SchemasType
5349 , Public
@@ -62,16 +58,9 @@ module Squeal.PostgreSQL.Schema
6258 , PGlabel (..)
6359 -- * Data Definitions
6460 , Create
65− , CreateIfNotExists
66− , CreateOrReplace
6761 , Drop
68− , DropSchemum
69− , DropIfExists
70− , DropSchemumIfExists
7162 , Alter
72− , AlterIfExists
7363 , Rename
74− , RenameIfExists
7564 , ConstraintInvolves
7665 , DropIfConstraintsInvolve
7766 , IsNotElem
@@ -143,9 +132,7 @@ data PGType
143132 | PGenum [Symbol] -- ^ enumerated (enum) types are data types that comprise a static, ordered set of values.
144133 | PGcomposite RowType -- ^ a composite type represents the structure of a row or record; it is essentially just a list of field names and their data types.
145134 | PGtsvector -- ^ A tsvector value is a sorted list of distinct lexemes, which are words that have been normalized to merge different variants of the same word.
146− | PGtsquery -- ^ A tsquery value stores lexemes that are to be searched for.
147− | PGoid -- Object identifiers (OIDs) are used internally by PostgreSQL as primary keys for various system tables.
148− | PGrange PGType -- ^ Range types are data types representing a range of values of some element type (called the range's subtype).
135+ | PGtsquery -- ^ A tsquery value stores lexemes that are to be searched for
149136 | UnsafePGType Symbol -- ^ an escape hatch for unsupported PostgreSQL types
150137
151138-- | `NullityType` encodes the potential presence or definite absence of a
@@ -260,19 +247,9 @@ type FromType = [(Symbol,RowType)]
260247
261248-- | `ColumnsToRow` removes column constraints.
262249type family ColumnsToRow (columns :: ColumnsType) :: RowType where
263− ColumnsToRow (column ::: _ :=> ty ': column1 ::: _ :=> ty1 ': column2 ::: _ :=> ty2 ': column3 ::: _ :=> ty3 ': column4 ::: _ :=> ty4 ': column5 ::: _ :=> ty5 ': columns) =
264− column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': column3 ::: ty3 ': column4 ::: ty4 ': column5 ::: ty5 ': ColumnsToRow columns
265− ColumnsToRow (column ::: _ :=> ty ': column1 ::: _ :=> ty1 ': column2 ::: _ :=> ty2 ': column3 ::: _ :=> ty3 ': column4 ::: _ :=> ty4 ': columns) =
266− column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': column3 ::: ty3 ': column4 ::: ty4 ': ColumnsToRow columns
267− ColumnsToRow (column ::: _ :=> ty ': column1 ::: _ :=> ty1 ': column2 ::: _ :=> ty2 ': column3 ::: _ :=> ty3 ': columns) =
268− column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': column3 ::: ty3 ': ColumnsToRow columns
269− ColumnsToRow (column ::: _ :=> ty ': column1 ::: _ :=> ty1 ': column2 ::: _ :=> ty2 ': columns) =
270− column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': ColumnsToRow columns
271− ColumnsToRow (column ::: _ :=> ty ': column1 ::: _ :=> ty1 ': columns) =
272− column ::: ty ': column1 ::: ty1 ': ColumnsToRow columns
273− ColumnsToRow (column ::: _ :=> ty ': columns) =
274− column ::: ty ': ColumnsToRow columns
275250 ColumnsToRow '[] = '[]
251+ ColumnsToRow (column ::: constraint :=> ty ': columns) =
252+ column ::: ty ': ColumnsToRow columns
276253
277254-- | `TableToColumns` removes table constraints.
278255type family TableToColumns (table :: TableType) :: ColumnsType where
@@ -305,24 +282,14 @@ instance ty0 ~ ty1 => SamePGType
305282
306283-- | `AllNotNull` is a constraint that proves a `ColumnsType` has no @NULL@s.
307284type 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
314285 AllNotNull '[] = ()
286+ AllNotNull (column ::: def :=> 'NotNull ty ': columns) = AllNotNull columns
315287
316288-- | `NotAllNull` is a constraint that proves a `ColumnsType` has some
317289-- @NOT NULL@.
318290type family NotAllNull (columns :: ColumnsType) :: Constraint where
319− NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()
320− NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()
321− NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()
322− NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()
323− NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()
324− NotAllNull (_ ::: _ :=> 'NotNull _ ': _) = ()
325− NotAllNull (_ ::: _ :=> 'Null _ ': columns) = NotAllNull columns
291+ NotAllNull (column ::: def :=> 'NotNull ty ': columns) = ()
292+ NotAllNull (column ::: def :=> 'Null ty ': columns) = NotAllNull columns
326293
327294-- | `NullifyType` is an idempotent that nullifies a `NullityType`.
328295type family NullifyType (ty :: NullityType) :: NullityType where
@@ -331,37 +298,17 @@ type family NullifyType (ty :: NullityType) :: NullityType where
331298
332299-- | `NullifyRow` is an idempotent that nullifies a `RowType`.
333300type family NullifyRow (columns :: RowType) :: RowType where
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
301+ NullifyRow '[] = '[]
344302 NullifyRow (column ::: ty ': columns) =
345303 column ::: NullifyType ty ': NullifyRow columns
346− NullifyRow '[] = '[]
347304
348305-- | `NullifyFrom` is an idempotent that nullifies a `FromType`
349306-- used to nullify the left or right hand side of an outer join
350307-- in a `Squeal.PostgreSQL.Query.FromClause`.
351308type family NullifyFrom (tables :: FromType) :: FromType where
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
309+ NullifyFrom '[] = '[]
362310 NullifyFrom (table ::: columns ': tables) =
363311 table ::: NullifyRow columns ': NullifyFrom tables
364− NullifyFrom '[] = '[]
365312
366313-- | @Create alias x xs@ adds @alias ::: x@ to the end of @xs@ and is used in
367314-- `Squeal.PostgreSQL.Definition.createTable` statements and in @ALTER TABLE@
@@ -371,101 +318,30 @@ type family Create alias x xs where
371318 Create alias x (alias ::: y ': xs) = TypeError
372319 ('Text "Create: alias "
373320 ':<>: 'ShowType alias
374− ':<>: 'Text "already exists")
321+ ':<>: 'Text "already in use")
375322 Create alias y (x ': xs) = x ': Create alias y xs
376323
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−
394324-- | @Drop alias xs@ removes the type associated with @alias@ in @xs@
395325-- and is used in `Squeal.PostgreSQL.Definition.dropTable` statements
396326-- and in @ALTER TABLE@ `Squeal.PostgreSQL.Definition.dropColumn` statements.
397327type family Drop alias xs where
398− Drop alias '[] = TypeError
399− ('Text "Drop: alias "
400− ':<>: 'ShowType alias
401− ':<>: 'Text " does not exist" )
402− Drop alias (alias ::: x ': xs) = xs
328+ Drop alias ((alias ::: x) ': xs) = xs
403329 Drop alias (x ': xs) = x ': Drop alias xs
404330
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−
437331-- | @Alter alias x xs@ replaces the type associated with an @alias@ in @xs@
438332-- with the type @x@ and is used in `Squeal.PostgreSQL.Definition.alterTable`
439333-- and `Squeal.PostgreSQL.Definition.alterColumn`.
440334type family Alter alias x xs where
441− Alter alias x '[] = TypeError
442− ('Text "Alter: alias "
443− ':<>: 'ShowType alias
444− ':<>: 'Text " does not exist" )
445335 Alter alias x1 (alias ::: x0 ': xs) = alias ::: x1 ': xs
446336 Alter alias x1 (x0 ': xs) = x0 ': Alter alias x1 xs
447337
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−
453338-- | @Rename alias0 alias1 xs@ replaces the alias @alias0@ by @alias1@ in @xs@
454339-- and is used in `Squeal.PostgreSQL.Definition.alterTableRename` and
455340-- `Squeal.PostgreSQL.Definition.renameColumn`.
456341type family Rename alias0 alias1 xs where
457− Rename alias0 alias1 '[] = TypeError
458− ('Text "Rename: alias "
459− ':<>: 'ShowType alias0
460− ':<>: 'Text " does not exist" )
461342 Rename alias0 alias1 ((alias0 ::: x0) ': xs) = (alias1 ::: x0) ': xs
462343 Rename alias0 alias1 (x ': xs) = x ': Rename alias0 alias1 xs
463344
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−
469345-- | Check if a `TableConstraint` involves a column
470346type family ConstraintInvolves column constraint where
471347 ConstraintInvolves column ('Check columns) = column `Elem` columns
@@ -488,29 +364,6 @@ data SchemumType
488364 = Table TableType
489365 | View RowType
490366 | Typedef PGType
491− | Index IndexType
492− | Function FunctionType
493− | Operator OperatorType
494− | UnsafeSchemum Symbol
495−
496−type FunctionType = ([NullityType], ReturnsType)
497−
498−data IndexType
499− = Btree
500− | Hash
501− | Gist
502− | Spgist
503− | Gin
504− | Brin
505−
506−data ReturnsType
507− = Returns NullityType
508− | ReturnsTable RowType
509−
510−data OperatorType
511− = BinaryOp NullityType NullityType NullityType
512− | LeftOp NullityType NullityType
513− | RightOp NullityType NullityType
514367
515368{- | The schema of a database consists of a list of aliased,
516369user-defined `SchemumType`s.
squeal-postgresql/test/Doc.hsdeleted−6
@@ -1,6 +0,0 @@
1−module Main (main) where
2−
3−import Test.DocTest
4−
5−main :: IO ()
6−main = doctest [ "-isrc", "src" ]
squeal-postgresql/test/DocTest.hsnew file+18
@@ -0,0 +1,18 @@
1+module Main (main) where
2+
3+import Test.DocTest
4+
5+main :: IO ()
6+main = doctest
7+ [ "-isrc"
8+ , "src/Squeal/PostgreSQL.hs"
9+ , "src/Squeal/PostgreSQL/Binary.hs"
10+ , "src/Squeal/PostgreSQL/Definition.hs"
11+ , "src/Squeal/PostgreSQL/Manipulation.hs"
12+ , "src/Squeal/PostgreSQL/Query.hs"
13+ , "src/Squeal/PostgreSQL/Expression.hs"
14+ , "src/Squeal/PostgreSQL/PQ.hs"
15+ , "src/Squeal/PostgreSQL/Migration.hs"
16+ , "src/Squeal/PostgreSQL/Transaction.hs"
17+ , "src/Squeal/PostgreSQL/Pool.hs"
18+ ]
squeal-postgresql/test/Property.hsdeleted−166
@@ -1,166 +0,0 @@
1−{-# LANGUAGE
2− DataKinds
3− , GADTs
4− , LambdaCase
5− , OverloadedLabels
6− , OverloadedStrings
7− , TypeApplications
8− , TypeOperators
9−#-}
10−
11−module Main (main) where
12−
13−import Control.Monad.Trans
14−import Data.ByteString (ByteString)
15−import Data.ByteString.Char8 (unpack)
16−import Data.Scientific (fromFloatDigits)
17−import Data.Fixed (Fixed(MkFixed), Micro, Pico)
18−import Data.String (IsString(fromString))
19−import Data.Time
20−import Squeal.PostgreSQL hiding (check, defaultMain, Group)
21−import Hedgehog hiding (Range)
22−import qualified Hedgehog.Gen as Gen
23−import qualified Hedgehog.Main as Main
24−import qualified Hedgehog.Range as Range
25−
26−main :: IO ()
27−main = Main.defaultMain [checkSequential roundtrips]
28−
29−roundtrips :: Group
30−roundtrips = Group "roundtrips"
31− [ roundtrip int2 genInt16
32− , roundtrip int4 genInt32
33− , roundtrip int8 genInt64
34− , roundtrip bool Gen.bool
35− , roundtrip numeric genScientific
36− , roundtrip float4 genFloat
37− , roundtrip float8 genDouble
38− , roundtripOn normalizeTimeOfDay time genTimeOfDay
39− -- , roundtrip timetz genTimeWithZone normalizeTimeWithZone
40− , roundtripOn normalizeLocalTime timestamp genLocalTime
41− , roundtrip timestamptz genUTCTime
42− , roundtrip date genDay
43− , roundtrip interval genDiffTime
44− , roundtripOn normalizeIntRange int4range (genRange genInt32)
45− , roundtripOn normalizeIntRange int8range (genRange genInt64)
46− , roundtrip numrange (genRange genScientific)
47− , roundtripOn (fmap normalizeLocalTime) tsrange (genRange genLocalTime)
48− , roundtrip tstzrange (genRange genUTCTime)
49− , roundtripOn normalizeIntRange daterange (genRange genDay)
50− ]
51− where
52− genInt16 = Gen.int16 Range.exponentialBounded
53− genInt32 = Gen.int32 Range.exponentialBounded
54− genInt64 = Gen.int64 Range.exponentialBounded
55− genScientific = fromFloatDigits <$> genFloat
56− genPosFloat = Gen.float
57− (Range.exponentialFloatFrom 1 minPosFloat maxPosFloat)
58− genFloat = Gen.prune $ Gen.choice
59− [ genPosFloat
60− , negate <$> genPosFloat
61− , Gen.element [0,1/0] ]
62− genPosDouble = Gen.double
63− (Range.exponentialFloatFrom 1 minPosFloat maxPosFloat)
64− genDouble = Gen.prune $ Gen.choice
65− [ genPosDouble
66− , negate <$> genPosDouble
67− , Gen.element [0,1/0] ]
68− genRange gen = do
69− lb <- gen
70− ub <- Gen.filter (lb <) gen
71− Gen.element
72− [ Empty, singleton lb, whole
73− , lb <=..<= ub , lb <=..< ub, lb <..<= ub, lb <..< ub
74− , atLeast lb, moreThan lb, atMost ub, lessThan ub ]
75− genDay = do
76− y <- toInteger <$> Gen.int (Range.constant 2000 2019)
77− m <- Gen.int (Range.constant 1 12)
78− d <- Gen.int (Range.constant 1 28)
79− return $ fromGregorian y m d
80− genDiffTime = secondsToDiffTime . toInteger <$>
81− Gen.int (Range.constant 0 86401)
82− genUTCTime = UTCTime <$> genDay <*> genDiffTime
83− genTimeOfDay = do
84− h <- Gen.int (Range.constant 0 23)
85− m <- Gen.int (Range.constant 0 59)
86− s <- MkFixed . toInteger <$> Gen.int (Range.constant 0 59)
87− return $ TimeOfDay h m s
88− genLocalTime = LocalTime <$> genDay <*> genTimeOfDay
89− -- genTimeZone = Gen.element $ map (read @TimeZone)
90− -- [ "UTC", "UT", "GMT", "EST", "EDT", "CST"
91− -- , "CDT", "MST", "MDT", "PST", "PDT" ]
92− -- genTimeWithZone = (,) <$> genTimeOfDay <*> genTimeZone
93−
94−roundtrip
95− :: (OidOf ty, ToParam x ty, FromValue ty x, Show x, Eq x)
96− => TypeExpression schemas ('NotNull ty)
97− -> Gen x
98− -> (PropertyName, Property)
99−roundtrip = roundtripOn id
100−
101−roundtripOn
102− :: (OidOf ty, ToParam x ty, FromValue ty x, Show x, Eq x)
103− => (x -> x)
104− -> TypeExpression schemas ('NotNull ty)
105− -> Gen x
106− -> (PropertyName, Property)
107−roundtripOn norm ty gen = propertyWithName $ do
108− x <- forAll gen
109− Just (Only y) <- lift . withConnection connectionString $
110− firstRow =<< runQueryParams
111− (values_ (parameter @1 ty `as` #fromOnly)) (Only x)
112− norm x === y
113− where
114− propertyWithName prop =
115− (fromString (unpack (renderSQL ty)), property prop)
116−
117−maxPosFloat :: RealFloat a => a
118−maxPosFloat = x
119− where
120− n = floatDigits x
121− b = floatRadix x
122− (_, u) = floatRange x
123− x = encodeFloat (b^n - 1) (u - n)
124−
125−minPosFloat :: RealFloat a => a
126−minPosFloat = x
127− where
128− n = floatDigits x
129− b = floatRadix x
130− (l, _) = floatRange x
131− x = encodeFloat (b^n - 1) (l - n - 1)
132−
133−connectionString :: ByteString
134−connectionString = "host=localhost port=5432 dbname=exampledb"
135−
136−normalizeIntRange :: (Enum int, Ord int) => Range int -> Range int
137−normalizeIntRange = \case
138− Empty -> Empty
139− NonEmpty l u ->
140− let
141− l' = normalizeL l
142− u' = normalizeU u
143− in if emptyNormalized l' u' then Empty else NonEmpty l' u'
144− where
145− normalizeL = \case
146− Open l -> Closed (succ l)
147− normalized -> normalized
148− normalizeU = \case
149− Closed u -> Open (succ u)
150− normalized -> normalized
151− emptyNormalized (Closed l) (Open u) = l >= u
152− emptyNormalized _ _ = False
153−
154−normalizeTimeOfDay :: TimeOfDay -> TimeOfDay
155−normalizeTimeOfDay (TimeOfDay h m s) = TimeOfDay h m
156− . fromRational @Pico
157− . toRational @Micro
158− . fromRational @Micro
159− . toRational @Pico
160− $ s
161−
162−normalizeLocalTime :: LocalTime -> LocalTime
163−normalizeLocalTime (LocalTime d t) = LocalTime d (normalizeTimeOfDay t)
164−
165−-- normalizeTimeWithZone :: (TimeOfDay, TimeZone) -> (TimeOfDay, TimeZone)
166−-- normalizeTimeWithZone (t, z) = (normalizeTimeOfDay t, z)
squeal-postgresql/test/Spec.hsdeleted−136
@@ -1,136 +0,0 @@
1−{-# LANGUAGE
2− DataKinds
3− , DeriveAnyClass
4− , DeriveGeneric
5− , DerivingStrategies
6− , DuplicateRecordFields
7− , FlexibleContexts
8− , OverloadedLabels
9− , OverloadedLists
10− , OverloadedStrings
11− , TypeApplications
12− , TypeFamilies
13− , TypeInType
14− , TypeOperators
15−#-}
16−
17−module Main (main) where
18−
19−import Control.Concurrent.Async (replicateConcurrently)
20−import Data.ByteString (ByteString)
21−import Data.Int (Int32)
22−import Data.Text (Text)
23−import Test.Hspec
24−
25−import qualified Generics.SOP as SOP
26−import qualified GHC.Generics as GHC
27−
28−import Squeal.PostgreSQL
29−
30−main :: IO ()
31−main = hspec spec
32−
33−type Schemas = Public
34− '[ "users" ::: 'Table (
35− '[ "pk_users" ::: 'PrimaryKey '["id"]
36− , "unique_names" ::: 'Unique '["name"]
37− ] :=>
38− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
39− , "name" ::: 'NoDef :=> 'NotNull 'PGtext ] ) ]
40−
41−data User = User
42− { userName :: Text
43− } deriving stock (Eq, Show, GHC.Generic)
44− deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
45−
46−insertUser :: Manipulation_ Schemas User ()
47−insertUser = insertInto_ #users
48− (Values_ (Default `as` #id :* Set (param @1) `as` #name))
49−
50−setup :: Definition (Public '[]) Schemas
51−setup =
52− createTable #users
53− ( serial `as` #id :*
54− notNullable text `as` #name )
55− ( primaryKey #id `as` #pk_users :*
56− unique #name `as` #unique_names )
57−
58−teardown :: Definition Schemas (Public '[])
59−teardown = dropTable #users
60−
61−silence :: MonadPQ schemas pq => pq ()
62−silence = manipulate_ $
63− UnsafeManipulation "SET client_min_messages TO WARNING;"
64−
65−setupDB :: IO ()
66−setupDB = withConnection connectionString $
67− silence & pqThen (define setup)
68−
69−dropDB :: IO ()
70−dropDB = withConnection connectionString $
71− silence & pqThen (define teardown)
72−
73−connectionString :: ByteString
74−connectionString = "host=localhost port=5432 dbname=exampledb"
75−
76−spec :: Spec
77−spec = before_ setupDB . after_ dropDB $ do
78−
79− describe "Exceptions" $ do
80−
81− let
82− testUser = User "TestUser"
83− newUser = manipulateParams_ insertUser
84− insertUserTwice = newUser testUser >> newUser testUser
85− err23505 = PQException $ PQState FatalError (Just "23505")
86− (Just "ERROR: duplicate key value violates unique constraint \"unique_names\"\nDETAIL: Key (name)=(TestUser) already exists.\n")
87−
88− it "should be thrown for constraint violation" $
89− withConnection connectionString insertUserTwice
90− `shouldThrow` (== err23505)
91−
92− it "should be rethrown for constraint violation in a transaction" $
93− withConnection connectionString (transactionally_ insertUserTwice)
94− `shouldThrow` (== err23505)
95−
96− describe "Pools" $
97−
98− it "should manage concurrent transactions" $ do
99− pool <- createConnectionPool
100− "host=localhost port=5432 dbname=exampledb" 1 0.5 10
101− let
102− query :: Query_ (Public '[]) () (Only Char)
103− query = values_ (literal 'a' `as` #fromOnly)
104− session = usingConnectionPool pool . transactionally_ $ do
105− result <- runQuery query
106− Just (Only chr) <- firstRow result
107− return chr
108− chrs <- replicateConcurrently 10 session
109− chrs `shouldSatisfy` all (== 'a')
110−
111− describe "Ranges" $
112−
113− it "should correctly decode ranges" $ do
114−
115− rangesOut <- withConnection connectionString $ do
116− let
117− query :: Query_ (Public '[]) () (Only (Range Int32))
118− query = values
119− ( range int4range (atLeast 3) `as` #fromOnly )
120− [ range int4range (3 <=..< 5) `as` #fromOnly
121− , range int4range Empty `as` #fromOnly
122− , range int4range whole `as` #fromOnly ]
123− getRows =<< runQuery query
124− (fromOnly <$> rangesOut :: [Range Int32]) `shouldBe`
125− [ atLeast 3, 3 <=..< 5, Empty, whole ]
126−
127− describe "Parameters" $ do
128−
129− it "should run queries that don't reference all their parameters" $ do
130−
131− out <- withConnection connectionString $ do
132− let
133− query :: Query_ (Public '[]) (Char,Int32) (Only Int32)
134− query = values_ (param @2 `as` #fromOnly)
135− firstRow =<< runQueryParams query ('a', 3 :: Int32)
136− (fromOnly <$> out :: Maybe Int32) `shouldBe` Just 3
squeal-postgresql/test/Specs/ExceptionHandling.hsnew file+125
@@ -0,0 +1,125 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE DuplicateRecordFields #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE OverloadedLabels #-}
6+{-# LANGUAGE OverloadedLists #-}
7+{-# LANGUAGE OverloadedStrings #-}
8+{-# LANGUAGE TypeApplications #-}
9+{-# LANGUAGE TypeFamilies #-}
10+{-# LANGUAGE TypeInType #-}
11+{-# LANGUAGE TypeOperators #-}
12+module ExceptionHandling
13+ ( specs
14+ , User (..)
15+ )
16+where
17+
18+import Control.Monad (void)
19+import Control.Monad.IO.Class (MonadIO (..))
20+import qualified Data.ByteString.Char8 as Char8
21+import Data.Int (Int16)
22+import Data.Text (Text)
23+import Data.Vector (Vector)
24+import qualified Generics.SOP as SOP
25+import qualified GHC.Generics as GHC
26+import Squeal.PostgreSQL
27+import Test.Hspec
28+
29+type Schema =
30+ '[ "users" ::: 'Table (
31+ '[ "pk_users" ::: 'PrimaryKey '["id"]
32+ , "unique_names" ::: 'Unique '["name"]
33+ ] :=>
34+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
35+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext
36+ , "vec" ::: 'NoDef :=> 'NotNull ('PGvararray ('Null 'PGint2))
37+ ])
38+ , "emails" ::: 'Table (
39+ '[ "pk_emails" ::: 'PrimaryKey '["id"]
40+ , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
41+ ] :=>
42+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
43+ , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
44+ , "email" ::: 'NoDef :=> 'Null 'PGtext
45+ ])
46+ ]
47+
48+type Schemas = Public Schema
49+
50+data User =
51+ User { userName :: Text
52+ , userEmail :: Maybe Text
53+ , userVec :: VarArray (Vector (Maybe Int16)) }
54+ deriving (Show, GHC.Generic)
55+instance SOP.Generic User
56+instance SOP.HasDatatypeInfo User
57+
58+insertUser :: Manipulation '[] Schemas '[ 'NotNull 'PGtext, 'NotNull ('PGvararray ('Null 'PGint2))]
59+ '[ "fromOnly" ::: 'NotNull 'PGint4 ]
60+insertUser = insertInto #users
61+ (Values_ (Default `as` #id :* Set (param @1) `as` #name :* Set (param @2) `as` #vec))
62+ OnConflictDoRaise (Returning (#id `as` #fromOnly))
63+
64+setup :: Definition (Public '[]) Schemas
65+setup =
66+ createTable #users
67+ ( serial `as` #id :*
68+ (text & notNullable) `as` #name :*
69+ (vararray int2 & notNullable) `as` #vec )
70+ ( primaryKey #id `as` #pk_users
71+ :* unique #name `as` #unique_names )
72+ >>>
73+ createTable #emails
74+ ( serial `as` #id :*
75+ (int & notNullable) `as` #user_id :*
76+ (text & nullable) `as` #email )
77+ ( primaryKey #id `as` #pk_emails :*
78+ foreignKey #user_id #users #id
79+ OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
80+
81+teardown :: Definition Schemas (Public '[])
82+teardown = dropTable #emails >>> dropTable #users
83+
84+migration :: Migration Definition (Public '[]) Schemas
85+migration = Migration { name = "test"
86+ , up = setup
87+ , down = teardown }
88+
89+setupDB :: IO ()
90+setupDB = withConnection connectionString $
91+ manipulate (UnsafeManipulation "SET client_min_messages TO WARNING;")
92+ & pqThen (migrateUp (single migration))
93+
94+dropDB :: IO ()
95+dropDB = withConnection connectionString $
96+ manipulate (UnsafeManipulation "SET client_min_messages TO WARNING;")
97+ & pqThen (migrateDown (single migration))
98+
99+connectionString :: Char8.ByteString
100+connectionString = "host=localhost port=5432 dbname=exampledb"
101+
102+testUser :: User
103+testUser = User "TestUser" Nothing (VarArray [])
104+
105+newUser :: (MonadIO m, MonadPQ Schemas m) => User -> m ()
106+newUser u = void $ manipulateParams insertUser (userName u, userVec u)
107+
108+insertUserTwice :: (MonadIO m, MonadPQ Schemas m) => m ()
109+insertUserTwice = newUser testUser >> newUser testUser
110+
111+specs :: SpecWith ()
112+specs = before_ setupDB $ after_ dropDB $
113+ describe "Exceptions" $ do
114+
115+ let
116+ dupKeyErr = PQException $ PQState FatalError (Just "23505")
117+ (Just "ERROR: duplicate key value violates unique constraint \"unique_names\"\nDETAIL: Key (name)=(TestUser) already exists.\n")
118+
119+ it "should be thrown for unique constraint violation in a manipulation" $
120+ withConnection connectionString insertUserTwice
121+ `shouldThrow` (== dupKeyErr)
122+
123+ it "should be rethrown for unique constraint violation in a manipulation by a transaction" $
124+ withConnection connectionString (transactionally_ insertUserTwice)
125+ `shouldThrow` (== dupKeyErr)
squeal-postgresql/test/Specs/Specs.hsnew file+7
@@ -0,0 +1,7 @@
1+module Specs where
2+
3+import Test.Hspec
4+import qualified ExceptionHandling
5+
6+main :: IO ()
7+main = hspec ExceptionHandling.specs
stack.yaml+1−3
@@ -1,8 +1,6 @@
1−resolver: nightly-2019-07-14
1+resolver: lts-13.8
22packages:
33- squeal-postgresql
44
55extra-deps:
66- unliftio-pool-0.2.1.0
7−- github: morphismtech/free-categories
8− commit: c0e555fbefb5c21619e532264c4dfeac556d0630