on dev help sign in
48 files changed+4256−2274
since splitsnapshots
unifiedsplit
.circleci/config.yml+1−1 README.md+59−70 RELEASE NOTES.md+400 squeal-postgresql/exe/Example.hs+9−7 squeal-postgresql/squeal-postgresql.cabal+38−13 squeal-postgresql/src/Squeal/PostgreSQL.hs+63−84 squeal-postgresql/src/Squeal/PostgreSQL/Alias.hs−9 squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs+193−67 squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs+12−1016 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+91−17 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Aggregate.hs+19−4 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Collection.hs+15−5 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Comparison.hs+12−12 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Json.hs+109−175 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Logic.hs+2−2 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Math.hs+4−7 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/SetOf.hs → squeal-postgresql/src/Squeal/PostgreSQL/Expression/Set.hs+57−24 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Subquery.hs+2−3 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Text.hs+3−4 squeal-postgresql/src/Squeal/PostgreSQL/Expression/TextSearch.hs+20−21 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Time.hs+7−12 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Type.hs+168−5 squeal-postgresql/src/Squeal/PostgreSQL/List.hs+17−46 squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs+155−153 squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs+32−18 squeal-postgresql/src/Squeal/PostgreSQL/PG.hs+41−42 squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs+52−20 squeal-postgresql/src/Squeal/PostgreSQL/Pool.hs+67−99 squeal-postgresql/src/Squeal/PostgreSQL/Query.hs+214−83 squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs+161−60 squeal-postgresql/src/Squeal/PostgreSQL/Transaction.hs+23 squeal-postgresql/src/Squeal/PostgreSQL/Tutorial.hs−39 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−126 squeal-postgresql/test/Specs/Specs.hs−7 stack.yaml+3−1
.circleci/config.yml+1−1
@@ -2,7 +2,7 @@ version: 2
22jobs:
33 build:
44 docker:
5− - image: haskell:8.6.3
5+ - image: haskell:8.6.5
66 - image: circleci/postgres:latest
77 environment:
88 POSTGRES_USER: root
README.md+59−70
@@ -46,7 +46,11 @@ composable and cover a large portion of SQL.
4646* transactions
4747* views
4848* array, composite and enumerated types
49−* json operations
49+* json functions and operations
50+* multischema support
51+* correlated subqueries
52+* window functions
53+* text search
5054
5155## installation
5256
@@ -72,19 +76,17 @@ First, we need some language extensions because Squeal uses modern GHC
7276features.
7377
7478```Haskell
75−>>> :set -XDataKinds -XDeriveGeneric -XOverloadedLabels
76−>>> :set -XOverloadedStrings -XTypeApplications -XTypeOperators
79+>>> :set -XDataKinds -XDeriveGeneric -XOverloadedLabels -XFlexibleContexts
80+>>> :set -XOverloadedStrings -XTypeApplications -XTypeOperators -XGADTs
7781```
7882
7983We'll need some imports.
8084
8185```Haskell
82−>>> import Control.Monad (void)
8386>>> import Control.Monad.IO.Class (liftIO)
8487>>> import Data.Int (Int32)
8588>>> import Data.Text (Text)
8689>>> import Squeal.PostgreSQL
87−>>> import Squeal.PostgreSQL.Render
8890```
8991
9092We'll use generics to easily convert between Haskell and PostgreSQL values.
@@ -99,27 +101,27 @@ we use `DataKinds` and `TypeOperators`.
99101
100102```Haskell
101103>>> :{
104+type UsersColumns =
105+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
106+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext ]
107+type UsersConstraints = '[ "pk_users" ::: 'PrimaryKey '["id"] ]
108+type EmailsColumns =
109+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
110+ , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
111+ , "email" ::: 'NoDef :=> 'Null 'PGtext ]
112+type EmailsConstraints =
113+ '[ "pk_emails" ::: 'PrimaryKey '["id"]
114+ , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"] ]
102115type Schema =
103− '[ "users" ::: 'Table (
104− '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
105− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
106− , "name" ::: 'NoDef :=> 'NotNull 'PGtext
107− ])
108− , "emails" ::: 'Table (
109− '[ "pk_emails" ::: 'PrimaryKey '["id"]
110− , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
111− ] :=>
112− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
113− , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
114− , "email" ::: 'NoDef :=> 'Null 'PGtext
115− ])
116− ]
116+ '[ "users" ::: 'Table (UsersConstraints :=> UsersColumns)
117+ , "emails" ::: 'Table (EmailsConstraints :=> EmailsColumns) ]
118+type Schemas = Public Schema
117119:}
118120```
119121
120122Notice the use of type operators.
121123
122−`:::` is used to pair an alias `GHC.TypeLits.Symbol` with a `SchemumType`,
124+`:::` is used to pair an alias `Symbol` with a `SchemumType`,
123125a `TableConstraint` or a `ColumnType`. It is intended to connote Haskell's `::`
124126operator.
125127
@@ -137,7 +139,7 @@ labels to refer to named tables and columns in our schema.
137139```Haskell
138140>>> :{
139141let
140− setup :: Definition '[] Schema
142+ setup :: Definition (Public '[]) Schemas
141143 setup =
142144 createTable #users
143145 ( serial `as` #id :*
@@ -169,7 +171,7 @@ primary and foreign keys, making them somewhat complex. Our `teardown`
169171```Haskell
170172>>> :{
171173let
172− teardown :: Definition Schema '[]
174+ teardown :: Definition Schemas (Public '[])
173175 teardown = dropTable #emails >>> dropTable #users
174176:}
175177
@@ -178,54 +180,54 @@ DROP TABLE "emails";
178180DROP TABLE "users";
179181```
180182
181−Next, we'll write `Manipulation`s to insert data into our two tables.
182−A `Manipulation` like `insertRow`, `update` or `deleteFrom`
183−has three type parameters, the schema it refers to, a list of parameters
184−it can take as input, and a list of columns it produces as output. When
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.
185+
186+```Haskell
187+>>> data User = User { userName :: Text, userEmail :: Maybe Text } deriving (Show, GHC.Generic)
188+>>> instance SOP.Generic User
189+>>> instance SOP.HasDatatypeInfo User
190+```
191+
192+Next, we'll write `Manipulation_`s to insert `User`s into our two tables.
193+A `Manipulation_` like `insertInto`, `update` or `deleteFrom`
194+has three type parameters, the schemas it refers to, input parameters
195+and an output row. When
185196we insert into the users table, we will need a parameter for the `name`
186197field but not for the `id` field. Since it's serial, we can use a default
187198value. However, since the emails table refers to the users table, we will
188199need to retrieve the user id that the insert generates and insert it into
189−the emails table. Take a careful look at the type and definition of both
190−of our inserts.
200+the emails table. We can do this in a single `Manipulation_` by using a
201+`with` statement.
191202
192203```Haskell
193204>>> :{
194205let
195− insertUser :: Manipulation Schema '[ 'NotNull 'PGtext ] '[ "fromOnly" ::: 'NotNull 'PGint4 ]
196− insertUser = insertRow #users
197− (Default `as` #id :* Set (param @1) `as` #name)
198− OnConflictDoNothing (Returning (#id `as` #fromOnly))
199−:}
200−
201−>>> :{
202−let
203− insertEmail :: Manipulation Schema '[ 'NotNull 'PGint4, 'Null 'PGtext] '[]
204− insertEmail = insertRow #emails
205− ( Default `as` #id :*
206− Set (param @1) `as` #user_id :*
207− Set (param @2) `as` #email )
208− OnConflictDoNothing (Returning Nil)
206+ insertUser :: Manipulation_ Schemas User ()
207+ insertUser = with (u `as` #u) e
208+ where
209+ u = insertInto #users
210+ (Values_ (Default `as` #id :* Set (param @1) `as` #name))
211+ OnConflictDoRaise (Returning_ (#id :* param @2 `as` #email))
212+ e = insertInto_ #emails $ Select
213+ (Default `as` #id :* Set (#u ! #id) `as` #user_id :* Set (#u ! #email) `as` #email)
214+ (from (common #u))
209215:}
210216
211217>>> printSQL insertUser
212−INSERT INTO "users" ("id", "name") VALUES (DEFAULT, ($1 :: text)) ON CONFLICT DO NOTHING RETURNING "id" AS "fromOnly"
213−>>> printSQL insertEmail
214−INSERT INTO "emails" ("id", "user_id", "email") VALUES (DEFAULT, ($1 :: int4), ($2 :: text)) ON CONFLICT DO NOTHING
218+WITH "u" AS (INSERT INTO "users" ("id", "name") VALUES (DEFAULT, ($1 :: text)) RETURNING "id" AS "id", ($2 :: text) AS "email") INSERT INTO "emails" ("user_id", "email") SELECT "u"."id", "u"."email" FROM "u" AS "u"
215219```
216220
217−Next we write a `Query` to retrieve users from the database. We're not
221+Next we write a `Query_` to retrieve users from the database. We're not
218222interested in the ids here, just the usernames and email addresses. We
219−need to use an inner join to get the right result. A `Query` is like a
220−`Manipulation` with the same kind of type parameters.
223+need to use an `innerJoin` to get the right result. A `Query_` is like a
224+`Manipulation_` with the same kind of type parameters.
221225
222226```Haskell
223227>>> :{
224228let
225− getUsers :: Query Schema '[]
226− '[ "userName" ::: 'NotNull 'PGtext
227− , "userEmail" ::: 'Null 'PGtext ]
228− getUsers = select
229+ getUsers :: Query_ Schemas () User
230+ getUsers = select_
229231 (#u ! #name `as` #userName :* #e ! #email `as` #userEmail)
230232 ( from (table (#users `as` #u)
231233 & innerJoin (table (#emails `as` #e))
@@ -236,19 +238,7 @@ let
236238SELECT "u"."name" AS "userName", "e"."email" AS "userEmail" FROM "users" AS "u" INNER JOIN "emails" AS "e" ON ("u"."id" = "e"."user_id")
237239```
238240
239−Now that we've defined the SQL side of things, we'll need a Haskell type
240−for users. We give the type `Generics.SOP.Generic` and
241−`Generics.SOP.HasDatatypeInfo` instances so that we can decode the rows
242−we receive when we run `getUsers`. Notice that the record fields of the
243−`User` type match the column names of `getUsers`.
244−
245−```Haskell
246−>>> data User = User { userName :: Text, userEmail :: Maybe Text } deriving (Show, GHC.Generic)
247−>>> instance SOP.Generic User
248−>>> instance SOP.HasDatatypeInfo User
249−```
250−
251−Let's also create some users to add to the database.
241+Let's create some users to add to the database.
252242
253243```Haskell
254244>>> :{
@@ -273,19 +263,18 @@ transformer and when the schema doesn't change we can use `Monad` and
273263```Haskell
274264>>> :{
275265let
276− session :: PQ Schema Schema IO ()
266+ session :: PQ Schemas Schemas IO ()
277267 session = do
278− idResults <- traversePrepared insertUser (Only . userName <$> users)
279− ids <- traverse (fmap fromOnly . getRow 0) idResults
280− traversePrepared_ insertEmail (zip (ids :: [Int32]) (userEmail <$> users))
268+ _ <- traversePrepared_ insertUser users
281269 usersResult <- runQuery getUsers
282270 usersRows <- getRows usersResult
283271 liftIO $ print (usersRows :: [User])
284272in
285− void . withConnection "host=localhost port=5432 dbname=exampledb" $
273+ withConnection "host=localhost port=5432 dbname=exampledb" $
286274 define setup
287275 & pqThen session
288276 & pqThen (define teardown)
289277:}
290278[User {userName = "Alice", userEmail = Just "alice@gmail.com"},User {userName = "Bob", userEmail = Nothing},User {userName = "Carole", userEmail = Just "carole@hotmail.com"}]
279+-}
291280```
RELEASE NOTES.md+400
@@ -1,5 +1,405 @@
11## RELEASE NOTES
22
3+### Version 0.5
4+
5+Version 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.
8+
9+**Multi-schema support**
10+
11+Previous versions of Squeal only supported definitions in the "public"
12+schema. Squeal 0.5 adds support for multiple schemas with the new kind
13+
14+```Haskell
15+type SchemasType = [(Symbol,SchemaType)]
16+```
17+
18+In order to upgrade your queries, manipulations and definitions from
19+Squeal 0.4, you will have to apply the `Public` type family, which indicates
20+that your only schema is the "public" schema.
21+
22+```Haskell
23+-- Squeal 0.4
24+setup :: Definition '[] Schema
25+
26+-- Squeal 0.5
27+setup :: Definition (Public '[]) (Public Schema)
28+```
29+
30+You can create non-public schemas using `createSchema` and inversely
31+remove them using `dropSchema`. There is also an idempotent
32+`createSchemaIfNotExists`.
33+
34+In order to handle aliases which may refer to non-public schemas, Squeal 0.5
35+introduces `QualifiedAlias`es. A `QualifiedAlias` can be referred to using
36+the `(!)` operator from the `IsQualified` typeclass; but if you want to refer
37+to an alias from the "public" schema, you can continue to use a single
38+overloaded label, no need to write `#public ! #tab`, just write `#tab`.
39+
40+**Top-level statements**
41+
42+As a consequence of multi-schema support, common table expressions that
43+a `Query` or `Manipulation` may refer to had to be broken into a new parameter.
44+Additionally, `Query` gained another new parameter for its outer scope which
45+will be discussed in the next section.
46+
47+To simplify type signatures that you have to write for top-level queries
48+and manipulations, Squeal 0.5 introduces the `Query_` and `Manipulation_`
49+type families.
50+
51+```
52+type family Query_
53+ (schemas :: SchemasType)
54+ (parameters :: Type)
55+ (row :: Type) where
56+ Query_ schemas params row =
57+ Query '[] '[] schemas (TuplePG params) (RowPG row)
58+```
59+
60+As you see, a top-level `Query_` has no outer scope and no common
61+table expressions in scope, they are empty `'[]`. Moreover,
62+its parameters and row parameters are now `Type`s, which are
63+converted to corresponding Postgres types using the `TuplePG`
64+and `RowPG` type families. This means you can write the type signatures
65+for your top-level statements using the Haskell types that you
66+intend to input and retrieve when running the statements. Similar
67+to `Query_`, there is a `Manipulation_` type, the only difference
68+being that a general `Manipulation` doesn't have an outer scope,
69+only a scope for common table expressions.
70+
71+**Subquery expressions**
72+
73+Previous versions of Squeal offered subquery expression support
74+but there were issues. The common use case of using the `IN` operator
75+from SQL was overly complex. There was a proliferation of subquery
76+functions to handle different comparison operators, each with two versions
77+for comparing `ALL` or `ANY` of the query rows. And, most confoundedly,
78+there was no way to support the `EXISTS` subquery because the "outer scope"
79+for a query was not available.
80+
81+Squeal adds an outer scope to the `Query` type.
82+
83+```Haskell
84+newtype Query
85+ (outer :: FromType)
86+ (commons :: FromType)
87+ (schemas :: SchemasType)
88+ (params :: [NullityType])
89+ (row :: RowType)
90+ = UnsafeQuery { renderQuery :: ByteString }
91+```
92+
93+This enables a well-typed `exists` function.
94+
95+```Haskell
96+exists
97+ :: Query (Join outer from) commons schemas params row
98+ -> Condition outer commons grp schemas params from
99+```
100+
101+The `in_` and `notIn` functions were simplified to handle the most
102+common use case of comparing to a list of values.
103+
104+```Haskell
105+in_
106+ :: Expression outer commons grp schemas params from ty -- ^ expression
107+ -> [Expression outer commons grp schemas params from ty]
108+ -> Condition outer commons grp schemas params from
109+```
110+
111+Finally, general subquery comparisons were abstracted to work with
112+any comparison operators, using the `Operator` type which will be discussed in
113+the next section.
114+
115+```Haskell
116+subAll
117+ :: Expression outer commons grp schemas params from ty1
118+ -> Operator ty1 ty2 ('Null 'PGbool)
119+ -> Query (Join outer from) commons schemas params '[col ::: ty2]
120+ -> Condition outer commons grp schemas params from
121+
122+subAny
123+ :: Expression outer commons grp schemas params from ty1
124+ -> Operator ty1 ty2 ('Null 'PGbool)
125+ -> Query (Join outer from) commons schemas params '[col ::: ty2]
126+ -> Condition outer commons grp schemas params from
127+```
128+
129+**Expression RankNTypes**
130+
131+Squeal 0.5 introduces RankNType type synonyms for common expression patterns.
132+The simplest example is the `Expr` type, a type for "closed" expressions
133+that cannot reference any aliases or parameters.
134+
135+```Haskell
136+type Expr x
137+ = forall outer commons grp schemas params from
138+ . Expression outer commons grp schemas params from x
139+```
140+
141+There is also a function type `(-->)`, which is a subtype of the usual Haskell function
142+type `(->)`.
143+
144+```Haskell
145+type (-->) x y
146+ = forall outer commons grp schemas params from
147+ . Expression outer commons grp schemas params from x
148+ -> Expression outer commons grp schemas params from y
149+```
150+
151+We saw in the subquery section that there is an `Operator` type.
152+
153+```Haskell
154+type Operator x1 x2 y
155+ = forall outer commons grp schemas params from
156+ . Expression outer commons grp schemas params from x1
157+ -> Expression outer commons grp schemas params from x2
158+ -> Expression outer commons grp schemas params from y
159+```
160+
161+There are also types `FunctionN` and `FunctionVar` for n-ary functions
162+and variadic functions.
163+
164+```
165+type FunctionN xs y
166+ = forall outer commons grp schemas params from
167+ . NP (Expression outer commons grp schemas params from) xs
168+ -> Expression outer commons grp schemas params from y
169+```
170+
171+An n-ary function takes an `NP` list of `Expression`s as its argument.
172+Squeal 0.5 adds a helpful operator `(*:)`, to help scrap your `Nil`s.
173+You can construct an `NP` list now by using the operator `(:*)`,
174+until your last element, using `(*:)` there. For instance, the function
175+`atan2_` takes two arguments, `atan2_ (pi *: 2)`.
176+
177+**Selections**
178+
179+Previously, Squeal provided a couple versions of `SELECT` depending
180+on whether you wanted to select all columns of a unique table
181+in the from clause, i.e. `*`, all columns of a particular table
182+in the from clause, i.e. `.*`, or a list of columns from the from clause.
183+
184+Squeal 0.5 refactors this pattern into a `Selection` GADT type, allowing
185+for abstraction and combinations that were not possible before.
186+
187+```Haskell
188+data Selection outer commons grp schemas params from row where
189+ Star
190+ :: HasUnique tab from row
191+ => Selection outer commons 'Ungrouped schemas params from row
192+ DotStar
193+ :: Has tab from row
194+ => Alias tab
195+ -> Selection outer commons 'Ungrouped schemas params from row
196+ List
197+ :: SListI row
198+ => NP (Aliased (Expression outer commons grp schemas params from)) row
199+ -> Selection outer commons grp schemas params from row
200+ Over
201+ :: SListI row
202+ => NP (Aliased (WindowFunction outer commons grp schemas params from)) row
203+ -> WindowDefinition outer commons grp schemas params from
204+ -> Selection outer commons grp schemas params from row
205+ Also
206+ :: Selection outer commons grp schemas params from right
207+ -> Selection outer commons grp schemas params from left
208+ -> Selection outer commons grp schemas params from (Join left right)
209+```
210+
211+In addition to the `Star`, `DotStar` and `List` constructors, there is an
212+`Also` constructor combinator, which enables users to combine `Selection`s.
213+Additionally, there is an `Over` constructor that is used to enable
214+window functions, described in the next section.
215+
216+To upgrade from Squeal 0.4, you will replace `selectStar` with `select Star`,
217+replace `selectDotStar #tab` with `select (DotStar #tab)`. The `List`
218+selection is such a common use case that there is a function `select_` which
219+automatically applies it, so to upgrade from Squeal 0.4, replace `select`
220+with `select_`. There are also independent `selectDistinct` and `selectDistinct_`
221+functions to filter out duplicate rows.
222+
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+
240+**Window functions and aggregation**
241+
242+Previous versions of Squeal provided no support for window functions.
243+Squeal 0.5 adds support for window functions. We saw `Over` in the
244+previous section.
245+
246+```Haskell
247+Over
248+ :: SListI row
249+ => NP (Aliased (WindowFunction outer commons grp schemas params from)) row
250+ -> WindowDefinition outer commons grp schemas params from
251+ -> Selection outer commons grp schemas params from row
252+```
253+
254+`Over` combines window functions with window definitions. A `WindowDefinition`
255+is constructed using the `partitionBy` function, optionally with an `orderBy`
256+clause. For example,
257+
258+```Haskell
259+query :: Query_ (Public Schema) () (Row Int32 Int32)
260+query = select
261+ (#col1 & Also (rank `as` #col2 `Over` (partitionBy #col1 & orderBy [#col2 & Asc])))
262+ (from (table #tab))
263+```
264+
265+Here the `rank` function is a `WindowFunction`
266+
267+```Haskell
268+rank :: WinFun0 ('NotNull 'PGint8)
269+rank = UnsafeWindowFunction "rank()"
270+```
271+
272+`WinFun0` is a RankNType, like `Expr` was, used for no argument window functions.
273+Similarly, there are also `WinFun1` and `WinFunN` types for
274+window functions and n-ary window functions.
275+
276+In order to use the same syntax for certain window functions and aggregate functions,
277+a new typeclass `Aggregate` was introduced. So for instance, `sum_` can be
278+either a `Distinction` `Expression` or a `WindowFunction`, used either with
279+a `groupBy` or with a `partitionBy` in the appropriate way.
280+
281+```
282+data Distinction (expr :: kind -> Type) (ty :: kind)
283+ = All (expr ty)
284+ | Distinct (expr ty)
285+```
286+
287+Aggregate functions can be run over all rows or only over distinct rows,
288+while window functions bear no such distinction.
289+
290+**Migrations**
291+
292+Thanks to [https://github.com/Raveline](Raveline) Squeal 0.5 introduces
293+a function `defaultMain` to easily create a command line program to
294+run or rewind your migrations.
295+
296+Previously, Squeal's migrations were impure, allowing in addition to
297+running `Definition`s to run arbitrary `IO` operations, such as inserting
298+data into the database or printing out status messages. In order to
299+provide compatibility with other migration systems, Squeal 0.5 introduces
300+pure migrations, that is migrations that are only `Definition`s.
301+
302+```Haskell
303+data Migration p schemas0 schemas1 = Migration
304+ { name :: Text -- ^ The `name` of a `Migration`.
305+ -- Each `name` in a `Migration` should be unique.
306+ , up :: p schemas0 schemas1 -- ^ The `up` instruction of a `Migration`.
307+ , down :: p schemas1 schemas0 -- ^ The `down` instruction of a `Migration`.
308+ } deriving (GHC.Generic)
309+```
310+
311+A pure migration is a `Migration Definition`, a pair of inverse
312+`Definition`s with a unique name. To recover impure migrations, Squeal 0.5
313+introduces the `Terminally` type.
314+
315+```Haskell
316+newtype Terminally trans monad x0 x1 = Terminally
317+ { runTerminally :: trans x0 x1 monad () }
318+```
319+
320+`Terminally` applies the indexed monad transformer and the monad it transforms
321+to the unit type `()`, thereby turning an indexed monad into a `Category`. An
322+impure migration is a `Migration (Terminally PQ IO)`. You can always cast
323+a pure migration into an impure migration with the functor, `pureMigration`.
324+
325+```Haskell
326+pureMigration
327+ :: Migration Definition schemas0 schemas1
328+ -> Migration (Terminally PQ IO) schemas0 schemas1
329+```
330+
331+To run either pure or impure migrations, Squeal 0.5 introduces
332+a typeclass, `Migratory`.
333+
334+```
335+class Category p => Migratory p where
336+
337+ migrateUp
338+ :: AlignedList (Migration p) schemas0 schemas1
339+ -> PQ schemas0 schemas1 IO ()
340+
341+ migrateDown
342+ :: AlignedList (Migration p) schemas0 schemas1
343+ -> PQ schemas1 schemas0 IO ()
344+```
345+
346+The signatures of `migrateUp` and `migrateDown` have been changed
347+to make them easier to compose with other `PQ` actions.
348+
349+**Transactions**
350+
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**
358+
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`.
362+
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.
370+
371+**Literals**
372+
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+
377+**Set returning functions**
378+
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+
382+**Text search**
383+
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.
402+
3403### Version 0.4
4404
5405Version 0.4 strengthens Squeal's type system, adds
squeal-postgresql/exe/Example.hs+9−7
@@ -11,7 +11,6 @@
1111
1212module Main (main, main2) where
1313
14−import Control.Monad (void)
1514import Control.Monad.IO.Class (MonadIO (..))
1615import Data.Int (Int16, Int32)
1716import Data.Monoid ((<>))
@@ -39,6 +38,7 @@ type Schema =
3938 , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
4039 , "email" ::: 'NoDef :=> 'Null 'PGtext
4140 ])
41+ , "positive" ::: 'Typedef 'PGfloat4
4242 ]
4343
4444type Schemas = Public Schema
@@ -53,23 +53,25 @@ setup =
5353 >>>
5454 createTable #emails
5555 ( serial `as` #id :*
56− (int & notNullable) `as` #user_id :*
57− (text & nullable) `as` #email )
56+ hask @Int32 `as` #user_id :*
57+ hask @(Maybe Text) `as` #email )
5858 ( primaryKey #id `as` #pk_emails :*
5959 foreignKey #user_id #users #id
6060 OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
61+ >>>
62+ createDomain #positive real (#value .> 0 .&& (#value & isNotNull))
6163
6264teardown :: Definition Schemas (Public '[])
63−teardown = dropTable #emails >>> dropTable #users
65+teardown = dropType #positive >>> dropTable #emails >>> dropTable #users
6466
6567insertUser :: Manipulation_ Schemas (Text, VarArray (Vector (Maybe Int16))) (Only Int32)
6668insertUser = insertInto #users
67− (Values_ (defaultAs #id :* param @1 `as` #name :* param @2 `as` #vec))
69+ (Values_ (Default `as` #id :* Set (param @1) `as` #name :* Set (param @2) `as` #vec))
6870 (OnConflict (OnConstraint #pk_users) DoNothing) (Returning_ (#id `as` #fromOnly))
6971
7072insertEmail :: Manipulation_ Schemas (Int32, Maybe Text) ()
7173insertEmail = insertInto_ #emails
72− (Values_ (defaultAs #id :* param @1 `as` #user_id :* param @2 `as` #email))
74+ (Values_ (Default `as` #id :* Set (param @1) `as` #user_id :* Set (param @2) `as` #email))
7375
7476getUsers :: Query_ Schemas () User
7577getUsers = select_
@@ -117,7 +119,7 @@ main = do
117119
118120main2 :: IO ()
119121main2 =
120− void . withConnection "host=localhost port=5432 dbname=exampledb" $
122+ withConnection "host=localhost port=5432 dbname=exampledb" $
121123 define setup
122124 & pqThen session
123125 & pqThen (define teardown)
squeal-postgresql/squeal-postgresql.cabal+38−13
@@ -1,5 +1,5 @@
11name: squeal-postgresql
2−version: 0.4.9.0
2+version: 0.5.1.0
33synopsis: Squeal PostgreSQL Library
44description: Squeal is a type-safe embedding of PostgreSQL in Haskell
55homepage: https://github.com/morphismtech/squeal
@@ -25,6 +25,13 @@ 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
2835 Squeal.PostgreSQL.Expression
2936 Squeal.PostgreSQL.Expression.Aggregate
3037 Squeal.PostgreSQL.Expression.Collection
@@ -35,7 +42,8 @@ library
3542 Squeal.PostgreSQL.Expression.Math
3643 Squeal.PostgreSQL.Expression.Null
3744 Squeal.PostgreSQL.Expression.Parameter
38− Squeal.PostgreSQL.Expression.SetOf
45+ Squeal.PostgreSQL.Expression.Range
46+ Squeal.PostgreSQL.Expression.Set
3947 Squeal.PostgreSQL.Expression.Sort
4048 Squeal.PostgreSQL.Expression.Subquery
4149 Squeal.PostgreSQL.Expression.Text
@@ -54,7 +62,7 @@ library
5462 Squeal.PostgreSQL.Schema
5563 Squeal.PostgreSQL.Transaction
5664 default-language: Haskell2010
57− ghc-options: -Wall -Werror
65+ ghc-options: -Wall
5866 build-depends:
5967 aeson >= 1.2.4.0
6068 , base >= 4.11.1.0 && < 5.0
@@ -62,7 +70,8 @@ library
6270 , bytestring >= 0.10.8.2
6371 , bytestring-strict-builder >= 0.4.5
6472 , deepseq >= 1.4.3.0
65− , generics-sop >= 0.3.2.0
73+ , free-categories >= 0.1.0.0
74+ , generics-sop >= 0.3.2.0 && < 0.5.0.0
6675 , mmorph >= 1.1.1
6776 , mtl >= 2.2.2
6877 , network-ip >= 0.3.0.2
@@ -79,34 +88,50 @@ library
7988 , uuid-types >= 1.0.3
8089 , vector >= 0.12.0.1
8190
82−test-suite squeal-postgresql-doctest
91+test-suite doctest
8392 default-language: Haskell2010
8493 type: exitcode-stdio-1.0
8594 hs-source-dirs: test
8695 ghc-options: -Wall
87− main-is: DocTest.hs
96+ main-is: Doc.hs
8897 build-depends:
8998 base >= 4.10.0.0
9099 , 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
91116
92−test-suite squeal-postgresql-specs
117+test-suite spec
93118 default-language: Haskell2010
94119 type: exitcode-stdio-1.0
95− hs-source-dirs: test/Specs
96− ghc-options: -Wall -main-is Specs
97− main-is: Specs.hs
98− other-modules: ExceptionHandling
120+ hs-source-dirs: test
121+ ghc-options: -Wall
122+ main-is: Spec.hs
99123 build-depends:
100124 base >= 4.10.0.0
125+ , async >= 2.2.2
101126 , bytestring >= 0.10.8.2
102127 , generics-sop >= 0.3.1.0
103128 , hspec >= 2.4.8
129+ , mtl >= 2.2.2
104130 , squeal-postgresql
105131 , text >= 1.2.2.2
106− , transformers >= 0.5.2.0
107132 , vector >= 0.12.0.1
108133
109−executable squeal-postgresql-example
134+executable example
110135 default-language: Haskell2010
111136 hs-source-dirs: exe
112137 ghc-options: -Wall
squeal-postgresql/src/Squeal/PostgreSQL.hs+63−84
@@ -11,17 +11,15 @@ Let's see an example!
1111First, we need some language extensions because Squeal uses modern GHC
1212features.
1313
14−>>> :set -XDataKinds -XDeriveGeneric -XOverloadedLabels
14+>>> :set -XDataKinds -XDeriveGeneric -XOverloadedLabels -XFlexibleContexts
1515>>> :set -XOverloadedStrings -XTypeApplications -XTypeOperators -XGADTs
1616
1717We'll need some imports.
1818
19−>>> import Control.Monad (void)
2019>>> import Control.Monad.IO.Class (liftIO)
2120>>> import Data.Int (Int32)
2221>>> import Data.Text (Text)
2322>>> import Squeal.PostgreSQL
24−>>> import Squeal.PostgreSQL.Render
2523
2624We'll use generics to easily convert between Haskell and PostgreSQL values.
2725
@@ -104,45 +102,44 @@ let
104102DROP TABLE "emails";
105103DROP TABLE "users";
106104
107−Next, we'll write `Manipulation`s to insert data into our two tables.
108−A `Manipulation` like `insertInto`, `update` or `deleteFrom`
109−has three type parameters, the schema it refers to, a list of parameters
110−it can take as input, and a list of columns it produces as output. When
111−we insert into the users table, we will need a parameter for the @name@
112−field but not for the @id@ field. Since it's serial, we can use a default
113−value. However, since the emails table refers to the users table, we will
114−need to retrieve the user id that the insert generates and insert it into
115−the emails table. Take a careful look at the type and definition of both
116−of our inserts.
117−
118−We'll need a Haskell type for users. We give the type `Generics.SOP.Generic` and
119−`Generics.SOP.HasDatatypeInfo` instances so that we can decode the rows
120−we receive when we run @getUsers@. Notice that the record fields of the
121−@User@ type match the column names of @getUsers@.
105+We'll need a Haskell type for @User@s. We give the type `Generics.SOP.Generic` and
106+`Generics.SOP.HasDatatypeInfo` instances so that we can encode and decode @User@s.
122107
123108>>> data User = User { userName :: Text, userEmail :: Maybe Text } deriving (Show, GHC.Generic)
124109>>> instance SOP.Generic User
125110>>> instance SOP.HasDatatypeInfo User
126111
112+Next, we'll write `Manipulation_`s to insert @User@s into our two tables.
113+A `Manipulation_` like `insertInto`, `update` or `deleteFrom`
114+has three type parameters, the schemas it refers to, input parameters
115+and an output row. When
116+we insert into the users table, we will need a parameter for the @name@
117+field but not for the @id@ field. Since it's serial, we can use a default
118+value. However, since the emails table refers to the users table, we will
119+need to retrieve the user id that the insert generates and insert it into
120+the emails table. We can do this in a single `Manipulation_` by using a
121+`with` statement.
122+
127123>>> :{
128124let
129125 insertUser :: Manipulation_ Schemas User ()
130126 insertUser = with (u `as` #u) e
131127 where
132128 u = insertInto #users
133− (Values_ (defaultAs #id :* param @1 `as` #name))
129+ (Values_ (Default `as` #id :* Set (param @1) `as` #name))
134130 OnConflictDoRaise (Returning_ (#id :* param @2 `as` #email))
135− e = insertInto_ #emails
136− (Select (defaultAs #id :* #u ! #id `as` #user_id :* #u ! #email) (from (common #u)))
131+ e = insertInto_ #emails $ Select
132+ (Default `as` #id :* Set (#u ! #id) `as` #user_id :* Set (#u ! #email) `as` #email)
133+ (from (common #u))
137134:}
138135
139136>>> printSQL insertUser
140137WITH "u" AS (INSERT INTO "users" ("id", "name") VALUES (DEFAULT, ($1 :: text)) RETURNING "id" AS "id", ($2 :: text) AS "email") INSERT INTO "emails" ("user_id", "email") SELECT "u"."id", "u"."email" FROM "u" AS "u"
141138
142−Next we write a `Query` to retrieve users from the database. We're not
139+Next we write a `Query_` to retrieve users from the database. We're not
143140interested in the ids here, just the usernames and email addresses. We
144−need to use an inner join to get the right result. A `Query` is like a
145−`Manipulation` with the same kind of type parameters.
141+need to use an `innerJoin` to get the right result. A `Query_` is like a
142+`Manipulation_` with the same kind of type parameters.
146143
147144>>> :{
148145let
@@ -186,69 +183,51 @@ let
186183 usersRows <- getRows usersResult
187184 liftIO $ print (usersRows :: [User])
188185in
189− void . withConnection "host=localhost port=5432 dbname=exampledb" $
186+ withConnection "host=localhost port=5432 dbname=exampledb" $
190187 define setup
191188 & pqThen session
192189 & pqThen (define teardown)
193190:}
194191[User {userName = "Alice", userEmail = Just "alice@gmail.com"},User {userName = "Bob", userEmail = Nothing},User {userName = "Carole", userEmail = Just "carole@hotmail.com"}]
195192-}
196−module Squeal.PostgreSQL
197− ( module Squeal.PostgreSQL.Alias
198− , module Squeal.PostgreSQL.Binary
199− , module Squeal.PostgreSQL.Definition
200− , module Squeal.PostgreSQL.Expression
201− , module Squeal.PostgreSQL.Expression.Aggregate
202− , module Squeal.PostgreSQL.Expression.Collection
203− , module Squeal.PostgreSQL.Expression.Comparison
204− , module Squeal.PostgreSQL.Expression.Json
205− , module Squeal.PostgreSQL.Expression.Literal
206− , module Squeal.PostgreSQL.Expression.Logic
207− , module Squeal.PostgreSQL.Expression.Math
208− , module Squeal.PostgreSQL.Expression.Null
209− , module Squeal.PostgreSQL.Expression.Parameter
210− , module Squeal.PostgreSQL.Expression.SetOf
211− , module Squeal.PostgreSQL.Expression.Sort
212− , module Squeal.PostgreSQL.Expression.Subquery
213− , module Squeal.PostgreSQL.Expression.Text
214− , module Squeal.PostgreSQL.Expression.TextSearch
215− , module Squeal.PostgreSQL.Expression.Time
216− , module Squeal.PostgreSQL.Expression.Type
217− , module Squeal.PostgreSQL.Expression.Window
218− , module Squeal.PostgreSQL.List
219− , module Squeal.PostgreSQL.Manipulation
220− , module Squeal.PostgreSQL.PG
221− , module Squeal.PostgreSQL.PQ
222− , module Squeal.PostgreSQL.Query
223− , module Squeal.PostgreSQL.Schema
224− , module Squeal.PostgreSQL.Transaction
225− ) where
226−
227−import Squeal.PostgreSQL.Alias
228−import Squeal.PostgreSQL.Binary
229−import Squeal.PostgreSQL.Definition
230−import Squeal.PostgreSQL.Expression
231−import Squeal.PostgreSQL.Expression.Aggregate
232−import Squeal.PostgreSQL.Expression.Collection
233−import Squeal.PostgreSQL.Expression.Comparison
234−import Squeal.PostgreSQL.Expression.Json
235−import Squeal.PostgreSQL.Expression.Literal
236−import Squeal.PostgreSQL.Expression.Logic
237−import Squeal.PostgreSQL.Expression.Math
238−import Squeal.PostgreSQL.Expression.Null
239−import Squeal.PostgreSQL.Expression.Parameter
240−import Squeal.PostgreSQL.Expression.SetOf
241−import Squeal.PostgreSQL.Expression.Sort
242−import Squeal.PostgreSQL.Expression.Subquery
243−import Squeal.PostgreSQL.Expression.Text
244−import Squeal.PostgreSQL.Expression.TextSearch
245−import Squeal.PostgreSQL.Expression.Time
246−import Squeal.PostgreSQL.Expression.Type
247−import Squeal.PostgreSQL.Expression.Window
248−import Squeal.PostgreSQL.List
249−import Squeal.PostgreSQL.Manipulation
250−import Squeal.PostgreSQL.PG
251−import Squeal.PostgreSQL.PQ
252−import Squeal.PostgreSQL.Query
253−import Squeal.PostgreSQL.Schema
254−import Squeal.PostgreSQL.Transaction
193+module Squeal.PostgreSQL (module X, RenderSQL(..), printSQL) where
194+
195+import Squeal.PostgreSQL.Alias as X
196+import Squeal.PostgreSQL.Binary as X
197+import 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
205+import Squeal.PostgreSQL.Expression as X
206+import Squeal.PostgreSQL.Expression.Aggregate as X
207+import Squeal.PostgreSQL.Expression.Collection as X
208+import Squeal.PostgreSQL.Expression.Comparison as X
209+import Squeal.PostgreSQL.Expression.Json as X
210+import Squeal.PostgreSQL.Expression.Literal as X
211+import Squeal.PostgreSQL.Expression.Logic as X
212+import Squeal.PostgreSQL.Expression.Math as X
213+import Squeal.PostgreSQL.Expression.Null as X
214+import Squeal.PostgreSQL.Expression.Parameter as X
215+import Squeal.PostgreSQL.Expression.Range as X
216+import Squeal.PostgreSQL.Expression.Set as X
217+import Squeal.PostgreSQL.Expression.Sort as X
218+import Squeal.PostgreSQL.Expression.Subquery as X
219+import Squeal.PostgreSQL.Expression.Text as X
220+import Squeal.PostgreSQL.Expression.TextSearch as X
221+import Squeal.PostgreSQL.Expression.Time as X
222+import Squeal.PostgreSQL.Expression.Type as X
223+import Squeal.PostgreSQL.Expression.Window as X
224+import Squeal.PostgreSQL.List as X
225+import Squeal.PostgreSQL.Manipulation as X
226+import Squeal.PostgreSQL.Migration as X
227+import Squeal.PostgreSQL.PG as X
228+import Squeal.PostgreSQL.Pool as X
229+import Squeal.PostgreSQL.PQ as X
230+import Squeal.PostgreSQL.Query as X
231+import Squeal.PostgreSQL.Render (RenderSQL(..), printSQL)
232+import Squeal.PostgreSQL.Schema as X
233+import Squeal.PostgreSQL.Transaction as X
squeal-postgresql/src/Squeal/PostgreSQL/Alias.hs−9
@@ -46,7 +46,6 @@ module Squeal.PostgreSQL.Alias
4646 , HasIn
4747 , QualifiedAlias (..)
4848 , IsQualified (..)
49− , DefaultAliasable (..)
5049 -- * Grouping
5150 , Grouping (..)
5251 , GroupedBy
@@ -189,14 +188,6 @@ choose which subfields to update.
189188class HasIn fields field where
190189instance (Has alias fields field) => HasIn fields (alias ::: field) where
191190
192−{- |
193−The `DefaultAliasable` class is intended to help with Scrap your Nils
194−for default inserts and updates.
195−-}
196−class KnownSymbol alias
197− => DefaultAliasable alias aliased | aliased -> alias where
198− defaultAs :: Alias alias -> aliased
199−
200191-- | `HasAll` extends `Has` to take lists of @aliases@ and @fields@ and infer
201192-- a list of @subfields@.
202193class
squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs+193−67
@@ -39,7 +39,7 @@ the input and output should be equal.
3939
4040>>> let input = Row 2 "hi" (Just True)
4141>>> :{
42−void . withConnection "host=localhost port=5432 dbname=exampledb" $ do
42+withConnection "host=localhost port=5432 dbname=exampledb" $ do
4343 result <- runQueryParams roundTrip input
4444 Just output <- firstRow result
4545 liftIO . print $ input == output
@@ -78,7 +78,7 @@ let
7878>>> :set -XOverloadedLists
7979>>> let input = Row (VarArray [1,2]) (FixArray (Just 1,Nothing)) (FixArray ((1,2),(3,4),(5,6)))
8080>>> :{
81−void . withConnection "host=localhost port=5432 dbname=exampledb" $ do
81+withConnection "host=localhost port=5432 dbname=exampledb" $ do
8282 result <- runQueryParams roundTrip input
8383 Just output <- firstRow result
8484 liftIO . print $ input == output
@@ -170,7 +170,7 @@ let
170170 Just output <- firstRow result
171171 liftIO . print $ input == output
172172in
173− void . withConnection "host=localhost port=5432 dbname=exampledb" $
173+ withConnection "host=localhost port=5432 dbname=exampledb" $
174174 define setup
175175 & pqThen session
176176 & pqThen (define teardown)
@@ -215,6 +215,10 @@ module Squeal.PostgreSQL.Binary
215215 , FromFixArray (..)
216216 -- * Only
217217 , Only (..)
218+ -- * Oid
219+ , OidOf (..)
220+ , OidOfParam (..)
221+ , OidOfField (..)
218222 ) where
219223
220224import BinaryParser
@@ -228,6 +232,7 @@ import Data.Time
228232import Data.UUID.Types
229233import Data.Vector (Vector)
230234import Data.Word
235+import Foreign.C.Types (CUInt(CUInt))
231236import Generics.SOP
232237import Generics.SOP.Record
233238import GHC.TypeLits
@@ -241,6 +246,7 @@ import qualified Data.Text.Lazy as Lazy (Text)
241246import qualified Data.Text as Strict (Text)
242247import qualified Data.Text as Strict.Text
243248import qualified Data.Vector as Vector
249+import qualified Database.PostgreSQL.LibPQ as LibPQ
244250import qualified GHC.Generics as GHC
245251import qualified PostgreSQL.Binary.Decoding as Decoding
246252import qualified PostgreSQL.Binary.Encoding as Encoding
@@ -271,11 +277,9 @@ class ToParam (x :: Type) (pg :: PGType) where
271277 toParam :: x -> K Encoding.Encoding pg
272278instance ToParam Bool 'PGbool where toParam = K . Encoding.bool
273279instance ToParam Int16 'PGint2 where toParam = K . Encoding.int2_int16
274−instance ToParam Word16 'PGint2 where toParam = K . Encoding.int2_word16
275280instance ToParam Int32 'PGint4 where toParam = K . Encoding.int4_int32
276−instance ToParam Word32 'PGint4 where toParam = K . Encoding.int4_word32
277281instance ToParam Int64 'PGint8 where toParam = K . Encoding.int8_int64
278−instance ToParam Word64 'PGint8 where toParam = K . Encoding.int8_word64
282+instance ToParam Oid 'PGoid where toParam = K . Encoding.int4_word32 . getOid
279283instance ToParam Float 'PGfloat4 where toParam = K . Encoding.float4
280284instance ToParam Double 'PGfloat8 where toParam = K . Encoding.float8
281285instance ToParam Scientific 'PGnumeric where toParam = K . Encoding.numeric
@@ -308,24 +312,26 @@ instance Aeson.ToJSON x => ToParam (Json x) 'PGjson where
308312instance Aeson.ToJSON x => ToParam (Jsonb x) 'PGjsonb where
309313 toParam = K . Encoding.jsonb_bytes
310314 . Lazy.ByteString.toStrict . Aeson.encode . getJsonb
311−instance (ToNullityParam x ty, ty ~ nullity pg, HasOid pg)
315+instance (ToNullityParam x ty, ty ~ nullity pg, OidOf pg)
312316 => ToParam (VarArray [x]) ('PGvararray ty) where
313317 toParam = K
314− . Encoding.array_foldable (oid @pg) (unK . toNullityParam @x @ty)
318+ . Encoding.array_foldable
319+ (getOid (oidOf @pg)) (unK . toNullityParam @x @ty)
315320 . getVarArray
316−instance (ToParam x pg, HasOid pg)
321+instance (ToParam x pg, OidOf pg)
317322 => ToParam (VarArray (Vector x)) ('PGvararray ('NotNull pg)) where
318323 toParam = K
319− . Encoding.array_vector (oid @pg) (unK . toParam @x @pg)
324+ . Encoding.array_vector (getOid (oidOf @pg)) (unK . toParam @x @pg)
320325 . getVarArray
321−instance (ToParam x pg, HasOid pg)
326+instance (ToParam x pg, OidOf pg)
322327 => ToParam (VarArray (Vector (Maybe x))) ('PGvararray ('Null pg)) where
323328 toParam = K
324− . Encoding.nullableArray_vector (oid @pg) (unK . toParam @x @pg)
329+ . Encoding.nullableArray_vector
330+ (getOid (oidOf @pg)) (unK . toParam @x @pg)
325331 . getVarArray
326−instance (ToFixArray x dims ty, ty ~ nullity pg, HasOid pg)
332+instance (ToFixArray x dims ty, ty ~ nullity pg, OidOf pg)
327333 => ToParam (FixArray x) ('PGfixarray dims ty) where
328− toParam = K . Encoding.array (oid @pg)
334+ toParam = K . Encoding.array (getOid (oidOf @pg))
329335 . unK . unK . toFixArray @x @dims @ty . getFixArray
330336instance
331337 ( IsEnumType x
@@ -350,7 +356,7 @@ instance
350356 ( SListI fields
351357 , IsRecord x xs
352358 , AllZip ToField xs fields
353− , All HasAliasedOid fields
359+ , All OidOfField fields
354360 ) => ToParam (Composite x) ('PGcomposite fields) where
355361 toParam =
356362 let
@@ -358,7 +364,7 @@ instance
358364 encoders = htrans (Proxy @ToField) toField
359365
360366 composite
361− :: All HasAliasedOid row
367+ :: All OidOfField row
362368 => NP (K (Maybe Encoding.Encoding)) row
363369 -> K Encoding.Encoding ('PGcomposite row)
364370 composite fields = K $
@@ -375,26 +381,139 @@ instance
375381 int32BE (fromIntegral (lengthSList (Proxy @xs))) <>
376382 let
377383 each
378− :: HasAliasedOid field
384+ :: OidOfField field
379385 => K (Maybe Encoding.Encoding) field
380386 -> Encoding.Encoding
381387 each (K field :: K (Maybe Encoding.Encoding) field) =
382− word32BE (aliasedOid @field)
388+ word32BE (getOid (oidOfField @field))
383389 <> case field of
384390 Nothing -> int64BE (-1)
385391 Just value ->
386392 int32BE (fromIntegral (builderLength value))
387393 <> value
388394 in
389− hcfoldMap (Proxy @HasAliasedOid) each fields
395+ hcfoldMap (Proxy @OidOfField) each fields
390396
391397 in
392398 composite . encoders . toRecord . getComposite
393399
394−class HasAliasedOid (field :: (Symbol, NullityType)) where
395− aliasedOid :: Word32
396−instance HasOid ty => HasAliasedOid (alias ::: nullity ty) where
397− aliasedOid = oid @ty
400+-- | The object identifier of a `PGType`.
401+--
402+-- >>> :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
398517
399518-- | A `ToNullityParam` constraint gives an encoding of a Haskell `Type` into
400519-- into the binary format of a PostgreSQL `NullityType`.
@@ -463,6 +582,7 @@ instance FromValue 'PGbool Bool where fromValue = Decoding.bool
463582instance FromValue 'PGint2 Int16 where fromValue = Decoding.int
464583instance FromValue 'PGint4 Int32 where fromValue = Decoding.int
465584instance FromValue 'PGint8 Int64 where fromValue = Decoding.int
585+instance FromValue 'PGoid Word32 where fromValue = Decoding.int
466586instance FromValue 'PGfloat4 Float where fromValue = Decoding.float4
467587instance FromValue 'PGfloat8 Double where fromValue = Decoding.float8
468588instance FromValue 'PGnumeric Scientific where fromValue = Decoding.numeric
@@ -649,50 +769,53 @@ instance
649769 = fmap fromRecord
650770 . hsequence'
651771 . htrans (Proxy @FromField) fromField
652−instance (FromField (col ::: pg) (col ::: hask))
653− => FromRow '[col ::: pg] (P (col ::: hask)) where
654− fromRow (pg :* Nil) = (unComp . fromField) pg
655−instance
656− ( row ~ Join row1 row2
657− , FromRow row1 hask1
658− , FromRow row2 hask2
659− , SListI row
660− ) => FromRow row (hask1, hask2) where
661− fromRow row = case disjoin @row1 @row2 row of
662− (row1, row2) -> (,) <$> fromRow row1 <*> fromRow row2
663−instance
664− ( row ~ Join row1 row23
665− , FromRow row1 hask1
666− , FromRow row23 (hask2, hask3)
667− , SListI row
668− ) => FromRow row (hask1, hask2, hask3) where
669− fromRow row = case disjoin @row1 @row23 row of
670− (row1, row23) -> do
671− hask1 <- fromRow row1
672− (hask2, hask3) <- fromRow row23
673− return (hask1, hask2, hask3)
674−instance
675− ( row ~ Join row1 row234
676− , FromRow row1 hask1
677− , FromRow row234 (hask2, hask3, hask4)
678− , SListI row
679− ) => FromRow row (hask1, hask2, hask3, hask4) where
680− fromRow row = case disjoin @row1 @row234 row of
681− (row1, row234) -> do
682− hask1 <- fromRow row1
683− (hask2, hask3, hask4) <- fromRow row234
684− return (hask1, hask2, hask3, hask4)
685−instance
686− ( row ~ Join row1 row2345
687− , FromRow row1 hask1
688− , FromRow row2345 (hask2, hask3, hask4, hask5)
689− , SListI row
690− ) => FromRow row (hask1, hask2, hask3, hask4, hask5) where
691− fromRow row = case disjoin @row1 @row2345 row of
692− (row1, row2345) -> do
693− hask1 <- fromRow row1
694− (hask2, hask3, hask4, hask5) <- fromRow row2345
695− return (hask1, hask2, hask3, hask4, hask5)
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)
696819
697820-- | `Only` is a 1-tuple type, useful for encoding a single parameter with
698821-- `toParams` or decoding a single value with `fromRow`.
@@ -720,3 +843,6 @@ replicateMN
720843 => m x -> m (NP I xs)
721844replicateMN mx = hsequence' $
722845 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+12−1016
@@ -11,13 +11,15 @@ Squeal data definition language.
1111{-# LANGUAGE
1212 AllowAmbiguousTypes
1313 , ConstraintKinds
14+ , DeriveAnyClass
1415 , DeriveGeneric
16+ , DerivingStrategies
1517 , FlexibleContexts
1618 , FlexibleInstances
1719 , GADTs
18− , GeneralizedNewtypeDeriving
1920 , LambdaCase
2021 , MultiParamTypeClasses
22+ , OverloadedLabels
2123 , OverloadedStrings
2224 , RankNTypes
2325 , ScopedTypeVariables
@@ -25,83 +27,25 @@ Squeal data definition language.
2527 , TypeInType
2628 , TypeOperators
2729 , UndecidableSuperClasses
30+ , UndecidableInstances
2831#-}
2932
3033module Squeal.PostgreSQL.Definition
3134 ( -- * Definition
3235 Definition (..)
3336 , (>>>)
34− -- * Tables
35− -- ** Create
36− , createSchema
37− , createSchemaIfNotExists
38− , createTable
39− , createTableIfNotExists
40− , createView
41− , createTypeEnum
42− , createTypeEnumFrom
43− , createTypeComposite
44− , createTypeCompositeFrom
45− , createDomain
46− , TableConstraintExpression (..)
47− , check
48− , unique
49− , primaryKey
50− , foreignKey
51− , ForeignKeyed
52− , OnDeleteClause (..)
53− , OnUpdateClause (..)
54− -- ** Drop
55− , dropSchema
56− , dropTable
57− , dropView
58− , dropType
59− -- ** Alter
60− , alterTable
61− , alterTableRename
62− , AlterTable (..)
63− , addConstraint
64− , dropConstraint
65− , AddColumn (..)
66− , dropColumn
67− , renameColumn
68− , alterColumn
69− , AlterColumn (..)
70− , setDefault
71− , dropDefault
72− , setNotNull
73− , dropNotNull
74− , alterType
75− -- * Columns
76− , ColumnTypeExpression (..)
77− , nullable
78− , notNullable
79− , default_
80− , serial2
81− , smallserial
82− , serial4
83− , serial
84− , serial8
85− , bigserial
37+ , manipDefinition
8638 ) where
8739
8840import Control.Category
8941import Control.DeepSeq
9042import Data.ByteString
9143import Data.Monoid
92−import GHC.TypeLits
9344import Prelude hiding ((.), id)
9445
95−import qualified Generics.SOP as SOP
9646import qualified GHC.Generics as GHC
9747
98−import Squeal.PostgreSQL.Alias
99−import Squeal.PostgreSQL.Expression
100−import Squeal.PostgreSQL.Expression.Logic
101−import Squeal.PostgreSQL.Expression.Type
102−import Squeal.PostgreSQL.List
103−import Squeal.PostgreSQL.PG
104−import Squeal.PostgreSQL.Query
48+import Squeal.PostgreSQL.Manipulation
10549import Squeal.PostgreSQL.Render
10650import Squeal.PostgreSQL.Schema
10751
@@ -129,958 +73,10 @@ instance Category Definition where
12973 ddl1 . ddl0 = UnsafeDefinition $
13074 renderSQL ddl0 <> "\n" <> renderSQL ddl1
13175
132−{-----------------------------------------
133−CREATE statements
134−-----------------------------------------}
135−
136−createSchema
137− :: KnownSymbol sch
138− => Alias sch
139− -> Definition schemas (Create sch '[] schemas)
140−createSchema sch = UnsafeDefinition $
141− "CREATE" <+> "SCHEMA" <+> renderSQL sch <> ";"
142−
143−createSchemaIfNotExists
144− :: (KnownSymbol sch, Has sch schemas schema)
145− => Alias sch
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
14681 -> Definition schemas schemas
147−createSchemaIfNotExists sch = UnsafeDefinition $
148− "CREATE" <+> "SCHEMA" <+> "IF" <+> "NOT" <+> "EXISTS"
149− <+> renderSQL sch <> ";"
150−
151−{- | `createTable` adds a table to the schema.
152−
153−>>> :set -XOverloadedLabels
154−>>> :{
155−type Table = '[] :=>
156− '[ "a" ::: 'NoDef :=> 'Null 'PGint4
157− , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]
158−:}
159−
160−>>> :{
161−let
162− setup :: Definition (Public '[]) (Public '["tab" ::: 'Table Table])
163− setup = createTable #tab
164− (nullable int `as` #a :* nullable real `as` #b) Nil
165−in printSQL setup
166−:}
167−CREATE TABLE "tab" ("a" int NULL, "b" real NULL);
168−-}
169−createTable
170− :: ( KnownSymbol sch
171− , KnownSymbol tab
172− , columns ~ (col ': cols)
173− , SOP.SListI columns
174− , SOP.SListI constraints
175− , Has sch schemas0 schema0
176− , schemas1 ~ Alter sch (Create tab ('Table (constraints :=> columns)) schema0) schemas0 )
177− => QualifiedAlias sch tab -- ^ the name of the table to add
178− -> NP (Aliased (ColumnTypeExpression schemas0)) columns
179− -- ^ the names and datatype of each column
180− -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints
181− -- ^ constraints that must hold for the table
182− -> Definition schemas0 schemas1
183−createTable tab columns constraints = UnsafeDefinition $
184− "CREATE TABLE" <+> renderCreation tab columns constraints
185−
186−{-| `createTableIfNotExists` creates a table if it doesn't exist, but does not add it to the schema.
187−Instead, the schema already has the table so if the table did not yet exist, the schema was wrong.
188−`createTableIfNotExists` fixes this. Interestingly, this property makes it an idempotent in
189−the `Category` of `Definition`s.
190−
191−>>> :set -XOverloadedLabels -XTypeApplications
192−>>> :{
193−type Table = '[] :=>
194− '[ "a" ::: 'NoDef :=> 'Null 'PGint4
195− , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]
196−:}
197−
198−>>> type Schemas = Public '["tab" ::: 'Table Table]
199−
200−>>> :{
201−let
202− setup :: Definition Schemas Schemas
203− setup = createTableIfNotExists #tab
204− (nullable int `as` #a :* nullable real `as` #b) Nil
205−in printSQL setup
206−:}
207−CREATE TABLE IF NOT EXISTS "tab" ("a" int NULL, "b" real NULL);
208−-}
209−createTableIfNotExists
210− :: ( Has sch schemas schema
211− , Has tab schema ('Table (constraints :=> columns))
212− , SOP.SListI columns
213− , SOP.SListI constraints )
214− => QualifiedAlias sch tab -- ^ the name of the table to add
215− -> NP (Aliased (ColumnTypeExpression schemas)) columns
216− -- ^ the names and datatype of each column
217− -> NP (Aliased (TableConstraintExpression sch tab schemas)) constraints
218− -- ^ constraints that must hold for the table
219− -> Definition schemas schemas
220−createTableIfNotExists tab columns constraints = UnsafeDefinition $
221− "CREATE TABLE IF NOT EXISTS"
222− <+> renderCreation tab columns constraints
223−
224−-- helper function for `createTable` and `createTableIfNotExists`
225−renderCreation
226− :: ( KnownSymbol sch
227− , KnownSymbol tab
228− , SOP.SListI columns
229− , SOP.SListI constraints )
230− => QualifiedAlias sch tab -- ^ the name of the table to add
231− -> NP (Aliased (ColumnTypeExpression schemas0)) columns
232− -- ^ the names and datatype of each column
233− -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints
234− -- ^ constraints that must hold for the table
235− -> ByteString
236−renderCreation tab columns constraints = renderSQL tab
237− <+> parenthesized
238− ( renderCommaSeparated renderColumnDef columns
239− <> ( case constraints of
240− Nil -> ""
241− _ -> ", " <>
242− renderCommaSeparated renderConstraint constraints ) )
243− <> ";"
244− where
245− renderColumnDef :: Aliased (ColumnTypeExpression schemas) x -> ByteString
246− renderColumnDef (ty `As` column) =
247− renderSQL column <+> renderColumnTypeExpression ty
248− renderConstraint
249− :: Aliased (TableConstraintExpression sch tab schemas) constraint
250− -> ByteString
251− renderConstraint (constraint `As` alias) =
252− "CONSTRAINT" <+> renderSQL alias <+> renderSQL constraint
253−
254−-- | Data types are a way to limit the kind of data that can be stored in a
255−-- table. For many applications, however, the constraint they provide is
256−-- too coarse. For example, a column containing a product price should
257−-- probably only accept positive values. But there is no standard data type
258−-- that accepts only positive numbers. Another issue is that you might want
259−-- to constrain column data with respect to other columns or rows.
260−-- For example, in a table containing product information,
261−-- there should be only one row for each product number.
262−-- `TableConstraint`s give you as much control over the data in your tables
263−-- as you wish. If a user attempts to store data in a column that would
264−-- violate a constraint, an error is raised. This applies
265−-- even if the value came from the default value definition.
266−newtype TableConstraintExpression
267− (sch :: Symbol)
268− (tab :: Symbol)
269− (schemas :: SchemasType)
270− (constraint :: TableConstraint)
271− = UnsafeTableConstraintExpression
272− { renderTableConstraintExpression :: ByteString }
273− deriving (GHC.Generic,Show,Eq,Ord,NFData)
274−instance RenderSQL
275− (TableConstraintExpression sch tab schemas constraint) where
276− renderSQL = renderTableConstraintExpression
277−
278−{-| A `check` constraint is the most generic `TableConstraint` type.
279−It allows you to specify that the value in a certain column must satisfy
280−a Boolean (truth-value) expression.
281−
282−>>> :{
283−type Schema = '[
284− "tab" ::: 'Table ('[ "inequality" ::: 'Check '["a","b"]] :=> '[
285− "a" ::: 'NoDef :=> 'NotNull 'PGint4,
286− "b" ::: 'NoDef :=> 'NotNull 'PGint4
287− ])]
288−:}
289−
290−>>> :{
291−let
292− definition :: Definition (Public '[]) (Public Schema)
293− definition = createTable #tab
294− ( (int & notNullable) `as` #a :*
295− (int & notNullable) `as` #b )
296− ( check (#a :* #b) (#a .> #b) `as` #inequality )
297−:}
298−
299−>>> printSQL definition
300−CREATE TABLE "tab" ("a" int NOT NULL, "b" int NOT NULL, CONSTRAINT "inequality" CHECK (("a" > "b")));
301−-}
302−check
303− :: ( Has sch schemas schema
304− , Has tab schema ('Table table)
305− , HasAll aliases (TableToRow table) subcolumns )
306− => NP Alias aliases
307− -- ^ specify the subcolumns which are getting checked
308− -> (forall t. Condition '[] '[] 'Ungrouped schemas '[] '[t ::: subcolumns])
309− -- ^ a closed `Condition` on those subcolumns
310− -> TableConstraintExpression sch tab schemas ('Check aliases)
311−check _cols condition = UnsafeTableConstraintExpression $
312− "CHECK" <+> parenthesized (renderSQL condition)
313−
314−{-| A `unique` constraint ensure that the data contained in a column,
315−or a group of columns, is unique among all the rows in the table.
316−
317−>>> :{
318−type Schema = '[
319− "tab" ::: 'Table( '[ "uq_a_b" ::: 'Unique '["a","b"]] :=> '[
320− "a" ::: 'NoDef :=> 'Null 'PGint4,
321− "b" ::: 'NoDef :=> 'Null 'PGint4
322− ])]
323−:}
324−
325−>>> :{
326−let
327− definition :: Definition (Public '[]) (Public Schema)
328− definition = createTable #tab
329− ( (int & nullable) `as` #a :*
330− (int & nullable) `as` #b )
331− ( unique (#a :* #b) `as` #uq_a_b )
332−:}
333−
334−>>> printSQL definition
335−CREATE TABLE "tab" ("a" int NULL, "b" int NULL, CONSTRAINT "uq_a_b" UNIQUE ("a", "b"));
336−-}
337−unique
338− :: ( Has sch schemas schema
339− , Has tab schema('Table table)
340− , HasAll aliases (TableToRow table) subcolumns )
341− => NP Alias aliases
342− -- ^ specify subcolumns which together are unique for each row
343− -> TableConstraintExpression sch tab schemas ('Unique aliases)
344−unique columns = UnsafeTableConstraintExpression $
345− "UNIQUE" <+> parenthesized (renderSQL columns)
346−
347−{-| A `primaryKey` constraint indicates that a column, or group of columns,
348−can be used as a unique identifier for rows in the table.
349−This requires that the values be both unique and not null.
350−
351−>>> :{
352−type Schema = '[
353− "tab" ::: 'Table ('[ "pk_id" ::: 'PrimaryKey '["id"]] :=> '[
354− "id" ::: 'Def :=> 'NotNull 'PGint4,
355− "name" ::: 'NoDef :=> 'NotNull 'PGtext
356− ])]
357−:}
358−
359−>>> :{
360−let
361− definition :: Definition (Public '[]) (Public Schema)
362− definition = createTable #tab
363− ( serial `as` #id :*
364− (text & notNullable) `as` #name )
365− ( primaryKey #id `as` #pk_id )
366−:}
367−
368−>>> printSQL definition
369−CREATE TABLE "tab" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_id" PRIMARY KEY ("id"));
370−-}
371−primaryKey
372− :: ( Has sch schemas schema
373− , Has tab schema ('Table table)
374− , HasAll aliases (TableToColumns table) subcolumns
375− , AllNotNull subcolumns )
376− => NP Alias aliases
377− -- ^ specify the subcolumns which together form a primary key.
378− -> TableConstraintExpression sch tab schemas ('PrimaryKey aliases)
379−primaryKey columns = UnsafeTableConstraintExpression $
380− "PRIMARY KEY" <+> parenthesized (renderSQL columns)
381−
382−{-| A `foreignKey` specifies that the values in a column
383−(or a group of columns) must match the values appearing in some row of
384−another table. We say this maintains the referential integrity
385−between two related tables.
386−
387−>>> :{
388−type Schema =
389− '[ "users" ::: 'Table (
390− '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
391− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
392− , "name" ::: 'NoDef :=> 'NotNull 'PGtext
393− ])
394− , "emails" ::: 'Table (
395− '[ "pk_emails" ::: 'PrimaryKey '["id"]
396− , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
397− ] :=>
398− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
399− , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
400− , "email" ::: 'NoDef :=> 'Null 'PGtext
401− ])
402− ]
403−:}
404−
405−>>> :{
406−let
407− setup :: Definition (Public '[]) (Public Schema)
408− setup =
409− createTable #users
410− ( serial `as` #id :*
411− (text & notNullable) `as` #name )
412− ( primaryKey #id `as` #pk_users ) >>>
413− createTable #emails
414− ( serial `as` #id :*
415− (int & notNullable) `as` #user_id :*
416− (text & nullable) `as` #email )
417− ( primaryKey #id `as` #pk_emails :*
418− foreignKey #user_id #users #id
419− OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
420−in printSQL setup
421−:}
422−CREATE TABLE "users" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_users" PRIMARY KEY ("id"));
423−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);
424−
425−A `foreignKey` can even be a table self-reference.
426−
427−>>> :{
428−type Schema =
429− '[ "employees" ::: 'Table (
430− '[ "employees_pk" ::: 'PrimaryKey '["id"]
431− , "employees_employer_fk" ::: 'ForeignKey '["employer_id"] "employees" '["id"]
432− ] :=>
433− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
434− , "name" ::: 'NoDef :=> 'NotNull 'PGtext
435− , "employer_id" ::: 'NoDef :=> 'Null 'PGint4
436− ])
437− ]
438−:}
439−
440−>>> :{
441−let
442− setup :: Definition (Public '[]) (Public Schema)
443− setup =
444− createTable #employees
445− ( serial `as` #id :*
446− (text & notNullable) `as` #name :*
447− (integer & nullable) `as` #employer_id )
448− ( primaryKey #id `as` #employees_pk :*
449− foreignKey #employer_id #employees #id
450− OnDeleteCascade OnUpdateCascade `as` #employees_employer_fk )
451−in printSQL setup
452−:}
453−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);
454−-}
455−foreignKey
456− :: (ForeignKeyed schemas sch schema child parent
457− table reftable
458− columns refcolumns
459− constraints cols
460− reftys tys )
461− => NP Alias columns
462− -- ^ column or columns in the table
463− -> Alias parent
464− -- ^ reference table
465− -> NP Alias refcolumns
466− -- ^ reference column or columns in the reference table
467− -> OnDeleteClause
468− -- ^ what to do when reference is deleted
469− -> OnUpdateClause
470− -- ^ what to do when reference is updated
471− -> TableConstraintExpression sch child schemas
472− ('ForeignKey columns parent refcolumns)
473−foreignKey keys parent refs ondel onupd = UnsafeTableConstraintExpression $
474− "FOREIGN KEY" <+> parenthesized (renderSQL keys)
475− <+> "REFERENCES" <+> renderSQL parent
476− <+> parenthesized (renderSQL refs)
477− <+> renderSQL ondel
478− <+> renderSQL onupd
479−
480−-- | A constraint synonym between types involved in a foreign key constraint.
481−type ForeignKeyed schemas
482− sch
483− schema
484− child parent
485− table reftable
486− columns refcolumns
487− constraints cols
488− reftys tys =
489− ( Has sch schemas schema
490− , Has child schema ('Table table)
491− , Has parent schema ('Table reftable)
492− , HasAll columns (TableToColumns table) tys
493− , reftable ~ (constraints :=> cols)
494− , HasAll refcolumns cols reftys
495− , SOP.AllZip SamePGType tys reftys
496− , Uniquely refcolumns constraints )
497−
498−-- | `OnDeleteClause` indicates what to do with rows that reference a deleted row.
499−data OnDeleteClause
500− = OnDeleteNoAction
501− -- ^ if any referencing rows still exist when the constraint is checked,
502− -- an error is raised
503− | OnDeleteRestrict -- ^ prevents deletion of a referenced row
504− | OnDeleteCascade
505− -- ^ specifies that when a referenced row is deleted,
506− -- row(s) referencing it should be automatically deleted as well
507− deriving (GHC.Generic,Show,Eq,Ord)
508−instance NFData OnDeleteClause
509−-- | Render `OnDeleteClause`.
510−instance RenderSQL OnDeleteClause where
511− renderSQL = \case
512− OnDeleteNoAction -> "ON DELETE NO ACTION"
513− OnDeleteRestrict -> "ON DELETE RESTRICT"
514− OnDeleteCascade -> "ON DELETE CASCADE"
515−
516−-- | Analagous to `OnDeleteClause` there is also `OnUpdateClause` which is invoked
517−-- when a referenced column is changed (updated).
518−data OnUpdateClause
519− = OnUpdateNoAction
520− -- ^ if any referencing rows has not changed when the constraint is checked,
521− -- an error is raised
522− | OnUpdateRestrict -- ^ prevents update of a referenced row
523− | OnUpdateCascade
524− -- ^ the updated values of the referenced column(s) should be copied
525− -- into the referencing row(s)
526− deriving (GHC.Generic,Show,Eq,Ord)
527−instance NFData OnUpdateClause
528−
529−-- | Render `OnUpdateClause`.
530−instance RenderSQL OnUpdateClause where
531− renderSQL = \case
532− OnUpdateNoAction -> "ON UPDATE NO ACTION"
533− OnUpdateRestrict -> "ON UPDATE RESTRICT"
534− OnUpdateCascade -> "ON UPDATE CASCADE"
535−
536−{-----------------------------------------
537−DROP statements
538−-----------------------------------------}
539−
540−-- >>> :{
541−-- let
542−-- definition :: Definition '["muh_schema" ::: schema, "public" ::: public] '["public" ::: public]
543−-- definition = dropSchema #muh_schema
544−-- :}
545−--
546−-- >>> printSQL definition
547−-- DROP SCHEMA "muh_schema";
548−dropSchema
549− :: Has sch schemas schema
550− => Alias sch
551− -> Definition schemas (Drop sch schemas)
552−dropSchema sch = UnsafeDefinition $ "DROP SCHEMA" <+> renderSQL sch <> ";"
553−
554−-- | `dropTable` removes a table from the schema.
555−--
556−-- >>> :{
557−-- let
558−-- definition :: Definition '["public" ::: '["muh_table" ::: 'Table t]] (Public '[])
559−-- definition = dropTable #muh_table
560−-- :}
561−--
562−-- >>> printSQL definition
563−-- DROP TABLE "muh_table";
564−dropTable
565− :: ( Has sch schemas schema
566− , Has tab schema ('Table table))
567− => QualifiedAlias sch tab -- ^ table to remove
568− -> Definition schemas (Alter sch (Drop tab schema) schemas)
569−dropTable tab = UnsafeDefinition $ "DROP TABLE" <+> renderSQL tab <> ";"
570−
571−{-----------------------------------------
572−ALTER statements
573−-----------------------------------------}
574−
575−-- | `alterTable` changes the definition of a table from the schema.
576−alterTable
577− :: (Has sch schemas schema, Has tab schema ('Table table0))
578− => QualifiedAlias sch tab -- ^ table to alter
579− -> AlterTable sch tab schemas table1 -- ^ alteration to perform
580− -> Definition schemas (Alter sch (Alter tab ('Table table1) schema) schemas)
581−alterTable tab alteration = UnsafeDefinition $
582− "ALTER TABLE"
583− <+> renderSQL tab
584− <+> renderAlterTable alteration
585− <> ";"
586−
587−-- | `alterTableRename` changes the name of a table from the schema.
588−--
589−-- >>> printSQL $ alterTableRename #foo #bar
590−-- ALTER TABLE "foo" RENAME TO "bar";
591−alterTableRename
592− :: (KnownSymbol table0, KnownSymbol table1)
593− => Alias table0 -- ^ table to rename
594− -> Alias table1 -- ^ what to rename it
595− -> Definition schema (Rename table0 table1 schema)
596−alterTableRename table0 table1 = UnsafeDefinition $
597− "ALTER TABLE" <+> renderSQL table0
598− <+> "RENAME TO" <+> renderSQL table1 <> ";"
599−
600−-- | An `AlterTable` describes the alteration to perform on the columns
601−-- of a table.
602−newtype AlterTable
603− (sch :: Symbol)
604− (tab :: Symbol)
605− (schemas :: SchemasType)
606− (table :: TableType) =
607− UnsafeAlterTable {renderAlterTable :: ByteString}
608− deriving (GHC.Generic,Show,Eq,Ord,NFData)
609−
610−-- | An `addConstraint` adds a table constraint.
611−--
612−-- >>> :{
613−-- let
614−-- definition :: Definition
615−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
616−-- '["public" ::: '["tab" ::: 'Table ('["positive" ::: 'Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
617−-- definition = alterTable #tab (addConstraint #positive (check #col (#col .> 0)))
618−-- in printSQL definition
619−-- :}
620−-- ALTER TABLE "tab" ADD CONSTRAINT "positive" CHECK (("col" > 0));
621−addConstraint
622− :: ( KnownSymbol alias
623− , Has sch schemas schema
624− , Has tab schema ('Table table0)
625− , table0 ~ (constraints :=> columns)
626− , table1 ~ (Create alias constraint constraints :=> columns) )
627− => Alias alias
628− -> TableConstraintExpression sch tab schemas constraint
629− -- ^ constraint to add
630− -> AlterTable sch tab schemas table1
631−addConstraint alias constraint = UnsafeAlterTable $
632− "ADD" <+> "CONSTRAINT" <+> renderSQL alias
633− <+> renderSQL constraint
634−
635−-- | A `dropConstraint` drops a table constraint.
636−--
637−-- >>> :{
638−-- let
639−-- definition :: Definition
640−-- '["public" ::: '["tab" ::: 'Table ('["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
641−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
642−-- definition = alterTable #tab (dropConstraint #positive)
643−-- in printSQL definition
644−-- :}
645−-- ALTER TABLE "tab" DROP CONSTRAINT "positive";
646−dropConstraint
647− :: ( KnownSymbol constraint
648− , Has sch schemas schema
649− , Has tab schema ('Table table0)
650− , table0 ~ (constraints :=> columns)
651− , table1 ~ (Drop constraint constraints :=> columns) )
652− => Alias constraint
653− -- ^ constraint to drop
654− -> AlterTable sch tab schemas table1
655−dropConstraint constraint = UnsafeAlterTable $
656− "DROP" <+> "CONSTRAINT" <+> renderSQL constraint
657−
658−-- | An `AddColumn` is either @NULL@ or has @DEFAULT@.
659−class AddColumn ty where
660− -- | `addColumn` adds a new column, initially filled with whatever
661− -- default value is given or with @NULL@.
662− --
663− -- >>> :{
664− -- let
665− -- definition :: Definition
666− -- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]
667− -- '["public" ::: '["tab" ::: 'Table ('[] :=>
668− -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
669− -- , "col2" ::: 'Def :=> 'Null 'PGtext ])]]
670− -- definition = alterTable #tab (addColumn #col2 (text & nullable & default_ "foo"))
671− -- in printSQL definition
672− -- :}
673− -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL DEFAULT E'foo';
674− --
675− -- >>> :{
676− -- let
677− -- definition :: Definition
678− -- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]
679− -- '["public" ::: '["tab" ::: 'Table ('[] :=>
680− -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
681− -- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]]
682− -- definition = alterTable #tab (addColumn #col2 (text & nullable))
683− -- in printSQL definition
684− -- :}
685− -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL;
686− addColumn
687− :: ( KnownSymbol column
688− , Has sch schemas schema
689− , Has tab schema ('Table table0)
690− , table0 ~ (constraints :=> columns) )
691− => Alias column -- ^ column to add
692− -> ColumnTypeExpression schemas ty -- ^ type of the new column
693− -> AlterTable sch tab schemas (constraints :=> Create column ty columns)
694− addColumn column ty = UnsafeAlterTable $
695− "ADD COLUMN" <+> renderSQL column <+> renderColumnTypeExpression ty
696−instance {-# OVERLAPPING #-} AddColumn ('Def :=> ty)
697−instance {-# OVERLAPPABLE #-} AddColumn ('NoDef :=> 'Null ty)
698−
699−-- | A `dropColumn` removes a column. Whatever data was in the column
700−-- disappears. Table constraints involving the column are dropped, too.
701−-- However, if the column is referenced by a foreign key constraint of
702−-- another table, PostgreSQL will not silently drop that constraint.
703−--
704−-- >>> :{
705−-- let
706−-- definition :: Definition
707−-- '["public" ::: '["tab" ::: 'Table ('[] :=>
708−-- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
709−-- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]]
710−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]
711−-- definition = alterTable #tab (dropColumn #col2)
712−-- in printSQL definition
713−-- :}
714−-- ALTER TABLE "tab" DROP COLUMN "col2";
715−dropColumn
716− :: ( KnownSymbol column
717− , Has sch schemas schema
718− , Has tab schema ('Table table0)
719− , table0 ~ (constraints :=> columns)
720− , table1 ~ (constraints :=> Drop column columns) )
721− => Alias column -- ^ column to remove
722− -> AlterTable sch tab schemas table1
723−dropColumn column = UnsafeAlterTable $
724− "DROP COLUMN" <+> renderSQL column
725−
726−-- | A `renameColumn` renames a column.
727−--
728−-- >>> :{
729−-- let
730−-- definition :: Definition
731−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["foo" ::: 'NoDef :=> 'Null 'PGint4])]]
732−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["bar" ::: 'NoDef :=> 'Null 'PGint4])]]
733−-- definition = alterTable #tab (renameColumn #foo #bar)
734−-- in printSQL definition
735−-- :}
736−-- ALTER TABLE "tab" RENAME COLUMN "foo" TO "bar";
737−renameColumn
738− :: ( KnownSymbol column0
739− , KnownSymbol column1
740− , Has sch schemas schema
741− , Has tab schema ('Table table0)
742− , table0 ~ (constraints :=> columns)
743− , table1 ~ (constraints :=> Rename column0 column1 columns) )
744− => Alias column0 -- ^ column to rename
745− -> Alias column1 -- ^ what to rename the column
746− -> AlterTable sch tab schemas table1
747−renameColumn column0 column1 = UnsafeAlterTable $
748− "RENAME COLUMN" <+> renderSQL column0 <+> "TO" <+> renderSQL column1
749−
750−-- | An `alterColumn` alters a single column.
751−alterColumn
752− :: ( KnownSymbol column
753− , Has sch schemas schema
754− , Has tab schema ('Table table0)
755− , table0 ~ (constraints :=> columns)
756− , Has column columns ty0
757− , table1 ~ (constraints :=> Alter column ty1 columns))
758− => Alias column -- ^ column to alter
759− -> AlterColumn schemas ty0 ty1 -- ^ alteration to perform
760− -> AlterTable sch tab schemas table1
761−alterColumn column alteration = UnsafeAlterTable $
762− "ALTER COLUMN" <+> renderSQL column <+> renderAlterColumn alteration
763−
764−-- | An `AlterColumn` describes the alteration to perform on a single column.
765−newtype AlterColumn (schemas :: SchemasType) (ty0 :: ColumnType) (ty1 :: ColumnType) =
766− UnsafeAlterColumn {renderAlterColumn :: ByteString}
767− deriving (GHC.Generic,Show,Eq,Ord,NFData)
768−
769−-- | A `setDefault` sets a new default for a column. Note that this doesn't
770−-- affect any existing rows in the table, it just changes the default for
771−-- future insert and update commands.
772−--
773−-- >>> :{
774−-- let
775−-- definition :: Definition
776−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
777−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]]
778−-- definition = alterTable #tab (alterColumn #col (setDefault 5))
779−-- in printSQL definition
780−-- :}
781−-- ALTER TABLE "tab" ALTER COLUMN "col" SET DEFAULT 5;
782−setDefault
783− :: Expression '[] '[] 'Ungrouped schemas '[] '[] ty -- ^ default value to set
784− -> AlterColumn schemas (constraint :=> ty) ('Def :=> ty)
785−setDefault expression = UnsafeAlterColumn $
786− "SET DEFAULT" <+> renderExpression expression
787−
788−-- | A `dropDefault` removes any default value for a column.
789−--
790−-- >>> :{
791−-- let
792−-- definition :: Definition
793−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]]
794−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
795−-- definition = alterTable #tab (alterColumn #col dropDefault)
796−-- in printSQL definition
797−-- :}
798−-- ALTER TABLE "tab" ALTER COLUMN "col" DROP DEFAULT;
799−dropDefault :: AlterColumn schemas ('Def :=> ty) ('NoDef :=> ty)
800−dropDefault = UnsafeAlterColumn $ "DROP DEFAULT"
801−
802−-- | A `setNotNull` adds a @NOT NULL@ constraint to a column.
803−-- The constraint will be checked immediately, so the table data must satisfy
804−-- the constraint before it can be added.
805−--
806−-- >>> :{
807−-- let
808−-- definition :: Definition
809−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
810−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
811−-- definition = alterTable #tab (alterColumn #col setNotNull)
812−-- in printSQL definition
813−-- :}
814−-- ALTER TABLE "tab" ALTER COLUMN "col" SET NOT NULL;
815−setNotNull
816− :: AlterColumn schemas (constraint :=> 'Null ty) (constraint :=> 'NotNull ty)
817−setNotNull = UnsafeAlterColumn $ "SET NOT NULL"
818−
819−-- | A `dropNotNull` drops a @NOT NULL@ constraint from a column.
820−--
821−-- >>> :{
822−-- let
823−-- definition :: Definition
824−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
825−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
826−-- definition = alterTable #tab (alterColumn #col dropNotNull)
827−-- in printSQL definition
828−-- :}
829−-- ALTER TABLE "tab" ALTER COLUMN "col" DROP NOT NULL;
830−dropNotNull
831− :: AlterColumn schemas (constraint :=> 'NotNull ty) (constraint :=> 'Null ty)
832−dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL"
833−
834−-- | An `alterType` converts a column to a different data type.
835−-- This will succeed only if each existing entry in the column can be
836−-- converted to the new type by an implicit cast.
837−--
838−-- >>> :{
839−-- let
840−-- definition :: Definition
841−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
842−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGnumeric])]]
843−-- definition =
844−-- alterTable #tab (alterColumn #col (alterType (numeric & notNullable)))
845−-- in printSQL definition
846−-- :}
847−-- ALTER TABLE "tab" ALTER COLUMN "col" TYPE numeric NOT NULL;
848−alterType :: ColumnTypeExpression schemas ty -> AlterColumn schemas ty0 ty
849−alterType ty = UnsafeAlterColumn $ "TYPE" <+> renderColumnTypeExpression ty
850−
851−{- | Create a view.
852−>>> type ABC = '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4]
853−>>> type BC = '["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4]
854−>>> :{
855−let
856− definition :: Definition
857− '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC)]]
858− '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC), "bc" ::: 'View BC]]
859− definition =
860− createView #bc (select_ (#b :* #c) (from (table #abc)))
861−in printSQL definition
862−:}
863−CREATE VIEW "bc" AS SELECT "b" AS "b", "c" AS "c" FROM "abc" AS "abc";
864−-}
865−createView
866− :: (KnownSymbol sch, KnownSymbol vw, Has sch schemas schema)
867− => QualifiedAlias sch vw -- ^ the name of the view to add
868− -> Query '[] '[] schemas '[] view -- ^ query
869− -> Definition schemas (Alter sch (Create vw ('View view) schema) schemas)
870−createView alias query = UnsafeDefinition $
871− "CREATE" <+> "VIEW" <+> renderSQL alias <+> "AS"
872− <+> renderQuery query <> ";"
873−
874−-- | Drop a view.
875−--
876−-- >>> :{
877−-- let
878−-- definition :: Definition
879−-- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])
880−-- , "bc" ::: 'View ('["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4])]]
881−-- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])]]
882−-- definition = dropView #bc
883−-- in printSQL definition
884−-- :}
885−-- DROP VIEW "bc";
886−dropView
887− :: (Has sch schemas schema, Has vw schema ('View view))
888− => QualifiedAlias sch vw -- ^ view to remove
889− -> Definition schemas (Alter sch (Drop vw schema) schemas)
890−dropView vw = UnsafeDefinition $ "DROP VIEW" <+> renderSQL vw <> ";"
891−
892−-- | Enumerated types are created using the `createTypeEnum` command, for example
893−--
894−-- >>> printSQL $ (createTypeEnum #mood (label @"sad" :* label @"ok" :* label @"happy") :: Definition (Public '[]) '["public" ::: '["mood" ::: 'Typedef ('PGenum '["sad","ok","happy"])]])
895−-- CREATE TYPE "mood" AS ENUM ('sad', 'ok', 'happy');
896−createTypeEnum
897− :: (KnownSymbol enum, Has sch schemas schema, SOP.All KnownSymbol labels)
898− => QualifiedAlias sch enum
899− -- ^ name of the user defined enumerated type
900− -> NP PGlabel labels
901− -- ^ labels of the enumerated type
902− -> Definition schemas (Alter sch (Create enum ('Typedef ('PGenum labels)) schema) schemas)
903−createTypeEnum enum labels = UnsafeDefinition $
904− "CREATE" <+> "TYPE" <+> renderSQL enum <+> "AS" <+> "ENUM" <+>
905− parenthesized (renderSQL labels) <> ";"
906−
907−-- | Enumerated types can also be generated from a Haskell type, for example
908−--
909−-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic
910−-- >>> instance SOP.Generic Schwarma
911−-- >>> instance SOP.HasDatatypeInfo Schwarma
912−-- >>> :{
913−-- let
914−-- createSchwarma :: Definition (Public '[]) '["public" ::: '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))]]
915−-- createSchwarma = createTypeEnumFrom @Schwarma #schwarma
916−-- in
917−-- printSQL createSchwarma
918−-- :}
919−-- CREATE TYPE "schwarma" AS ENUM ('Beef', 'Lamb', 'Chicken');
920−createTypeEnumFrom
921− :: forall hask sch enum schemas schema.
922− ( SOP.Generic hask
923− , SOP.All KnownSymbol (LabelsPG hask)
924− , KnownSymbol enum
925− , Has sch schemas schema )
926− => QualifiedAlias sch enum
927− -- ^ name of the user defined enumerated type
928− -> Definition schemas (Alter sch (Create enum ('Typedef (PG (Enumerated hask))) schema) schemas)
929−createTypeEnumFrom enum = createTypeEnum enum
930− (SOP.hpure label :: NP PGlabel (LabelsPG hask))
931−
932−{- | `createTypeComposite` creates a composite type. The composite type is
933−specified by a list of attribute names and data types.
934−
935−>>> :{
936−type PGcomplex = 'PGcomposite
937− '[ "real" ::: 'NotNull 'PGfloat8
938− , "imaginary" ::: 'NotNull 'PGfloat8 ]
939−:}
940−
941−>>> :{
942−let
943− setup :: Definition (Public '[]) '["public" ::: '["complex" ::: 'Typedef PGcomplex]]
944− setup = createTypeComposite #complex
945− (float8 `as` #real :* float8 `as` #imaginary)
946−in printSQL setup
947−:}
948−CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);
949−-}
950−createTypeComposite
951− :: (KnownSymbol ty, Has sch schemas schema, SOP.SListI fields)
952− => QualifiedAlias sch ty
953− -- ^ name of the user defined composite type
954− -> NP (Aliased (TypeExpression schemas)) fields
955− -- ^ list of attribute names and data types
956− -> Definition schemas (Alter sch (Create ty ('Typedef ('PGcomposite fields)) schema) schemas)
957−createTypeComposite ty fields = UnsafeDefinition $
958− "CREATE" <+> "TYPE" <+> renderSQL ty <+> "AS" <+> parenthesized
959− (renderCommaSeparated renderField fields) <> ";"
960− where
961− renderField :: Aliased (TypeExpression schemas) x -> ByteString
962− renderField (typ `As` alias) =
963− renderSQL alias <+> renderSQL typ
964−
965−-- | Composite types can also be generated from a Haskell type, for example
966−--
967−-- >>> data Complex = Complex {real :: Double, imaginary :: Double} deriving GHC.Generic
968−-- >>> instance SOP.Generic Complex
969−-- >>> instance SOP.HasDatatypeInfo Complex
970−-- >>> type Schema = '["complex" ::: 'Typedef (PG (Composite Complex))]
971−-- >>> :{
972−-- let
973−-- createComplex :: Definition (Public '[]) (Public Schema)
974−-- createComplex = createTypeCompositeFrom @Complex #complex
975−-- in
976−-- printSQL createComplex
977−-- :}
978−-- CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);
979−createTypeCompositeFrom
980− :: forall hask sch ty schemas schema.
981− ( SOP.All (FieldTyped schemas) (RowPG hask)
982− , KnownSymbol ty
983− , Has sch schemas schema )
984− => QualifiedAlias sch ty
985− -- ^ name of the user defined composite type
986− -> Definition schemas (Alter sch (Create ty ( 'Typedef (PG (Composite hask))) schema) schemas)
987−createTypeCompositeFrom ty = createTypeComposite ty
988− (SOP.hcpure (SOP.Proxy :: SOP.Proxy (FieldTyped schemas)) fieldtype
989− :: NP (Aliased (TypeExpression schemas)) (RowPG hask))
990−
991−{-|
992−`createDomain` creates a new domain. A domain is essentially a data type
993−with constraints (restrictions on the allowed set of values).
994−
995−Domains are useful for abstracting common constraints on fields
996−into a single location for maintenance. For example, several tables might
997−contain email address columns, all requiring the same `check` constraint
998−to verify the address syntax. Define a domain rather than setting up
999−each table's constraint individually.
1000−
1001−>>> :{
1002−let
1003− createPositive :: Definition (Public '[]) (Public '["positive" ::: 'Typedef 'PGfloat4])
1004− createPositive = createDomain #positive real (#value .> 0 .&& (#value & isNotNull))
1005−in printSQL createPositive
1006−:}
1007−CREATE DOMAIN "positive" AS real CHECK ((("value" > 0) AND "value" IS NOT NULL));
1008−-}
1009−createDomain
1010− :: (Has sch schemas schema, KnownSymbol dom)
1011− => QualifiedAlias sch dom
1012− -> (forall nullity. TypeExpression schemas (nullity ty))
1013− -> (forall tab. Condition '[] '[] 'Ungrouped schemas '[] '[tab ::: '["value" ::: 'Null ty]])
1014− -> Definition schemas (Alter sch (Create alias ('Typedef ty) schema) schemas)
1015−createDomain dom ty condition =
1016− UnsafeDefinition $ "CREATE DOMAIN" <+> renderSQL dom
1017− <+> "AS" <+> renderTypeExpression ty
1018− <+> "CHECK" <+> parenthesized (renderSQL condition) <> ";"
1019−
1020−class FieldTyped schemas ty where
1021− fieldtype :: Aliased (TypeExpression schemas) ty
1022−instance (KnownSymbol alias, PGTyped schemas ty)
1023− => FieldTyped schemas (alias ::: ty) where
1024− fieldtype = pgtype `As` Alias
1025−
1026−-- | Drop a type.
1027−--
1028−-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic
1029−-- >>> instance SOP.Generic Schwarma
1030−-- >>> instance SOP.HasDatatypeInfo Schwarma
1031−-- >>> printSQL (dropType #schwarma :: Definition '["public" ::: '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))]] (Public '[]))
1032−-- DROP TYPE "schwarma";
1033−dropType
1034− :: (Has sch schemas schema, Has td schema ('Typedef ty))
1035− => QualifiedAlias sch td
1036− -- ^ name of the user defined type
1037− -> Definition schemas (Alter sch (Drop td schema) schemas)
1038−dropType tydef = UnsafeDefinition $ "DROP" <+> "TYPE" <+> renderSQL tydef <> ";"
1039−
1040−-- | `ColumnTypeExpression`s are used in `createTable` commands.
1041−newtype ColumnTypeExpression (schemas :: SchemasType) (ty :: ColumnType)
1042− = UnsafeColumnTypeExpression { renderColumnTypeExpression :: ByteString }
1043− deriving (GHC.Generic,Show,Eq,Ord,NFData)
1044−instance RenderSQL (ColumnTypeExpression schemas ty) where
1045− renderSQL = renderColumnTypeExpression
1046−
1047−-- | used in `createTable` commands as a column constraint to note that
1048−-- @NULL@ may be present in a column
1049−nullable
1050− :: TypeExpression schemas (nullity ty)
1051− -> ColumnTypeExpression schemas ('NoDef :=> 'Null ty)
1052−nullable ty = UnsafeColumnTypeExpression $ renderSQL ty <+> "NULL"
1053−
1054−-- | used in `createTable` commands as a column constraint to ensure
1055−-- @NULL@ is not present in a column
1056−notNullable
1057− :: TypeExpression schemas (nullity ty)
1058− -> ColumnTypeExpression schemas ('NoDef :=> 'NotNull ty)
1059−notNullable ty = UnsafeColumnTypeExpression $ renderSQL ty <+> "NOT NULL"
1060−
1061−-- | used in `createTable` commands as a column constraint to give a default
1062−default_
1063− :: Expression '[] '[] 'Ungrouped schemas '[] '[] ty
1064− -> ColumnTypeExpression schemas ('NoDef :=> ty)
1065− -> ColumnTypeExpression schemas ('Def :=> ty)
1066−default_ x ty = UnsafeColumnTypeExpression $
1067− renderSQL ty <+> "DEFAULT" <+> renderExpression x
1068−
1069−-- | not a true type, but merely a notational convenience for creating
1070−-- unique identifier columns with type `PGint2`
1071−serial2, smallserial
1072− :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint2)
1073−serial2 = UnsafeColumnTypeExpression "serial2"
1074−smallserial = UnsafeColumnTypeExpression "smallserial"
1075−-- | not a true type, but merely a notational convenience for creating
1076−-- unique identifier columns with type `PGint4`
1077−serial4, serial
1078− :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint4)
1079−serial4 = UnsafeColumnTypeExpression "serial4"
1080−serial = UnsafeColumnTypeExpression "serial"
1081−-- | not a true type, but merely a notational convenience for creating
1082−-- unique identifier columns with type `PGint8`
1083−serial8, bigserial
1084− :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint8)
1085−serial8 = UnsafeColumnTypeExpression "serial8"
1086−bigserial = UnsafeColumnTypeExpression "bigserial"
82+manipDefinition = UnsafeDefinition . (<> ";") . renderSQL
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Function.hsnew file+238
@@ -0,0 +1,238 @@
1+{-|
2+Module: Squeal.PostgreSQL.Definition.Function
3+Description: Create and drop function and operator definitions
4+Copyright: (c) Eitan Chatav, 2017
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Create and drop function and operator definitions.
9+-}
10+
11+{-# LANGUAGE
12+ AllowAmbiguousTypes
13+ , ConstraintKinds
14+ , DeriveAnyClass
15+ , DeriveGeneric
16+ , DerivingStrategies
17+ , FlexibleContexts
18+ , FlexibleInstances
19+ , GADTs
20+ , LambdaCase
21+ , MultiParamTypeClasses
22+ , OverloadedLabels
23+ , OverloadedStrings
24+ , RankNTypes
25+ , ScopedTypeVariables
26+ , TypeApplications
27+ , TypeInType
28+ , TypeOperators
29+ , UndecidableSuperClasses
30+#-}
31+
32+module Squeal.PostgreSQL.Definition.Function
33+ ( createFunction
34+ , createOrReplaceFunction
35+ , createSetFunction
36+ , createOrReplaceSetFunction
37+ , createBinaryOp
38+ , createLeftOp
39+ , createRightOp
40+ , dropFunction
41+ , dropFunctionIfExists
42+ , dropOperator
43+ , dropOperatorIfExists
44+ , FunctionDefinition(..)
45+ , languageSqlExpr
46+ , languageSqlQuery
47+ ) where
48+
49+import Control.DeepSeq
50+import Data.ByteString
51+import GHC.TypeLits
52+
53+import qualified Generics.SOP as SOP
54+import qualified GHC.Generics as GHC
55+
56+import Squeal.PostgreSQL.Alias
57+import Squeal.PostgreSQL.Definition
58+import Squeal.PostgreSQL.Expression
59+import Squeal.PostgreSQL.Expression.Type
60+import Squeal.PostgreSQL.List
61+import Squeal.PostgreSQL.Query
62+import Squeal.PostgreSQL.Render
63+import Squeal.PostgreSQL.Schema
64+
65+-- $setup
66+-- >>> import Squeal.PostgreSQL
67+
68+createFunction
69+ :: ( Has sch schemas schema
70+ , KnownSymbol fun
71+ , SOP.SListI args )
72+ => QualifiedAlias sch fun
73+ -> NP (TypeExpression schemas) args
74+ -> TypeExpression schemas ret
75+ -> FunctionDefinition schemas args ('Returns ret)
76+ -> Definition schemas (Alter sch (Create fun ('Function (args :=> 'Returns ret)) schema) schemas)
77+createFunction fun args ret fundef = UnsafeDefinition $
78+ "CREATE" <+> "FUNCTION" <+> renderSQL fun
79+ <+> parenthesized (renderCommaSeparated renderSQL args)
80+ <+> "RETURNS" <+> renderSQL ret <+> renderSQL fundef <> ";"
81+
82+createOrReplaceFunction
83+ :: ( Has sch schemas schema
84+ , KnownSymbol fun
85+ , SOP.SListI args )
86+ => QualifiedAlias sch fun
87+ -> NP (TypeExpression schemas) args
88+ -> TypeExpression schemas ret
89+ -> FunctionDefinition schemas args ('Returns ret)
90+ -> Definition schemas (Alter sch (CreateOrReplace fun ('Function (args :=> 'Returns ret)) schema) schemas)
91+createOrReplaceFunction fun args ret fundef = UnsafeDefinition $
92+ "CREATE" <+> "OR" <+> "REPLACE" <+> "FUNCTION" <+> renderSQL fun
93+ <+> parenthesized (renderCommaSeparated renderSQL args)
94+ <+> "RETURNS" <+> renderSQL ret <+> renderSQL fundef <> ";"
95+
96+languageSqlExpr
97+ :: Expression '[] '[] 'Ungrouped schemas args '[] ret
98+ -> FunctionDefinition schemas args ('Returns ret)
99+languageSqlExpr expr = UnsafeFunctionDefinition $
100+ "language sql as"
101+ <+> "$$" <+> renderSQL (values_ (expr `as` #ret)) <+> "$$"
102+
103+languageSqlQuery
104+ :: Query '[] '[] schemas args rets
105+ -> FunctionDefinition schemas args ('ReturnsTable rets)
106+languageSqlQuery qry = UnsafeFunctionDefinition $
107+ "language sql as" <+> "$$" <+> renderSQL qry <+> "$$"
108+
109+createSetFunction
110+ :: ( Has sch schemas schema
111+ , KnownSymbol fun
112+ , SOP.SListI args
113+ , SOP.SListI rets )
114+ => QualifiedAlias sch fun
115+ -> NP (TypeExpression schemas) args
116+ -> NP (Aliased (TypeExpression schemas)) rets
117+ -> FunctionDefinition schemas args ('ReturnsTable rets)
118+ -> Definition schemas (Alter sch (Create fun ('Function (args :=> 'ReturnsTable rets)) schema) schemas)
119+createSetFunction fun args rets fundef = UnsafeDefinition $
120+ "CREATE" <+> "FUNCTION" <+> renderSQL fun
121+ <+> parenthesized (renderCommaSeparated renderSQL args)
122+ <+> "RETURNS" <+> "TABLE"
123+ <+> parenthesized (renderCommaSeparated renderRet rets)
124+ <+> renderSQL fundef <> ";"
125+ where
126+ renderRet :: Aliased (TypeExpression s) r -> ByteString
127+ renderRet (ty `As` col) = renderSQL col <+> renderSQL ty
128+
129+createOrReplaceSetFunction
130+ :: ( Has sch schemas schema
131+ , KnownSymbol fun
132+ , SOP.SListI args
133+ , SOP.SListI rets )
134+ => QualifiedAlias sch fun
135+ -> NP (TypeExpression schemas) args
136+ -> NP (Aliased (TypeExpression schemas)) rets
137+ -> FunctionDefinition schemas args ('ReturnsTable rets)
138+ -> Definition schemas (Alter sch (CreateOrReplace fun ('Function (args :=> 'ReturnsTable rets)) schema) schemas)
139+createOrReplaceSetFunction fun args rets fundef = UnsafeDefinition $
140+ "CREATE" <+> "OR" <+> "REPLACE" <+> "FUNCTION" <+> renderSQL fun
141+ <+> parenthesized (renderCommaSeparated renderSQL args)
142+ <+> "RETURNS" <+> "TABLE"
143+ <+> parenthesized (renderCommaSeparated renderRet rets)
144+ <+> renderSQL fundef <> ";"
145+ where
146+ renderRet :: Aliased (TypeExpression s) r -> ByteString
147+ renderRet (ty `As` col) = renderSQL col <+> renderSQL ty
148+
149+createBinaryOp
150+ :: forall op fun sch schemas schema x y z.
151+ ( Has sch schemas schema
152+ , Has fun schema ('Function ('[x,y] :=> 'Returns z))
153+ , KnownSymbol op )
154+ => QualifiedAlias sch fun
155+ -> TypeExpression schemas x
156+ -> TypeExpression schemas y
157+ -> Definition schemas
158+ (Alter sch (Create op ('Operator ('BinaryOp x y z)) schema) schemas)
159+createBinaryOp fun x y = UnsafeDefinition $
160+ "CREATE" <+> "OPERATOR" <+> renderSymbol @op
161+ <+> parenthesized (commaSeparated opdef)
162+ where
163+ opdef =
164+ [ "FUNCTION" <+> "=" <+> renderSQL fun
165+ , "LEFTARG" <+> "=" <+> renderSQL x
166+ , "RIGHTARG" <+> "=" <+> renderSQL y ]
167+
168+createLeftOp
169+ :: forall op fun sch schemas schema x y.
170+ ( Has sch schemas schema
171+ , Has fun schema ('Function ('[x] :=> 'Returns y))
172+ , KnownSymbol op )
173+ => QualifiedAlias sch fun
174+ -> TypeExpression schemas x
175+ -> Definition schemas
176+ (Alter sch (Create op ('Operator ('LeftOp x y)) schema) schemas)
177+createLeftOp fun x = UnsafeDefinition $
178+ "CREATE" <+> "OPERATOR" <+> renderSymbol @op
179+ <+> parenthesized (commaSeparated opdef)
180+ where
181+ opdef =
182+ [ "FUNCTION" <+> "=" <+> renderSQL fun
183+ , "RIGHTARG" <+> "=" <+> renderSQL x ]
184+
185+createRightOp
186+ :: forall op fun sch schemas schema x y.
187+ ( Has sch schemas schema
188+ , Has fun schema ('Function ('[x] :=> 'Returns y))
189+ , KnownSymbol op )
190+ => QualifiedAlias sch fun
191+ -> TypeExpression schemas x
192+ -> Definition schemas
193+ (Alter sch (Create op ('Operator ('RightOp x y)) schema) schemas)
194+createRightOp fun x = UnsafeDefinition $
195+ "CREATE" <+> "OPERATOR" <+> renderSymbol @op
196+ <+> parenthesized (commaSeparated opdef)
197+ where
198+ opdef =
199+ [ "FUNCTION" <+> "=" <+> renderSQL fun
200+ , "LEFTARG" <+> "=" <+> renderSQL x ]
201+
202+dropFunction
203+ :: (Has sch schemas schema, KnownSymbol fun)
204+ => QualifiedAlias sch fun
205+ -- ^ name of the user defined function
206+ -> Definition schemas (Alter sch (DropSchemum fun 'Function schema) schemas)
207+dropFunction fun = UnsafeDefinition $
208+ "DROP" <+> "FUNCTION" <+> renderSQL fun <> ";"
209+
210+dropFunctionIfExists
211+ :: (Has sch schemas schema, KnownSymbol fun)
212+ => QualifiedAlias sch fun
213+ -- ^ name of the user defined function
214+ -> Definition schemas (Alter sch (DropSchemumIfExists fun 'Function schema) schemas)
215+dropFunctionIfExists fun = UnsafeDefinition $
216+ "DROP FUNCTION IF EXISTS" <+> renderSQL fun <> ";"
217+
218+dropOperator
219+ :: (Has sch schemas schema, KnownSymbol op)
220+ => QualifiedAlias sch op
221+ -- ^ name of the user defined operator
222+ -> Definition schemas (Alter sch (DropSchemum op 'Operator schema) schemas)
223+dropOperator op = UnsafeDefinition $
224+ "DROP" <+> "OPERATOR" <+> renderSQL op <> ";"
225+
226+dropOperatorIfExists
227+ :: (Has sch schemas schema, KnownSymbol op)
228+ => QualifiedAlias sch op
229+ -- ^ name of the user defined operator
230+ -> Definition schemas (Alter sch (DropSchemumIfExists op 'Operator schema) schemas)
231+dropOperatorIfExists op = UnsafeDefinition $
232+ "DROP OPERATOR IF EXISTS" <+> renderSQL op <> ";"
233+
234+newtype FunctionDefinition schemas args ret = UnsafeFunctionDefinition
235+ { renderFunctionDefinition :: ByteString }
236+ deriving (Eq,Show,GHC.Generic,NFData)
237+instance RenderSQL (FunctionDefinition schemas args ret) where
238+ renderSQL = renderFunctionDefinition
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Index.hsnew file+159
@@ -0,0 +1,159 @@
1+{-|
2+Module: Squeal.PostgreSQL.Definition.Index
3+Description: Create and drop index definitions
4+Copyright: (c) Eitan Chatav, 2017
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Create and drop index definitions.
9+-}
10+
11+{-# LANGUAGE
12+ AllowAmbiguousTypes
13+ , ConstraintKinds
14+ , DeriveAnyClass
15+ , DeriveGeneric
16+ , DerivingStrategies
17+ , FlexibleContexts
18+ , FlexibleInstances
19+ , GADTs
20+ , LambdaCase
21+ , MultiParamTypeClasses
22+ , OverloadedLabels
23+ , OverloadedStrings
24+ , RankNTypes
25+ , ScopedTypeVariables
26+ , TypeApplications
27+ , TypeInType
28+ , TypeOperators
29+ , UndecidableSuperClasses
30+#-}
31+
32+module Squeal.PostgreSQL.Definition.Index
33+ ( createIndex
34+ , createIndexIfNotExists
35+ , dropIndex
36+ , dropIndexIfExists
37+ , IndexMethod (..)
38+ , btree
39+ , hash
40+ , gist
41+ , spgist
42+ , gin
43+ , brin
44+ ) where
45+
46+import Data.ByteString
47+import GHC.TypeLits
48+
49+import qualified GHC.Generics as GHC
50+
51+import Squeal.PostgreSQL.Alias
52+import Squeal.PostgreSQL.Definition
53+import Squeal.PostgreSQL.Expression.Sort
54+import Squeal.PostgreSQL.Render
55+import Squeal.PostgreSQL.Schema
56+
57+-- $setup
58+-- >>> import Squeal.PostgreSQL
59+
60+{- |
61+>>> :{
62+type Table = '[] :=>
63+ '[ "a" ::: 'NoDef :=> 'Null 'PGint4
64+ , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]
65+:}
66+
67+>>> :{
68+let
69+ setup :: Definition (Public '[]) (Public '["tab" ::: 'Table Table, "ix" ::: 'Index 'Btree])
70+ setup =
71+ createTable #tab (nullable int `as` #a :* nullable real `as` #b) Nil >>>
72+ createIndex #ix #tab btree [#a & AscNullsFirst, #b & AscNullsLast]
73+in printSQL setup
74+:}
75+CREATE TABLE "tab" ("a" int NULL, "b" real NULL);
76+CREATE INDEX "ix" ON "tab" USING btree (("a") ASC NULLS FIRST, ("b") ASC NULLS LAST);
77+-}
78+createIndex
79+ :: (Has sch schemas schema, Has tab schema ('Table table), KnownSymbol ix)
80+ => Alias ix
81+ -> QualifiedAlias sch tab
82+ -> IndexMethod method
83+ -> [SortExpression '[] '[] 'Ungrouped schemas '[] '[tab ::: TableToRow table]]
84+ -> Definition schemas (Alter sch (Create ix ('Index method) schema) schemas)
85+createIndex ix tab method cols = UnsafeDefinition $
86+ "CREATE" <+> "INDEX" <+> renderSQL ix <+> "ON" <+> renderSQL tab
87+ <+> "USING" <+> renderSQL method
88+ <+> parenthesized (commaSeparated (renderIndex <$> cols))
89+ <> ";"
90+ where
91+ renderIndex = \case
92+ Asc expression -> parenthesized (renderSQL expression) <+> "ASC"
93+ Desc expression -> parenthesized (renderSQL expression) <+> "DESC"
94+ AscNullsFirst expression -> parenthesized (renderSQL expression)
95+ <+> "ASC NULLS FIRST"
96+ DescNullsFirst expression -> parenthesized (renderSQL expression)
97+ <+> "DESC NULLS FIRST"
98+ AscNullsLast expression -> parenthesized (renderSQL expression)
99+ <+> "ASC NULLS LAST"
100+ DescNullsLast expression -> parenthesized (renderSQL expression)
101+ <+> "DESC NULLS LAST"
102+
103+createIndexIfNotExists
104+ :: (Has sch schemas schema, Has tab schema ('Table table), KnownSymbol ix)
105+ => Alias ix
106+ -> QualifiedAlias sch tab
107+ -> IndexMethod method
108+ -> [SortExpression '[] '[] 'Ungrouped schemas '[] '[tab ::: TableToRow table]]
109+ -> Definition schemas (Alter sch (CreateIfNotExists ix ('Index method) schema) schemas)
110+createIndexIfNotExists ix tab method cols = UnsafeDefinition $
111+ "CREATE INDEX IF NOT EXISTS" <+> renderSQL ix <+> "ON" <+> renderSQL tab
112+ <+> "USING" <+> renderSQL method
113+ <+> parenthesized (commaSeparated (renderIndex <$> cols))
114+ <> ";"
115+ where
116+ renderIndex = \case
117+ Asc expression -> parenthesized (renderSQL expression) <+> "ASC"
118+ Desc expression -> parenthesized (renderSQL expression) <+> "DESC"
119+ AscNullsFirst expression -> parenthesized (renderSQL expression)
120+ <+> "ASC NULLS FIRST"
121+ DescNullsFirst expression -> parenthesized (renderSQL expression)
122+ <+> "DESC NULLS FIRST"
123+ AscNullsLast expression -> parenthesized (renderSQL expression)
124+ <+> "ASC NULLS LAST"
125+ DescNullsLast expression -> parenthesized (renderSQL expression)
126+ <+> "DESC NULLS LAST"
127+
128+newtype IndexMethod ty = UnsafeIndexMethod {renderIndexMethod :: ByteString}
129+ deriving stock (Eq, Ord, Show, GHC.Generic)
130+instance RenderSQL (IndexMethod ty) where renderSQL = renderIndexMethod
131+btree :: IndexMethod 'Btree
132+btree = UnsafeIndexMethod "btree"
133+hash :: IndexMethod 'Hash
134+hash = UnsafeIndexMethod "hash"
135+gist :: IndexMethod 'Gist
136+gist = UnsafeIndexMethod "gist"
137+spgist :: IndexMethod 'Spgist
138+spgist = UnsafeIndexMethod "spgist"
139+gin :: IndexMethod 'Gin
140+gin = UnsafeIndexMethod "gin"
141+brin :: IndexMethod 'Brin
142+brin = UnsafeIndexMethod "brin"
143+
144+-- |
145+-- >>> printSQL (dropIndex #ix :: Definition (Public '["ix" ::: 'Index 'Btree]) (Public '[]))
146+-- DROP INDEX "ix";
147+dropIndex
148+ :: (Has sch schemas schema, KnownSymbol ix)
149+ => QualifiedAlias sch ix
150+ -- ^ name of the user defined index
151+ -> Definition schemas (Alter sch (DropSchemum ix 'Index schema) schemas)
152+dropIndex ix = UnsafeDefinition $ "DROP" <+> "INDEX" <+> renderSQL ix <> ";"
153+
154+dropIndexIfExists
155+ :: (Has sch schemas schema, KnownSymbol ix)
156+ => QualifiedAlias sch ix
157+ -- ^ name of the user defined index
158+ -> Definition schemas (Alter sch (DropSchemumIfExists ix 'Index schema) schemas)
159+dropIndexIfExists ix = UnsafeDefinition $ "DROP INDEX IF EXISTS" <+> renderSQL ix <> ";"
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Schema.hsnew file+96
@@ -0,0 +1,96 @@
1+{-|
2+Module: Squeal.PostgreSQL.Definition.Schema
3+Description: Create and drop schema definitions
4+Copyright: (c) Eitan Chatav, 2017
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Create and drop schema definitions.
9+-}
10+
11+{-# LANGUAGE
12+ AllowAmbiguousTypes
13+ , ConstraintKinds
14+ , DeriveAnyClass
15+ , DeriveGeneric
16+ , DerivingStrategies
17+ , FlexibleContexts
18+ , FlexibleInstances
19+ , GADTs
20+ , LambdaCase
21+ , MultiParamTypeClasses
22+ , OverloadedLabels
23+ , OverloadedStrings
24+ , RankNTypes
25+ , ScopedTypeVariables
26+ , TypeApplications
27+ , TypeInType
28+ , TypeOperators
29+ , UndecidableSuperClasses
30+#-}
31+
32+module Squeal.PostgreSQL.Definition.Schema
33+ ( createSchema
34+ , createSchemaIfNotExists
35+ , dropSchema
36+ , dropSchemaIfExists
37+ ) where
38+
39+import GHC.TypeLits
40+
41+import Squeal.PostgreSQL.Alias
42+import Squeal.PostgreSQL.Definition
43+import Squeal.PostgreSQL.Render
44+import Squeal.PostgreSQL.Schema
45+
46+-- $setup
47+-- >>> import Squeal.PostgreSQL
48+
49+{- |
50+`createSchema` enters a new schema into the current database.
51+The schema name must be distinct from the name of any existing schema
52+in the current database.
53+
54+A schema is essentially a namespace: it contains named objects
55+(tables, data types, functions, and operators) whose names
56+can duplicate those of other objects existing in other schemas.
57+Named objects are accessed by `QualifiedAlias`es with the schema
58+name as a prefix.
59+-}
60+createSchema
61+ :: KnownSymbol sch
62+ => Alias sch
63+ -> Definition schemas (Create sch '[] schemas)
64+createSchema sch = UnsafeDefinition $
65+ "CREATE" <+> "SCHEMA" <+> renderSQL sch <> ";"
66+
67+{- | Idempotent version of `createSchema`. -}
68+createSchemaIfNotExists
69+ :: (KnownSymbol sch, Has sch schemas schema)
70+ => Alias sch
71+ -> Definition schemas (CreateIfNotExists sch '[] schemas)
72+createSchemaIfNotExists sch = UnsafeDefinition $
73+ "CREATE" <+> "SCHEMA" <+> "IF" <+> "NOT" <+> "EXISTS"
74+ <+> renderSQL sch <> ";"
75+
76+-- | >>> :{
77+-- let
78+-- definition :: Definition '["muh_schema" ::: schema, "public" ::: public] '["public" ::: public]
79+-- definition = dropSchema #muh_schema
80+-- :}
81+--
82+-- >>> printSQL definition
83+-- DROP SCHEMA "muh_schema";
84+dropSchema
85+ :: KnownSymbol sch
86+ => Alias sch
87+ -- ^ user defined schema
88+ -> Definition schemas (Drop sch schemas)
89+dropSchema sch = UnsafeDefinition $ "DROP SCHEMA" <+> renderSQL sch <> ";"
90+
91+dropSchemaIfExists
92+ :: KnownSymbol sch
93+ => Alias sch
94+ -- ^ user defined schema
95+ -> Definition schemas (DropIfExists sch schemas)
96+dropSchemaIfExists sch = UnsafeDefinition $ "DROP SCHEMA" <+> renderSQL sch <> ";"
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Table.hsnew file+500
@@ -0,0 +1,500 @@
1+{-|
2+Module: Squeal.PostgreSQL.Definition.Table
3+Description: Create, drop and alter table definitions
4+Copyright: (c) Eitan Chatav, 2017
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Create, drop and alter table definitions.
9+-}
10+
11+{-# LANGUAGE
12+ AllowAmbiguousTypes
13+ , ConstraintKinds
14+ , DeriveAnyClass
15+ , DeriveGeneric
16+ , DerivingStrategies
17+ , FlexibleContexts
18+ , FlexibleInstances
19+ , GADTs
20+ , LambdaCase
21+ , MultiParamTypeClasses
22+ , OverloadedLabels
23+ , OverloadedStrings
24+ , RankNTypes
25+ , ScopedTypeVariables
26+ , TypeApplications
27+ , TypeInType
28+ , TypeOperators
29+ , UndecidableSuperClasses
30+#-}
31+
32+module Squeal.PostgreSQL.Definition.Table
33+ ( createTable
34+ , createTableIfNotExists
35+ , dropTable
36+ , dropTableIfExists
37+ , alterTable
38+ , alterTableIfExists
39+ , alterTableRename
40+ , alterTableIfExistsRename
41+ , AlterTable (..)
42+ , addConstraint
43+ , dropConstraint
44+ , AddColumn (..)
45+ , dropColumn
46+ , renameColumn
47+ , alterColumn
48+ , AlterColumn (..)
49+ , setDefault
50+ , dropDefault
51+ , setNotNull
52+ , dropNotNull
53+ , alterType
54+ ) where
55+
56+import Control.DeepSeq
57+import Data.ByteString
58+import GHC.TypeLits
59+
60+import qualified Generics.SOP as SOP
61+import qualified GHC.Generics as GHC
62+
63+import Squeal.PostgreSQL.Alias
64+import Squeal.PostgreSQL.Definition
65+import Squeal.PostgreSQL.Definition.Table.Constraint
66+import Squeal.PostgreSQL.Expression
67+import Squeal.PostgreSQL.Expression.Type
68+import Squeal.PostgreSQL.List
69+import Squeal.PostgreSQL.Render
70+import Squeal.PostgreSQL.Schema
71+
72+-- $setup
73+-- >>> import Squeal.PostgreSQL
74+
75+{- | `createTable` adds a table to the schema.
76+
77+>>> :set -XOverloadedLabels
78+>>> :{
79+type Table = '[] :=>
80+ '[ "a" ::: 'NoDef :=> 'Null 'PGint4
81+ , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]
82+:}
83+
84+>>> :{
85+let
86+ setup :: Definition (Public '[]) (Public '["tab" ::: 'Table Table])
87+ setup = createTable #tab
88+ (nullable int `as` #a :* nullable real `as` #b) Nil
89+in printSQL setup
90+:}
91+CREATE TABLE "tab" ("a" int NULL, "b" real NULL);
92+-}
93+createTable
94+ :: ( KnownSymbol sch
95+ , KnownSymbol tab
96+ , columns ~ (col ': cols)
97+ , SOP.SListI columns
98+ , SOP.SListI constraints
99+ , Has sch schemas0 schema0
100+ , schemas1 ~ Alter sch (Create tab ('Table (constraints :=> columns)) schema0) schemas0 )
101+ => QualifiedAlias sch tab -- ^ the name of the table to add
102+ -> NP (Aliased (ColumnTypeExpression schemas0)) columns
103+ -- ^ the names and datatype of each column
104+ -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints
105+ -- ^ constraints that must hold for the table
106+ -> Definition schemas0 schemas1
107+createTable tab columns constraints = UnsafeDefinition $
108+ "CREATE TABLE" <+> renderCreation tab columns constraints
109+
110+{-| `createTableIfNotExists` creates a table if it doesn't exist, but does not add it to the schema.
111+Instead, the schema already has the table so if the table did not yet exist, the schema was wrong.
112+`createTableIfNotExists` fixes this. Interestingly, this property makes it an idempotent in
113+the `Category` of `Definition`s.
114+
115+>>> :set -XOverloadedLabels -XTypeApplications
116+>>> :{
117+type Table = '[] :=>
118+ '[ "a" ::: 'NoDef :=> 'Null 'PGint4
119+ , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]
120+:}
121+
122+>>> type Schemas = Public '["tab" ::: 'Table Table]
123+
124+>>> :{
125+let
126+ setup :: Definition Schemas Schemas
127+ setup = createTableIfNotExists #tab
128+ (nullable int `as` #a :* nullable real `as` #b) Nil
129+in printSQL setup
130+:}
131+CREATE TABLE IF NOT EXISTS "tab" ("a" int NULL, "b" real NULL);
132+-}
133+createTableIfNotExists
134+ :: ( KnownSymbol sch
135+ , KnownSymbol tab
136+ , columns ~ (col ': cols)
137+ , SOP.SListI columns
138+ , SOP.SListI constraints
139+ , Has sch schemas0 schema0
140+ , schemas1 ~ Alter sch (CreateIfNotExists tab ('Table (constraints :=> columns)) schema0) schemas0 )
141+ => QualifiedAlias sch tab -- ^ the name of the table to add
142+ -> NP (Aliased (ColumnTypeExpression schemas0)) columns
143+ -- ^ the names and datatype of each column
144+ -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints
145+ -- ^ constraints that must hold for the table
146+ -> Definition schemas0 schemas1
147+createTableIfNotExists tab columns constraints = UnsafeDefinition $
148+ "CREATE TABLE IF NOT EXISTS"
149+ <+> renderCreation tab columns constraints
150+
151+-- helper function for `createTable` and `createTableIfNotExists`
152+renderCreation
153+ :: ( KnownSymbol sch
154+ , KnownSymbol tab
155+ , SOP.SListI columns
156+ , SOP.SListI constraints )
157+ => QualifiedAlias sch tab -- ^ the name of the table to add
158+ -> NP (Aliased (ColumnTypeExpression schemas0)) columns
159+ -- ^ the names and datatype of each column
160+ -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints
161+ -- ^ constraints that must hold for the table
162+ -> ByteString
163+renderCreation tab columns constraints = renderSQL tab
164+ <+> parenthesized
165+ ( renderCommaSeparated renderColumnDef columns
166+ <> ( case constraints of
167+ Nil -> ""
168+ _ -> ", " <>
169+ renderCommaSeparated renderConstraint constraints ) )
170+ <> ";"
171+ where
172+ renderColumnDef :: Aliased (ColumnTypeExpression schemas) x -> ByteString
173+ renderColumnDef (ty `As` column) =
174+ renderSQL column <+> renderColumnTypeExpression ty
175+ renderConstraint
176+ :: Aliased (TableConstraintExpression sch tab schemas) constraint
177+ -> ByteString
178+ renderConstraint (constraint `As` alias) =
179+ "CONSTRAINT" <+> renderSQL alias <+> renderSQL constraint
180+
181+-- | `dropTable` removes a table from the schema.
182+--
183+-- >>> :{
184+-- let
185+-- definition :: Definition '["public" ::: '["muh_table" ::: 'Table t]] (Public '[])
186+-- definition = dropTable #muh_table
187+-- :}
188+--
189+-- >>> printSQL definition
190+-- DROP TABLE "muh_table";
191+dropTable
192+ :: ( Has sch schemas schema
193+ , KnownSymbol tab )
194+ => QualifiedAlias sch tab -- ^ table to remove
195+ -> Definition schemas (Alter sch (DropSchemum tab 'Table schema) schemas)
196+dropTable tab = UnsafeDefinition $ "DROP TABLE" <+> renderSQL tab <> ";"
197+
198+dropTableIfExists
199+ :: ( Has sch schemas schema
200+ , KnownSymbol tab)
201+ => QualifiedAlias sch tab -- ^ table to remove
202+ -> Definition schemas (Alter sch (DropSchemumIfExists tab 'Table schema) schemas)
203+dropTableIfExists tab = UnsafeDefinition $ "DROP TABLE IF EXISTS" <+> renderSQL tab <> ";"
204+
205+-- | `alterTable` changes the definition of a table from the schema.
206+alterTable
207+ :: (Has sch schemas schema, KnownSymbol tab)
208+ => QualifiedAlias sch tab -- ^ table to alter
209+ -> AlterTable sch tab schemas table -- ^ alteration to perform
210+ -> Definition schemas (Alter sch (Alter tab ('Table table) schema) schemas)
211+alterTable tab alteration = UnsafeDefinition $
212+ "ALTER TABLE"
213+ <+> renderSQL tab
214+ <+> renderAlterTable alteration
215+ <> ";"
216+
217+-- | `alterTable` changes the definition of a table from the schema.
218+alterTableIfExists
219+ :: (Has sch schemas schema, KnownSymbol tab)
220+ => QualifiedAlias sch tab -- ^ table to alter
221+ -> AlterTable sch tab schemas table -- ^ alteration to perform
222+ -> Definition schemas (Alter sch (AlterIfExists tab ('Table table) schema) schemas)
223+alterTableIfExists tab alteration = UnsafeDefinition $
224+ "ALTER TABLE IF EXISTS"
225+ <+> renderSQL tab
226+ <+> renderAlterTable alteration
227+ <> ";"
228+
229+-- | `alterTableRename` changes the name of a table from the schema.
230+--
231+-- >>> printSQL $ alterTableRename #foo #bar
232+-- ALTER TABLE "foo" RENAME TO "bar";
233+alterTableRename
234+ :: (KnownSymbol tab0, KnownSymbol tab1)
235+ => Alias tab0 -- ^ table to rename
236+ -> Alias tab1 -- ^ what to rename it
237+ -> Definition schema (Rename tab0 tab1 schema)
238+alterTableRename tab0 tab1 = UnsafeDefinition $
239+ "ALTER TABLE" <+> renderSQL tab0
240+ <+> "RENAME TO" <+> renderSQL tab1 <> ";"
241+
242+alterTableIfExistsRename
243+ :: (KnownSymbol tab0, KnownSymbol tab1)
244+ => Alias tab0 -- ^ table to rename
245+ -> Alias tab1 -- ^ what to rename it
246+ -> Definition schema (RenameIfExists tab0 tab1 schema)
247+alterTableIfExistsRename tab0 tab1 = UnsafeDefinition $
248+ "ALTER TABLE IF EXISTS" <+> renderSQL tab0
249+ <+> "RENAME TO" <+> renderSQL tab1 <> ";"
250+
251+-- | An `AlterTable` describes the alteration to perform on the columns
252+-- of a table.
253+newtype AlterTable
254+ (sch :: Symbol)
255+ (tab :: Symbol)
256+ (schemas :: SchemasType)
257+ (table :: TableType) =
258+ UnsafeAlterTable {renderAlterTable :: ByteString}
259+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
260+
261+-- | An `addConstraint` adds a table constraint.
262+--
263+-- >>> :{
264+-- let
265+-- definition :: Definition
266+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
267+-- '["public" ::: '["tab" ::: 'Table ('["positive" ::: 'Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
268+-- definition = alterTable #tab (addConstraint #positive (check #col (#col .> 0)))
269+-- in printSQL definition
270+-- :}
271+-- ALTER TABLE "tab" ADD CONSTRAINT "positive" CHECK (("col" > 0));
272+addConstraint
273+ :: ( KnownSymbol alias
274+ , Has sch schemas schema
275+ , Has tab schema ('Table table0)
276+ , table0 ~ (constraints :=> columns)
277+ , table1 ~ (Create alias constraint constraints :=> columns) )
278+ => Alias alias
279+ -> TableConstraintExpression sch tab schemas constraint
280+ -- ^ constraint to add
281+ -> AlterTable sch tab schemas table1
282+addConstraint alias constraint = UnsafeAlterTable $
283+ "ADD" <+> "CONSTRAINT" <+> renderSQL alias
284+ <+> renderSQL constraint
285+
286+-- | A `dropConstraint` drops a table constraint.
287+--
288+-- >>> :{
289+-- let
290+-- definition :: Definition
291+-- '["public" ::: '["tab" ::: 'Table ('["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
292+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
293+-- definition = alterTable #tab (dropConstraint #positive)
294+-- in printSQL definition
295+-- :}
296+-- ALTER TABLE "tab" DROP CONSTRAINT "positive";
297+dropConstraint
298+ :: ( KnownSymbol constraint
299+ , Has sch schemas schema
300+ , Has tab schema ('Table table0)
301+ , table0 ~ (constraints :=> columns)
302+ , table1 ~ (Drop constraint constraints :=> columns) )
303+ => Alias constraint
304+ -- ^ constraint to drop
305+ -> AlterTable sch tab schemas table1
306+dropConstraint constraint = UnsafeAlterTable $
307+ "DROP" <+> "CONSTRAINT" <+> renderSQL constraint
308+
309+-- | An `AddColumn` is either @NULL@ or has @DEFAULT@.
310+class AddColumn ty where
311+ -- | `addColumn` adds a new column, initially filled with whatever
312+ -- default value is given or with @NULL@.
313+ --
314+ -- >>> :{
315+ -- let
316+ -- definition :: Definition
317+ -- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]
318+ -- '["public" ::: '["tab" ::: 'Table ('[] :=>
319+ -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
320+ -- , "col2" ::: 'Def :=> 'Null 'PGtext ])]]
321+ -- definition = alterTable #tab (addColumn #col2 (text & nullable & default_ "foo"))
322+ -- in printSQL definition
323+ -- :}
324+ -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL DEFAULT E'foo';
325+ --
326+ -- >>> :{
327+ -- let
328+ -- definition :: Definition
329+ -- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]
330+ -- '["public" ::: '["tab" ::: 'Table ('[] :=>
331+ -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
332+ -- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]]
333+ -- definition = alterTable #tab (addColumn #col2 (text & nullable))
334+ -- in printSQL definition
335+ -- :}
336+ -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL;
337+ addColumn
338+ :: ( KnownSymbol column
339+ , Has sch schemas schema
340+ , Has tab schema ('Table table0)
341+ , table0 ~ (constraints :=> columns) )
342+ => Alias column -- ^ column to add
343+ -> ColumnTypeExpression schemas ty -- ^ type of the new column
344+ -> AlterTable sch tab schemas (constraints :=> Create column ty columns)
345+ addColumn column ty = UnsafeAlterTable $
346+ "ADD COLUMN" <+> renderSQL column <+> renderColumnTypeExpression ty
347+instance {-# OVERLAPPING #-} AddColumn ('Def :=> ty)
348+instance {-# OVERLAPPABLE #-} AddColumn ('NoDef :=> 'Null ty)
349+
350+-- | A `dropColumn` removes a column. Whatever data was in the column
351+-- disappears. Table constraints involving the column are dropped, too.
352+-- However, if the column is referenced by a foreign key constraint of
353+-- another table, PostgreSQL will not silently drop that constraint.
354+--
355+-- >>> :{
356+-- let
357+-- definition :: Definition
358+-- '["public" ::: '["tab" ::: 'Table ('[] :=>
359+-- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
360+-- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]]
361+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]
362+-- definition = alterTable #tab (dropColumn #col2)
363+-- in printSQL definition
364+-- :}
365+-- ALTER TABLE "tab" DROP COLUMN "col2";
366+dropColumn
367+ :: ( KnownSymbol column
368+ , Has sch schemas schema
369+ , Has tab schema ('Table table0)
370+ , table0 ~ (constraints :=> columns)
371+ , table1 ~ (constraints :=> Drop column columns) )
372+ => Alias column -- ^ column to remove
373+ -> AlterTable sch tab schemas table1
374+dropColumn column = UnsafeAlterTable $
375+ "DROP COLUMN" <+> renderSQL column
376+
377+-- | A `renameColumn` renames a column.
378+--
379+-- >>> :{
380+-- let
381+-- definition :: Definition
382+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["foo" ::: 'NoDef :=> 'Null 'PGint4])]]
383+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["bar" ::: 'NoDef :=> 'Null 'PGint4])]]
384+-- definition = alterTable #tab (renameColumn #foo #bar)
385+-- in printSQL definition
386+-- :}
387+-- ALTER TABLE "tab" RENAME COLUMN "foo" TO "bar";
388+renameColumn
389+ :: ( KnownSymbol column0
390+ , KnownSymbol column1
391+ , Has sch schemas schema
392+ , Has tab schema ('Table table0)
393+ , table0 ~ (constraints :=> columns)
394+ , table1 ~ (constraints :=> Rename column0 column1 columns) )
395+ => Alias column0 -- ^ column to rename
396+ -> Alias column1 -- ^ what to rename the column
397+ -> AlterTable sch tab schemas table1
398+renameColumn column0 column1 = UnsafeAlterTable $
399+ "RENAME COLUMN" <+> renderSQL column0 <+> "TO" <+> renderSQL column1
400+
401+-- | An `alterColumn` alters a single column.
402+alterColumn
403+ :: ( KnownSymbol column
404+ , Has sch schemas schema
405+ , Has tab schema ('Table table0)
406+ , table0 ~ (constraints :=> columns)
407+ , Has column columns ty0
408+ , table1 ~ (constraints :=> Alter column ty1 columns))
409+ => Alias column -- ^ column to alter
410+ -> AlterColumn schemas ty0 ty1 -- ^ alteration to perform
411+ -> AlterTable sch tab schemas table1
412+alterColumn column alteration = UnsafeAlterTable $
413+ "ALTER COLUMN" <+> renderSQL column <+> renderAlterColumn alteration
414+
415+-- | An `AlterColumn` describes the alteration to perform on a single column.
416+newtype AlterColumn (schemas :: SchemasType) (ty0 :: ColumnType) (ty1 :: ColumnType) =
417+ UnsafeAlterColumn {renderAlterColumn :: ByteString}
418+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
419+
420+-- | A `setDefault` sets a new default for a column. Note that this doesn't
421+-- affect any existing rows in the table, it just changes the default for
422+-- future insert and update commands.
423+--
424+-- >>> :{
425+-- let
426+-- definition :: Definition
427+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
428+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]]
429+-- definition = alterTable #tab (alterColumn #col (setDefault 5))
430+-- in printSQL definition
431+-- :}
432+-- ALTER TABLE "tab" ALTER COLUMN "col" SET DEFAULT 5;
433+setDefault
434+ :: Expression '[] '[] 'Ungrouped schemas '[] '[] ty -- ^ default value to set
435+ -> AlterColumn schemas (constraint :=> ty) ('Def :=> ty)
436+setDefault expression = UnsafeAlterColumn $
437+ "SET DEFAULT" <+> renderExpression expression
438+
439+-- | A `dropDefault` removes any default value for a column.
440+--
441+-- >>> :{
442+-- let
443+-- definition :: Definition
444+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]]
445+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
446+-- definition = alterTable #tab (alterColumn #col dropDefault)
447+-- in printSQL definition
448+-- :}
449+-- ALTER TABLE "tab" ALTER COLUMN "col" DROP DEFAULT;
450+dropDefault :: AlterColumn schemas ('Def :=> ty) ('NoDef :=> ty)
451+dropDefault = UnsafeAlterColumn $ "DROP DEFAULT"
452+
453+-- | A `setNotNull` adds a @NOT NULL@ constraint to a column.
454+-- The constraint will be checked immediately, so the table data must satisfy
455+-- the constraint before it can be added.
456+--
457+-- >>> :{
458+-- let
459+-- definition :: Definition
460+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
461+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
462+-- definition = alterTable #tab (alterColumn #col setNotNull)
463+-- in printSQL definition
464+-- :}
465+-- ALTER TABLE "tab" ALTER COLUMN "col" SET NOT NULL;
466+setNotNull
467+ :: AlterColumn schemas (constraint :=> 'Null ty) (constraint :=> 'NotNull ty)
468+setNotNull = UnsafeAlterColumn $ "SET NOT NULL"
469+
470+-- | A `dropNotNull` drops a @NOT NULL@ constraint from a column.
471+--
472+-- >>> :{
473+-- let
474+-- definition :: Definition
475+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
476+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
477+-- definition = alterTable #tab (alterColumn #col dropNotNull)
478+-- in printSQL definition
479+-- :}
480+-- ALTER TABLE "tab" ALTER COLUMN "col" DROP NOT NULL;
481+dropNotNull
482+ :: AlterColumn schemas (constraint :=> 'NotNull ty) (constraint :=> 'Null ty)
483+dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL"
484+
485+-- | An `alterType` converts a column to a different data type.
486+-- This will succeed only if each existing entry in the column can be
487+-- converted to the new type by an implicit cast.
488+--
489+-- >>> :{
490+-- let
491+-- definition :: Definition
492+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
493+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGnumeric])]]
494+-- definition =
495+-- alterTable #tab (alterColumn #col (alterType (numeric & notNullable)))
496+-- in printSQL definition
497+-- :}
498+-- ALTER TABLE "tab" ALTER COLUMN "col" TYPE numeric NOT NULL;
499+alterType :: ColumnTypeExpression schemas ty -> AlterColumn schemas ty0 ty
500+alterType ty = UnsafeAlterColumn $ "TYPE" <+> renderColumnTypeExpression ty
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Table/Constraint.hsnew file+339
@@ -0,0 +1,339 @@
1+{-|
2+Module: Squeal.PostgreSQL.Definition.Table.Constraint
3+Description: Table constraint expressions
4+Copyright: (c) Eitan Chatav, 2017
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Table constraint expressions.
9+-}
10+
11+{-# LANGUAGE
12+ AllowAmbiguousTypes
13+ , ConstraintKinds
14+ , DeriveAnyClass
15+ , DeriveGeneric
16+ , DerivingStrategies
17+ , FlexibleContexts
18+ , FlexibleInstances
19+ , GADTs
20+ , LambdaCase
21+ , MultiParamTypeClasses
22+ , OverloadedLabels
23+ , OverloadedStrings
24+ , RankNTypes
25+ , ScopedTypeVariables
26+ , TypeApplications
27+ , TypeInType
28+ , TypeOperators
29+ , UndecidableSuperClasses
30+#-}
31+
32+module Squeal.PostgreSQL.Definition.Table.Constraint
33+ ( TableConstraintExpression (..)
34+ , check
35+ , unique
36+ , primaryKey
37+ , foreignKey
38+ , ForeignKeyed
39+ , OnDeleteClause (..)
40+ , OnUpdateClause (..)
41+ ) where
42+
43+import Control.DeepSeq
44+import Data.ByteString
45+import GHC.TypeLits
46+
47+import qualified Generics.SOP as SOP
48+import qualified GHC.Generics as GHC
49+
50+import Squeal.PostgreSQL.Alias
51+import Squeal.PostgreSQL.Expression.Logic
52+import Squeal.PostgreSQL.List
53+import Squeal.PostgreSQL.Render
54+import Squeal.PostgreSQL.Schema
55+
56+-- $setup
57+-- >>> import Squeal.PostgreSQL
58+
59+-- | Data types are a way to limit the kind of data that can be stored in a
60+-- table. For many applications, however, the constraint they provide is
61+-- too coarse. For example, a column containing a product price should
62+-- probably only accept positive values. But there is no standard data type
63+-- that accepts only positive numbers. Another issue is that you might want
64+-- to constrain column data with respect to other columns or rows.
65+-- For example, in a table containing product information,
66+-- there should be only one row for each product number.
67+-- `TableConstraint`s give you as much control over the data in your tables
68+-- as you wish. If a user attempts to store data in a column that would
69+-- violate a constraint, an error is raised. This applies
70+-- even if the value came from the default value definition.
71+newtype TableConstraintExpression
72+ (sch :: Symbol)
73+ (tab :: Symbol)
74+ (schemas :: SchemasType)
75+ (constraint :: TableConstraint)
76+ = UnsafeTableConstraintExpression
77+ { renderTableConstraintExpression :: ByteString }
78+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
79+instance RenderSQL
80+ (TableConstraintExpression sch tab schemas constraint) where
81+ renderSQL = renderTableConstraintExpression
82+
83+{-| A `check` constraint is the most generic `TableConstraint` type.
84+It allows you to specify that the value in a certain column must satisfy
85+a Boolean (truth-value) expression.
86+
87+>>> :{
88+type Schema = '[
89+ "tab" ::: 'Table ('[ "inequality" ::: 'Check '["a","b"]] :=> '[
90+ "a" ::: 'NoDef :=> 'NotNull 'PGint4,
91+ "b" ::: 'NoDef :=> 'NotNull 'PGint4
92+ ])]
93+:}
94+
95+>>> :{
96+let
97+ definition :: Definition (Public '[]) (Public Schema)
98+ definition = createTable #tab
99+ ( (int & notNullable) `as` #a :*
100+ (int & notNullable) `as` #b )
101+ ( check (#a :* #b) (#a .> #b) `as` #inequality )
102+:}
103+
104+>>> printSQL definition
105+CREATE TABLE "tab" ("a" int NOT NULL, "b" int NOT NULL, CONSTRAINT "inequality" CHECK (("a" > "b")));
106+-}
107+check
108+ :: ( Has sch schemas schema
109+ , Has tab schema ('Table table)
110+ , HasAll aliases (TableToRow table) subcolumns )
111+ => NP Alias aliases
112+ -- ^ specify the subcolumns which are getting checked
113+ -> (forall t. Condition '[] '[] 'Ungrouped schemas '[] '[t ::: subcolumns])
114+ -- ^ a closed `Condition` on those subcolumns
115+ -> TableConstraintExpression sch tab schemas ('Check aliases)
116+check _cols condition = UnsafeTableConstraintExpression $
117+ "CHECK" <+> parenthesized (renderSQL condition)
118+
119+{-| A `unique` constraint ensure that the data contained in a column,
120+or a group of columns, is unique among all the rows in the table.
121+
122+>>> :{
123+type Schema = '[
124+ "tab" ::: 'Table( '[ "uq_a_b" ::: 'Unique '["a","b"]] :=> '[
125+ "a" ::: 'NoDef :=> 'Null 'PGint4,
126+ "b" ::: 'NoDef :=> 'Null 'PGint4
127+ ])]
128+:}
129+
130+>>> :{
131+let
132+ definition :: Definition (Public '[]) (Public Schema)
133+ definition = createTable #tab
134+ ( (int & nullable) `as` #a :*
135+ (int & nullable) `as` #b )
136+ ( unique (#a :* #b) `as` #uq_a_b )
137+:}
138+
139+>>> printSQL definition
140+CREATE TABLE "tab" ("a" int NULL, "b" int NULL, CONSTRAINT "uq_a_b" UNIQUE ("a", "b"));
141+-}
142+unique
143+ :: ( Has sch schemas schema
144+ , Has tab schema('Table table)
145+ , HasAll aliases (TableToRow table) subcolumns )
146+ => NP Alias aliases
147+ -- ^ specify subcolumns which together are unique for each row
148+ -> TableConstraintExpression sch tab schemas ('Unique aliases)
149+unique columns = UnsafeTableConstraintExpression $
150+ "UNIQUE" <+> parenthesized (renderSQL columns)
151+
152+{-| A `primaryKey` constraint indicates that a column, or group of columns,
153+can be used as a unique identifier for rows in the table.
154+This requires that the values be both unique and not null.
155+
156+>>> :{
157+type Schema = '[
158+ "tab" ::: 'Table ('[ "pk_id" ::: 'PrimaryKey '["id"]] :=> '[
159+ "id" ::: 'Def :=> 'NotNull 'PGint4,
160+ "name" ::: 'NoDef :=> 'NotNull 'PGtext
161+ ])]
162+:}
163+
164+>>> :{
165+let
166+ definition :: Definition (Public '[]) (Public Schema)
167+ definition = createTable #tab
168+ ( serial `as` #id :*
169+ (text & notNullable) `as` #name )
170+ ( primaryKey #id `as` #pk_id )
171+:}
172+
173+>>> printSQL definition
174+CREATE TABLE "tab" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_id" PRIMARY KEY ("id"));
175+-}
176+primaryKey
177+ :: ( Has sch schemas schema
178+ , Has tab schema ('Table table)
179+ , HasAll aliases (TableToColumns table) subcolumns
180+ , AllNotNull subcolumns )
181+ => NP Alias aliases
182+ -- ^ specify the subcolumns which together form a primary key.
183+ -> TableConstraintExpression sch tab schemas ('PrimaryKey aliases)
184+primaryKey columns = UnsafeTableConstraintExpression $
185+ "PRIMARY KEY" <+> parenthesized (renderSQL columns)
186+
187+{-| A `foreignKey` specifies that the values in a column
188+(or a group of columns) must match the values appearing in some row of
189+another table. We say this maintains the referential integrity
190+between two related tables.
191+
192+>>> :{
193+type Schema =
194+ '[ "users" ::: 'Table (
195+ '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
196+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
197+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext
198+ ])
199+ , "emails" ::: 'Table (
200+ '[ "pk_emails" ::: 'PrimaryKey '["id"]
201+ , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
202+ ] :=>
203+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
204+ , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
205+ , "email" ::: 'NoDef :=> 'Null 'PGtext
206+ ])
207+ ]
208+:}
209+
210+>>> :{
211+let
212+ setup :: Definition (Public '[]) (Public Schema)
213+ setup =
214+ createTable #users
215+ ( serial `as` #id :*
216+ (text & notNullable) `as` #name )
217+ ( primaryKey #id `as` #pk_users ) >>>
218+ createTable #emails
219+ ( serial `as` #id :*
220+ (int & notNullable) `as` #user_id :*
221+ (text & nullable) `as` #email )
222+ ( primaryKey #id `as` #pk_emails :*
223+ foreignKey #user_id #users #id
224+ OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
225+in printSQL setup
226+:}
227+CREATE TABLE "users" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_users" PRIMARY KEY ("id"));
228+CREATE TABLE "emails" ("id" serial, "user_id" int NOT NULL, "email" text NULL, CONSTRAINT "pk_emails" PRIMARY KEY ("id"), CONSTRAINT "fk_user_id" FOREIGN KEY ("user_id") REFERENCES "users" ("id") ON DELETE CASCADE ON UPDATE CASCADE);
229+
230+A `foreignKey` can even be a table self-reference.
231+
232+>>> :{
233+type Schema =
234+ '[ "employees" ::: 'Table (
235+ '[ "employees_pk" ::: 'PrimaryKey '["id"]
236+ , "employees_employer_fk" ::: 'ForeignKey '["employer_id"] "employees" '["id"]
237+ ] :=>
238+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
239+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext
240+ , "employer_id" ::: 'NoDef :=> 'Null 'PGint4
241+ ])
242+ ]
243+:}
244+
245+>>> :{
246+let
247+ setup :: Definition (Public '[]) (Public Schema)
248+ setup =
249+ createTable #employees
250+ ( serial `as` #id :*
251+ (text & notNullable) `as` #name :*
252+ (integer & nullable) `as` #employer_id )
253+ ( primaryKey #id `as` #employees_pk :*
254+ foreignKey #employer_id #employees #id
255+ OnDeleteCascade OnUpdateCascade `as` #employees_employer_fk )
256+in printSQL setup
257+:}
258+CREATE TABLE "employees" ("id" serial, "name" text NOT NULL, "employer_id" integer NULL, CONSTRAINT "employees_pk" PRIMARY KEY ("id"), CONSTRAINT "employees_employer_fk" FOREIGN KEY ("employer_id") REFERENCES "employees" ("id") ON DELETE CASCADE ON UPDATE CASCADE);
259+-}
260+foreignKey
261+ :: (ForeignKeyed schemas sch schema child parent
262+ table reftable
263+ columns refcolumns
264+ constraints cols
265+ reftys tys )
266+ => NP Alias columns
267+ -- ^ column or columns in the table
268+ -> Alias parent
269+ -- ^ reference table
270+ -> NP Alias refcolumns
271+ -- ^ reference column or columns in the reference table
272+ -> OnDeleteClause
273+ -- ^ what to do when reference is deleted
274+ -> OnUpdateClause
275+ -- ^ what to do when reference is updated
276+ -> TableConstraintExpression sch child schemas
277+ ('ForeignKey columns parent refcolumns)
278+foreignKey keys parent refs ondel onupd = UnsafeTableConstraintExpression $
279+ "FOREIGN KEY" <+> parenthesized (renderSQL keys)
280+ <+> "REFERENCES" <+> renderSQL parent
281+ <+> parenthesized (renderSQL refs)
282+ <+> renderSQL ondel
283+ <+> renderSQL onupd
284+
285+-- | A constraint synonym between types involved in a foreign key constraint.
286+type ForeignKeyed schemas
287+ sch
288+ schema
289+ child parent
290+ table reftable
291+ columns refcolumns
292+ constraints cols
293+ reftys tys =
294+ ( Has sch schemas schema
295+ , Has child schema ('Table table)
296+ , Has parent schema ('Table reftable)
297+ , HasAll columns (TableToColumns table) tys
298+ , reftable ~ (constraints :=> cols)
299+ , HasAll refcolumns cols reftys
300+ , SOP.AllZip SamePGType tys reftys
301+ , Uniquely refcolumns constraints )
302+
303+-- | `OnDeleteClause` indicates what to do with rows that reference a deleted row.
304+data OnDeleteClause
305+ = OnDeleteNoAction
306+ -- ^ if any referencing rows still exist when the constraint is checked,
307+ -- an error is raised
308+ | OnDeleteRestrict -- ^ prevents deletion of a referenced row
309+ | OnDeleteCascade
310+ -- ^ specifies that when a referenced row is deleted,
311+ -- row(s) referencing it should be automatically deleted as well
312+ deriving (GHC.Generic,Show,Eq,Ord)
313+instance NFData OnDeleteClause
314+-- | Render `OnDeleteClause`.
315+instance RenderSQL OnDeleteClause where
316+ renderSQL = \case
317+ OnDeleteNoAction -> "ON DELETE NO ACTION"
318+ OnDeleteRestrict -> "ON DELETE RESTRICT"
319+ OnDeleteCascade -> "ON DELETE CASCADE"
320+
321+-- | Analagous to `OnDeleteClause` there is also `OnUpdateClause` which is invoked
322+-- when a referenced column is changed (updated).
323+data OnUpdateClause
324+ = OnUpdateNoAction
325+ -- ^ if any referencing rows has not changed when the constraint is checked,
326+ -- an error is raised
327+ | OnUpdateRestrict -- ^ prevents update of a referenced row
328+ | OnUpdateCascade
329+ -- ^ the updated values of the referenced column(s) should be copied
330+ -- into the referencing row(s)
331+ deriving (GHC.Generic,Show,Eq,Ord)
332+instance NFData OnUpdateClause
333+
334+-- | Render `OnUpdateClause`.
335+instance RenderSQL OnUpdateClause where
336+ renderSQL = \case
337+ OnUpdateNoAction -> "ON UPDATE NO ACTION"
338+ OnUpdateRestrict -> "ON UPDATE RESTRICT"
339+ OnUpdateCascade -> "ON UPDATE CASCADE"
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Type.hsnew file+229
@@ -0,0 +1,229 @@
1+{-|
2+Module: Squeal.PostgreSQL.Definition.Type
3+Description: Create and drop type definitions
4+Copyright: (c) Eitan Chatav, 2017
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Create and drop type definitions.
9+-}
10+
11+{-# LANGUAGE
12+ AllowAmbiguousTypes
13+ , ConstraintKinds
14+ , DeriveAnyClass
15+ , DeriveGeneric
16+ , DerivingStrategies
17+ , FlexibleContexts
18+ , FlexibleInstances
19+ , GADTs
20+ , LambdaCase
21+ , MultiParamTypeClasses
22+ , OverloadedLabels
23+ , OverloadedStrings
24+ , RankNTypes
25+ , ScopedTypeVariables
26+ , TypeApplications
27+ , TypeInType
28+ , TypeOperators
29+ , UndecidableSuperClasses
30+#-}
31+
32+module Squeal.PostgreSQL.Definition.Type
33+ ( createTypeEnum
34+ , createTypeEnumFrom
35+ , createTypeComposite
36+ , createTypeCompositeFrom
37+ , createTypeRange
38+ , createDomain
39+ , dropType
40+ , dropTypeIfExists
41+ ) where
42+
43+import Data.ByteString
44+import Data.Monoid
45+import GHC.TypeLits
46+import Prelude hiding ((.), id)
47+
48+import qualified Generics.SOP as SOP
49+
50+import Squeal.PostgreSQL.Alias
51+import Squeal.PostgreSQL.Expression.Logic
52+import Squeal.PostgreSQL.Expression.Type
53+import Squeal.PostgreSQL.Definition
54+import Squeal.PostgreSQL.List
55+import Squeal.PostgreSQL.PG
56+import Squeal.PostgreSQL.Render
57+import Squeal.PostgreSQL.Schema
58+
59+-- $setup
60+-- >>> import Squeal.PostgreSQL
61+-- >>> import qualified GHC.Generics as GHC
62+-- >>> import qualified Generics.SOP as SOP
63+
64+-- | Enumerated types are created using the `createTypeEnum` command, for example
65+--
66+-- >>> printSQL $ (createTypeEnum #mood (label @"sad" :* label @"ok" :* label @"happy") :: Definition (Public '[]) '["public" ::: '["mood" ::: 'Typedef ('PGenum '["sad","ok","happy"])]])
67+-- CREATE TYPE "mood" AS ENUM ('sad', 'ok', 'happy');
68+createTypeEnum
69+ :: (KnownSymbol enum, Has sch schemas schema, SOP.All KnownSymbol labels)
70+ => QualifiedAlias sch enum
71+ -- ^ name of the user defined enumerated type
72+ -> NP PGlabel labels
73+ -- ^ labels of the enumerated type
74+ -> Definition schemas (Alter sch (Create enum ('Typedef ('PGenum labels)) schema) schemas)
75+createTypeEnum enum labels = UnsafeDefinition $
76+ "CREATE" <+> "TYPE" <+> renderSQL enum <+> "AS" <+> "ENUM" <+>
77+ parenthesized (renderSQL labels) <> ";"
78+
79+-- | Enumerated types can also be generated from a Haskell type, for example
80+--
81+-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic
82+-- >>> instance SOP.Generic Schwarma
83+-- >>> instance SOP.HasDatatypeInfo Schwarma
84+-- >>> :{
85+-- let
86+-- createSchwarma :: Definition (Public '[]) '["public" ::: '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))]]
87+-- createSchwarma = createTypeEnumFrom @Schwarma #schwarma
88+-- in
89+-- printSQL createSchwarma
90+-- :}
91+-- CREATE TYPE "schwarma" AS ENUM ('Beef', 'Lamb', 'Chicken');
92+createTypeEnumFrom
93+ :: forall hask sch enum schemas schema.
94+ ( SOP.Generic hask
95+ , SOP.All KnownSymbol (LabelsPG hask)
96+ , KnownSymbol enum
97+ , Has sch schemas schema )
98+ => QualifiedAlias sch enum
99+ -- ^ name of the user defined enumerated type
100+ -> Definition schemas (Alter sch (Create enum ('Typedef (PG (Enumerated hask))) schema) schemas)
101+createTypeEnumFrom enum = createTypeEnum enum
102+ (SOP.hpure label :: NP PGlabel (LabelsPG hask))
103+
104+{- | `createTypeComposite` creates a composite type. The composite type is
105+specified by a list of attribute names and data types.
106+
107+>>> :{
108+type PGcomplex = 'PGcomposite
109+ '[ "real" ::: 'NotNull 'PGfloat8
110+ , "imaginary" ::: 'NotNull 'PGfloat8 ]
111+:}
112+
113+>>> :{
114+let
115+ setup :: Definition (Public '[]) '["public" ::: '["complex" ::: 'Typedef PGcomplex]]
116+ setup = createTypeComposite #complex
117+ (float8 `as` #real :* float8 `as` #imaginary)
118+in printSQL setup
119+:}
120+CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);
121+-}
122+createTypeComposite
123+ :: (KnownSymbol ty, Has sch schemas schema, SOP.SListI fields)
124+ => QualifiedAlias sch ty
125+ -- ^ name of the user defined composite type
126+ -> NP (Aliased (TypeExpression schemas)) fields
127+ -- ^ list of attribute names and data types
128+ -> Definition schemas (Alter sch (Create ty ('Typedef ('PGcomposite fields)) schema) schemas)
129+createTypeComposite ty fields = UnsafeDefinition $
130+ "CREATE" <+> "TYPE" <+> renderSQL ty <+> "AS" <+> parenthesized
131+ (renderCommaSeparated renderField fields) <> ";"
132+ where
133+ renderField :: Aliased (TypeExpression schemas) x -> ByteString
134+ renderField (typ `As` alias) =
135+ renderSQL alias <+> renderSQL typ
136+
137+-- | Composite types can also be generated from a Haskell type, for example
138+--
139+-- >>> data Complex = Complex {real :: Double, imaginary :: Double} deriving GHC.Generic
140+-- >>> instance SOP.Generic Complex
141+-- >>> instance SOP.HasDatatypeInfo Complex
142+-- >>> type Schema = '["complex" ::: 'Typedef (PG (Composite Complex))]
143+-- >>> :{
144+-- let
145+-- createComplex :: Definition (Public '[]) (Public Schema)
146+-- createComplex = createTypeCompositeFrom @Complex #complex
147+-- in
148+-- printSQL createComplex
149+-- :}
150+-- CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);
151+createTypeCompositeFrom
152+ :: forall hask sch ty schemas schema.
153+ ( SOP.All (FieldTyped schemas) (RowPG hask)
154+ , KnownSymbol ty
155+ , Has sch schemas schema )
156+ => QualifiedAlias sch ty
157+ -- ^ name of the user defined composite type
158+ -> Definition schemas (Alter sch (Create ty ( 'Typedef (PG (Composite hask))) schema) schemas)
159+createTypeCompositeFrom ty = createTypeComposite ty
160+ (SOP.hcpure (SOP.Proxy :: SOP.Proxy (FieldTyped schemas)) fieldtype
161+ :: NP (Aliased (TypeExpression schemas)) (RowPG hask))
162+
163+{-|
164+`createDomain` creates a new domain. A domain is essentially a data type
165+with constraints (restrictions on the allowed set of values).
166+
167+Domains are useful for abstracting common constraints on fields
168+into a single location for maintenance. For example, several tables might
169+contain email address columns, all requiring the same `check` constraint
170+to verify the address syntax. Define a domain rather than setting up
171+each table's constraint individually.
172+
173+>>> :{
174+let
175+ createPositive :: Definition (Public '[]) (Public '["positive" ::: 'Typedef 'PGfloat4])
176+ createPositive = createDomain #positive real (#value .> 0 .&& (#value & isNotNull))
177+in printSQL createPositive
178+:}
179+CREATE DOMAIN "positive" AS real CHECK ((("value" > 0) AND "value" IS NOT NULL));
180+-}
181+createDomain
182+ :: (Has sch schemas schema, KnownSymbol dom)
183+ => QualifiedAlias sch dom
184+ -> (forall null. TypeExpression schemas (null ty))
185+ -> (forall tab. Condition '[] '[] 'Ungrouped schemas '[] '[tab ::: '["value" ::: 'Null ty]])
186+ -> Definition schemas (Alter sch (Create dom ('Typedef ty) schema) schemas)
187+createDomain dom ty condition =
188+ UnsafeDefinition $ "CREATE DOMAIN" <+> renderSQL dom
189+ <+> "AS" <+> renderTypeExpression ty
190+ <+> "CHECK" <+> parenthesized (renderSQL condition) <> ";"
191+
192+{- |
193+>>> :{
194+let
195+ createSmallIntRange :: Definition (Public '[]) (Public '["int2range" ::: 'Typedef ('PGrange 'PGint2)])
196+ createSmallIntRange = createTypeRange #int2range int2
197+in printSQL createSmallIntRange
198+:}
199+CREATE TYPE "int2range" AS RANGE (subtype = int2);
200+-}
201+createTypeRange
202+ :: (Has sch schemas schema, KnownSymbol range)
203+ => QualifiedAlias sch range
204+ -> (forall null. TypeExpression schemas (null ty))
205+ -> Definition schemas (Alter sch (Create range ('Typedef ('PGrange ty)) schema) schemas)
206+createTypeRange range ty = UnsafeDefinition $
207+ "CREATE" <+> "TYPE" <+> renderSQL range <+> "AS" <+> "RANGE" <+>
208+ parenthesized ("subtype" <+> "=" <+> renderTypeExpression ty) <> ";"
209+
210+-- | Drop a type.
211+--
212+-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic
213+-- >>> instance SOP.Generic Schwarma
214+-- >>> instance SOP.HasDatatypeInfo Schwarma
215+-- >>> printSQL (dropType #schwarma :: Definition '["public" ::: '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))]] (Public '[]))
216+-- DROP TYPE "schwarma";
217+dropType
218+ :: (Has sch schemas schema, KnownSymbol td)
219+ => QualifiedAlias sch td
220+ -- ^ name of the user defined type
221+ -> Definition schemas (Alter sch (DropSchemum td 'Typedef schema) schemas)
222+dropType tydef = UnsafeDefinition $ "DROP" <+> "TYPE" <+> renderSQL tydef <> ";"
223+
224+dropTypeIfExists
225+ :: (Has sch schemas schema, KnownSymbol td)
226+ => QualifiedAlias sch td
227+ -- ^ name of the user defined type
228+ -> Definition schemas (Alter sch (DropSchemumIfExists td 'Typedef schema) schemas)
229+dropTypeIfExists tydef = UnsafeDefinition $ "DROP" <+> "TYPE" <+> renderSQL tydef <> ";"
squeal-postgresql/src/Squeal/PostgreSQL/Definition/View.hsnew file+104
@@ -0,0 +1,104 @@
1+{-|
2+Module: Squeal.PostgreSQL.Definition.View
3+Description: Create and drop view definitions
4+Copyright: (c) Eitan Chatav, 2017
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Create and drop view definitions.
9+-}
10+
11+{-# LANGUAGE
12+ AllowAmbiguousTypes
13+ , ConstraintKinds
14+ , DeriveAnyClass
15+ , DeriveGeneric
16+ , DerivingStrategies
17+ , FlexibleContexts
18+ , FlexibleInstances
19+ , GADTs
20+ , LambdaCase
21+ , MultiParamTypeClasses
22+ , OverloadedLabels
23+ , OverloadedStrings
24+ , RankNTypes
25+ , ScopedTypeVariables
26+ , TypeApplications
27+ , TypeInType
28+ , TypeOperators
29+ , UndecidableSuperClasses
30+#-}
31+
32+module Squeal.PostgreSQL.Definition.View
33+ ( createView
34+ , createOrReplaceView
35+ , dropView
36+ , dropViewIfExists
37+ ) where
38+
39+import GHC.TypeLits
40+
41+import Squeal.PostgreSQL.Alias
42+import Squeal.PostgreSQL.Definition
43+import Squeal.PostgreSQL.Query
44+import Squeal.PostgreSQL.Render
45+import Squeal.PostgreSQL.Schema
46+
47+-- $setup
48+-- >>> import Squeal.PostgreSQL
49+
50+{- | Create a view.
51+>>> type ABC = '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4]
52+>>> type BC = '["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4]
53+>>> :{
54+let
55+ definition :: Definition
56+ '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC)]]
57+ '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC), "bc" ::: 'View BC]]
58+ definition =
59+ createView #bc (select_ (#b :* #c) (from (table #abc)))
60+in printSQL definition
61+:}
62+CREATE VIEW "bc" AS SELECT "b" AS "b", "c" AS "c" FROM "abc" AS "abc";
63+-}
64+createView
65+ :: (Has sch schemas schema, KnownSymbol vw)
66+ => QualifiedAlias sch vw -- ^ the name of the view to add
67+ -> Query '[] '[] schemas '[] view -- ^ query
68+ -> Definition schemas (Alter sch (Create vw ('View view) schema) schemas)
69+createView alias query = UnsafeDefinition $
70+ "CREATE" <+> "VIEW" <+> renderSQL alias <+> "AS"
71+ <+> renderQuery query <> ";"
72+
73+createOrReplaceView
74+ :: (Has sch schemas schema, KnownSymbol vw)
75+ => QualifiedAlias sch vw -- ^ the name of the view to add
76+ -> Query '[] '[] schemas '[] view -- ^ query
77+ -> Definition schemas (Alter sch (CreateOrReplace vw ('View view) schema) schemas)
78+createOrReplaceView alias query = UnsafeDefinition $
79+ "CREATE OR REPLACE VIEW" <+> renderSQL alias <+> "AS"
80+ <+> renderQuery query <> ";"
81+
82+-- | Drop a view.
83+--
84+-- >>> :{
85+-- let
86+-- definition :: Definition
87+-- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])
88+-- , "bc" ::: 'View ('["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4])]]
89+-- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])]]
90+-- definition = dropView #bc
91+-- in printSQL definition
92+-- :}
93+-- DROP VIEW "bc";
94+dropView
95+ :: (Has sch schemas schema, KnownSymbol vw)
96+ => QualifiedAlias sch vw -- ^ view to remove
97+ -> Definition schemas (Alter sch (DropSchemum vw 'View schema) schemas)
98+dropView vw = UnsafeDefinition $ "DROP VIEW" <+> renderSQL vw <> ";"
99+
100+dropViewIfExists
101+ :: (Has sch schemas schema, KnownSymbol vw)
102+ => QualifiedAlias sch vw -- ^ view to remove
103+ -> Definition schemas (Alter sch (DropIfExists vw schema) schemas)
104+dropViewIfExists vw = UnsafeDefinition $ "DROP VIEW IF EXISTS" <+> renderSQL vw <> ";"
squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs+91−17
@@ -34,17 +34,26 @@ module Squeal.PostgreSQL.Expression
3434 ( -- * Expression
3535 Expression (..)
3636 , Expr
37− , (:-->)
37+ , type (-->)
38+ , FunctionDB
3839 , unsafeFunction
39− , unsafeUnaryOpL
40− , unsafeUnaryOpR
40+ , function
41+ , unsafeLeftOp
42+ , leftOp
43+ , unsafeRightOp
44+ , rightOp
4145 , Operator
46+ , OperatorDB
4247 , unsafeBinaryOp
48+ , binaryOp
4349 , FunctionVar
4450 , unsafeFunctionVar
45− , FunctionN
51+ , type (--->)
52+ , FunctionNDB
4653 , unsafeFunctionN
54+ , functionN
4755 , PGSubset (..)
56+ , PGIntersect (..)
4857 -- * Re-export
4958 , (&)
5059 , K (..)
@@ -136,31 +145,54 @@ type Operator x1 x2 y
136145 -> Expression outer commons grp schemas params from y
137146 -- ^ output
138147
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+
139157-- | A @RankNType@ for functions with a single argument.
140158-- These could be either function calls or unary operators.
141159-- This is a subtype of the usual Haskell function type `Prelude.->`,
142160-- indeed a subcategory as it is closed under the usual
143161-- `Prelude..` and `Prelude.id`.
144−type (:-->) x y
162+type (-->) x y
145163 = forall outer commons grp schemas params from
146164 . Expression outer commons grp schemas params from x
147165 -- ^ input
148166 -> Expression outer commons grp schemas params from y
149167 -- ^ output
150168
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+
151176{- | A @RankNType@ for functions with a fixed-length list of heterogeneous arguments.
152177Use the `*:` operator to end your argument lists, like so.
153178
154179>>> printSQL (unsafeFunctionN "fun" (true :* false :* localTime *: true))
155180fun(TRUE, FALSE, LOCALTIME, TRUE)
156181-}
157−type FunctionN xs y
182+type (--->) xs y
158183 = forall outer commons grp schemas params from
159184 . NP (Expression outer commons grp schemas params from) xs
160185 -- ^ inputs
161186 -> Expression outer commons grp schemas params from y
162187 -- ^ output
163188
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+
164196{- | A @RankNType@ for functions with a variable-length list of
165197homogeneous arguments and at least 1 more argument.
166198-}
@@ -286,28 +318,63 @@ unsafeBinaryOp :: ByteString -> Operator ty0 ty1 ty2
286318unsafeBinaryOp op x y = UnsafeExpression $ parenthesized $
287319 renderSQL x <+> op <+> renderSQL y
288320
289−-- | >>> printSQL $ unsafeUnaryOpL "NOT" true
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
290329-- (NOT TRUE)
291−unsafeUnaryOpL :: ByteString -> x :--> y
292−unsafeUnaryOpL op x = UnsafeExpression $ parenthesized $ op <+> renderSQL x
330+unsafeLeftOp :: ByteString -> x --> y
331+unsafeLeftOp op x = UnsafeExpression $ parenthesized $ op <+> renderSQL x
293332
294−-- | >>> printSQL $ true & unsafeUnaryOpR "IS NOT TRUE"
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"
295341-- (TRUE IS NOT TRUE)
296−unsafeUnaryOpR :: ByteString -> x :--> y
297−unsafeUnaryOpR op x = UnsafeExpression $ parenthesized $ renderSQL x <+> op
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
298351
299352-- | >>> printSQL $ unsafeFunction "f" true
300353-- f(TRUE)
301−unsafeFunction :: ByteString -> x :--> y
354+unsafeFunction :: ByteString -> x --> y
302355unsafeFunction fun x = UnsafeExpression $
303356 fun <> parenthesized (renderSQL x)
304357
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+
305364-- | >>> printSQL $ unsafeFunctionN "f" (currentTime :* localTimestamp :* false *: literal 'a')
306365-- f(CURRENT_TIME, LOCALTIMESTAMP, FALSE, E'a')
307−unsafeFunctionN :: SListI xs => ByteString -> FunctionN xs y
366+unsafeFunctionN :: SListI xs => ByteString -> xs ---> y
308367unsafeFunctionN fun xs = UnsafeExpression $
309368 fun <> parenthesized (renderCommaSeparated renderSQL xs)
310369
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+
311378instance ty `In` PGNum
312379 => Num (Expression outer commons grp schemas params from (null ty)) where
313380 (+) = unsafeBinaryOp "+"
@@ -353,14 +420,21 @@ instance (ty `In` PGNum, ty `In` PGFloating) => Floating
353420 atanh x = log ((1 + x) / (1 - x)) / 2
354421
355422-- | Contained by operators
356−class PGSubset container where
357− (@>) :: Operator (null0 container) (null1 container) ('Null 'PGbool)
423+class PGSubset ty where
424+ (@>) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
358425 (@>) = unsafeBinaryOp "@>"
359− (<@) :: Operator (null0 container) (null1 container) ('Null 'PGbool)
426+ (<@) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
360427 (<@) = unsafeBinaryOp "<@"
361428instance PGSubset 'PGjsonb
362429instance PGSubset 'PGtsquery
363430instance 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)
364438
365439instance IsString
366440 (Expression outer commons grp schemas params from (null 'PGtext)) where
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Aggregate.hs+19−4
@@ -26,6 +26,7 @@ Aggregate functions
2626module Squeal.PostgreSQL.Expression.Aggregate
2727 ( Aggregate (..)
2828 , Distinction (..)
29+ , PGSum
2930 , PGAvg
3031 ) where
3132
@@ -79,15 +80,14 @@ class Aggregate expr1 exprN aggr
7980
8081 -- | >>> :{
8182 -- let
82− -- expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: 'Null 'PGnumeric]] ('NotNull 'PGnumeric)
83+ -- expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: 'Null 'PGnumeric]] ('Null 'PGnumeric)
8384 -- expression = sum_ (Distinct #col)
8485 -- in printSQL expression
8586 -- :}
8687 -- sum(DISTINCT "col")
8788 sum_
88− :: ty `In` PGNum
89− => expr1 (null ty)
90− -> aggr ('NotNull ty)
89+ :: expr1 (null ty)
90+ -> aggr ('Null (PGSum ty))
9191
9292 -- | input values, including nulls, concatenated into an array
9393 arrayAgg
@@ -434,6 +434,21 @@ 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+
437452-- | A type family that calculates `PGAvg` type of a `PGType`.
438453type family PGAvg ty where
439454 PGAvg 'PGint2 = 'PGnumeric
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Collection.hs+15−5
@@ -1,3 +1,13 @@
1+{-|
2+Module: Squeal.PostgreSQL.Expression.Collection
3+Description: Array and composite functions
4+Copyright: (c) Eitan Chatav, 2019
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Array and composite functions
9+-}
10+
111{-# LANGUAGE
212 AllowAmbiguousTypes
313 , DataKinds
@@ -32,7 +42,7 @@ import qualified Generics.SOP as SOP
3242
3343import Squeal.PostgreSQL.Alias
3444import Squeal.PostgreSQL.Expression
35−import Squeal.PostgreSQL.Expression.SetOf
45+import Squeal.PostgreSQL.Expression.Set
3646import Squeal.PostgreSQL.List
3747import Squeal.PostgreSQL.Render
3848import Squeal.PostgreSQL.Schema
@@ -101,20 +111,20 @@ array2 xss = UnsafeExpression $ "ARRAY" <>
101111
102112-- | >>> printSQL $ cardinality (array [null_, false, true])
103113-- cardinality(ARRAY[NULL, FALSE, TRUE])
104−cardinality :: null ('PGvararray ty) :--> null 'PGint8
114+cardinality :: null ('PGvararray ty) --> null 'PGint8
105115cardinality = unsafeFunction "cardinality"
106116
107117-- | >>> printSQL $ array [null_, false, true] & index 2
108118-- (ARRAY[NULL, FALSE, TRUE])[2]
109119index
110120 :: Word64 -- ^ index
111− -> null ('PGvararray ty) :--> NullifyType ty
121+ -> null ('PGvararray ty) --> NullifyType ty
112122index n expr = UnsafeExpression $
113123 parenthesized (renderSQL expr) <> "[" <> fromString (show n) <> "]"
114124
115125-- | Expand an array to a set of rows
116−unnest :: SetOfFunction "unnest" (null ('PGvararray ty)) '["unnest" ::: ty]
117−unnest = unsafeSetOfFunction
126+unnest :: SetFunction "unnest" (null ('PGvararray ty)) '["unnest" ::: ty]
127+unnest = unsafeSetFunction
118128
119129-- | A row constructor is an expression that builds a row value
120130-- (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 = unsafeUnaryOpR "IS TRUE"
165+isTrue :: null0 'PGbool --> null1 'PGbool
166+isTrue = unsafeRightOp "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 = unsafeUnaryOpR "IS NOT TRUE"
173+isNotTrue :: null0 'PGbool --> null1 'PGbool
174+isNotTrue = unsafeRightOp "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 = unsafeUnaryOpR "IS FALSE"
181+isFalse :: null0 'PGbool --> null1 'PGbool
182+isFalse = unsafeRightOp "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 = unsafeUnaryOpR "IS NOT FALSE"
189+isNotFalse :: null0 'PGbool --> null1 'PGbool
190+isNotFalse = unsafeRightOp "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 = unsafeUnaryOpR "IS UNKNOWN"
197+isUnknown :: null0 'PGbool --> null1 'PGbool
198+isUnknown = unsafeRightOp "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 = unsafeUnaryOpR "IS NOT UNKNOWN"
205+isNotUnknown :: null0 'PGbool --> null1 'PGbool
206+isNotUnknown = unsafeRightOp "IS NOT UNKNOWN"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Json.hs+109−175
@@ -1,3 +1,13 @@
1+{-|
2+Module: Squeal.PostgreSQL.Expression.Json
3+Description: Json and Jsonb functions and operators
4+Copyright: (c) Eitan Chatav, 2019
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Json and Jsonb functions and operators
9+-}
10+
111{-# LANGUAGE
212 DataKinds
313 , FlexibleContexts
@@ -11,6 +21,7 @@
1121 , TypeApplications
1222 , TypeOperators
1323 , UndecidableInstances
24+ , UndecidableSuperClasses
1425#-}
1526
1627module Squeal.PostgreSQL.Expression.Json
@@ -32,19 +43,13 @@ module Squeal.PostgreSQL.Expression.Json
3243 , rowToJson
3344 , jsonBuildArray
3445 , jsonbBuildArray
35− , PGBuildObject
36− , jsonBuildObject
37− , jsonbBuildObject
46+ , JsonBuildObject (..)
3847 , jsonObject
3948 , jsonbObject
4049 , jsonZipObject
4150 , jsonbZipObject
4251 , jsonArrayLength
4352 , jsonbArrayLength
44− , jsonExtractPath
45− , jsonbExtractPath
46− , jsonExtractPathAsText
47− , jsonbExtractPathAsText
4853 , jsonTypeof
4954 , jsonbTypeof
5055 , jsonStripNulls
@@ -59,10 +64,12 @@ module Squeal.PostgreSQL.Expression.Json
5964 , jsonbEachText
6065 , jsonObjectKeys
6166 , jsonbObjectKeys
67+ , JsonPopulateFunction
6268 , jsonPopulateRecord
6369 , jsonbPopulateRecord
6470 , jsonPopulateRecordSet
6571 , jsonbPopulateRecordSet
72+ , JsonToRecordFunction
6673 , jsonToRecord
6774 , jsonbToRecord
6875 , jsonToRecordSet
@@ -74,7 +81,7 @@ import GHC.TypeLits
7481
7582import Squeal.PostgreSQL.Alias
7683import Squeal.PostgreSQL.Expression
77−import Squeal.PostgreSQL.Expression.SetOf
84+import Squeal.PostgreSQL.Expression.Set
7885import Squeal.PostgreSQL.Expression.Type
7986import Squeal.PostgreSQL.List
8087import Squeal.PostgreSQL.Query
@@ -149,18 +156,18 @@ infixl 9 .?&
149156
150157-- | Delete a key or keys from a JSON object, or remove an array element.
151158--
152−-- If the right operand is..
159+-- If the right operand is
153160--
154−-- @ text @: Delete key/value pair or string element from left operand. Key/value pairs
155−-- are matched based on their key value.
161+-- @ text @: Delete key / value pair or string element from left operand.
162+-- Key / value pairs are matched based on their key value,
156163--
157−-- @ text[] @: Delete multiple key/value pairs or string elements
158−-- from left operand. Key/value pairs are matched based on their key value.
164+-- @ text[] @: Delete multiple key / value pairs or string elements
165+-- from left operand. Key / value pairs are matched based on their key value,
159166--
160167-- @ integer @: Delete the array element with specified index (Negative integers
161168-- count from the end). Throws an error if top level container is not an array.
162169(.-.)
163− :: (key `In` '[ 'PGtext, 'PGvararray ('NotNull 'PGtext), 'PGint4, 'PGint2 ]) -- hlint error without parens here
170+ :: key `In` '[ 'PGtext, 'PGvararray ('NotNull 'PGtext), 'PGint4, 'PGint2 ]
164171 => Operator (null 'PGjsonb) (null key) (null 'PGjsonb)
165172infixl 6 .-.
166173(.-.) = unsafeBinaryOp "-"
@@ -181,7 +188,7 @@ Table 9.45: JSON creation functions
181188-- otherwise, a scalar value is produced. For any scalar type other than a
182189-- number, a Boolean, or a null value, the text representation will be used, in
183190-- such a fashion that it is a valid json value.
184−toJson :: null ty :--> null 'PGjson
191+toJson :: null ty --> null 'PGjson
185192toJson = unsafeFunction "to_json"
186193
187194-- | Returns the value as jsonb. Arrays and composites are converted
@@ -190,48 +197,42 @@ toJson = unsafeFunction "to_json"
190197-- otherwise, a scalar value is produced. For any scalar type other than a
191198-- number, a Boolean, or a null value, the text representation will be used, in
192199-- such a fashion that it is a valid jsonb value.
193−toJsonb :: null ty :--> null 'PGjsonb
200+toJsonb :: null ty --> null 'PGjsonb
194201toJsonb = unsafeFunction "to_jsonb"
195202
196203-- | Returns the array as a JSON array. A PostgreSQL multidimensional array
197204-- becomes a JSON array of arrays.
198−arrayToJson :: null ('PGvararray ty) :--> null 'PGjson
205+arrayToJson :: null ('PGvararray ty) --> null 'PGjson
199206arrayToJson = unsafeFunction "array_to_json"
200207
201208-- | Returns the row as a JSON object.
202−rowToJson :: null ('PGcomposite ty) :--> null 'PGjson
209+rowToJson :: null ('PGcomposite ty) --> null 'PGjson
203210rowToJson = unsafeFunction "row_to_json"
204211
205212-- | Builds a possibly-heterogeneously-typed JSON array out of a variadic
206213-- argument list.
207−jsonBuildArray :: SOP.SListI tuple => FunctionN tuple (null 'PGjson)
214+jsonBuildArray :: SOP.SListI tuple => tuple ---> null 'PGjson
208215jsonBuildArray = unsafeFunctionN "json_build_array"
209216
210217-- | Builds a possibly-heterogeneously-typed (binary) JSON array out of a
211218-- variadic argument list.
212−jsonbBuildArray :: SOP.SListI tuple => FunctionN tuple (null 'PGjsonb)
219+jsonbBuildArray :: SOP.SListI tuple => tuple ---> null 'PGjsonb
213220jsonbBuildArray = unsafeFunctionN "jsonb_build_array"
214221
215−class PGBuildObject tys where
216−instance PGBuildObject '[]
217−instance (PGBuildObject tys, key `In` PGJsonKey)
218− => PGBuildObject ('NotNull key ': value ': tys)
219−
220222-- | Builds a possibly-heterogeneously-typed JSON object out of a variadic
221223-- argument list. The elements of the argument list must alternate between text
222224-- and values.
223−jsonBuildObject
224− :: (SOP.SListI elems, PGBuildObject elems)
225− => FunctionN elems (null 'PGjson)
226−jsonBuildObject = unsafeFunctionN "json_build_object"
227−
228−-- | Builds a possibly-heterogeneously-typed (binary) JSON object out of a
229−-- variadic argument list. The elements of the argument list must alternate
230−-- between keys and values.
231−jsonbBuildObject
232− :: (SOP.SListI elems, PGBuildObject elems)
233− => FunctionN elems (null 'PGjsonb)
234−jsonbBuildObject = unsafeFunctionN "jsonb_build_object"
225+class SOP.SListI tys => JsonBuildObject tys where
226+
227+ jsonBuildObject :: tys ---> null 'PGjson
228+ jsonBuildObject = unsafeFunctionN "json_build_object"
229+
230+ jsonbBuildObject :: tys ---> null 'PGjsonb
231+ jsonbBuildObject = unsafeFunctionN "jsonb_build_object"
232+
233+instance JsonBuildObject '[]
234+instance (JsonBuildObject tys, key `In` PGJsonKey)
235+ => JsonBuildObject ('NotNull key ': value ': tys)
235236
236237-- | Builds a JSON object out of a text array.
237238-- The array must have two dimensions
@@ -239,7 +240,7 @@ jsonbBuildObject = unsafeFunctionN "jsonb_build_object"
239240-- which are taken as a key/value pair.
240241jsonObject
241242 :: null ('PGfixarray '[n,2] ('NotNull 'PGtext))
242− :--> null 'PGjson
243+ --> null 'PGjson
243244jsonObject = unsafeFunction "json_object"
244245
245246-- | Builds a binary JSON object out of a text array.
@@ -248,24 +249,24 @@ jsonObject = unsafeFunction "json_object"
248249-- which are taken as a key/value pair.
249250jsonbObject
250251 :: null ('PGfixarray '[n,2] ('NotNull 'PGtext))
251− :--> null 'PGjsonb
252+ --> null 'PGjsonb
252253jsonbObject = unsafeFunction "jsonb_object"
253254
254255-- | This is an alternate form of 'jsonObject' that takes two arrays; one for
255256-- keys and one for values, that are zipped pairwise to create a JSON object.
256−jsonZipObject :: FunctionN
257+jsonZipObject ::
257258 '[ null ('PGvararray ('NotNull 'PGtext))
258259 , null ('PGvararray ('NotNull 'PGtext)) ]
259− ( null 'PGjson )
260+ ---> null 'PGjson
260261jsonZipObject = unsafeFunctionN "json_object"
261262
262263-- | This is an alternate form of 'jsonbObject' that takes two arrays; one for
263264-- keys and one for values, that are zipped pairwise to create a binary JSON
264265-- object.
265−jsonbZipObject :: FunctionN
266+jsonbZipObject ::
266267 '[ null ('PGvararray ('NotNull 'PGtext))
267268 , null ('PGvararray ('NotNull 'PGtext)) ]
268− ( null 'PGjsonb )
269+ ---> null 'PGjsonb
269270jsonbZipObject = unsafeFunctionN "jsonb_object"
270271
271272{-----------------------------------------
@@ -273,121 +274,72 @@ Table 9.46: JSON processing functions
273274-----------------------------------------}
274275
275276-- | Returns the number of elements in the outermost JSON array.
276−jsonArrayLength :: null 'PGjson :--> null 'PGint4
277+jsonArrayLength :: null 'PGjson --> null 'PGint4
277278jsonArrayLength = unsafeFunction "json_array_length"
278279
279280-- | Returns the number of elements in the outermost binary JSON array.
280−jsonbArrayLength :: null 'PGjsonb :--> null 'PGint4
281+jsonbArrayLength :: null 'PGjsonb --> null 'PGint4
281282jsonbArrayLength = unsafeFunction "jsonb_array_length"
282283
283−-- | Returns JSON value pointed to by the given path (equivalent to #>
284−-- operator).
285−jsonExtractPath
286− :: SOP.SListI elems
287− => Expression outer commons grp schemas params from (null 'PGjson)
288− -> NP (Expression outer commons grp schemas params from) elems
289− -> Expression outer commons grp schemas params from (null 'PGjsonb)
290−jsonExtractPath x xs =
291− unsafeFunctionN "json_extract_path" (x :* xs)
292−
293−-- | Returns JSON value pointed to by the given path (equivalent to #>
294−-- operator).
295−jsonbExtractPath
296− :: SOP.SListI elems
297− => Expression outer commons grp schemas params from (null 'PGjsonb)
298− -> NP (Expression outer commons grp schemas params from) elems
299− -> Expression outer commons grp schemas params from (null 'PGjsonb)
300−jsonbExtractPath x xs =
301− unsafeFunctionN "jsonb_extract_path" (x :* xs)
302−
303−-- | Returns JSON value pointed to by the given path (equivalent to #>
304−-- operator), as text.
305−jsonExtractPathAsText
306− :: SOP.SListI elems
307− => Expression outer commons grp schemas params from (null 'PGjson)
308− -> NP (Expression outer commons grp schemas params from) elems
309− -> Expression outer commons grp schemas params from (null 'PGjson)
310−jsonExtractPathAsText x xs =
311− unsafeFunctionN "json_extract_path_text" (x :* xs)
312−
313−-- | Returns JSON value pointed to by the given path (equivalent to #>
314−-- operator), as text.
315−jsonbExtractPathAsText
316− :: SOP.SListI elems
317− => Expression outer commons grp schemas params from (null 'PGjsonb)
318− -> NP (Expression outer commons grp schemas params from) elems
319− -> Expression outer commons grp schemas params from (null 'PGjsonb)
320−jsonbExtractPathAsText x xs =
321− unsafeFunctionN "jsonb_extract_path_text" (x :* xs)
322−
323284-- | Returns the type of the outermost JSON value as a text string. Possible
324285-- types are object, array, string, number, boolean, and null.
325−jsonTypeof :: null 'PGjson :--> null 'PGtext
286+jsonTypeof :: null 'PGjson --> null 'PGtext
326287jsonTypeof = unsafeFunction "json_typeof"
327288
328289-- | Returns the type of the outermost binary JSON value as a text string.
329290-- Possible types are object, array, string, number, boolean, and null.
330−jsonbTypeof :: null 'PGjsonb :--> null 'PGtext
291+jsonbTypeof :: null 'PGjsonb --> null 'PGtext
331292jsonbTypeof = unsafeFunction "jsonb_typeof"
332293
333294-- | Returns its argument with all object fields that have null values omitted.
334295-- Other null values are untouched.
335−jsonStripNulls :: null 'PGjson :--> null 'PGjson
296+jsonStripNulls :: null 'PGjson --> null 'PGjson
336297jsonStripNulls = unsafeFunction "json_strip_nulls"
337298
338299-- | Returns its argument with all object fields that have null values omitted.
339300-- Other null values are untouched.
340−jsonbStripNulls :: null 'PGjsonb :--> null 'PGjsonb
301+jsonbStripNulls :: null 'PGjsonb --> null 'PGjsonb
341302jsonbStripNulls = unsafeFunction "jsonb_strip_nulls"
342303
343304-- | @ jsonbSet target path new_value create_missing @
344305--
345−-- Returns target with the section designated by path replaced by new_value,
346−-- or with new_value added if create_missing is true ( default is true) and the
306+-- Returns target with the section designated by path replaced by @new_value@,
307+-- or with @new_value@ added if create_missing is
308+-- `Squeal.PostgreSQL.Expression.Logic.true` and the
347309-- item designated by path does not exist. As with the path orientated
348310-- operators, negative integers that appear in path count from the end of JSON
349311-- arrays.
350−jsonbSet
351− :: Expression outer commons grp schemas params from (null 'PGjsonb)
352− -> Expression outer commons grp schemas params from (null ('PGvararray ('NotNull 'PGtext)))
353− -> Expression outer commons grp schemas params from (null 'PGjsonb)
354− -> Maybe (Expression outer commons grp schemas params from (null 'PGbool))
355− -> Expression outer commons grp schemas params from (null 'PGjsonb)
356−jsonbSet tgt path val createMissing = case createMissing of
357− Just m -> unsafeFunctionN "jsonb_set" (tgt :* path :* val :* m :* Nil)
358− Nothing -> unsafeFunctionN "jsonb_set" (tgt :* path :* val :* Nil)
312+jsonbSet ::
313+ '[ null 'PGjsonb, null ('PGvararray ('NotNull 'PGtext))
314+ , null 'PGjsonb, null 'PGbool ] ---> null 'PGjsonb
315+jsonbSet = unsafeFunctionN "jsonbSet"
359316
360317-- | @ jsonbInsert target path new_value insert_after @
361318--
362−-- Returns target with new_value inserted. If target section designated by
363−-- path is in a JSONB array, new_value will be inserted before target or after
364−-- if insert_after is true (default is false). If target section designated by
365−-- path is in JSONB object, new_value will be inserted only if target does not
319+-- Returns target with @new_value@ inserted. If target section designated by
320+-- path is in a JSONB array, @new_value@ will be inserted before target or after
321+-- if @insert_after@ is `Squeal.PostgreSQL.Expression.Logic.true`.
322+-- If target section designated by
323+-- path is in JSONB object, @new_value@ will be inserted only if target does not
366324-- exist. As with the path orientated operators, negative integers that appear
367325-- in path count from the end of JSON arrays.
368−jsonbInsert
369− :: Expression outer commons grp schemas params from (null 'PGjsonb)
370− -> Expression outer commons grp schemas params from (null ('PGvararray ('NotNull 'PGtext)))
371− -> Expression outer commons grp schemas params from (null 'PGjsonb)
372− -> Maybe (Expression outer commons grp schemas params from (null 'PGbool))
373− -> Expression outer commons grp schemas params from (null 'PGjsonb)
374−jsonbInsert tgt path val insertAfter = case insertAfter of
375− Just i -> unsafeFunctionN "jsonb_insert" (tgt :* path :* val :* i :* Nil)
376− Nothing -> unsafeFunctionN "jsonb_insert" (tgt :* path :* val :* Nil)
326+jsonbInsert ::
327+ '[ null 'PGjsonb, null ('PGvararray ('NotNull 'PGtext))
328+ , null 'PGjsonb, null 'PGbool ] ---> null 'PGjsonb
329+jsonbInsert = unsafeFunctionN "jsonb_insert"
377330
378331-- | Returns its argument as indented JSON text.
379−jsonbPretty :: null 'PGjsonb :--> null 'PGtext
332+jsonbPretty :: null 'PGjsonb --> null 'PGtext
380333jsonbPretty = unsafeFunction "jsonb_pretty"
381334
382−
383335{- | Expands the outermost JSON object into a set of key/value pairs.
384336
385337>>> printSQL (select Star (from (jsonEach (literal (Json (object ["a" .= "foo", "b" .= "bar"]))))))
386338SELECT * FROM json_each(('{"a":"foo","b":"bar"}' :: json))
387339-}
388−jsonEach :: SetOfFunction "json_each" (null 'PGjson)
340+jsonEach :: SetFunction "json_each" (null 'PGjson)
389341 '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGjson]
390−jsonEach = unsafeSetOfFunction
342+jsonEach = unsafeSetFunction
391343
392344{- | Expands the outermost binary JSON object into a set of key/value pairs.
393345
@@ -395,9 +347,9 @@ jsonEach = unsafeSetOfFunction
395347SELECT * FROM jsonb_each(('{"a":"foo","b":"bar"}' :: jsonb))
396348-}
397349jsonbEach
398− :: SetOfFunction "jsonb_each" (nullity 'PGjsonb)
350+ :: SetFunction "jsonb_each" (nullity 'PGjsonb)
399351 '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGjson]
400−jsonbEach = unsafeSetOfFunction
352+jsonbEach = unsafeSetFunction
401353
402354{- | Expands the outermost JSON object into a set of key/value pairs.
403355
@@ -405,9 +357,9 @@ jsonbEach = unsafeSetOfFunction
405357SELECT * FROM json_each_text(('{"a":"foo","b":"bar"}' :: json))
406358-}
407359jsonEachText
408− :: SetOfFunction "json_each_text" (null 'PGjson)
360+ :: SetFunction "json_each_text" (null 'PGjson)
409361 '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext]
410−jsonEachText = unsafeSetOfFunction
362+jsonEachText = unsafeSetFunction
411363
412364{- | Expands the outermost binary JSON object into a set of key/value pairs.
413365
@@ -415,9 +367,9 @@ jsonEachText = unsafeSetOfFunction
415367SELECT * FROM jsonb_each_text(('{"a":"foo","b":"bar"}' :: jsonb))
416368-}
417369jsonbEachText
418− :: SetOfFunction "jsonb_each_text" (null 'PGjsonb)
370+ :: SetFunction "jsonb_each_text" (null 'PGjsonb)
419371 '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext]
420−jsonbEachText = unsafeSetOfFunction
372+jsonbEachText = unsafeSetFunction
421373
422374{- | Returns set of keys in the outermost JSON object.
423375
@@ -425,9 +377,9 @@ jsonbEachText = unsafeSetOfFunction
425377json_object_keys(('{"a":"foo","b":"bar"}' :: json))
426378-}
427379jsonObjectKeys
428− :: SetOfFunction "json_object_keys" (nullity 'PGjson)
380+ :: SetFunction "json_object_keys" (nullity 'PGjson)
429381 '["json_object_keys" ::: 'NotNull 'PGtext]
430−jsonObjectKeys = unsafeSetOfFunction
382+jsonObjectKeys = unsafeSetFunction
431383
432384{- | Returns set of keys in the outermost JSON object.
433385
@@ -435,59 +387,57 @@ jsonObjectKeys = unsafeSetOfFunction
435387jsonb_object_keys(('{"a":"foo","b":"bar"}' :: jsonb))
436388-}
437389jsonbObjectKeys
438− :: SetOfFunction "jsonb_object_keys" (null 'PGjsonb)
390+ :: SetFunction "jsonb_object_keys" (null 'PGjsonb)
439391 '["jsonb_object_keys" ::: 'NotNull 'PGtext]
440−jsonbObjectKeys = unsafeSetOfFunction
392+jsonbObjectKeys = unsafeSetFunction
393+
394+-- | Build rows from Json types.
395+type JsonPopulateFunction fun json
396+ = forall schemas row outer commons params
397+ . json `In` PGJsonType
398+ => TypeExpression schemas ('NotNull ('PGcomposite row)) -- ^ row type
399+ -> Expression outer commons 'Ungrouped schemas params '[] ('NotNull json)
400+ -- ^ json type
401+ -> FromClause outer commons schemas params '[fun ::: row]
441402
442403unsafePopulateFunction
443− :: forall fun schemas null outer commons params ty row
444− . KnownSymbol fun
445− => Alias fun
446− -> TypeExpression schemas (null ('PGcomposite row))
447− -> Expression outer commons 'Ungrouped schemas params '[] ty
448− -> FromClause outer commons schemas params '[fun ::: row]
404+ :: forall fun ty
405+ . KnownSymbol fun => Alias fun -> JsonPopulateFunction fun ty
449406unsafePopulateFunction _fun ty expr = UnsafeFromClause $ renderSymbol @fun
450407 <> parenthesized ("null::" <> renderSQL ty <> ", " <> renderSQL expr)
451408
452409-- | Expands the JSON expression to a row whose columns match the record
453410-- type defined by the given table.
454−jsonPopulateRecord
455− :: TypeExpression schemas (nullity ('PGcomposite row)) -- ^ row type
456− -> Expression outer commons 'Ungrouped schemas params '[] (nullity 'PGjson) -- ^ json object
457− -> FromClause outer commons schemas params '["json_populate_record" ::: row]
411+jsonPopulateRecord :: JsonPopulateFunction "json_populate_record" 'PGjson
458412jsonPopulateRecord = unsafePopulateFunction #json_populate_record
459413
460414-- | Expands the binary JSON expression to a row whose columns match the record
461415-- type defined by the given table.
462−jsonbPopulateRecord
463− :: TypeExpression schemas (nullity ('PGcomposite row)) -- ^ row type
464− -> Expression outer commons 'Ungrouped schemas params '[] (nullity 'PGjsonb) -- ^ jsonb object
465− -> FromClause outer commons schemas params '["jsonb_populate_record" ::: row]
416+jsonbPopulateRecord :: JsonPopulateFunction "jsonb_populate_record" 'PGjsonb
466417jsonbPopulateRecord = unsafePopulateFunction #jsonb_populate_record
467418
468419-- | Expands the outermost array of objects in the given JSON expression to a
469420-- set of rows whose columns match the record type defined by the given table.
470−jsonPopulateRecordSet
471− :: TypeExpression schemas (nullity ('PGcomposite row)) -- ^ row type
472− -> Expression outer commons 'Ungrouped schemas params '[] (nullity 'PGjson) -- ^ json array
473− -> FromClause outer commons schemas params '["json_populate_record_set" ::: row]
421+jsonPopulateRecordSet :: JsonPopulateFunction "json_populate_record_set" 'PGjson
474422jsonPopulateRecordSet = unsafePopulateFunction #json_populate_record_set
475423
476424-- | Expands the outermost array of objects in the given binary JSON expression
477425-- to a set of rows whose columns match the record type defined by the given
478426-- table.
479−jsonbPopulateRecordSet
480− :: TypeExpression schemas (nullity ('PGcomposite row)) -- ^ row type
481− -> Expression outer commons 'Ungrouped schemas params '[] (nullity 'PGjsonb) -- ^ jsonb array
482− -> FromClause outer commons schemas params '["jsonb_populate_record_set" ::: row]
427+jsonbPopulateRecordSet :: JsonPopulateFunction "jsonb_populate_record_set" 'PGjsonb
483428jsonbPopulateRecordSet = unsafePopulateFunction #jsonb_populate_record_set
484429
485−unsafeRecordFunction
486− :: (SOP.SListI record, json `In` PGJsonType)
487− => ByteString
488− -> Expression outer commons 'Ungrouped schemas params '[] (nullity json)
489− -> Aliased (NP (Aliased (TypeExpression schemas))) (tab ::: record)
490− -> FromClause outer commons schemas params '[tab ::: record]
430+-- | Build rows from Json types.
431+type JsonToRecordFunction json
432+ = forall outer commons schemas params tab row
433+ . (SOP.SListI row, json `In` PGJsonType)
434+ => Expression outer commons 'Ungrouped schemas params '[] ('NotNull json)
435+ -- ^ json type
436+ -> Aliased (NP (Aliased (TypeExpression schemas))) (tab ::: row)
437+ -- ^ row type
438+ -> FromClause outer commons schemas params '[tab ::: row]
439+
440+unsafeRecordFunction :: ByteString -> JsonToRecordFunction json
491441unsafeRecordFunction fun expr (types `As` tab) = UnsafeFromClause $
492442 fun <> parenthesized (renderSQL expr) <+> "AS" <+> renderSQL tab
493443 <> parenthesized (renderCommaSeparated renderTy types)
@@ -496,33 +446,17 @@ unsafeRecordFunction fun expr (types `As` tab) = UnsafeFromClause $
496446 renderTy (ty `As` alias) = renderSQL alias <+> renderSQL ty
497447
498448-- | Builds an arbitrary record from a JSON object.
499−jsonToRecord
500− :: SOP.SListI record
501− => Expression outer commons 'Ungrouped schemas params '[] (nullity 'PGjson) -- ^ json object
502− -> Aliased (NP (Aliased (TypeExpression schemas))) (tab ::: record)
503− -> FromClause outer commons schemas params '[tab ::: record]
449+jsonToRecord :: JsonToRecordFunction 'PGjson
504450jsonToRecord = unsafeRecordFunction "json_to_record"
505451
506452-- | Builds an arbitrary record from a binary JSON object.
507−jsonbToRecord
508− :: SOP.SListI record
509− => Expression outer commons 'Ungrouped schemas params '[] (nullity 'PGjsonb) -- ^ jsonb object
510− -> Aliased (NP (Aliased (TypeExpression schemas))) (tab ::: record)
511− -> FromClause outer commons schemas params '[tab ::: record]
453+jsonbToRecord :: JsonToRecordFunction 'PGjsonb
512454jsonbToRecord = unsafeRecordFunction "jsonb_to_record"
513455
514456-- | Builds an arbitrary set of records from a JSON array of objects.
515−jsonToRecordSet
516− :: SOP.SListI record
517− => Expression outer commons 'Ungrouped schemas params '[] (nullity 'PGjson) -- ^ json array
518− -> Aliased (NP (Aliased (TypeExpression schemas))) (tab ::: record)
519− -> FromClause outer commons schemas params '[tab ::: record]
457+jsonToRecordSet :: JsonToRecordFunction 'PGjson
520458jsonToRecordSet = unsafeRecordFunction "json_to_record_set"
521459
522460-- | Builds an arbitrary set of records from a binary JSON array of objects.
523−jsonbToRecordSet
524− :: SOP.SListI record
525− => Expression outer commons 'Ungrouped schemas params '[] (nullity 'PGjsonb) -- ^ jsonb array
526− -> Aliased (NP (Aliased (TypeExpression schemas))) (tab ::: record)
527− -> FromClause outer commons schemas params '[tab ::: record]
461+jsonbToRecordSet :: JsonToRecordFunction 'PGjsonb
528462jsonbToRecordSet = unsafeRecordFunction "jsonb_to_record_set"
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_ = unsafeUnaryOpL "NOT"
50+not_ :: null 'PGbool --> null 'PGbool
51+not_ = unsafeLeftOp "NOT"
5252
5353-- | >>> printSQL $ true .&& false
5454-- (TRUE AND FALSE)
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Math.hs+4−7
@@ -29,7 +29,6 @@ import Squeal.PostgreSQL.Schema
2929
3030-- $setup
3131-- >>> import Squeal.PostgreSQL
32−-- >>> import Squeal.PostgreSQL.Render
3332
3433-- | >>> :{
3534-- let
@@ -38,9 +37,7 @@ import Squeal.PostgreSQL.Schema
3837-- in printSQL expression
3938-- :}
4039-- atan2(pi(), 2)
41−atan2_
42− :: float `In` PGFloating
43− => FunctionN '[ null float, null float] (null float)
40+atan2_ :: float `In` PGFloating => '[ null float, null float] ---> null float
4441atan2_ = unsafeFunctionN "atan2"
4542
4643
@@ -79,7 +76,7 @@ rem_ = unsafeBinaryOp "%"
7976-- in printSQL expression
8077-- :}
8178-- trunc(pi())
82−trunc :: frac `In` PGFloating => null frac :--> null frac
79+trunc :: frac `In` PGFloating => null frac --> null frac
8380trunc = unsafeFunction "trunc"
8481
8582-- | >>> :{
@@ -89,7 +86,7 @@ trunc = unsafeFunction "trunc"
8986-- in printSQL expression
9087-- :}
9188-- round(pi())
92−round_ :: frac `In` PGFloating => null frac :--> null frac
89+round_ :: frac `In` PGFloating => null frac --> null frac
9390round_ = unsafeFunction "round"
9491
9592-- | >>> :{
@@ -99,5 +96,5 @@ round_ = unsafeFunction "round"
9996-- in printSQL expression
10097-- :}
10198-- ceiling(pi())
102−ceiling_ :: frac `In` PGFloating => null frac :--> null frac
99+ceiling_ :: frac `In` PGFloating => null frac --> null frac
103100ceiling_ = 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 :: FunctionN '[ 'NotNull ty, 'NotNull ty] ('Null ty)
103+nullIf :: '[ 'NotNull ty, 'NotNull ty] ---> 'Null ty
104104nullIf = unsafeFunctionN "NULLIF"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Range.hsnew file+230
@@ -0,0 +1,230 @@
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/SetOf.hs → squeal-postgresql/src/Squeal/PostgreSQL/Expression/Set.hsrenamed+57−24
@@ -1,5 +1,5 @@
11{-|
2−Module: Squeal.PostgreSQL.Expression.SetOf
2+Module: Squeal.PostgreSQL.Expression.Set
33Description: Set returning functions
44Copyright: (c) Eitan Chatav, 2019
55Maintainer: eitan@morphism.tech
@@ -20,14 +20,18 @@ Set returning functions
2020 , TypeOperators
2121#-}
2222
23−module Squeal.PostgreSQL.Expression.SetOf
23+module Squeal.PostgreSQL.Expression.Set
2424 ( generateSeries
2525 , generateSeriesStep
2626 , generateSeriesTimestamp
27− , SetOfFunction
28− , unsafeSetOfFunction
29− , SetOfFunctionN
30− , unsafeSetOfFunctionN
27+ , SetFunction
28+ , unsafeSetFunction
29+ , SetFunctionDB
30+ , setFunction
31+ , SetFunctionN
32+ , unsafeSetFunctionN
33+ , SetFunctionNDB
34+ , setFunctionN
3135 ) where
3236
3337import GHC.TypeLits
@@ -44,46 +48,75 @@ import Squeal.PostgreSQL.Schema
4448{- |
4549A @RankNType@ for set returning functions with 1 argument.
4650-}
47−type SetOfFunction fun ty setof
51+type SetFunction fun ty row
4852 = forall outer commons schemas params
4953 . Expression outer commons 'Ungrouped schemas params '[] ty
5054 -- ^ input
51− -> FromClause outer commons schemas params '[fun ::: setof]
55+ -> FromClause outer commons schemas params '[fun ::: row]
56+ -- ^ output
57+
58+type SetFunctionDB fun schemas ty row
59+ = forall outer commons params
60+ . Expression outer commons 'Ungrouped schemas params '[] ty
61+ -- ^ input
62+ -> FromClause outer commons schemas params '[fun ::: row]
5263 -- ^ output
5364
5465-- | Escape hatch for a set returning function with 1 argument.
55−unsafeSetOfFunction
56− :: forall fun ty setof. KnownSymbol fun
57− => SetOfFunction fun ty setof -- ^ set returning function
58−unsafeSetOfFunction x = UnsafeFromClause $
66+unsafeSetFunction
67+ :: forall fun ty row. KnownSymbol fun
68+ => SetFunction fun ty row -- ^ set returning function
69+unsafeSetFunction x = UnsafeFromClause $
5970 renderSymbol @fun <> parenthesized (renderSQL x)
6071
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+
6179{- |
6280A @RankNType@ for set returning functions with multiple argument.
6381-}
64−type SetOfFunctionN fun tys setof
82+type SetFunctionN fun tys row
6583 = forall outer commons schemas params
6684 . NP (Expression outer commons 'Ungrouped schemas params '[]) tys
6785 -- ^ inputs
68− -> FromClause outer commons schemas params '[fun ::: setof]
86+ -> FromClause outer commons schemas params '[fun ::: row]
6987 -- ^ output
7088
7189-- | Escape hatch for a set returning function with multiple argument.
72−unsafeSetOfFunctionN
73− :: forall fun tys setof. (SOP.SListI tys, KnownSymbol fun)
74− => SetOfFunctionN fun tys setof -- ^ set returning function
75−unsafeSetOfFunctionN xs = UnsafeFromClause $
90+unsafeSetFunctionN
91+ :: forall fun tys row. (SOP.SListI tys, KnownSymbol fun)
92+ => SetFunctionN fun tys row -- ^ set returning function
93+unsafeSetFunctionN xs = UnsafeFromClause $
7694 renderSymbol @fun <> parenthesized (renderCommaSeparated renderSQL xs)
7795
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+
78111{- | @generateSeries (start *: stop)@
79112
80113Generate a series of values, from @start@ to @stop@ with a step size of one
81114-}
82115generateSeries
83116 :: ty `In` '[ 'PGint4, 'PGint8, 'PGnumeric]
84− => SetOfFunctionN "generate_series" '[ null ty, null ty]
117+ => SetFunctionN "generate_series" '[ null ty, null ty]
85118 '["generate_series" ::: null ty] -- ^ set returning function
86−generateSeries = unsafeSetOfFunctionN
119+generateSeries = unsafeSetFunctionN
87120
88121{- | @generateSeries (start :* stop *: step)@
89122
@@ -91,9 +124,9 @@ Generate a series of values, from @start@ to @stop@ with a step size of @step@
91124-}
92125generateSeriesStep
93126 :: ty `In` '[ 'PGint4, 'PGint8, 'PGnumeric]
94− => SetOfFunctionN "generate_series" '[null ty, null ty, null ty]
127+ => SetFunctionN "generate_series" '[null ty, null ty, null ty]
95128 '["generate_series" ::: null ty] -- ^ set returning function
96−generateSeriesStep = unsafeSetOfFunctionN
129+generateSeriesStep = unsafeSetFunctionN
97130
98131{- | @generateSeries (start :* stop *: step)@
99132
@@ -101,6 +134,6 @@ Generate a series of values, from @start@ to @stop@ with a step size of @step@
101134-}
102135generateSeriesTimestamp
103136 :: ty `In` '[ 'PGtimestamp, 'PGtimestamptz]
104− => SetOfFunctionN "generate_series" '[null ty, null ty, null 'PGinterval]
137+ => SetFunctionN "generate_series" '[null ty, null ty, null 'PGinterval]
105138 '["generate_series" ::: null ty] -- ^ set returning function
106−generateSeriesTimestamp = unsafeSetOfFunctionN
139+generateSeriesTimestamp = unsafeSetFunctionN
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Subquery.hs+2−3
@@ -33,7 +33,6 @@ import Squeal.PostgreSQL.Schema
3333
3434-- $setup
3535-- >>> import Squeal.PostgreSQL
36−-- >>> import Squeal.PostgreSQL.Render
3736
3837{- |
3938The argument of `exists` is an arbitrary subquery. The subquery is evaluated
@@ -81,8 +80,8 @@ using the given `Operator`, which must yield a Boolean result. The result of `su
8180if any `true` result is obtained. The result is `false` if no true result is found
8281(including the case where the subquery returns no rows).
8382
84−>>> printSQL $ subAll "foo" like (values_ ("foobar" `as` #foo))
85−(E'foo' LIKE ALL (SELECT * FROM (VALUES (E'foobar')) AS t ("foo")))
83+>>> printSQL $ subAny "foo" like (values_ ("foobar" `as` #foo))
84+(E'foo' LIKE ANY (SELECT * FROM (VALUES (E'foobar')) AS t ("foo")))
8685-}
8786subAny
8887 :: Expression outer commons grp schemas params from ty1 -- ^ expression
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Text.hs+3−4
@@ -27,21 +27,20 @@ import Squeal.PostgreSQL.Schema
2727
2828-- $setup
2929-- >>> import Squeal.PostgreSQL
30−-- >>> import Squeal.PostgreSQL.Render
3130
3231-- | >>> printSQL $ lower "ARRRGGG"
3332-- lower(E'ARRRGGG')
34−lower :: null 'PGtext :--> null 'PGtext
33+lower :: null 'PGtext --> null 'PGtext
3534lower = unsafeFunction "lower"
3635
3736-- | >>> printSQL $ upper "eeee"
3837-- upper(E'eeee')
39−upper :: null 'PGtext :--> null 'PGtext
38+upper :: null 'PGtext --> null 'PGtext
4039upper = unsafeFunction "upper"
4140
4241-- | >>> printSQL $ charLength "four"
4342-- char_length(E'four')
44−charLength :: null 'PGtext :--> null 'PGint4
43+charLength :: null 'PGtext --> null 'PGint4
4544charLength = unsafeFunction "char_length"
4645
4746-- | The `like` expression returns true if the @string@ matches
squeal-postgresql/src/Squeal/PostgreSQL/Expression/TextSearch.hs+20−21
@@ -55,8 +55,8 @@ import Squeal.PostgreSQL.Schema
5555(.|) = unsafeBinaryOp "||"
5656
5757-- | negate a `Squeal.PostgreSQL.Expression.Type.tsquery`
58−(.!) :: null 'PGtsquery :--> null 'PGtsquery
59−(.!) = unsafeUnaryOpL "!!"
58+(.!) :: null 'PGtsquery --> null 'PGtsquery
59+(.!) = unsafeLeftOp "!!"
6060
6161-- | `Squeal.PostgreSQL.Expression.Type.tsquery` followed by
6262-- `Squeal.PostgreSQL.Expression.Type.tsquery`
@@ -66,51 +66,50 @@ 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
109− :: FunctionN '[null 'PGtsvector, null ('PGchar 1)] (null 'PGtsvector)
108+setWeight :: '[null 'PGtsvector, null ('PGchar 1)] ---> null 'PGtsvector
110109setWeight = unsafeFunctionN "set_weight"
111110
112111-- | remove positions and weights from `Squeal.PostgreSQL.Expression.Type.tsvector`
113−strip :: null 'PGtsvector :--> null 'PGtsvector
112+strip :: null 'PGtsvector --> null 'PGtsvector
114113strip = unsafeFunction "strip"
115114
116115-- | @jsonToTSvector (document *: filter)@
@@ -123,7 +122,7 @@ strip = unsafeFunction "strip"
123122-- "boolean" (to include all Boolean values in the string format "true"/"false"),
124123-- "key" (to include all keys) or "all" (to include all above).
125124-- These values can be combined together to include, e.g. all string and numeric values.
126−jsonToTSvector :: FunctionN '[null 'PGjson, null 'PGjson] (null 'PGtsvector)
125+jsonToTSvector :: '[null 'PGjson, null 'PGjson] ---> null 'PGtsvector
127126jsonToTSvector = unsafeFunctionN "json_to_tsvector"
128127
129128-- | @jsonbToTSvector (document *: filter)@
@@ -136,23 +135,23 @@ jsonToTSvector = unsafeFunctionN "json_to_tsvector"
136135-- "boolean" (to include all Boolean values in the string format "true"/"false"),
137136-- "key" (to include all keys) or "all" (to include all above).
138137-- These values can be combined together to include, e.g. all string and numeric values.
139−jsonbToTSvector :: FunctionN '[null 'PGjsonb, null 'PGjsonb] (null 'PGtsvector)
138+jsonbToTSvector :: '[null 'PGjsonb, null 'PGjsonb] ---> null 'PGtsvector
140139jsonbToTSvector = unsafeFunctionN "jsonb_to_tsvector"
141140
142141-- | remove given lexeme from `Squeal.PostgreSQL.Expression.Type.tsvector`
143−tsDelete :: FunctionN
142+tsDelete ::
144143 '[null 'PGtsvector, null ('PGvararray ('NotNull 'PGtext))]
145− (null 'PGtsvector)
144+ ---> null 'PGtsvector
146145tsDelete = unsafeFunctionN "ts_delete"
147146
148147-- | select only elements with given weights from `Squeal.PostgreSQL.Expression.Type.tsvector`
149−tsFilter :: FunctionN
148+tsFilter ::
150149 '[null 'PGtsvector, null ('PGvararray ('NotNull ('PGchar 1)))]
151− (null 'PGtsvector)
150+ ---> null 'PGtsvector
152151tsFilter = unsafeFunctionN "ts_filter"
153152
154153-- | display a `Squeal.PostgreSQL.Expression.Type.tsquery` match
155154tsHeadline
156155 :: document `In` '[ 'PGtext, 'PGjson, 'PGjsonb]
157− => FunctionN '[null document, null 'PGtsquery] (null 'PGtext)
156+ => '[null document, null 'PGtsquery] ---> null 'PGtext
158157tsHeadline = unsafeFunctionN "ts_headline"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Time.hs+7−12
@@ -17,6 +17,7 @@ Date/Time functions and operators
1717 , OverloadedStrings
1818 , PolyKinds
1919 , RankNTypes
20+ , TypeOperators
2021#-}
2122
2223module Squeal.PostgreSQL.Expression.Time
@@ -85,9 +86,7 @@ Create date from year, month and day fields
8586>>> printSQL (makeDate (1984 :* 7 *: 3))
8687make_date(1984, 7, 3)
8788-}
88−makeDate :: FunctionN
89− '[ null 'PGint4, null 'PGint4, null 'PGint4 ]
90− ( null 'PGdate )
89+makeDate :: '[ null 'PGint4, null 'PGint4, null 'PGint4 ] ---> null 'PGdate
9190makeDate = unsafeFunctionN "make_date"
9291
9392{-|
@@ -96,9 +95,7 @@ Create time from hour, minute and seconds fields
9695>>> printSQL (makeTime (8 :* 15 *: 23.5))
9796make_time(8, 15, 23.5)
9897-}
99−makeTime :: FunctionN
100− '[ null 'PGint4, null 'PGint4, null 'PGfloat8 ]
101− ( null 'PGtime )
98+makeTime :: '[ null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtime
10299makeTime = unsafeFunctionN "make_time"
103100
104101{-|
@@ -107,10 +104,9 @@ Create timestamp from year, month, day, hour, minute and seconds fields
107104>>> printSQL (makeTimestamp (2013 :* 7 :* 15 :* 8 :* 15 *: 23.5))
108105make_timestamp(2013, 7, 15, 8, 15, 23.5)
109106-}
110−makeTimestamp :: FunctionN
107+makeTimestamp ::
111108 '[ null 'PGint4, null 'PGint4, null 'PGint4
112− , null 'PGint4, null 'PGint4, null 'PGfloat8 ]
113− ( null 'PGtimestamp )
109+ , null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtimestamp
114110makeTimestamp = unsafeFunctionN "make_timestamp"
115111
116112{-|
@@ -121,10 +117,9 @@ the current time zone is used
121117>>> printSQL (makeTimestamptz (2013 :* 7 :* 15 :* 8 :* 15 *: 23.5))
122118make_timestamptz(2013, 7, 15, 8, 15, 23.5)
123119-}
124−makeTimestamptz :: FunctionN
120+makeTimestamptz ::
125121 '[ null 'PGint4, null 'PGint4, null 'PGint4
126− , null 'PGint4, null 'PGint4, null 'PGfloat8 ]
127− ( null 'PGtimestamptz )
122+ , null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtimestamptz
128123makeTimestamptz = unsafeFunctionN "make_timestamptz"
129124
130125{-|
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Type.hs+168−5
@@ -23,12 +23,16 @@ Type expressions.
2323 , ScopedTypeVariables
2424 , TypeApplications
2525 , TypeOperators
26+ , UndecidableInstances
2627#-}
2728
2829module Squeal.PostgreSQL.Expression.Type
29− ( TypeExpression (..)
30− , cast
31− , PGTyped (..)
30+ ( -- * type casting
31+ cast
32+ , astype
33+ , inferredtype
34+ -- * type expressions
35+ , TypeExpression (..)
3236 , typedef
3337 , typetable
3438 , typeview
@@ -54,9 +58,11 @@ module Squeal.PostgreSQL.Expression.Type
5458 , bytea
5559 , timestamp
5660 , timestampWithTimeZone
61+ , timestamptz
5762 , date
5863 , time
5964 , timeWithTimeZone
65+ , timetz
6066 , interval
6167 , uuid
6268 , inet
@@ -66,6 +72,29 @@ module Squeal.PostgreSQL.Expression.Type
6672 , fixarray
6773 , tsvector
6874 , 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 (..)
6998 ) where
7099
71100import Control.DeepSeq
@@ -79,6 +108,7 @@ import qualified Generics.SOP as SOP
79108
80109import Squeal.PostgreSQL.Alias
81110import Squeal.PostgreSQL.Expression
111+import Squeal.PostgreSQL.PG
82112import Squeal.PostgreSQL.Render
83113import Squeal.PostgreSQL.Schema
84114
@@ -100,6 +130,29 @@ cast
100130cast ty x = UnsafeExpression $ parenthesized $
101131 renderSQL x <+> "::" <+> renderSQL ty
102132
133+-- | A safe version of `cast` which just matches a value with its type.
134+--
135+-- >>> printSQL (1 & astype int)
136+-- (1 :: int)
137+astype
138+ :: TypeExpression schemas ty
139+ -- ^ type to specify as
140+ -> Expression outer commons grp schemas params from ty
141+ -- ^ value
142+ -> Expression outer commons grp schemas params from ty
143+astype = cast
144+
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
103156
104157{-----------------------------------------
105158type expressions
@@ -117,6 +170,7 @@ instance RenderSQL (TypeExpression schemas ty) where
117170typedef
118171 :: (Has sch schemas schema, Has td schema ('Typedef ty))
119172 => QualifiedAlias sch td
173+ -- ^ type alias
120174 -> TypeExpression schemas (null ty)
121175typedef = UnsafeTypeExpression . renderSQL
122176
@@ -125,6 +179,7 @@ typedef = UnsafeTypeExpression . renderSQL
125179typetable
126180 :: (Has sch schemas schema, Has tab schema ('Table table))
127181 => QualifiedAlias sch tab
182+ -- ^ table alias
128183 -> TypeExpression schemas (null ('PGcomposite (TableToRow table)))
129184typetable = UnsafeTypeExpression . renderSQL
130185
@@ -133,6 +188,7 @@ typetable = UnsafeTypeExpression . renderSQL
133188typeview
134189 :: (Has sch schemas schema, Has vw schema ('View view))
135190 => QualifiedAlias sch vw
191+ -- ^ view alias
136192 -> TypeExpression schemas (null ('PGcomposite view))
137193typeview = UnsafeTypeExpression . renderSQL
138194
@@ -189,8 +245,9 @@ bytea = UnsafeTypeExpression "bytea"
189245timestamp :: TypeExpression schemas (null 'PGtimestamp)
190246timestamp = UnsafeTypeExpression "timestamp"
191247-- | date and time, including time zone
192−timestampWithTimeZone :: TypeExpression schemas (null 'PGtimestamptz)
248+timestampWithTimeZone, timestamptz :: TypeExpression schemas (null 'PGtimestamptz)
193249timestampWithTimeZone = UnsafeTypeExpression "timestamp with time zone"
250+timestamptz = UnsafeTypeExpression "timestamptz"
194251-- | calendar date (year, month, day)
195252date :: TypeExpression schemas (null 'PGdate)
196253date = UnsafeTypeExpression "date"
@@ -198,8 +255,9 @@ date = UnsafeTypeExpression "date"
198255time :: TypeExpression schemas (null 'PGtime)
199256time = UnsafeTypeExpression "time"
200257-- | time of day, including time zone
201−timeWithTimeZone :: TypeExpression schemas (null 'PGtimetz)
258+timeWithTimeZone, timetz :: TypeExpression schemas (null 'PGtimetz)
202259timeWithTimeZone = UnsafeTypeExpression "time with time zone"
260+timetz = UnsafeTypeExpression "timetz"
203261-- | time span
204262interval :: TypeExpression schemas (null 'PGinterval)
205263interval = UnsafeTypeExpression "interval"
@@ -246,6 +304,28 @@ tsvector = UnsafeTypeExpression "tsvector"
246304-- | text search document
247305tsquery :: TypeExpression schemas (null 'PGtsquery)
248306tsquery = 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"
249329
250330-- | `pgtype` is a demoted version of a `PGType`
251331class PGTyped schemas (ty :: NullityType) where
@@ -281,3 +361,86 @@ instance (SOP.All KnownNat dims, PGTyped schemas ty)
281361 pgtype = fixarray @dims (pgtype @schemas @ty)
282362instance PGTyped schemas (null 'PGtsvector) where pgtype = tsvector
283363instance 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+17−46
@@ -33,16 +33,16 @@ module Squeal.PostgreSQL.List
3333 , Join
3434 , disjoin
3535 , Additional (..)
36− , AlignedList (..)
37− , single
38− , extractList
39− , mapAligned
36+ , Path (..)
37+ , CFunctor (..)
38+ , CFoldable (..)
39+ , CFree (..)
4040 , Elem
4141 , In
4242 , Length
4343 ) where
4444
45−import Control.Category
45+import Control.Category.Free
4646import Data.Function ((&))
4747import Data.Kind
4848import Data.Type.Bool
@@ -50,8 +50,6 @@ import GHC.TypeLits
5050
5151import Generics.SOP as SOP
5252
53−import Squeal.PostgreSQL.Render
54−
5553-- | `Join` is simply promoted `++` and is used in @JOIN@s in
5654-- `Squeal.PostgreSQL.Query.FromClause`s.
5755type family Join xs ys where
@@ -78,42 +76,6 @@ instance Additional (NP expr) where
7876 Nil -> ys
7977 x :* xs -> x :* (xs & also ys)
8078
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−
11779-- | A useful operator for ending an `NP` list of length at least 2 without `Nil`.
11880(*:) :: f x -> f y -> NP f '[x,y]
11981x *: y = x :* y :* Nil
@@ -122,13 +84,18 @@ infixl 9 *:
12284-- | @Elem@ is a promoted `Data.List.elem`.
12385type family Elem x xs where
12486 Elem x '[] = 'False
125− Elem x (x ': xs) = 'True
87+ Elem x (x ': _) = 'True
88+ Elem x (_ ': x ': _) = 'True
89+ Elem x (_ ': _ ': x ': _) = 'True
90+ Elem x (_ ': _ ': _ ': x ': _) = 'True
91+ Elem x (_ ': _ ': _ ': _ ': x ': _) = 'True
92+ Elem x (_ ': _ ': _ ': _ ': _ ': x ': _) = 'True
12693 Elem x (_ ': xs) = Elem x xs
12794
12895-- | @In x xs@ is a constraint that proves that @x@ is in @xs@.
12996type family In x xs :: Constraint where
13097 In x xs = If (Elem x xs) (() :: Constraint)
131− (TypeError ('ShowType x ':<>: 'Text "is not in " ':<>: 'ShowType xs))
98+ (TypeError ('ShowType x ':<>: 'Text " is not in " ':<>: 'ShowType xs))
13299
133100{- | Calculate the `Length` of a type level list
134101
@@ -137,5 +104,9 @@ Length '[Char,String,Bool,Double] :: Nat
137104= 4
138105-}
139106type family Length (xs :: [k]) :: Nat where
140− Length (x : xs) = 1 + Length xs
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
141112 Length '[] = 0
squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs+155−153
@@ -18,6 +18,7 @@ Squeal data manipulation language.
1818 , MultiParamTypeClasses
1919 , OverloadedStrings
2020 , PatternSynonyms
21+ , QuantifiedConstraints
2122 , RankNTypes
2223 , ScopedTypeVariables
2324 , TypeApplications
@@ -29,19 +30,9 @@ Squeal data manipulation language.
2930
3031module Squeal.PostgreSQL.Manipulation
3132 ( -- * Manipulation
32− Manipulation (..)
33− , Manipulation_
33+ Manipulation_
34+ , Manipulation (..)
3435 , queryStatement
35− , QueryClause (..)
36− , pattern Values_
37− , DefaultAliasable (..)
38− , ColumnExpression (..)
39− , ReturningClause (..)
40− , pattern Returning_
41− , ConflictClause (..)
42− , ConflictTarget (..)
43− , ConflictAction (..)
44− , UsingClause (..)
4536 -- * Insert
4637 , insertInto
4738 , insertInto_
@@ -51,12 +42,21 @@ module Squeal.PostgreSQL.Manipulation
5142 -- * Delete
5243 , deleteFrom
5344 , deleteFrom_
45+ -- * Clauses
46+ , Optional (..)
47+ , QueryClause (..)
48+ , pattern Values_
49+ , ReturningClause (..)
50+ , pattern Returning_
51+ , ConflictClause (..)
52+ , ConflictTarget (..)
53+ , ConflictAction (..)
54+ , UsingClause (..)
5455 ) where
5556
5657import Control.DeepSeq
5758import Data.ByteString hiding (foldr)
5859import Data.Kind (Type)
59−import GHC.TypeLits (KnownSymbol)
6060
6161import qualified Generics.SOP as SOP
6262import qualified GHC.Generics as GHC
@@ -72,21 +72,65 @@ import Squeal.PostgreSQL.Schema
7272
7373-- $setup
7474-- >>> import Squeal.PostgreSQL
75+-- >>> import Data.Int
76+-- >>> import Data.Time
7577
7678{- |
7779A `Manipulation` is a statement which may modify data in the database,
7880but does not alter its schemas. Examples are inserts, updates and deletes.
7981A `Query` is also considered a `Manipulation` even though it does not modify data.
8082
83+The general `Manipulation` type is parameterized by
84+
85+* @commons :: FromType@ - scope for all `common` table expressions,
86+* @schemas :: SchemasType@ - scope for all `table`s and `view`s,
87+* @params :: [NullityType]@ - scope for all `Squeal.Expression.Parameter.parameter`s,
88+* @row :: RowType@ - return type of the `Query`.
89+-}
90+newtype Manipulation
91+ (commons :: FromType)
92+ (schemas :: SchemasType)
93+ (params :: [NullityType])
94+ (columns :: RowType)
95+ = UnsafeManipulation { renderManipulation :: ByteString }
96+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
97+instance RenderSQL (Manipulation commons schemas params columns) where
98+ renderSQL = renderManipulation
99+instance With Manipulation where
100+ with Done manip = manip
101+ with ctes manip = UnsafeManipulation $
102+ "WITH" <+> commaSeparated (ctoList renderSQL ctes) <+> renderSQL manip
103+
104+{- |
105+The top level `Manipulation_` type is parameterized by a @schemas@ `SchemasType`,
106+against which the query is type-checked, an input @parameters@ Haskell `Type`,
107+and an ouput row Haskell `Type`.
108+
109+A top-level `Manipulation_` can be run
110+using `Squeal.PostgreSQL.PQ.manipulateParams`, or if @parameters = ()@
111+using `Squeal.PostgreSQL.PQ.manipulate`.
112+
113+Generally, @parameters@ will be a Haskell tuple or record whose entries
114+may be referenced using positional
115+`Squeal.PostgreSQL.Expression.Parameter.parameter`s and @row@ will be a
116+Haskell record, whose entries will be targeted using overloaded labels.
117+
118+>>> :set -XDeriveAnyClass -XDerivingStrategies
119+>>> :{
120+data Row a b = Row { col1 :: a, col2 :: b }
121+ deriving stock (GHC.Generic)
122+ deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
123+:}
124+
81125simple insert:
82126
83127>>> type Columns = '["col1" ::: 'NoDef :=> 'Null 'PGint4, "col2" ::: 'Def :=> 'NotNull 'PGint4]
84128>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]
85129>>> :{
86130let
87− manipulation :: Manipulation '[] (Public Schema) '[] '[]
131+ manipulation :: Manipulation_ (Public Schema) () ()
88132 manipulation =
89− insertInto_ #tab (Values_ (2 `as` #col1 :* defaultAs #col2))
133+ insertInto_ #tab (Values_ (Set 2 `as` #col1 :* Default `as` #col2))
90134in printSQL manipulation
91135:}
92136INSERT INTO "tab" ("col1", "col2") VALUES (2, DEFAULT)
@@ -97,9 +141,9 @@ parameterized insert:
97141>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]
98142>>> :{
99143let
100− manipulation :: Manipulation '[] (Public Schema) '[ 'NotNull 'PGint4, 'NotNull 'PGint4 ] '[]
144+ manipulation :: Manipulation_ (Public Schema) (Int32, Int32) ()
101145 manipulation =
102− insertInto_ #tab (Values_ (param @1 `as` #col1 :* param @2 `as` #col2))
146+ insertInto_ #tab (Values_ (Set (param @1) `as` #col1 :* Set (param @2) `as` #col2))
103147in printSQL manipulation
104148:}
105149INSERT INTO "tab" ("col1", "col2") VALUES (($1 :: int4), ($2 :: int4))
@@ -108,9 +152,9 @@ returning insert:
108152
109153>>> :{
110154let
111− manipulation :: Manipulation '[] (Public Schema) '[] '["fromOnly" ::: 'NotNull 'PGint4]
155+ manipulation :: Manipulation_ (Public Schema) () (Only Int32)
112156 manipulation =
113− insertInto #tab (Values_ (2 `as` #col1 :* 3 `as` #col2))
157+ insertInto #tab (Values_ (Set 2 `as` #col1 :* Set 3 `as` #col2))
114158 OnConflictDoRaise (Returning (#col1 `as` #fromOnly))
115159in printSQL manipulation
116160:}
@@ -123,12 +167,12 @@ upsert:
123167>>> type CustomersSchema = '["customers" ::: 'Table (CustomersConstraints :=> CustomersColumns)]
124168>>> :{
125169let
126− manipulation :: Manipulation '[] (Public CustomersSchema) '[] '[]
170+ manipulation :: Manipulation_ (Public CustomersSchema) () ()
127171 manipulation =
128172 insertInto #customers
129− (Values_ ("John Smith" `as` #name :* "john@smith.com" `as` #email))
173+ (Values_ (Set "John Smith" `as` #name :* Set "john@smith.com" `as` #email))
130174 (OnConflict (OnConstraint #uq)
131− (DoUpdate (((#excluded ! #email) <> "; " <> (#customers ! #email)) `as` #email) []))
175+ (DoUpdate (Set (#excluded ! #email <> "; " <> #customers ! #email) `as` #email) []))
132176 (Returning_ Nil)
133177in printSQL manipulation
134178:}
@@ -138,7 +182,7 @@ query insert:
138182
139183>>> :{
140184let
141− manipulation :: Manipulation '[] (Public Schema) '[] '[]
185+ manipulation :: Manipulation_ (Public Schema) () ()
142186 manipulation = insertInto_ #tab (Subquery (select Star (from (table #tab))))
143187in printSQL manipulation
144188:}
@@ -148,8 +192,8 @@ update:
148192
149193>>> :{
150194let
151− manipulation :: Manipulation '[] (Public Schema) '[] '[]
152− manipulation = update_ #tab (2 `as` #col1) (#col1 ./= #col2)
195+ manipulation :: Manipulation_ (Public Schema) () ()
196+ manipulation = update_ #tab (Set 2 `as` #col1) (#col1 ./= #col2)
153197in printSQL manipulation
154198:}
155199UPDATE "tab" SET "col1" = 2 WHERE ("col1" <> "col2")
@@ -158,9 +202,7 @@ delete:
158202
159203>>> :{
160204let
161− manipulation :: Manipulation '[] (Public Schema) '[]
162− '[ "col1" ::: 'NotNull 'PGint4
163− , "col2" ::: 'NotNull 'PGint4 ]
205+ manipulation :: Manipulation_ (Public Schema) () (Row Int32 Int32)
164206 manipulation = deleteFrom #tab NoUsing (#col1 .== #col2) (Returning Star)
165207in printSQL manipulation
166208:}
@@ -171,13 +213,13 @@ delete and using clause:
171213>>> :{
172214type Schema3 =
173215 '[ "tab" ::: 'Table ('[] :=> Columns)
174− , "other_tab" ::: 'Table ('[] :=> Columns)
175− , "third_tab" ::: 'Table ('[] :=> Columns) ]
216+ , "other_tab" ::: 'Table ('[] :=> Columns)
217+ , "third_tab" ::: 'Table ('[] :=> Columns) ]
176218:}
177219
178220>>> :{
179221let
180− manipulation :: Manipulation '[] (Public Schema3) '[] '[]
222+ manipulation :: Manipulation_ (Public Schema3) () ()
181223 manipulation =
182224 deleteFrom #tab (Using (table #other_tab & also (table #third_tab)))
183225 ( (#tab ! #col2 .== #other_tab ! #col2)
@@ -193,7 +235,7 @@ with manipulation:
193235>>> type ProductsSchema = '["products" ::: 'Table ('[] :=> ProductsColumns), "products_deleted" ::: 'Table ('[] :=> ProductsColumns)]
194236>>> :{
195237let
196− manipulation :: Manipulation '[] (Public ProductsSchema) '[ 'NotNull 'PGdate] '[]
238+ manipulation :: Manipulation_ (Public ProductsSchema) (Only Day) ()
197239 manipulation = with
198240 (deleteFrom #products NoUsing (#date .< param @1) (Returning Star) `as` #del)
199241 (insertInto_ #products_deleted (Subquery (select Star (from (common #del)))))
@@ -201,26 +243,13 @@ in printSQL manipulation
201243:}
202244WITH "del" AS (DELETE FROM "products" WHERE ("date" < ($1 :: date)) RETURNING *) INSERT INTO "products_deleted" SELECT * FROM "del" AS "del"
203245-}
204−newtype Manipulation
205− (commons :: FromType)
206− (schemas :: SchemasType)
207− (params :: [NullityType])
208− (columns :: RowType)
209− = UnsafeManipulation { renderManipulation :: ByteString }
210− deriving (GHC.Generic,Show,Eq,Ord,NFData)
211−instance RenderSQL (Manipulation commons schemas params columns) where
212− renderSQL = renderManipulation
213−instance With Manipulation where
214− with Done manip = manip
215− with ctes manip = UnsafeManipulation $
216− "WITH" <+> renderSQL ctes <+> renderSQL manip
217−
218246type family Manipulation_ (schemas :: SchemasType) (params :: Type) (row :: Type) where
219247 Manipulation_ schemas params row = Manipulation '[] schemas (TuplePG params) (RowPG row)
220248
221249-- | Convert a `Query` into a `Manipulation`.
222250queryStatement
223251 :: Query '[] commons schemas params columns
252+ -- ^ `Query` to embed as a `Manipulation`
224253 -> Manipulation commons schemas params columns
225254queryStatement q = UnsafeManipulation $ renderSQL q
226255
@@ -243,9 +272,13 @@ insertInto
243272 , SOP.SListI columns
244273 , SOP.SListI row1 )
245274 => QualifiedAlias sch tab
275+ -- ^ table
246276 -> QueryClause commons schemas params columns
277+ -- ^ what to insert
247278 -> ConflictClause tab commons schemas params table
279+ -- ^ what to do in case of conflict
248280 -> ReturningClause commons schemas params '[tab ::: row0] row1
281+ -- ^ what to return
249282 -> Manipulation commons schemas params row1
250283insertInto tab qry conflict ret = UnsafeManipulation $
251284 "INSERT" <+> "INTO" <+> renderSQL tab
@@ -253,6 +286,7 @@ insertInto tab qry conflict ret = UnsafeManipulation $
253286 <> renderSQL conflict
254287 <> renderSQL ret
255288
289+-- | Like `insertInto` but with `OnConflictDoRaise` and `no` `ReturningClause`.
256290insertInto_
257291 :: ( Has sch schemas schema
258292 , Has tab schema ('Table table)
@@ -260,25 +294,33 @@ insertInto_
260294 , row ~ TableToRow table
261295 , SOP.SListI columns )
262296 => QualifiedAlias sch tab
297+ -- ^ table
263298 -> QueryClause commons schemas params columns
299+ -- ^ what to insert
264300 -> Manipulation commons schemas params '[]
265301insertInto_ tab qry =
266302 insertInto tab qry OnConflictDoRaise (Returning_ Nil)
267303
304+-- | A `QueryClause` describes what to `insertInto` a table.
268305data QueryClause commons schemas params columns where
269306 Values
270307 :: SOP.SListI columns
271− => NP (ColumnExpression 'Ungrouped schemas params '[]) columns
272− -> [NP (ColumnExpression 'Ungrouped schemas params '[]) columns]
308+ => NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[]))) columns
309+ -- ^ row of values
310+ -> [NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[]))) columns]
311+ -- ^ additional rows of values
273312 -> QueryClause commons schemas params columns
274313 Select
275314 :: SOP.SListI columns
276− => NP (ColumnExpression grp schemas params from) columns
315+ => NP (Aliased (Optional (Expression '[] commons grp schemas params from))) columns
316+ -- ^ row of values
277317 -> TableExpression '[] commons grp schemas params from
318+ -- ^ from a table expression
278319 -> QueryClause commons schemas params columns
279320 Subquery
280321 :: ColumnsToRow columns ~ row
281322 => Query '[] commons schemas params row
323+ -- ^ subquery to insert
282324 -> QueryClause commons schemas params columns
283325
284326instance RenderSQL (QueryClause commons schemas params columns) where
@@ -297,109 +339,41 @@ instance RenderSQL (QueryClause commons schemas params columns) where
297339 Subquery qry -> renderQuery qry
298340 where
299341 renderSQLPartMaybe, renderValuePartMaybe
300− :: ColumnExpression grp schemas params from column -> Maybe ByteString
342+ :: Aliased (Optional (Expression '[] commons grp schemas params from)) column
343+ -> Maybe ByteString
301344 renderSQLPartMaybe = \case
302− DefaultAs _ -> Nothing
303− Specific (_ `As` name) -> Just $ renderSQL name
345+ Default `As` _ -> Nothing
346+ Set _ `As` name -> Just $ renderSQL name
304347 renderValuePartMaybe = \case
305− DefaultAs _ -> Nothing
306− Specific (value `As` _) -> Just $ renderExpression value
348+ Default `As` _ -> Nothing
349+ Set value `As` _ -> Just $ renderExpression value
307350 renderSQLPart, renderValuePart
308− :: ColumnExpression grp schemas params from column -> ByteString
309− renderSQLPart = \case
310− DefaultAs name -> renderSQL name
311− Specific (_ `As` name) -> renderSQL name
312− renderValuePart = \case
313− DefaultAs _ -> "DEFAULT"
314− Specific (value `As` _) -> renderExpression value
351+ :: Aliased (Optional (Expression '[] commons grp schemas params from)) column
352+ -> ByteString
353+ renderSQLPart (_ `As` name) = renderSQL name
354+ renderValuePart (value `As` _) = renderSQL value
315355
356+-- | `Values_` describes a single `NP` list of `Aliased` `Optional` `Expression`s
357+-- whose `ColumnsType` must match the tables'.
316358pattern Values_
317359 :: SOP.SListI columns
318− => NP (ColumnExpression 'Ungrouped schemas params '[]) columns
360+ => NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[]))) columns
361+ -- ^ row of values
319362 -> QueryClause commons schemas params columns
320363pattern Values_ vals = Values vals []
321364
322−data ColumnExpression grp schemas params from column where
323− DefaultAs
324− :: KnownSymbol col
325− => Alias col
326− -> ColumnExpression grp schemas params from (col ::: 'Def :=> ty)
327− Specific
328− :: Aliased (Expression '[] '[] grp schemas params from) (col ::: ty)
329− -> ColumnExpression grp schemas params from (col ::: defness :=> ty)
330−
331−instance (KnownSymbol col, column ~ (col ::: defness :=> ty))
332− => Aliasable col
333− (Expression '[] '[] grp schemas params from ty)
334− (ColumnExpression grp schemas params from column) where
335− expression `as` col = Specific (expression `As` col)
336−instance (KnownSymbol col, columns ~ '[col ::: defness :=> ty])
337− => Aliasable col
338− (Expression '[] '[] grp schemas params from ty)
339− (NP (ColumnExpression grp schemas params from) columns) where
340− expression `as` col = expression `as` col :* Nil
341−instance (KnownSymbol col, column ~ (col ::: 'Def :=> ty))
342− => DefaultAliasable col (ColumnExpression grp schemas params from column) where
343− defaultAs = DefaultAs
344−instance (KnownSymbol col, columns ~ '[col ::: 'Def :=> ty])
345− => DefaultAliasable col (NP (ColumnExpression grp schemas params from) columns) where
346− defaultAs col = defaultAs col :* Nil
347−
348−instance (HasUnique tab from row, Has col row ty, column ~ (col ::: defness :=> ty))
349− => IsLabel col (ColumnExpression 'Ungrouped schemas params from column) where
350− fromLabel = fromLabel @col `as` Alias
351−instance (HasUnique tab from row, Has col row ty, columns ~ '[col ::: defness :=> ty])
352− => IsLabel col
353− (NP (ColumnExpression 'Ungrouped schemas params from) columns) where
354− fromLabel = fromLabel @col `as` Alias
355−
356−instance (Has tab from row, Has col row ty, column ~ (col ::: defness :=> ty))
357− => IsQualified tab col (ColumnExpression 'Ungrouped schemas params from column) where
358− tab ! col = tab ! col `as` col
359−instance (Has tab from row, Has col row ty, columns ~ '[col ::: defness :=> ty])
360− => IsQualified tab col (NP (ColumnExpression 'Ungrouped schemas params from) columns) where
361− tab ! col = tab ! col `as` col
362−
363−instance
364− ( HasUnique tab from row
365− , Has col row ty
366− , GroupedBy tab col bys
367− , column ~ (col ::: defness :=> ty)
368− ) => IsLabel col
369− (ColumnExpression ('Grouped bys) schemas params from column) where
370− fromLabel = fromLabel @col `as` Alias
371−instance
372− ( HasUnique tab from row
373− , Has col row ty
374− , GroupedBy tab col bys
375− , columns ~ '[col ::: defness :=> ty]
376− ) => IsLabel col
377− (NP (ColumnExpression ('Grouped bys) schemas params from) columns) where
378− fromLabel = fromLabel @col `as` Alias
379−
380−instance
381− ( Has tab from row
382− , Has col row ty
383− , GroupedBy tab col bys
384− , column ~ (col ::: defness :=> ty)
385− ) => IsQualified tab col
386− (ColumnExpression ('Grouped bys) schemas params from column) where
387− tab ! col = tab ! col `as` col
388−instance
389− ( Has tab from row
390− , Has col row ty
391− , GroupedBy tab col bys
392− , columns ~ '[col ::: defness :=> ty]
393− ) => IsQualified tab col
394− (NP (ColumnExpression ('Grouped bys) schemas params from) columns) where
395− tab ! col = tab ! col :* Nil
396−
397−instance RenderSQL (ColumnExpression grp schemas params from column) where
365+-- | `Optional` is either `Default` or a value, parameterized by an appropriate
366+-- `ColumnConstraint`.
367+data Optional expr ty where
368+ -- | Use the `Default` value for a column.
369+ Default :: Optional expr ('Def :=> ty)
370+ -- | `Set` a value for a column.
371+ Set :: expr ty -> Optional expr (def :=> ty)
372+
373+instance (forall x. RenderSQL (expr x)) => RenderSQL (Optional expr ty) where
398374 renderSQL = \case
399− DefaultAs col ->
400− renderSQL col <+> "=" <+> "DEFAULT"
401− Specific (expression `As` col) ->
402− renderSQL col <+> "=" <+> renderSQL expression
375+ Default -> "DEFAULT"
376+ Set expr -> renderSQL expr
403377
404378-- | A `ReturningClause` computes and return value(s) based
405379-- on each row actually inserted, updated or deleted. This is primarily
@@ -409,7 +383,7 @@ instance RenderSQL (ColumnExpression grp schemas params from column) where
409383-- deleted will be returned. For example, if a row was locked
410384-- but not updated because an `OnConflict` `DoUpdate` condition was not satisfied,
411385-- the row will not be returned. `Returning` `Star` will return all columns
412−-- in the row. Use @Returning Nil@ in the common case where no return
386+-- in the row. Use `Returning` `Nil` in the common case where no return
413387-- values are desired.
414388newtype ReturningClause commons schemas params from row =
415389 Returning (Selection '[] commons 'Ungrouped schemas params from row)
@@ -419,9 +393,11 @@ instance RenderSQL (ReturningClause commons schemas params from row) where
419393 Returning (List Nil) -> ""
420394 Returning selection -> " RETURNING" <+> renderSQL selection
421395
396+-- | `Returning` a `List`
422397pattern Returning_
423398 :: SOP.SListI row
424399 => NP (Aliased (Expression '[] commons 'Ungrouped schemas params from)) row
400+ -- ^ row of values
425401 -> ReturningClause commons schemas params from row
426402pattern Returning_ list = Returning (List list)
427403
@@ -434,7 +410,9 @@ data ConflictClause tab commons schemas params table where
434410 OnConflictDoRaise :: ConflictClause tab commons schemas params table
435411 OnConflict
436412 :: ConflictTarget constraints
413+ -- ^ conflict target
437414 -> ConflictAction tab commons schemas params columns
415+ -- ^ conflict action
438416 -> ConflictClause tab commons schemas params (constraints :=> columns)
439417
440418-- | Render a `ConflictClause`.
@@ -445,6 +423,17 @@ instance SOP.SListI (TableToColumns table)
445423 OnConflict target action -> " ON CONFLICT"
446424 <+> renderSQL target <+> renderSQL action
447425
426+{- |
427+`ConflictAction` specifies an alternative `OnConflict` action.
428+It can be either `DoNothing`, or a `DoUpdate` clause specifying
429+the exact details of the `update` action to be performed in case of a conflict.
430+The `Set` and WHERE `Condition`s in `OnConflict` `DoUpdate` have access to the
431+existing row using the table's name (or an alias), and to rows proposed
432+for insertion using the special @#excluded@ table.
433+`OnConflict` `DoNothing` simply avoids inserting a row as its alternative action.
434+`OnConflict` `DoUpdate` updates the existing row that conflicts
435+with the row proposed for insertion as its alternative action.
436+-}
448437data ConflictAction tab commons schemas params columns where
449438 DoNothing :: ConflictAction tab commons schemas params columns
450439 DoUpdate
@@ -453,8 +442,9 @@ data ConflictAction tab commons schemas params columns where
453442 , columns ~ (col0 ': cols)
454443 , SOP.All (HasIn columns) subcolumns
455444 , AllUnique subcolumns )
456− => NP (ColumnExpression 'Ungrouped schemas params '[tab ::: row, "excluded" ::: row]) subcolumns
445+ => NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[tab ::: row, "excluded" ::: row]))) subcolumns
457446 -> [Condition '[] commons 'Ungrouped schemas params '[tab ::: row, "excluded" ::: row]]
447+ -- ^ WHERE `Condition`s
458448 -> ConflictAction tab commons schemas params columns
459449
460450instance RenderSQL (ConflictAction tab commons schemas params columns) where
@@ -462,11 +452,17 @@ instance RenderSQL (ConflictAction tab commons schemas params columns) where
462452 DoNothing -> "DO NOTHING"
463453 DoUpdate updates whs'
464454 -> "DO UPDATE SET"
465− <+> renderCommaSeparated renderSQL updates
455+ <+> renderCommaSeparated renderUpdate updates
466456 <> case whs' of
467457 [] -> ""
468458 wh:whs -> " WHERE" <+> renderSQL (foldr (.&&) wh whs)
469459
460+renderUpdate
461+ :: (forall x. RenderSQL (expr x))
462+ => Aliased (Optional expr) ty
463+ -> ByteString
464+renderUpdate (expr `As` col) = renderSQL col <+> "=" <+> renderSQL expr
465+
470466-- | A `ConflictTarget` specifies the constraint violation that triggers a
471467-- `ConflictAction`.
472468data ConflictTarget constraints where
@@ -489,7 +485,6 @@ UPDATE statements
489485update
490486 :: ( SOP.SListI columns
491487 , SOP.SListI row1
492− , db ~ (commons :=> schemas)
493488 , Has sch schemas schema
494489 , Has tab schema ('Table table)
495490 , row0 ~ TableToRow table
@@ -497,7 +492,7 @@ update
497492 , SOP.All (HasIn columns) subcolumns
498493 , AllUnique subcolumns )
499494 => QualifiedAlias sch tab -- ^ table to update
500− -> NP (ColumnExpression 'Ungrouped schemas params '[tab ::: row0]) subcolumns
495+ -> NP (Aliased (Optional (Expression '[] '[] 'Ungrouped schemas params '[tab ::: row0]))) subcolumns
501496 -- ^ modified values to replace old values
502497 -> Condition '[] commons 'Ungrouped schemas params '[tab ::: row0]
503498 -- ^ condition under which to perform update on a row
@@ -507,14 +502,13 @@ update tab columns wh returning = UnsafeManipulation $
507502 "UPDATE"
508503 <+> renderSQL tab
509504 <+> "SET"
510− <+> renderCommaSeparated renderSQL columns
505+ <+> renderCommaSeparated renderUpdate columns
511506 <+> "WHERE" <+> renderSQL wh
512507 <> renderSQL returning
513508
514509-- | Update a row returning `Nil`.
515510update_
516511 :: ( SOP.SListI columns
517− , db ~ (commons :=> schemas)
518512 , Has sch schemas schema
519513 , Has tab schema ('Table table)
520514 , row ~ TableToRow table
@@ -522,7 +516,7 @@ update_
522516 , SOP.All (HasIn columns) subcolumns
523517 , AllUnique subcolumns )
524518 => QualifiedAlias sch tab -- ^ table to update
525− -> NP (ColumnExpression 'Ungrouped schemas params '[tab ::: row]) subcolumns
519+ -> NP (Aliased (Optional (Expression '[] '[] 'Ungrouped schemas params '[tab ::: row]))) subcolumns
526520 -- ^ modified values to replace old values
527521 -> Condition '[] commons 'Ungrouped schemas params '[tab ::: row]
528522 -- ^ condition under which to perform update on a row
@@ -533,16 +527,25 @@ update_ tab columns wh = update tab columns wh (Returning_ Nil)
533527DELETE statements
534528-----------------------------------------}
535529
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.
536539data UsingClause commons schemas params from where
537540 NoUsing :: UsingClause commons schemas params '[]
538541 Using
539542 :: FromClause '[] commons schemas params from
543+ -- ^ what to use
540544 -> UsingClause commons schemas params from
541545
542546-- | Delete rows from a table.
543547deleteFrom
544548 :: ( SOP.SListI row1
545− , db ~ (commons :=> schemas)
546549 , Has sch schemas schema
547550 , Has tab schema ('Table table)
548551 , row0 ~ TableToRow table
@@ -564,8 +567,7 @@ deleteFrom tab using wh returning = UnsafeManipulation $
564567
565568-- | Delete rows returning `Nil`.
566569deleteFrom_
567− :: ( db ~ (commons :=> schemas)
568− , Has sch schemas schema
570+ :: ( Has sch schemas schema
569571 , Has tab schema ('Table table)
570572 , row ~ TableToRow table
571573 , columns ~ TableToColumns table )
squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs+32−18
@@ -66,7 +66,7 @@ let
6666 }
6767:}
6868
69−Now that we have a couple migrations we can chain them together into an `AlignedList`.
69+Now that we have a couple migrations we can chain them together into a `Path`.
7070
7171>>> let migrations = makeUsers :>> makeEmails :>> Done
7272
@@ -164,7 +164,21 @@ import qualified Data.Text.IO as Text (putStrLn)
164164import qualified Generics.SOP as SOP
165165import qualified GHC.Generics as GHC
166166
167−import Squeal.PostgreSQL
167+import Squeal.PostgreSQL.Alias
168+import Squeal.PostgreSQL.Binary
169+import Squeal.PostgreSQL.Definition
170+import Squeal.PostgreSQL.Definition.Table
171+import Squeal.PostgreSQL.Definition.Table.Constraint
172+import Squeal.PostgreSQL.Expression.Comparison
173+import Squeal.PostgreSQL.Expression.Parameter
174+import Squeal.PostgreSQL.Expression.Time
175+import Squeal.PostgreSQL.Expression.Type
176+import Squeal.PostgreSQL.List
177+import Squeal.PostgreSQL.Manipulation
178+import Squeal.PostgreSQL.PQ
179+import Squeal.PostgreSQL.Query
180+import Squeal.PostgreSQL.Schema
181+import Squeal.PostgreSQL.Transaction
168182
169183-- | A `Migration` is a named "isomorphism" over a given category.
170184-- It should contain an inverse pair of `up` and `down`
@@ -178,34 +192,34 @@ data Migration p schemas0 schemas1 = Migration
178192
179193{- |
180194A `Migratory` @p@ is a `Category` for which one can execute or rewind
181−an `AlignedList` of `Migration`s over @p@. This includes the category of pure
195+a `Path` of `Migration`s over @p@. This includes the category of pure
182196SQL `Definition`s and the category of impure `Terminally` `PQ` `IO` actions.
183197-}
184198class Category p => Migratory p where
185199
186200 {- |
187− Run an `AlignedList` of `Migration`s.
201+ Run a `Path` of `Migration`s.
188202 Create the `MigrationsTable` as @public.schema_migrations@ if it does not already exist.
189203 In one transaction, for each each `Migration` query to see if the `Migration` has been executed;
190204 if not, `up` the `Migration` and insert its `name` in the `MigrationsTable`.
191205 -}
192206 migrateUp
193− :: AlignedList (Migration p) schemas0 schemas1
207+ :: Path (Migration p) schemas0 schemas1
194208 -> PQ schemas0 schemas1 IO ()
195209
196210 {- |
197− Rewind an `AlignedList` of `Migration`s.
211+ Rewind a `Path` of `Migration`s.
198212 Create the `MigrationsTable` as @public.schema_migrations@ if it does not already exist.
199213 In one transaction, for each each `Migration` query to see if the `Migration` has been executed;
200214 if so, `down` the `Migration` and delete its `name` in the `MigrationsTable`.
201215 -}
202216 migrateDown
203− :: AlignedList (Migration p) schemas0 schemas1
217+ :: Path (Migration p) schemas0 schemas1
204218 -> PQ schemas1 schemas0 IO ()
205219
206220instance Migratory Definition where
207− migrateUp = migrateUp . mapAligned pureMigration
208− migrateDown = migrateDown . mapAligned pureMigration
221+ migrateUp = migrateUp . cmap pureMigration
222+ migrateDown = migrateDown . cmap pureMigration
209223
210224{- | `Terminally` turns an indexed monad transformer and the monad it transforms
211225into a category by restricting the return type to @()@ and permuting the type variables.
@@ -237,8 +251,8 @@ terminally = Terminally . void
237251-- | A `pureMigration` turns a `Migration` involving only pure SQL
238252-- `Definition`s into a `Migration` that may be combined with arbitrary `IO`.
239253pureMigration
240− :: Migration Definition schema0 schema1
241− -> Migration (Terminally PQ IO) schema0 schema1
254+ :: Migration Definition schemas0 schemas1
255+ -> Migration (Terminally PQ IO) schemas0 schemas1
242256pureMigration migration = Migration
243257 { name = name migration
244258 , up = terminally . define $ up migration
@@ -254,7 +268,7 @@ instance Migratory (Terminally PQ IO) where
254268 where
255269
256270 upMigrations
257− :: AlignedList (Migration (Terminally PQ IO)) schemas0 schemas1
271+ :: Path (Migration (Terminally PQ IO)) schemas0 schemas1
258272 -> PQ MigrationsSchemas MigrationsSchemas IO ()
259273 upMigrations = \case
260274 Done -> return ()
@@ -283,7 +297,7 @@ instance Migratory (Terminally PQ IO) where
283297 where
284298
285299 downMigrations
286− :: AlignedList (Migration (Terminally PQ IO)) schemas0 schemas1
300+ :: Path (Migration (Terminally PQ IO)) schemas0 schemas1
287301 -> PQ MigrationsSchemas MigrationsSchemas IO ()
288302 downMigrations = \case
289303 Done -> return ()
@@ -339,7 +353,7 @@ createMigrations =
339353-- the time at which it was inserted.
340354insertMigration :: Manipulation_ MigrationsSchemas (Only Text) ()
341355insertMigration = insertInto_ #schema_migrations
342− (Values_ ((param @1) `as` #name :* defaultAs #executed_at))
356+ (Values_ (Set (param @1) `as` #name :* Default `as` #executed_at))
343357
344358-- | Deletes a `Migration` from the `MigrationsTable`, returning
345359-- the time at which it was inserted.
@@ -349,8 +363,8 @@ deleteMigration = deleteFrom_ #schema_migrations (#name .== param @1)
349363-- | Selects a `Migration` from the `MigrationsTable`, returning
350364-- the time at which it was inserted.
351365selectMigration
352− :: Query_ MigrationsSchemas (Only Text) (P ("executed_at" ::: UTCTime))
353−selectMigration = select_ #executed_at
366+ :: Query_ MigrationsSchemas (Only Text) (Only UTCTime)
367+selectMigration = select_ (#executed_at `as` #fromOnly)
354368 $ from (table (#schema_migrations))
355369 & where_ (#name .== param @1)
356370
@@ -370,7 +384,7 @@ defaultMain
370384 :: Migratory p
371385 => ByteString
372386 -- ^ connection string
373− -> AlignedList (Migration p) db0 db1
387+ -> Path (Migration p) db0 db1
374388 -- ^ migrations
375389 -> IO ()
376390defaultMain connectTo migrations = do
@@ -391,7 +405,7 @@ defaultMain connectTo migrations = do
391405 migrateStatus :: PQ schema schema IO ()
392406 migrateStatus = unsafePQ $ do
393407 runNames <- getRunMigrationNames
394− let names = extractList name migrations
408+ let names = ctoList name migrations
395409 unrunNames = names \\ runNames
396410 liftIO $ displayRunned runNames >> displayUnrunned unrunNames
397411
squeal-postgresql/src/Squeal/PostgreSQL/PG.hs+41−42
@@ -10,18 +10,20 @@ Stability: experimental
1010-}
1111{-# LANGUAGE
1212 AllowAmbiguousTypes
13+ , DeriveAnyClass
1314 , DeriveFoldable
1415 , DeriveFunctor
1516 , DeriveGeneric
1617 , DeriveTraversable
18+ , DerivingStrategies
1719 , DefaultSignatures
1820 , FlexibleContexts
1921 , FlexibleInstances
2022 , FunctionalDependencies
2123 , GADTs
2224 , LambdaCase
23− , OverloadedStrings
2425 , MultiParamTypeClasses
26+ , OverloadedStrings
2527 , ScopedTypeVariables
2628 , TypeApplications
2729 , TypeFamilies
@@ -45,7 +47,7 @@ module Squeal.PostgreSQL.PG
4547 , Enumerated (..)
4648 , VarArray (..)
4749 , FixArray (..)
48− , SOP.P (..)
50+ , LibPQ.Oid (..)
4951 -- * Type families
5052 , LabelsPG
5153 , DimPG
@@ -64,7 +66,6 @@ import Data.Int (Int16, Int32, Int64)
6466import Data.Scientific (Scientific)
6567import Data.Time (Day, DiffTime, LocalTime, TimeOfDay, TimeZone, UTCTime)
6668import Data.Vector (Vector)
67−import Data.Word (Word16, Word32, Word64)
6869import Data.UUID.Types (UUID)
6970import GHC.TypeLits
7071import Network.IP.Addr (NetAddr, IP)
@@ -73,13 +74,13 @@ import qualified Data.ByteString.Lazy as Lazy (ByteString)
7374import qualified Data.ByteString as Strict (ByteString)
7475import qualified Data.Text.Lazy as Lazy (Text)
7576import qualified Data.Text as Strict (Text)
77+import qualified Database.PostgreSQL.LibPQ as LibPQ
7678import qualified GHC.Generics as GHC
7779import qualified Generics.SOP as SOP
7880import qualified Generics.SOP.Record as SOP
7981import qualified Generics.SOP.Type.Metadata as Type
8082
8183import Squeal.PostgreSQL.Alias
82−import Squeal.PostgreSQL.List
8384import Squeal.PostgreSQL.Schema
8485
8586-- $setup
@@ -107,11 +108,7 @@ type instance PG Int32 = 'PGint4
107108-- | `PGint8`
108109type instance PG Int64 = 'PGint8
109110-- | `PGint2`
110−type instance PG Word16 = 'PGint2
111−-- | `PGint4`
112−type instance PG Word32 = 'PGint4
113−-- | `PGint8`
114−type instance PG Word64 = 'PGint8
111+type instance PG LibPQ.Oid = 'PGoid
115112-- | `PGnumeric`
116113type instance PG Scientific = 'PGnumeric
117114-- | `PGfloat4`
@@ -175,37 +172,22 @@ have `SOP.Generic` and `SOP.HasDatatypeInfo` instances;
175172>>> :kind! RowPG Person
176173RowPG Person :: [(Symbol, NullityType)]
177174= '["name" ::: 'NotNull 'PGtext, "age" ::: 'NotNull 'PGint4]
178−
179−Or to tuples of `SOP.P` types;
180−
181−>>> :kind! RowPG (SOP.P ("id" ::: Int32), SOP.P ("foreign_id" ::: Int32))
182−RowPG (SOP.P ("id" ::: Int32), SOP.P ("foreign_id" ::: Int32)) :: [(Symbol,
183− NullityType)]
184−= '[ '("id", 'NotNull 'PGint4), "foreign_id" ::: 'NotNull 'PGint4]
185−
186−Or to tuples which mix `SOP.P` types and record types.
187−
188−>>> :kind! RowPG (SOP.P ("id" ::: Int32), Person, SOP.P ("foreign_id" ::: Int32))
189−RowPG (SOP.P ("id" ::: Int32), Person, SOP.P ("foreign_id" ::: Int32)) :: [(Symbol,
190− NullityType)]
191−= '[ '("id", 'NotNull 'PGint4), '("name", 'NotNull 'PGtext),
192− '("age", 'NotNull 'PGint4), "foreign_id" ::: 'NotNull 'PGint4]
193175-}
194176type family RowPG (hask :: Type) :: RowType where
195− RowPG (hask1, hask2) = Join (RowPG hask1) (RowPG hask2)
196− RowPG (hask1, hask2, hask3) =
197− Join (RowPG hask1) (RowPG (hask2, hask3))
198− RowPG (hask1, hask2, hask3, hask4) =
199− Join (RowPG hask1) (RowPG (hask2, hask3, hask4))
200− RowPG (hask1, hask2, hask3, hask4, hask5) =
201− Join (RowPG hask1) (RowPG (hask2, hask3, hask4, hask5))
202− RowPG (SOP.P (col ::: ty)) = '[col ::: NullPG ty]
203177 RowPG hask = RowOf (SOP.RecordCodeOf hask)
204178
205179-- | `RowOf` applies `NullPG` to the fields of a list.
206180type family RowOf (record :: [(Symbol, Type)]) :: RowType where
207− RowOf '[] = '[]
181+ RowOf (col ::: ty ': col1 ::: ty1 ': col2 ::: ty2 ': col3 ::: ty3 ': col4 ::: ty4 ': record) =
182+ col ::: NullPG ty ': col1 ::: NullPG ty1 ': col2 ::: NullPG ty2 ': col3 ::: NullPG ty3 ': col4 ::: NullPG ty4 ': RowOf record
183+ RowOf (col ::: ty ': col1 ::: ty1 ': col2 ::: ty2 ': col3 ::: ty3 ': record) =
184+ col ::: NullPG ty ': col1 ::: NullPG ty1 ': col2 ::: NullPG ty2 ': col3 ::: NullPG ty3 ': RowOf record
185+ RowOf (col ::: ty ': col1 ::: ty1 ': col2 ::: ty2 ': record) =
186+ col ::: NullPG ty ': col1 ::: NullPG ty1 ': col2 ::: NullPG ty2 ': RowOf record
187+ RowOf (col ::: ty ': col1 ::: ty1 ': record) =
188+ col ::: NullPG ty ': col1::: NullPG ty1 ': RowOf record
208189 RowOf (col ::: ty ': record) = col ::: NullPG ty ': RowOf record
190+ RowOf '[] = '[]
209191
210192{- | `NullPG` turns a Haskell type into a `NullityType`.
211193
@@ -232,8 +214,17 @@ type family TuplePG (hask :: Type) :: [NullityType] where
232214
233215-- | `TupleOf` turns a list of Haskell `Type`s into a list of `NullityType`s.
234216type family TupleOf (tuple :: [Type]) :: [NullityType] where
235− TupleOf '[] = '[]
217+ TupleOf (hask ': hask1 ': hask2 ': hask3 ': hask4 ': hask5 ': tuple) =
218+ NullPG hask ': NullPG hask1 ': NullPG hask2 ': NullPG hask3 ': NullPG hask4 ': NullPG hask5 ': TupleOf tuple
219+ TupleOf (hask ': hask1 ': hask2 ': hask3 ': hask4 ': tuple) =
220+ NullPG hask ': NullPG hask1 ': NullPG hask2 ': NullPG hask3 ': NullPG hask4 ': TupleOf tuple
221+ TupleOf (hask ': hask1 ': hask2 ': hask3 ': tuple) =
222+ NullPG hask ': NullPG hask1 ': NullPG hask2 ': NullPG hask3 ': TupleOf tuple
223+ TupleOf (hask ': hask1 ': hask2 ': tuple) =
224+ NullPG hask ': NullPG hask1 ': NullPG hask2 ': TupleOf tuple
225+ TupleOf (hask ': hask1 ': tuple) = NullPG hask ': NullPG hask1 ': TupleOf tuple
236226 TupleOf (hask ': tuple) = NullPG hask ': TupleOf tuple
227+ TupleOf '[] = '[]
237228
238229-- | `TupleCodeOf` takes the `SOP.Code` of a haskell `Type`
239230-- and if it's a simple product returns it, otherwise giving a `TypeError`.
@@ -320,7 +311,7 @@ let
320311>>> let input = Only (Money 20020)
321312
322313>>> :{
323−void . withConnection "host=localhost port=5432 dbname=exampledb" $ do
314+withConnection "host=localhost port=5432 dbname=exampledb" $ do
324315 result <- runQueryParams roundTrip input
325316 Just output <- firstRow result
326317 liftIO . print $ input == output
@@ -328,7 +319,8 @@ void . withConnection "host=localhost port=5432 dbname=exampledb" $ do
328319True
329320-}
330321newtype Money = Money { cents :: Int64 }
331− deriving (Eq, Ord, Show, Read, GHC.Generic)
322+ deriving stock (Eq, Ord, Show, Read, GHC.Generic)
323+ deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
332324-- | `PGmoney`
333325type instance PG Money = 'PGmoney
334326
@@ -336,7 +328,8 @@ type instance PG Money = 'PGmoney
336328type it's applied to should be stored as a `PGjson`.
337329-}
338330newtype Json hask = Json {getJson :: hask}
339− deriving (Eq, Ord, Show, Read, GHC.Generic)
331+ deriving stock (Eq, Ord, Show, Read, GHC.Generic)
332+ deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
340333-- | `PGjson`
341334type instance PG (Json hask) = 'PGjson
342335
@@ -344,7 +337,8 @@ type instance PG (Json hask) = 'PGjson
344337type it's applied to should be stored as a `PGjsonb`.
345338-}
346339newtype Jsonb hask = Jsonb {getJsonb :: hask}
347− deriving (Eq, Ord, Show, Read, GHC.Generic)
340+ deriving stock (Eq, Ord, Show, Read, GHC.Generic)
341+ deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
348342-- | `PGjsonb`
349343type instance PG (Jsonb hask) = 'PGjsonb
350344
@@ -352,7 +346,8 @@ type instance PG (Jsonb hask) = 'PGjsonb
352346type it's applied to should be stored as a `PGcomposite`.
353347-}
354348newtype Composite record = Composite {getComposite :: record}
355− deriving (Eq, Ord, Show, Read, GHC.Generic)
349+ deriving stock (Eq, Ord, Show, Read, GHC.Generic)
350+ deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
356351-- | `PGcomposite` @(@`RowPG` @hask)@
357352type instance PG (Composite hask) = 'PGcomposite (RowPG hask)
358353
@@ -360,7 +355,8 @@ type instance PG (Composite hask) = 'PGcomposite (RowPG hask)
360355type it's applied to should be stored as a `PGenum`.
361356-}
362357newtype Enumerated enum = Enumerated {getEnumerated :: enum}
363− deriving (Eq, Ord, Show, Read, GHC.Generic)
358+ deriving stock (Eq, Ord, Show, Read, GHC.Generic)
359+ deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
364360-- | `PGenum` @(@`LabelsPG` @hask)@
365361type instance PG (Enumerated hask) = 'PGenum (LabelsPG hask)
366362
@@ -372,9 +368,11 @@ PG (VarArray (Vector Double)) :: PGType
372368= 'PGvararray ('NotNull 'PGfloat8)
373369-}
374370newtype VarArray arr = VarArray {getVarArray :: arr}
375− deriving (Eq, Ord, Show, Read, GHC.Generic)
371+ deriving stock (Eq, Ord, Show, Read, GHC.Generic)
372+ deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
376373-- | `PGvararray` @(@`NullPG` @hask)@
377374type instance PG (VarArray (Vector hask)) = 'PGvararray (NullPG hask)
375+type instance PG (VarArray [hask]) = 'PGvararray (NullPG hask)
378376
379377{- | The `FixArray` newtype is an indication that the Haskell
380378type it's applied to should be stored as a `PGfixarray`.
@@ -384,6 +382,7 @@ PG (FixArray ((Double, Double), (Double, Double))) :: PGType
384382= 'PGfixarray '[2, 2] ('NotNull 'PGfloat8)
385383-}
386384newtype FixArray arr = FixArray {getFixArray :: arr}
387− deriving (Eq, Ord, Show, Read, GHC.Generic)
385+ deriving stock (Eq, Ord, Show, Read, GHC.Generic)
386+ deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
388387-- | `PGfixarray` @(@`DimPG` @hask) (@`FixPG` @hask)@
389388type instance PG (FixArray hask) = 'PGfixarray (DimPG hask) (FixPG hask)
squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs+52−20
@@ -68,15 +68,17 @@ module Squeal.PostgreSQL.PQ
6868 , okResult
6969 , catchSqueal
7070 , handleSqueal
71+ , trySqueal
7172 ) where
7273
7374import Control.Exception (Exception, throw)
7475import Control.Monad.Except
7576import Control.Monad.Morph
76−import UnliftIO (MonadUnliftIO (..), bracket, catch, handle)
77+import UnliftIO (MonadUnliftIO (..), bracket, catch, handle, try)
7778import Data.ByteString (ByteString)
7879import Data.Foldable
7980import Data.Function ((&))
81+import Data.Functor ((<&>))
8082import Data.Kind
8183import Data.Text (pack, Text)
8284import Data.Traversable
@@ -85,6 +87,7 @@ import PostgreSQL.Binary.Encoding (encodingBytes)
8587
8688import qualified Control.Monad.Fail as Fail
8789import qualified Database.PostgreSQL.LibPQ as LibPQ
90+import qualified PostgreSQL.Binary.Encoding as Encoding
8891
8992import Squeal.PostgreSQL.Binary
9093import Squeal.PostgreSQL.Definition
@@ -314,13 +317,13 @@ a default instance.
314317-}
315318class Monad pq => MonadPQ schemas pq | pq -> schemas where
316319 manipulateParams
317− :: ToParams x params
320+ :: (ToParams x params, All OidOfParam params)
318321 => Manipulation '[] schemas params ys
319322 -- ^ `insertInto`, `update` or `deleteFrom`
320323 -> x -> pq (K LibPQ.Result ys)
321324 default manipulateParams
322325 :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)
323− => ToParams x params
326+ => (ToParams x params, All OidOfParam params)
324327 => Manipulation '[] schemas params ys
325328 -- ^ `insertInto`, `update` or `deleteFrom`
326329 -> x -> pq (K LibPQ.Result ys)
@@ -328,7 +331,7 @@ class Monad pq => MonadPQ schemas pq | pq -> schemas where
328331 manipulateParams manipulation params
329332
330333 manipulateParams_
331− :: ToParams x params
334+ :: (ToParams x params, All OidOfParam params)
332335 => Manipulation '[] schemas params '[]
333336 -- ^ `insertInto`, `update` or `deleteFrom`
334337 -> x -> pq ()
@@ -341,7 +344,7 @@ class Monad pq => MonadPQ schemas pq | pq -> schemas where
341344 manipulate_ = void . manipulate
342345
343346 runQueryParams
344− :: ToParams x params
347+ :: (ToParams x params, All OidOfParam params)
345348 => Query '[] '[] schemas params ys
346349 -- ^ `select` and friends
347350 -> x -> pq (K LibPQ.Result ys)
@@ -354,19 +357,19 @@ class Monad pq => MonadPQ schemas pq | pq -> schemas where
354357 runQuery q = runQueryParams q ()
355358
356359 traversePrepared
357− :: (ToParams x params, Traversable list)
360+ :: (ToParams x params, Traversable list, All OidOfParam params)
358361 => Manipulation '[] schemas params ys
359362 -- ^ `insertInto`, `update`, or `deleteFrom`, and friends
360363 -> list x -> pq (list (K LibPQ.Result ys))
361364 default traversePrepared
362365 :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)
363− => (ToParams x params, Traversable list)
366+ => (ToParams x params, Traversable list, All OidOfParam params)
364367 => Manipulation '[] schemas params ys -> list x -> pq (list (K LibPQ.Result ys))
365368 traversePrepared manipulation params = lift $
366369 traversePrepared manipulation params
367370
368371 forPrepared
369− :: (ToParams x params, Traversable list)
372+ :: (ToParams x params, Traversable list, All OidOfParam params)
370373 => list x
371374 -> Manipulation '[] schemas params ys
372375 -- ^ `insertInto`, `update` or `deleteFrom`
@@ -374,13 +377,13 @@ class Monad pq => MonadPQ schemas pq | pq -> schemas where
374377 forPrepared = flip traversePrepared
375378
376379 traversePrepared_
377− :: (ToParams x params, Foldable list)
380+ :: (ToParams x params, Foldable list, All OidOfParam params)
378381 => Manipulation '[] schemas params '[]
379382 -- ^ `insertInto`, `update` or `deleteFrom`
380383 -> list x -> pq ()
381384 default traversePrepared_
382385 :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)
383− => (ToParams x params, Foldable list)
386+ => (ToParams x params, Foldable list, All OidOfParam params)
384387 => Manipulation '[] schemas params '[]
385388 -- ^ `insertInto`, `update` or `deleteFrom`
386389 -> list x -> pq ()
@@ -388,7 +391,7 @@ class Monad pq => MonadPQ schemas pq | pq -> schemas where
388391 traversePrepared_ manipulation params
389392
390393 forPrepared_
391− :: (ToParams x params, Foldable list)
394+ :: (ToParams x params, Foldable list, All OidOfParam params)
392395 => list x
393396 -> Manipulation '[] schemas params '[]
394397 -- ^ `insertInto`, `update` or `deleteFrom`
@@ -408,9 +411,17 @@ instance (MonadIO io, schemas0 ~ schemas, schemas1 ~ schemas)
408411 (UnsafeManipulation q :: Manipulation '[] schemas ps ys) (params :: x) =
409412 PQ $ \ (K conn) -> do
410413 let
411− toParam' encoding =
412− (LibPQ.invalidOid, encodingBytes encoding, LibPQ.Binary)
413− params' = fmap (fmap toParam') (hcollapse (toParams @x @ps params))
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
414425 q' = q <> ";"
415426 resultMaybe <- liftIO $ LibPQ.execParams conn q' params' LibPQ.Binary
416427 case resultMaybe of
@@ -423,15 +434,22 @@ instance (MonadIO io, schemas0 ~ schemas, schemas1 ~ schemas)
423434 traversePrepared
424435 (UnsafeManipulation q :: Manipulation '[] schemas xs ys) (list :: list x) =
425436 PQ $ \ (K conn) -> liftIO $ do
426− let temp = "temporary_statement"
427− prepResultMaybe <- LibPQ.prepare conn temp q Nothing
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')
428446 case prepResultMaybe of
429447 Nothing -> throw $ ResultException
430448 "traversePrepared: LibPQ.prepare returned no results"
431449 Just prepResult -> okResult_ prepResult
432450 results <- for list $ \ params -> do
433451 let
434− toParam' encoding = (encodingBytes encoding,LibPQ.Binary)
452+ toParam' encoding = (encodingBytes encoding, LibPQ.Binary)
435453 params' = fmap (fmap toParam') (hcollapse (toParams @x @xs params))
436454 resultMaybe <- LibPQ.execPrepared conn temp params' LibPQ.Binary
437455 case resultMaybe of
@@ -450,8 +468,15 @@ instance (MonadIO io, schemas0 ~ schemas, schemas1 ~ schemas)
450468 traversePrepared_
451469 (UnsafeManipulation q :: Manipulation '[] schemas xs '[]) (list :: list x) =
452470 PQ $ \ (K conn) -> liftIO $ do
453− let temp = "temporary_statement"
454− prepResultMaybe <- LibPQ.prepare conn temp q Nothing
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')
455480 case prepResultMaybe of
456481 Nothing -> throw $ ResultException
457482 "traversePrepared_: LibPQ.prepare returned no results"
@@ -659,7 +684,7 @@ okResult_ result = liftIO $ do
659684 msg <- LibPQ.resultErrorMessage result
660685 throw . PQException $ PQState status stateCode msg
661686
662−-- | Check if a `Result`'s status is either `LibPQ.CommandOk`
687+-- | Check if a `LibPQ.Result`'s status is either `LibPQ.CommandOk`
663688-- or `LibPQ.TuplesOk` otherwise `throw` a `PQException`.
664689okResult :: MonadIO io => K LibPQ.Result row -> io ()
665690okResult = okResult_ . unK
@@ -678,3 +703,10 @@ handleSqueal
678703 => (SquealException -> io a) -- ^ handler
679704 -> io a -> io a
680705handleSqueal = 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+67−99
@@ -1,11 +1,33 @@
11{-|
2−Module: Squeal.PostgreSQL.Definition
3−Description: Pooled connections
2+Module: Squeal.PostgreSQL.Pool
3+Description: Connection pools
44Copyright: (c) Eitan Chatav, 2017
55Maintainer: eitan@morphism.tech
66Stability: experimental
77
8−A `MonadPQ` for pooled connections.
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
931-}
1032
1133{-# LANGUAGE
@@ -23,51 +45,19 @@ A `MonadPQ` for pooled connections.
2345
2446module Squeal.PostgreSQL.Pool
2547 ( -- * Pools
26− PoolPQ (..)
48+ Pool
2749 , createConnectionPool
28− , Pool
29− , destroyAllResources
50+ , usingConnectionPool
51+ , destroyConnectionPool
3052 ) where
3153
32−import Control.Monad.Trans
3354import Data.ByteString
3455import Data.Time
35−import Generics.SOP (K(..))
56+import Generics.SOP (K(..), unK)
3657import UnliftIO (MonadUnliftIO (..))
3758import UnliftIO.Pool (Pool, createPool, destroyAllResources, withResource)
3859
39−import qualified Control.Monad.Fail as Fail
40−
4160import 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
7161
7262-- | Create a striped pool of connections.
7363-- 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.
@@ -92,63 +82,41 @@ createConnectionPool
9282createConnectionPool conninfo stripes idle maxResrc =
9383 createPool (connectdb conninfo) finish stripes idle maxResrc
9484
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)
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
squeal-postgresql/src/Squeal/PostgreSQL/Query.hs+214−83
@@ -32,13 +32,15 @@ Squeal queries.
3232
3333module Squeal.PostgreSQL.Query
3434 ( -- * Queries
35− Query (..)
36− , Query_
35+ Query_
36+ , Query (..)
3737 -- ** Select
3838 , select
3939 , select_
4040 , selectDistinct
4141 , selectDistinct_
42+ , selectDistinctOn
43+ , selectDistinctOn_
4244 , Selection (..)
4345 -- ** Values
4446 , values
@@ -53,6 +55,7 @@ module Squeal.PostgreSQL.Query
5355 -- ** With
5456 , With (..)
5557 , CommonTableExpression (..)
58+ , withRecursive
5659 -- * Table Expressions
5760 , TableExpression (..)
5861 , from
@@ -100,10 +103,55 @@ import Squeal.PostgreSQL.Schema
100103
101104-- $setup
102105-- >>> import Squeal.PostgreSQL
106+-- >>> import Data.Int (Int32, Int64)
107+-- >>> import Data.Monoid (Sum (..))
108+-- >>> import Data.Text (Text)
109+-- >>> import qualified Generics.SOP as SOP
103110
104111{- |
105−The process of retrieving or the command to retrieve data from a database
106−is called a `Query`. Let's see some examples of queries.
112+The process of retrieving or the command to retrieve data from
113+a database is called a `Query`.
114+
115+The general `Query` type is parameterized by
116+
117+* @outer :: FromType@ - outer scope for a correlated subquery,
118+* @commons :: FromType@ - scope for all `common` table expressions,
119+* @schemas :: SchemasType@ - scope for all `table`s and `view`s,
120+* @params :: [NullityType]@ - scope for all `Squeal.Expression.Parameter.parameter`s,
121+* @row :: RowType@ - return type of the `Query`.
122+-}
123+newtype Query
124+ (outer :: FromType)
125+ (commons :: FromType)
126+ (schemas :: SchemasType)
127+ (params :: [NullityType])
128+ (row :: RowType)
129+ = UnsafeQuery { renderQuery :: ByteString }
130+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
131+instance RenderSQL (Query outer commons schemas params row) where renderSQL = renderQuery
132+
133+{- |
134+The top level `Query_` type is parameterized by a @schemas@ `SchemasType`,
135+against which the query is type-checked, an input @parameters@ Haskell `Type`,
136+and an ouput row Haskell `Type`.
137+
138+A top-level query can be run
139+using `Squeal.PostgreSQL.PQ.runQueryParams`, or if @parameters = ()@
140+using `Squeal.PostgreSQL.PQ.runQuery`.
141+
142+Generally, @parameters@ will be a Haskell tuple or record whose entries
143+may be referenced using positional
144+`Squeal.PostgreSQL.Expression.Parameter.parameter`s and @row@ will be a
145+Haskell record, whose entries will be targeted using overloaded labels.
146+
147+Let's see some examples of queries.
148+
149+>>> :set -XDeriveAnyClass -XDerivingStrategies
150+>>> :{
151+data Row a b = Row { col1 :: a, col2 :: b }
152+ deriving stock (GHC.Generic)
153+ deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
154+:}
107155
108156simple query:
109157
@@ -111,7 +159,7 @@ simple query:
111159>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]
112160>>> :{
113161let
114− query :: Query '[] '[] (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]
162+ query :: Query_ (Public Schema) () (Row Int32 Int32)
115163 query = select Star (from (table #tab))
116164in printSQL query
117165:}
@@ -121,21 +169,21 @@ restricted query:
121169
122170>>> :{
123171let
124− query :: Query '[] '[] (Public Schema) '[] '["sum" ::: 'NotNull 'PGint4, "col1" ::: 'NotNull 'PGint4]
172+ query :: Query_ (Public Schema) () (Row Int32 Int32)
125173 query =
126− select_ ((#col1 + #col2) `as` #sum :* #col1)
174+ select_ ((#col1 + #col2) `as` #col1 :* #col1 `as` #col2)
127175 ( from (table #tab)
128176 & where_ (#col1 .> #col2)
129177 & where_ (#col2 .> 0) )
130178in printSQL query
131179:}
132−SELECT ("col1" + "col2") AS "sum", "col1" AS "col1" FROM "tab" AS "tab" WHERE (("col1" > "col2") AND ("col2" > 0))
180+SELECT ("col1" + "col2") AS "col1", "col1" AS "col2" FROM "tab" AS "tab" WHERE (("col1" > "col2") AND ("col2" > 0))
133181
134182subquery:
135183
136184>>> :{
137185let
138− query :: Query '[] '[] (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]
186+ query :: Query_ (Public Schema) () (Row Int32 Int32)
139187 query = select Star (from (subquery (select Star (from (table #tab)) `as` #sub)))
140188in printSQL query
141189:}
@@ -145,7 +193,7 @@ limits and offsets:
145193
146194>>> :{
147195let
148− query :: Query '[] '[] (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]
196+ query :: Query_ (Public Schema) () (Row Int32 Int32)
149197 query = select Star (from (table #tab) & limit 100 & offset 2 & limit 50 & offset 2)
150198in printSQL query
151199:}
@@ -155,7 +203,7 @@ parameterized query:
155203
156204>>> :{
157205let
158− query :: Query '[] '[] (Public Schema) '[ 'NotNull 'PGint4] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]
206+ query :: Query_ (Public Schema) (Only Int32) (Row Int32 Int32)
159207 query = select Star (from (table #tab) & where_ (#col1 .> param @1))
160208in printSQL query
161209:}
@@ -165,21 +213,21 @@ aggregation query:
165213
166214>>> :{
167215let
168− query :: Query '[] '[] (Public Schema) '[] '["sum" ::: 'NotNull 'PGint4, "col1" ::: 'NotNull 'PGint4 ]
216+ query :: Query_ (Public Schema) () (Row Int64 Int32)
169217 query =
170− select_ (sum_ (All #col2) `as` #sum :* #col1)
218+ select_ ((fromNull 0 (sum_ (All #col2))) `as` #col1 :* #col1 `as` #col2)
171219 ( from (table (#tab `as` #table1))
172220 & groupBy #col1
173− & having (#col1 + sum_ (Distinct #col2) .> 1) )
221+ & having (sum_ (Distinct #col2) .> 1) )
174222in printSQL query
175223:}
176−SELECT sum(ALL "col2") AS "sum", "col1" AS "col1" FROM "tab" AS "table1" GROUP BY "col1" HAVING (("col1" + sum(DISTINCT "col2")) > 1)
224+SELECT COALESCE(sum(ALL "col2"), 0) AS "col1", "col1" AS "col2" FROM "tab" AS "table1" GROUP BY "col1" HAVING (sum(DISTINCT "col2") > 1)
177225
178226sorted query:
179227
180228>>> :{
181229let
182− query :: Query '[] '[] (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]
230+ query :: Query_ (Public Schema) () (Row Int32 Int32)
183231 query = select Star (from (table #tab) & orderBy [#col1 & Asc])
184232in printSQL query
185233:}
@@ -187,14 +235,12 @@ SELECT * FROM "tab" AS "tab" ORDER BY "col1" ASC
187235
188236joins:
189237
190−>>> :set -XFlexibleContexts
191238>>> :{
192239type OrdersColumns =
193240 '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4
194− , "price" ::: 'NoDef :=> 'NotNull 'PGfloat4
195− , "customer_id" ::: 'NoDef :=> 'NotNull 'PGint4
196− , "shipper_id" ::: 'NoDef :=> 'NotNull 'PGint4
197− ]
241+ , "price" ::: 'NoDef :=> 'NotNull 'PGfloat4
242+ , "customer_id" ::: 'NoDef :=> 'NotNull 'PGint4
243+ , "shipper_id" ::: 'NoDef :=> 'NotNull 'PGint4 ]
198244:}
199245
200246>>> :{
@@ -210,22 +256,27 @@ type OrdersConstraints =
210256>>> :{
211257type OrdersSchema =
212258 '[ "orders" ::: 'Table (OrdersConstraints :=> OrdersColumns)
213− , "customers" ::: 'Table (CustomersConstraints :=> NamesColumns)
214− , "shippers" ::: 'Table (ShippersConstraints :=> NamesColumns) ]
259+ , "customers" ::: 'Table (CustomersConstraints :=> NamesColumns)
260+ , "shippers" ::: 'Table (ShippersConstraints :=> NamesColumns) ]
261+:}
262+
263+>>> :{
264+data Order = Order
265+ { price :: Float
266+ , customerName :: Text
267+ , shipperName :: Text
268+ } deriving GHC.Generic
269+instance SOP.Generic Order
270+instance SOP.HasDatatypeInfo Order
215271:}
216272
217273>>> :{
218274let
219− query :: Query '[] '[] (Public OrdersSchema)
220− '[]
221− '[ "order_price" ::: 'NotNull 'PGfloat4
222− , "customer_name" ::: 'NotNull 'PGtext
223− , "shipper_name" ::: 'NotNull 'PGtext
224− ]
275+ query :: Query_ (Public OrdersSchema) () Order
225276 query = select_
226− ( #o ! #price `as` #order_price :*
227− #c ! #name `as` #customer_name :*
228− #s ! #name `as` #shipper_name )
277+ ( #o ! #price `as` #price :*
278+ #c ! #name `as` #customerName :*
279+ #s ! #name `as` #shipperName )
229280 ( from (table (#orders `as` #o)
230281 & innerJoin (table (#customers `as` #c))
231282 (#o ! #customer_id .== #c ! #id)
@@ -233,14 +284,16 @@ let
233284 (#o ! #shipper_id .== #s ! #id)) )
234285in printSQL query
235286:}
236−SELECT "o"."price" AS "order_price", "c"."name" AS "customer_name", "s"."name" AS "shipper_name" FROM "orders" AS "o" INNER JOIN "customers" AS "c" ON ("o"."customer_id" = "c"."id") INNER JOIN "shippers" AS "s" ON ("o"."shipper_id" = "s"."id")
287+SELECT "o"."price" AS "price", "c"."name" AS "customerName", "s"."name" AS "shipperName" FROM "orders" AS "o" INNER JOIN "customers" AS "c" ON ("o"."customer_id" = "c"."id") INNER JOIN "shippers" AS "s" ON ("o"."shipper_id" = "s"."id")
237288
238289self-join:
239290
240291>>> :{
241292let
242− query :: Query '[] '[] (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]
243− query = select (#t1 & DotStar) (from (table (#tab `as` #t1) & crossJoin (table (#tab `as` #t2))))
293+ query :: Query_ (Public Schema) () (Row Int32 Int32)
294+ query = select
295+ (#t1 & DotStar)
296+ (from (table (#tab `as` #t1) & crossJoin (table (#tab `as` #t2))))
244297in printSQL query
245298:}
246299SELECT "t1".* FROM "tab" AS "t1" CROSS JOIN "tab" AS "t2"
@@ -249,17 +302,19 @@ value queries:
249302
250303>>> :{
251304let
252− query :: Query '[] commons schemas '[] '["foo" ::: 'NotNull 'PGint2, "bar" ::: 'NotNull 'PGbool]
253− query = values (1 `as` #foo :* true `as` #bar) [2 `as` #foo :* false `as` #bar]
305+ query :: Query_ schemas () (Row String Bool)
306+ query = values
307+ ("true" `as` #col1 :* true `as` #col2)
308+ ["false" `as` #col1 :* false `as` #col2]
254309in printSQL query
255310:}
256−SELECT * FROM (VALUES (1, TRUE), (2, FALSE)) AS t ("foo", "bar")
311+SELECT * FROM (VALUES (E'true', TRUE), (E'false', FALSE)) AS t ("col1", "col2")
257312
258313set operations:
259314
260315>>> :{
261316let
262− query :: Query '[] '[] (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]
317+ query :: Query_ (Public Schema) () (Row Int32 Int32)
263318 query = select Star (from (table #tab)) `unionAll` select Star (from (table #tab))
264319in printSQL query
265320:}
@@ -269,7 +324,7 @@ with queries:
269324
270325>>> :{
271326let
272− query :: Query '[] '[] (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]
327+ query :: Query_ (Public Schema) () (Row Int32 Int32)
273328 query = with (
274329 select Star (from (table #tab)) `as` #cte1 :>>
275330 select Star (from (common #cte1)) `as` #cte2
@@ -282,40 +337,35 @@ window function queries
282337
283338>>> :{
284339let
285− query :: Query '[] '[] (Public Schema) '[] ["col1" ::: 'NotNull 'PGint4, "rank" ::: 'NotNull 'PGint8]
340+ query :: Query_ (Public Schema) () (Row Int32 Int64)
286341 query = select
287− (#col1 & Also (rank `as` #rank `Over` (partitionBy #col1 & orderBy [#col2 & Asc])))
342+ (#col1 & Also (rank `as` #col2 `Over` (partitionBy #col1 & orderBy [#col2 & Asc])))
288343 (from (table #tab))
289344in printSQL query
290345:}
291−SELECT "col1" AS "col1", rank() OVER (PARTITION BY "col1" ORDER BY "col2" ASC) AS "rank" FROM "tab" AS "tab"
346+SELECT "col1" AS "col1", rank() OVER (PARTITION BY "col1" ORDER BY "col2" ASC) AS "col2" FROM "tab" AS "tab"
292347
293348correlated subqueries
294349
295350>>> :{
296351let
297− query :: Query '[] '[] (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4]
352+ query :: Query_ (Public Schema) () (Only Int32)
298353 query =
299− select #col1 (from (table (#tab `as` #t1))
354+ select (#col1 `as` #fromOnly) (from (table (#tab `as` #t1))
300355 & where_ (exists (
301356 select Star (from (table (#tab `as` #t2))
302357 & where_ (#t2 ! #col2 .== #t1 ! #col1)))))
303358in printSQL query
304359:}
305−SELECT "col1" AS "col1" FROM "tab" AS "t1" WHERE EXISTS (SELECT * FROM "tab" AS "t2" WHERE ("t2"."col2" = "t1"."col1"))
360+SELECT "col1" AS "fromOnly" FROM "tab" AS "t1" WHERE EXISTS (SELECT * FROM "tab" AS "t2" WHERE ("t2"."col2" = "t1"."col1"))
361+
306362-}
307−newtype Query
308− (outer :: FromType)
309− (commons :: FromType)
363+type family Query_
310364 (schemas :: SchemasType)
311− (params :: [NullityType])
312− (row :: RowType)
313− = UnsafeQuery { renderQuery :: ByteString }
314− deriving (GHC.Generic,Show,Eq,Ord,NFData)
315−instance RenderSQL (Query outer commons schemas params row) where renderSQL = renderQuery
316−
317−type family Query_ (schemas :: SchemasType) (params :: Type) (row :: Type) where
318− Query_ schemas params row = Query '[] '[] schemas (TuplePG params) (RowPG row)
365+ (parameters :: Type)
366+ (row :: Type) where
367+ Query_ schemas params row =
368+ Query '[] '[] schemas (TuplePG params) (RowPG row)
319369
320370-- | The results of two queries can be combined using the set operation
321371-- `union`. Duplicate rows are eliminated.
@@ -480,7 +530,7 @@ instance IsString
480530select
481531 :: (SListI row, row ~ (x ': xs))
482532 => Selection outer commons grp schemas params from row
483− -- ^ select list
533+ -- ^ selection
484534 -> TableExpression outer commons grp schemas params from
485535 -- ^ intermediate virtual table
486536 -> Query outer commons schemas params row
@@ -489,20 +539,24 @@ select selection tabexpr = UnsafeQuery $
489539 <+> renderSQL selection
490540 <+> renderSQL tabexpr
491541
542+-- | Like `select` but takes an `NP` list of `Expression`s instead
543+-- of a general `Selection`.
492544select_
493545 :: (SListI row, row ~ (x ': xs))
494546 => NP (Aliased (Expression outer commons grp schemas params from)) row
547+ -- ^ select list
495548 -> TableExpression outer commons grp schemas params from
549+ -- ^ intermediate virtual table
496550 -> Query outer commons schemas params row
497−select_ list = select (List list)
551+select_ = select . List
498552
499553-- | After the select list has been processed, the result table can
500554-- be subject to the elimination of duplicate rows using `selectDistinct`.
501555selectDistinct
502556 :: (SListI columns, columns ~ (col ': cols))
503− => Selection outer commons 'Ungrouped schemas params from columns
504− -- ^ select list
505− -> TableExpression outer commons 'Ungrouped schemas params from
557+ => Selection outer commons grp schemas params from columns
558+ -- ^ selection
559+ -> TableExpression outer commons grp schemas params from
506560 -- ^ intermediate virtual table
507561 -> Query outer commons schemas params columns
508562selectDistinct selection tabexpr = UnsafeQuery $
@@ -510,14 +564,65 @@ selectDistinct selection tabexpr = UnsafeQuery $
510564 <+> renderSQL selection
511565 <+> renderSQL tabexpr
512566
567+-- | Like `selectDistinct` but takes an `NP` list of `Expression`s instead
568+-- of a general `Selection`.
513569selectDistinct_
514570 :: (SListI columns, columns ~ (col ': cols))
515− => NP (Aliased (Expression outer commons 'Ungrouped schemas params from)) columns
571+ => NP (Aliased (Expression outer commons grp schemas params from)) columns
516572 -- ^ select list
517− -> TableExpression outer commons 'Ungrouped schemas params from
573+ -> TableExpression outer commons grp schemas params from
518574 -- ^ intermediate virtual table
519575 -> Query outer commons schemas params columns
520−selectDistinct_ list = select (List list)
576+selectDistinct_ = selectDistinct . List
577+
578+{-|
579+`selectDistinctOn` keeps only the first row of each set of rows where
580+the given expressions evaluate to equal. The DISTINCT ON expressions are
581+interpreted using the same rules as for ORDER BY. ORDER BY is used to
582+ensure that the desired row appears first.
583+
584+The DISTINCT ON expression(s) must match the leftmost ORDER BY expression(s).
585+The ORDER BY clause will normally contain additional expression(s) that
586+determine the desired precedence of rows within each DISTINCT ON group.
587+
588+In order to guarantee they match and reduce redundancy, this function
589+will prepend the The DISTINCT ON expressions to the ORDER BY clause.
590+-}
591+selectDistinctOn
592+ :: (SListI columns, columns ~ (col ': cols))
593+ => [SortExpression outer commons grp schemas params from]
594+ -- ^ DISTINCT ON expression(s) and prepended to ORDER BY clause
595+ -> Selection outer commons grp schemas params from columns
596+ -- ^ selection
597+ -> TableExpression outer commons grp schemas params from
598+ -- ^ intermediate virtual table
599+ -> Query outer commons schemas params columns
600+selectDistinctOn distincts selection tab = UnsafeQuery $
601+ "SELECT DISTINCT ON"
602+ <+> parenthesized (commaSeparated (renderDistinctOn <$> distincts))
603+ <+> renderSQL selection
604+ <+> renderSQL (tab {orderByClause = distincts <> orderByClause tab})
605+ where
606+ renderDistinctOn = \case
607+ Asc expression -> renderSQL expression
608+ Desc expression -> renderSQL expression
609+ AscNullsFirst expression -> renderSQL expression
610+ DescNullsFirst expression -> renderSQL expression
611+ AscNullsLast expression -> renderSQL expression
612+ DescNullsLast expression -> renderSQL expression
613+
614+-- | Like `selectDistinctOn` but takes an `NP` list of `Expression`s instead
615+-- of a general `Selection`.
616+selectDistinctOn_
617+ :: (SListI columns, columns ~ (col ': cols))
618+ => [SortExpression outer commons grp schemas params from]
619+ -- ^ distinct on and return the first row in ordering
620+ -> NP (Aliased (Expression outer commons grp schemas params from)) columns
621+ -- ^ selection
622+ -> TableExpression outer commons grp schemas params from
623+ -- ^ intermediate virtual table
624+ -> Query outer commons schemas params columns
625+selectDistinctOn_ distincts = selectDistinctOn distincts . List
521626
522627-- | `values` computes a row value or set of row values
523628-- specified by value expressions. It is most commonly used
@@ -652,7 +757,7 @@ instance RenderSQL (TableExpression outer commons grp schemas params from) where
652757from
653758 :: FromClause outer commons schemas params from -- ^ table reference
654759 -> TableExpression outer commons 'Ungrouped schemas params from
655−from tab = TableExpression tab [] NoGroups NoHaving [] [] []
760+from tab = TableExpression tab [] noGroups NoHaving [] [] []
656761
657762-- | A `where_` is an endomorphism of `TableExpression`s which adds a
658763-- search condition to the `whereClause`.
@@ -673,7 +778,7 @@ groupBy
673778groupBy bys rels = TableExpression
674779 { fromClause = fromClause rels
675780 , whereClause = whereClause rels
676− , groupByClause = Group bys
781+ , groupByClause = group bys
677782 , havingClause = Having []
678783 , orderByClause = []
679784 , limitClause = limitClause rels
@@ -887,19 +992,20 @@ instance (Has rel rels cols, Has col cols ty, bys ~ '[ '(rel, col)])
887992-- done on @NoGroups@ while all output `Expression`s must be aggregated
888993-- in @Group Nil@. In general, all output `Expression`s in the
889994-- complement of @bys@ must be aggregated in @Group bys@.
890−data GroupByClause grp from where
891− NoGroups :: GroupByClause 'Ungrouped from
892− Group
893− :: SListI bys
894− => NP (By from) bys
895− -> GroupByClause ('Grouped bys) from
896−
897−-- | Renders a `GroupByClause`.
995+newtype GroupByClause grp from = UnsafeGroupByClause
996+ { renderGroupByClause :: ByteString }
997+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
898998instance RenderSQL (GroupByClause grp from) where
899− renderSQL = \case
900− NoGroups -> ""
901− Group Nil -> ""
902− Group bys -> " GROUP BY" <+> renderCommaSeparated renderSQL bys
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'
9031009
9041010-- | A `HavingClause` is used to eliminate groups that are not of interest.
9051011-- An `Ungrouped` `TableExpression` may only use `NoHaving` while a `Grouped`
@@ -943,8 +1049,8 @@ instance
9431049 , commons1 ~ (cte ::: common ': commons)
9441050 ) => Aliasable cte
9451051 (statement commons schemas params common)
946− (AlignedList (CommonTableExpression statement schemas params) commons commons1) where
947− statement `as` cte = single (statement `as` cte)
1052+ (Path (CommonTableExpression statement schemas params) commons commons1) where
1053+ statement `as` cte = csingleton (statement `as` cte)
9481054
9491055instance (forall c s p r. RenderSQL (statement c s p r)) => RenderSQL
9501056 (CommonTableExpression statement schemas params commons0 commons1) where
@@ -956,7 +1062,7 @@ instance (forall c s p r. RenderSQL (statement c s p r)) => RenderSQL
9561062-- defining temporary tables that exist just for one query.
9571063class With statement where
9581064 with
959− :: AlignedList (CommonTableExpression statement schemas params) commons0 commons1
1065+ :: Path (CommonTableExpression statement schemas params) commons0 commons1
9601066 -- ^ common table expressions
9611067 -> statement commons1 schemas params row
9621068 -- ^ larger query
@@ -964,4 +1070,29 @@ class With statement where
9641070instance With (Query outer) where
9651071 with Done query = query
9661072 with ctes query = UnsafeQuery $
967− "WITH" <+> renderSQL ctes <+> renderSQL query
1073+ "WITH" <+> commaSeparated (ctoList renderSQL ctes) <+> renderSQL query
1074+
1075+{- |
1076+>>> import Data.Monoid (Sum (..))
1077+>>> import Data.Int (Int64)
1078+>>> :{
1079+ let
1080+ query :: Query_ schema () (Sum Int64)
1081+ query = withRecursive
1082+ ( values_ ((1 & astype int) `as` #n)
1083+ `unionAll`
1084+ select_ ((#n + 1) `as` #n)
1085+ (from (common #t) & where_ (#n .< 100)) `as` #t )
1086+ ( select_ (fromNull 0 (sum_ (All #n)) `as` #getSum) (from (common #t) & groupBy Nil))
1087+ in printSQL query
1088+:}
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"
1090+-}
1091+withRecursive
1092+ :: Aliased (Query outer (recursive ': commons) schemas params) recursive
1093+ -> Query outer (recursive ': commons) schemas params row
1094+ -> Query outer commons schemas params row
1095+withRecursive (recursive `As` cte) query = UnsafeQuery $
1096+ "WITH RECURSIVE" <+> renderSQL cte
1097+ <+> "AS" <+> parenthesized (renderSQL recursive)
1098+ <+> renderSQL query
squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs+161−60
@@ -44,6 +44,10 @@ module Squeal.PostgreSQL.Schema
4444 , ColumnsType
4545 , TableType
4646 , SchemumType (..)
47+ , IndexType (..)
48+ , FunctionType
49+ , OperatorType (..)
50+ , ReturnsType (..)
4751 , SchemaType
4852 , SchemasType
4953 , Public
@@ -58,15 +62,21 @@ module Squeal.PostgreSQL.Schema
5862 , PGlabel (..)
5963 -- * Data Definitions
6064 , Create
65+ , CreateIfNotExists
66+ , CreateOrReplace
6167 , Drop
68+ , DropSchemum
69+ , DropIfExists
70+ , DropSchemumIfExists
6271 , Alter
72+ , AlterIfExists
6373 , Rename
74+ , RenameIfExists
6475 , ConstraintInvolves
6576 , DropIfConstraintsInvolve
6677 , IsNotElem
6778 , AllUnique
6879 -- * Type Classifications
69− , HasOid (..)
7080 , PGNum
7181 , PGIntegral
7282 , PGFloating
@@ -90,17 +100,19 @@ import Control.Category
90100import Data.Kind
91101import Data.Monoid hiding (All)
92102import Data.Type.Bool
93−import Data.Word (Word32)
94103import Generics.SOP
95104import GHC.TypeLits
96105import Prelude hiding (id, (.))
97106
98107import Squeal.PostgreSQL.Alias
108+import Squeal.PostgreSQL.List
99109import Squeal.PostgreSQL.Render
100110
111+-- $setup
112+-- >>> import Squeal.PostgreSQL
113+
101114-- | `PGType` is the promoted datakind of PostgreSQL types.
102115--
103−-- >>> import Squeal.PostgreSQL.Schema
104116-- >>> :kind 'PGbool
105117-- 'PGbool :: PGType
106118data PGType
@@ -131,37 +143,11 @@ data PGType
131143 | PGenum [Symbol] -- ^ enumerated (enum) types are data types that comprise a static, ordered set of values.
132144 | 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.
133145 | PGtsvector -- ^ A tsvector value is a sorted list of distinct lexemes, which are words that have been normalized to merge different variants of the same word.
134− | PGtsquery -- ^ A tsquery value stores lexemes that are to be searched for
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).
135149 | UnsafePGType Symbol -- ^ an escape hatch for unsupported PostgreSQL types
136150
137−-- | The object identifier of a `PGType`.
138−--
139−-- >>> :set -XTypeApplications
140−-- >>> oid @'PGbool
141−-- 16
142−class HasOid (ty :: PGType) where oid :: Word32
143−instance HasOid 'PGbool where oid = 16
144−instance HasOid 'PGint2 where oid = 21
145−instance HasOid 'PGint4 where oid = 23
146−instance HasOid 'PGint8 where oid = 20
147−instance HasOid 'PGnumeric where oid = 1700
148−instance HasOid 'PGfloat4 where oid = 700
149−instance HasOid 'PGfloat8 where oid = 701
150−instance HasOid ('PGchar n) where oid = 18
151−instance HasOid ('PGvarchar n) where oid = 1043
152−instance HasOid 'PGtext where oid = 25
153−instance HasOid 'PGbytea where oid = 17
154−instance HasOid 'PGtimestamp where oid = 1114
155−instance HasOid 'PGtimestamptz where oid = 1184
156−instance HasOid 'PGdate where oid = 1082
157−instance HasOid 'PGtime where oid = 1083
158−instance HasOid 'PGtimetz where oid = 1266
159−instance HasOid 'PGinterval where oid = 1186
160−instance HasOid 'PGuuid where oid = 2950
161−instance HasOid 'PGinet where oid = 869
162−instance HasOid 'PGjson where oid = 114
163−instance HasOid 'PGjsonb where oid = 3802
164−
165151-- | `NullityType` encodes the potential presence or definite absence of a
166152-- @NULL@ allowing operations which are sensitive to such to be well typed.
167153--
@@ -274,9 +260,19 @@ type FromType = [(Symbol,RowType)]
274260
275261-- | `ColumnsToRow` removes column constraints.
276262type family ColumnsToRow (columns :: ColumnsType) :: RowType where
277− ColumnsToRow '[] = '[]
278− ColumnsToRow (column ::: constraint :=> ty ': columns) =
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) =
279274 column ::: ty ': ColumnsToRow columns
275+ ColumnsToRow '[] = '[]
280276
281277-- | `TableToColumns` removes table constraints.
282278type family TableToColumns (table :: TableType) :: ColumnsType where
@@ -286,15 +282,6 @@ type family TableToColumns (table :: TableType) :: ColumnsType where
286282type family TableToRow (table :: TableType) :: RowType where
287283 TableToRow tab = ColumnsToRow (TableToColumns tab)
288284
289−-- | @Elem@ is a promoted `Data.List.elem`.
290−type family Elem x xs where
291− Elem x '[] = 'False
292− Elem x (x ': xs) = 'True
293− Elem x (_ ': xs) = Elem x xs
294−
295−-- | @In x xs@ is a constraint that proves that @x@ is in @xs@.
296−type family In x xs :: Constraint where In x xs = Elem x xs ~ 'True
297−
298285-- | Numeric Postgres types.
299286type PGNum =
300287 '[ 'PGint2, 'PGint4, 'PGint8, 'PGnumeric, 'PGfloat4, 'PGfloat8]
@@ -318,14 +305,24 @@ instance ty0 ~ ty1 => SamePGType
318305
319306-- | `AllNotNull` is a constraint that proves a `ColumnsType` has no @NULL@s.
320307type 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
321314 AllNotNull '[] = ()
322− AllNotNull (column ::: def :=> 'NotNull ty ': columns) = AllNotNull columns
323315
324316-- | `NotAllNull` is a constraint that proves a `ColumnsType` has some
325317-- @NOT NULL@.
326318type family NotAllNull (columns :: ColumnsType) :: Constraint where
327− NotAllNull (column ::: def :=> 'NotNull ty ': columns) = ()
328− NotAllNull (column ::: def :=> 'Null ty ': columns) = NotAllNull columns
319+ NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()
320+ NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()
321+ NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()
322+ NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()
323+ NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()
324+ NotAllNull (_ ::: _ :=> 'NotNull _ ': _) = ()
325+ NotAllNull (_ ::: _ :=> 'Null _ ': columns) = NotAllNull columns
329326
330327-- | `NullifyType` is an idempotent that nullifies a `NullityType`.
331328type family NullifyType (ty :: NullityType) :: NullityType where
@@ -334,17 +331,37 @@ type family NullifyType (ty :: NullityType) :: NullityType where
334331
335332-- | `NullifyRow` is an idempotent that nullifies a `RowType`.
336333type family NullifyRow (columns :: RowType) :: RowType where
337− NullifyRow '[] = '[]
334+ NullifyRow (column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': column3 ::: ty3 ': column4 ::: ty4 ': column5 ::: ty5 ': columns) =
335+ column ::: NullifyType ty ': column1 ::: NullifyType ty1 ': column2 ::: NullifyType ty2 ': column3 ::: NullifyType ty3 ': column4 ::: NullifyType ty4 ': column5 ::: NullifyType ty5 ': NullifyRow columns
336+ NullifyRow (column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': column3 ::: ty3 ': column4 ::: ty4 ': columns) =
337+ column ::: NullifyType ty ': column1 ::: NullifyType ty1 ': column2 ::: NullifyType ty2 ': column3 ::: NullifyType ty3 ': column4 ::: NullifyType ty4 ': NullifyRow columns
338+ NullifyRow (column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': column3 ::: ty3 ': columns) =
339+ column ::: NullifyType ty ': column1 ::: NullifyType ty1 ': column2 ::: NullifyType ty2 ': column3 ::: NullifyType ty3 ': NullifyRow columns
340+ NullifyRow (column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': columns) =
341+ column ::: NullifyType ty ': column1 ::: NullifyType ty1 ': column2 ::: NullifyType ty2 ': NullifyRow columns
342+ NullifyRow (column ::: ty ': column1 ::: ty1 ': columns) =
343+ column ::: NullifyType ty ': column1 ::: NullifyType ty1 ': NullifyRow columns
338344 NullifyRow (column ::: ty ': columns) =
339345 column ::: NullifyType ty ': NullifyRow columns
346+ NullifyRow '[] = '[]
340347
341348-- | `NullifyFrom` is an idempotent that nullifies a `FromType`
342349-- used to nullify the left or right hand side of an outer join
343350-- in a `Squeal.PostgreSQL.Query.FromClause`.
344351type family NullifyFrom (tables :: FromType) :: FromType where
345− NullifyFrom '[] = '[]
352+ NullifyFrom (table ::: columns ': table1 ::: columns1 ': table2 ::: columns2 ': table3 ::: columns3 ': table4 ::: columns4 ': table5 ::: columns5 ': tables) =
353+ table ::: NullifyRow columns ': table1 ::: NullifyRow columns1 ': table2 ::: NullifyRow columns2 ': table3 ::: NullifyRow columns3 ': table4 ::: NullifyRow columns5 ': table5 ::: NullifyRow columns4 ': NullifyFrom tables
354+ NullifyFrom (table ::: columns ': table1 ::: columns1 ': table2 ::: columns2 ': table3 ::: columns3 ': table4 ::: columns4 ': tables) =
355+ table ::: NullifyRow columns ': table1 ::: NullifyRow columns1 ': table2 ::: NullifyRow columns2 ': table3 ::: NullifyRow columns3 ': table4 ::: NullifyRow columns4 ': NullifyFrom tables
356+ NullifyFrom (table ::: columns ': table1 ::: columns1 ': table2 ::: columns2 ': table3 ::: columns3 ': tables) =
357+ table ::: NullifyRow columns ': table1 ::: NullifyRow columns1 ': table2 ::: NullifyRow columns2 ': table3 ::: NullifyRow columns3 ': NullifyFrom tables
358+ NullifyFrom (table ::: columns ': table1 ::: columns1 ': table2 ::: columns2 ': tables) =
359+ table ::: NullifyRow columns ': table1 ::: NullifyRow columns1 ': table2 ::: NullifyRow columns2 ': NullifyFrom tables
360+ NullifyFrom (table ::: columns ': table1 ::: columns1 ': tables) =
361+ table ::: NullifyRow columns ': table1 ::: NullifyRow columns1 ': NullifyFrom tables
346362 NullifyFrom (table ::: columns ': tables) =
347363 table ::: NullifyRow columns ': NullifyFrom tables
364+ NullifyFrom '[] = '[]
348365
349366-- | @Create alias x xs@ adds @alias ::: x@ to the end of @xs@ and is used in
350367-- `Squeal.PostgreSQL.Definition.createTable` statements and in @ALTER TABLE@
@@ -354,30 +371,101 @@ type family Create alias x xs where
354371 Create alias x (alias ::: y ': xs) = TypeError
355372 ('Text "Create: alias "
356373 ':<>: 'ShowType alias
357− ':<>: 'Text "already in use")
374+ ':<>: 'Text "already exists")
358375 Create alias y (x ': xs) = x ': Create alias y xs
359376
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+
360394-- | @Drop alias xs@ removes the type associated with @alias@ in @xs@
361395-- and is used in `Squeal.PostgreSQL.Definition.dropTable` statements
362396-- and in @ALTER TABLE@ `Squeal.PostgreSQL.Definition.dropColumn` statements.
363397type family Drop alias xs where
364− Drop alias ((alias ::: x) ': xs) = xs
398+ Drop alias '[] = TypeError
399+ ('Text "Drop: alias "
400+ ':<>: 'ShowType alias
401+ ':<>: 'Text " does not exist" )
402+ Drop alias (alias ::: x ': xs) = xs
365403 Drop alias (x ': xs) = x ': Drop alias xs
366404
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+
367437-- | @Alter alias x xs@ replaces the type associated with an @alias@ in @xs@
368438-- with the type @x@ and is used in `Squeal.PostgreSQL.Definition.alterTable`
369439-- and `Squeal.PostgreSQL.Definition.alterColumn`.
370440type family Alter alias x xs where
441+ Alter alias x '[] = TypeError
442+ ('Text "Alter: alias "
443+ ':<>: 'ShowType alias
444+ ':<>: 'Text " does not exist" )
371445 Alter alias x1 (alias ::: x0 ': xs) = alias ::: x1 ': xs
372446 Alter alias x1 (x0 ': xs) = x0 ': Alter alias x1 xs
373447
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+
374453-- | @Rename alias0 alias1 xs@ replaces the alias @alias0@ by @alias1@ in @xs@
375454-- and is used in `Squeal.PostgreSQL.Definition.alterTableRename` and
376455-- `Squeal.PostgreSQL.Definition.renameColumn`.
377456type family Rename alias0 alias1 xs where
457+ Rename alias0 alias1 '[] = TypeError
458+ ('Text "Rename: alias "
459+ ':<>: 'ShowType alias0
460+ ':<>: 'Text " does not exist" )
378461 Rename alias0 alias1 ((alias0 ::: x0) ': xs) = (alias1 ::: x0) ': xs
379462 Rename alias0 alias1 (x ': xs) = x ': Rename alias0 alias1 xs
380463
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+
381469-- | Check if a `TableConstraint` involves a column
382470type family ConstraintInvolves column constraint where
383471 ConstraintInvolves column ('Check columns) = column `Elem` columns
@@ -394,22 +482,35 @@ type family DropIfConstraintsInvolve column constraints where
394482 (DropIfConstraintsInvolve column constraints)
395483 (alias ::: constraint ': DropIfConstraintsInvolve column constraints)
396484
397−{- | Calculate the `Length` of a type level list
398−
399−>>> :kind! Length '[Char,String,Bool,Double]
400−Length '[Char,String,Bool,Double] :: Nat
401−= 4
402−-}
403−type family Length (xs :: [k]) :: Nat where
404− Length (x : xs) = 1 + Length xs
405− Length '[] = 0
406−
407485-- | A `SchemumType` is a user-defined type, either a `Table`,
408486-- `View` or `Typedef`.
409487data SchemumType
410488 = Table TableType
411489 | View RowType
412490 | 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
413514
414515{- | The schema of a database consists of a list of aliased,
415516user-defined `SchemumType`s.
squeal-postgresql/src/Squeal/PostgreSQL/Transaction.hs+23
@@ -21,6 +21,8 @@ module Squeal.PostgreSQL.Transaction
2121 transactionally
2222 , transactionally_
2323 , transactionallyRetry
24+ , ephemerally
25+ , ephemerally_
2426 , begin
2527 , commit
2628 , rollback
@@ -94,6 +96,27 @@ transactionallyRetry mode tx = mask $ \restore ->
9496 throwIO err
9597 Right x -> return x
9698
99+{- | Run a computation `ephemerally`;
100+Like `transactionally` but always `rollback`, useful in testing.
101+-}
102+ephemerally
103+ :: (MonadUnliftIO tx, MonadPQ schemas tx)
104+ => TransactionMode
105+ -> tx x -- ^ run inside an ephemeral transaction
106+ -> tx x
107+ephemerally mode tx = mask $ \restore -> do
108+ manipulate_ $ begin mode
109+ result <- restore tx `onException` (manipulate_ rollback)
110+ manipulate_ rollback
111+ return result
112+
113+{- | Run a computation `ephemerally` in `defaultMode`. -}
114+ephemerally_
115+ :: (MonadUnliftIO tx, MonadPQ schemas tx)
116+ => tx x -- ^ run inside an ephemeral transaction
117+ -> tx x
118+ephemerally_ = ephemerally defaultMode
119+
97120-- | @BEGIN@ a transaction.
98121begin :: TransactionMode -> Manipulation_ schemas () ()
99122begin mode = UnsafeManipulation $ "BEGIN" <+> renderSQL mode
squeal-postgresql/src/Squeal/PostgreSQL/Tutorial.hsdeleted−39
@@ -1,39 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Tutorail
3−Description: Squeal tutorial module
4−Copyright: (c) Eitan Chatav, 2017
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−== `P` records
9−
10−A `P` record is an ad-hoc, anonymous record constructed
11−as a tuple of `P`s, a datatype from `Generics.SOP.Record`, like so:
12−
13−>>> type Rec = (P ("foo" ::: Double), P ("bar" ::: Char))
14−
15−Let's see what the image of `Rec` is under the `RowPG` type family.
16−
17−>>> :kind! RowPG Rec
18−RowPG Rec :: [(Symbol, NullityType)]
19−= '[ '("foo", 'NotNull 'PGfloat8), "bar" ::: 'NotNull ('PGchar 1)]
20−
21−`P` records are ad-hoc, anonymous records so unlike Haskell records
22−you don't have to define them outside of their use site, for instance
23−in the row type parameter of a `Query_` type family.
24−
25−>>> :{
26−let
27− query :: Query_ schemas () (P ("foo" ::: Double))
28− query = values_ (1 `as` #foo)
29−in printSQL query
30−:}
31−SELECT * FROM (VALUES (1)) AS t ("foo")
32−
33−You can even mix `P` records with normal Haskell records, which is very
34−useful for creating entity types, Haskell records with associated ids.
35−
36−>>> data Row = Row {foo :: Double, bar :: Char} deriving (GHC.Generic)
37−-}
38−
39−module Squeal.PostgreSQL.Tutorial where
squeal-postgresql/test/Doc.hsnew file+6
@@ -0,0 +1,6 @@
1+module Main (main) where
2+
3+import Test.DocTest
4+
5+main :: IO ()
6+main = doctest [ "-isrc", "src" ]
squeal-postgresql/test/DocTest.hsdeleted−18
@@ -1,18 +0,0 @@
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.hsnew file+166
@@ -0,0 +1,166 @@
1+{-# LANGUAGE
2+ DataKinds
3+ , GADTs
4+ , LambdaCase
5+ , OverloadedLabels
6+ , OverloadedStrings
7+ , TypeApplications
8+ , TypeOperators
9+#-}
10+
11+module Main (main) where
12+
13+import Control.Monad.Trans
14+import Data.ByteString (ByteString)
15+import Data.ByteString.Char8 (unpack)
16+import Data.Scientific (fromFloatDigits)
17+import Data.Fixed (Fixed(MkFixed), Micro, Pico)
18+import Data.String (IsString(fromString))
19+import Data.Time
20+import Squeal.PostgreSQL hiding (check, defaultMain, Group)
21+import Hedgehog hiding (Range)
22+import qualified Hedgehog.Gen as Gen
23+import qualified Hedgehog.Main as Main
24+import qualified Hedgehog.Range as Range
25+
26+main :: IO ()
27+main = Main.defaultMain [checkSequential roundtrips]
28+
29+roundtrips :: Group
30+roundtrips = Group "roundtrips"
31+ [ roundtrip int2 genInt16
32+ , roundtrip int4 genInt32
33+ , roundtrip int8 genInt64
34+ , roundtrip bool Gen.bool
35+ , roundtrip numeric genScientific
36+ , roundtrip float4 genFloat
37+ , roundtrip float8 genDouble
38+ , roundtripOn normalizeTimeOfDay time genTimeOfDay
39+ -- , roundtrip timetz genTimeWithZone normalizeTimeWithZone
40+ , roundtripOn normalizeLocalTime timestamp genLocalTime
41+ , roundtrip timestamptz genUTCTime
42+ , roundtrip date genDay
43+ , roundtrip interval genDiffTime
44+ , roundtripOn normalizeIntRange int4range (genRange genInt32)
45+ , roundtripOn normalizeIntRange int8range (genRange genInt64)
46+ , roundtrip numrange (genRange genScientific)
47+ , roundtripOn (fmap normalizeLocalTime) tsrange (genRange genLocalTime)
48+ , roundtrip tstzrange (genRange genUTCTime)
49+ , roundtripOn normalizeIntRange daterange (genRange genDay)
50+ ]
51+ where
52+ genInt16 = Gen.int16 Range.exponentialBounded
53+ genInt32 = Gen.int32 Range.exponentialBounded
54+ genInt64 = Gen.int64 Range.exponentialBounded
55+ genScientific = fromFloatDigits <$> genFloat
56+ genPosFloat = Gen.float
57+ (Range.exponentialFloatFrom 1 minPosFloat maxPosFloat)
58+ genFloat = Gen.prune $ Gen.choice
59+ [ genPosFloat
60+ , negate <$> genPosFloat
61+ , Gen.element [0,1/0] ]
62+ genPosDouble = Gen.double
63+ (Range.exponentialFloatFrom 1 minPosFloat maxPosFloat)
64+ genDouble = Gen.prune $ Gen.choice
65+ [ genPosDouble
66+ , negate <$> genPosDouble
67+ , Gen.element [0,1/0] ]
68+ genRange gen = do
69+ lb <- gen
70+ ub <- Gen.filter (lb <) gen
71+ Gen.element
72+ [ Empty, singleton lb, whole
73+ , lb <=..<= ub , lb <=..< ub, lb <..<= ub, lb <..< ub
74+ , atLeast lb, moreThan lb, atMost ub, lessThan ub ]
75+ genDay = do
76+ y <- toInteger <$> Gen.int (Range.constant 2000 2019)
77+ m <- Gen.int (Range.constant 1 12)
78+ d <- Gen.int (Range.constant 1 28)
79+ return $ fromGregorian y m d
80+ genDiffTime = secondsToDiffTime . toInteger <$>
81+ Gen.int (Range.constant 0 86401)
82+ genUTCTime = UTCTime <$> genDay <*> genDiffTime
83+ genTimeOfDay = do
84+ h <- Gen.int (Range.constant 0 23)
85+ m <- Gen.int (Range.constant 0 59)
86+ s <- MkFixed . toInteger <$> Gen.int (Range.constant 0 59)
87+ return $ TimeOfDay h m s
88+ genLocalTime = LocalTime <$> genDay <*> genTimeOfDay
89+ -- genTimeZone = Gen.element $ map (read @TimeZone)
90+ -- [ "UTC", "UT", "GMT", "EST", "EDT", "CST"
91+ -- , "CDT", "MST", "MDT", "PST", "PDT" ]
92+ -- genTimeWithZone = (,) <$> genTimeOfDay <*> genTimeZone
93+
94+roundtrip
95+ :: (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.hsnew file+136
@@ -0,0 +1,136 @@
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.hsdeleted−126
@@ -1,126 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE DeriveGeneric #-}
3−{-# LANGUAGE DuplicateRecordFields #-}
4−{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE OverloadedLabels #-}
6−{-# LANGUAGE OverloadedLists #-}
7−{-# LANGUAGE OverloadedStrings #-}
8−{-# LANGUAGE TypeApplications #-}
9−{-# LANGUAGE TypeFamilies #-}
10−{-# LANGUAGE TypeInType #-}
11−{-# LANGUAGE TypeOperators #-}
12−module ExceptionHandling
13− ( specs
14− , User (..)
15− )
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 Squeal.PostgreSQL.Migration
28−import Test.Hspec
29−
30−type Schema =
31− '[ "users" ::: 'Table (
32− '[ "pk_users" ::: 'PrimaryKey '["id"]
33− , "unique_names" ::: 'Unique '["name"]
34− ] :=>
35− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
36− , "name" ::: 'NoDef :=> 'NotNull 'PGtext
37− , "vec" ::: 'NoDef :=> 'NotNull ('PGvararray ('Null 'PGint2))
38− ])
39− , "emails" ::: 'Table (
40− '[ "pk_emails" ::: 'PrimaryKey '["id"]
41− , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
42− ] :=>
43− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
44− , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
45− , "email" ::: 'NoDef :=> 'Null 'PGtext
46− ])
47− ]
48−
49−type Schemas = Public Schema
50−
51−data User =
52− User { userName :: Text
53− , userEmail :: Maybe Text
54− , userVec :: VarArray (Vector (Maybe Int16)) }
55− deriving (Show, GHC.Generic)
56−instance SOP.Generic User
57−instance SOP.HasDatatypeInfo User
58−
59−insertUser :: Manipulation '[] Schemas '[ 'NotNull 'PGtext, 'NotNull ('PGvararray ('Null 'PGint2))]
60− '[ "fromOnly" ::: 'NotNull 'PGint4 ]
61−insertUser = insertInto #users
62− (Values_ (defaultAs #id :* param @1 `as` #name :* param @2 `as` #vec))
63− OnConflictDoRaise (Returning (#id `as` #fromOnly))
64−
65−setup :: Definition (Public '[]) Schemas
66−setup =
67− createTable #users
68− ( serial `as` #id :*
69− (text & notNullable) `as` #name :*
70− (vararray int2 & notNullable) `as` #vec )
71− ( primaryKey #id `as` #pk_users
72− :* unique #name `as` #unique_names )
73− >>>
74− createTable #emails
75− ( serial `as` #id :*
76− (int & notNullable) `as` #user_id :*
77− (text & nullable) `as` #email )
78− ( primaryKey #id `as` #pk_emails :*
79− foreignKey #user_id #users #id
80− OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
81−
82−teardown :: Definition Schemas (Public '[])
83−teardown = dropTable #emails >>> dropTable #users
84−
85−migration :: Migration Definition (Public '[]) Schemas
86−migration = Migration { name = "test"
87− , up = setup
88− , down = teardown }
89−
90−setupDB :: IO ()
91−setupDB = void . withConnection connectionString $
92− manipulate (UnsafeManipulation "SET client_min_messages TO WARNING;")
93− & pqThen (migrateUp (single migration))
94−
95−dropDB :: IO ()
96−dropDB = void . withConnection connectionString $
97− manipulate (UnsafeManipulation "SET client_min_messages TO WARNING;")
98− & pqThen (migrateDown (single migration))
99−
100−connectionString :: Char8.ByteString
101−connectionString = "host=localhost port=5432 dbname=exampledb"
102−
103−testUser :: User
104−testUser = User "TestUser" Nothing (VarArray [])
105−
106−newUser :: (MonadIO m, MonadPQ Schemas m) => User -> m ()
107−newUser u = void $ manipulateParams insertUser (userName u, userVec u)
108−
109−insertUserTwice :: (MonadIO m, MonadPQ Schemas m) => m ()
110−insertUserTwice = newUser testUser >> newUser testUser
111−
112−specs :: SpecWith ()
113−specs = before_ setupDB $ after_ dropDB $
114− describe "Exceptions" $ do
115−
116− let
117− dupKeyErr = PQException $ PQState FatalError (Just "23505")
118− (Just "ERROR: duplicate key value violates unique constraint \"unique_names\"\nDETAIL: Key (name)=(TestUser) already exists.\n")
119−
120− it "should be thrown for unique constraint violation in a manipulation" $
121− withConnection connectionString insertUserTwice
122− `shouldThrow` (== dupKeyErr)
123−
124− it "should be rethrown for unique constraint violation in a manipulation by a transaction" $
125− withConnection connectionString (transactionally_ insertUserTwice)
126− `shouldThrow` (== dupKeyErr)
squeal-postgresql/test/Specs/Specs.hsdeleted−7
@@ -1,7 +0,0 @@
1−module Specs where
2−
3−import Test.Hspec
4−import qualified ExceptionHandling
5−
6−main :: IO ()
7−main = hspec ExceptionHandling.specs
stack.yaml+3−1
@@ -1,6 +1,8 @@
1−resolver: lts-13.8
1+resolver: nightly-2019-07-14
22packages:
33- squeal-postgresql
44
55extra-deps:
66- unliftio-pool-0.2.1.0
7+- github: morphismtech/free-categories
8+ commit: c0e555fbefb5c21619e532264c4dfeac556d0630