git.iko.soy/squeal
on dev help sign in
swap
ddc9847191 ahead, 0 behind
.circleci/config.yml+1−1
since splitsnapshots
unifiedsplit
@@ -2,7 +2,7 @@ version: 2
2jobs:
2jobs:
3 build:
3 build:
4 docker:
4 docker:
5− - image: haskell:8.6.3
5+ - image: haskell:8.6.5
6 - image: circleci/postgres:latest
6 - image: circleci/postgres:latest
7 environment:
7 environment:
8 POSTGRES_USER: root
8 POSTGRES_USER: root
README.md+59−70
@@ -46,7 +46,11 @@ composable and cover a large portion of SQL.
46* transactions
46* transactions
47* views
47* views
48* array, composite and enumerated types
48* 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
50
54
51## installation
55## installation
52
56
@@ -72,19 +76,17 @@ First, we need some language extensions because Squeal uses modern GHC
72features.
76features.
73
77
74```Haskell
78```Haskell
75−>>> :set -XDataKinds -XDeriveGeneric -XOverloadedLabels
79+>>> :set -XDataKinds -XDeriveGeneric -XOverloadedLabels -XFlexibleContexts
76−>>> :set -XOverloadedStrings -XTypeApplications -XTypeOperators
80+>>> :set -XOverloadedStrings -XTypeApplications -XTypeOperators -XGADTs
77```
81```
78
82
79We'll need some imports.
83We'll need some imports.
80
84
81```Haskell
85```Haskell
82−>>> import Control.Monad (void)
83>>> import Control.Monad.IO.Class (liftIO)
86>>> import Control.Monad.IO.Class (liftIO)
84>>> import Data.Int (Int32)
87>>> import Data.Int (Int32)
85>>> import Data.Text (Text)
88>>> import Data.Text (Text)
86>>> import Squeal.PostgreSQL
89>>> import Squeal.PostgreSQL
87−>>> import Squeal.PostgreSQL.Render
88```
90```
89
91
90We'll use generics to easily convert between Haskell and PostgreSQL values.
92We'll use generics to easily convert between Haskell and PostgreSQL values.
@@ -99,27 +101,27 @@ we use `DataKinds` and `TypeOperators`.
99
101
100```Haskell
102```Haskell
101>>> :{
103>>> :{
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"] ]
102type Schema =
115type Schema =
103− '[ "users" ::: 'Table (
116+ '[ "users" ::: 'Table (UsersConstraints :=> UsersColumns)
104− '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
105− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
106− , "name" ::: 'NoDef :=> 'NotNull 'PGtext
107− ])
108− , "emails" ::: 'Table (
117+ , "emails" ::: 'Table (EmailsConstraints :=> EmailsColumns) ]
109− '[ "pk_emails" ::: 'PrimaryKey '["id"]
118+type Schemas = Public Schema
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− ]
117:}
119:}
118```
120```
119
121
120Notice the use of type operators.
122Notice the use of type operators.
121
123
122−`:::` is used to pair an alias `GHC.TypeLits.Symbol` with a `SchemumType`,
124+`:::` is used to pair an alias `Symbol` with a `SchemumType`,
123a `TableConstraint` or a `ColumnType`. It is intended to connote Haskell's `::`
125a `TableConstraint` or a `ColumnType`. It is intended to connote Haskell's `::`
124operator.
126operator.
125
127
@@ -137,7 +139,7 @@ labels to refer to named tables and columns in our schema.
137```Haskell
139```Haskell
138>>> :{
140>>> :{
139let
141let
140− setup :: Definition '[] Schema
142+ setup :: Definition (Public '[]) Schemas
141 setup =
143 setup =
142 createTable #users
144 createTable #users
143 ( serial `as` #id :*
145 ( serial `as` #id :*
@@ -169,7 +171,7 @@ primary and foreign keys, making them somewhat complex. Our `teardown`
169```Haskell
171```Haskell
170>>> :{
172>>> :{
171let
173let
172− teardown :: Definition Schema '[]
174+ teardown :: Definition Schemas (Public '[])
173 teardown = dropTable #emails >>> dropTable #users
175 teardown = dropTable #emails >>> dropTable #users
174:}
176:}
175
177
@@ -178,54 +180,54 @@ DROP TABLE "emails";
178DROP TABLE "users";
180DROP TABLE "users";
179```
181```
180
182
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+
181−Next, we'll write `Manipulation`s to insert data into our two tables.
192+Next, we'll write `Manipulation_`s to insert `User`s into our two tables.
182−A `Manipulation` like `insertRow`, `update` or `deleteFrom`
193+A `Manipulation_` like `insertInto`, `update` or `deleteFrom`
183−has three type parameters, the schema it refers to, a list of parameters
194+has three type parameters, the schemas it refers to, input parameters
184−it can take as input, and a list of columns it produces as output. When
195+and an output row. When
185we insert into the users table, we will need a parameter for the `name`
196we insert into the users table, we will need a parameter for the `name`
186field but not for the `id` field. Since it's serial, we can use a default
197field but not for the `id` field. Since it's serial, we can use a default
187value. However, since the emails table refers to the users table, we will
198value. However, since the emails table refers to the users table, we will
188need to retrieve the user id that the insert generates and insert it into
199need to retrieve the user id that the insert generates and insert it into
189−the emails table. Take a careful look at the type and definition of both
200+the emails table. We can do this in a single `Manipulation_` by using a
190−of our inserts.
201+`with` statement.
191
202
192```Haskell
203```Haskell
193>>> :{
204>>> :{
194let
205let
195− insertUser :: Manipulation Schema '[ 'NotNull 'PGtext ] '[ "fromOnly" ::: 'NotNull 'PGint4 ]
206+ insertUser :: Manipulation_ Schemas User ()
196− insertUser = insertRow #users
207+ insertUser = with (u `as` #u) e
208+ where
209+ u = insertInto #users
197− (Default `as` #id :* Set (param @1) `as` #name)
210+ (Values_ (Default `as` #id :* Set (param @1) `as` #name))
198− OnConflictDoNothing (Returning (#id `as` #fromOnly))
211+ OnConflictDoRaise (Returning_ (#id :* param @2 `as` #email))
199−:}
212+ e = insertInto_ #emails $ Select
200−
201−>>> :{
202−let
203− insertEmail :: Manipulation Schema '[ 'NotNull 'PGint4, 'Null 'PGtext] '[]
204− insertEmail = insertRow #emails
205− ( Default `as` #id :*
213+ (Default `as` #id :* Set (#u ! #id) `as` #user_id :* Set (#u ! #email) `as` #email)
206− Set (param @1) `as` #user_id :*
214+ (from (common #u))
207− Set (param @2) `as` #email )
208− OnConflictDoNothing (Returning Nil)
209:}
215:}
210
216
211>>> printSQL insertUser
217>>> printSQL insertUser
212−INSERT INTO "users" ("id", "name") VALUES (DEFAULT, ($1 :: text)) ON CONFLICT DO NOTHING RETURNING "id" AS "fromOnly"
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"
213−>>> printSQL insertEmail
214−INSERT INTO "emails" ("id", "user_id", "email") VALUES (DEFAULT, ($1 :: int4), ($2 :: text)) ON CONFLICT DO NOTHING
215```
219```
216
220
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
218interested in the ids here, just the usernames and email addresses. We
222interested 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
223+need to use an `innerJoin` to get the right result. A `Query_` is like a
220−`Manipulation` with the same kind of type parameters.
224+`Manipulation_` with the same kind of type parameters.
221
225
222```Haskell
226```Haskell
223>>> :{
227>>> :{
224let
228let
225− getUsers :: Query Schema '[]
229+ getUsers :: Query_ Schemas () User
226− '[ "userName" ::: 'NotNull 'PGtext
227− , "userEmail" ::: 'Null 'PGtext ]
228− getUsers = select
230+ getUsers = select_
229 (#u ! #name `as` #userName :* #e ! #email `as` #userEmail)
231 (#u ! #name `as` #userName :* #e ! #email `as` #userEmail)
230 ( from (table (#users `as` #u)
232 ( from (table (#users `as` #u)
231 & innerJoin (table (#emails `as` #e))
233 & innerJoin (table (#emails `as` #e))
@@ -236,19 +238,7 @@ let
236SELECT "u"."name" AS "userName", "e"."email" AS "userEmail" FROM "users" AS "u" INNER JOIN "emails" AS "e" ON ("u"."id" = "e"."user_id")
238SELECT "u"."name" AS "userName", "e"."email" AS "userEmail" FROM "users" AS "u" INNER JOIN "emails" AS "e" ON ("u"."id" = "e"."user_id")
237```
239```
238
240
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.
252
242
253```Haskell
243```Haskell
254>>> :{
244>>> :{
@@ -273,19 +263,18 @@ transformer and when the schema doesn't change we can use `Monad` and
273```Haskell
263```Haskell
274>>> :{
264>>> :{
275let
265let
276− session :: PQ Schema Schema IO ()
266+ session :: PQ Schemas Schemas IO ()
277 session = do
267 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
281 usersResult <- runQuery getUsers
269 usersResult <- runQuery getUsers
282 usersRows <- getRows usersResult
270 usersRows <- getRows usersResult
283 liftIO $ print (usersRows :: [User])
271 liftIO $ print (usersRows :: [User])
284in
272in
285− void . withConnection "host=localhost port=5432 dbname=exampledb" $
273+ withConnection "host=localhost port=5432 dbname=exampledb" $
286 define setup
274 define setup
287 & pqThen session
275 & pqThen session
288 & pqThen (define teardown)
276 & pqThen (define teardown)
289:}
277:}
290[User {userName = "Alice", userEmail = Just "alice@gmail.com"},User {userName = "Bob", userEmail = Nothing},User {userName = "Carole", userEmail = Just "carole@hotmail.com"}]
278[User {userName = "Alice", userEmail = Just "alice@gmail.com"},User {userName = "Bob", userEmail = Nothing},User {userName = "Carole", userEmail = Just "carole@hotmail.com"}]
279+-}
291```
280```
RELEASE NOTES.md+400
@@ -1,5 +1,405 @@
1## RELEASE NOTES
1## RELEASE NOTES
2
2
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+
3### Version 0.4
403### Version 0.4
4
404
5Version 0.4 strengthens Squeal's type system, adds
405Version 0.4 strengthens Squeal's type system, adds
squeal-postgresql/exe/Example.hs+9−7
@@ -11,7 +11,6 @@
11
11
12module Main (main, main2) where
12module Main (main, main2) where
13
13
14−import Control.Monad (void)
15import Control.Monad.IO.Class (MonadIO (..))
14import Control.Monad.IO.Class (MonadIO (..))
16import Data.Int (Int16, Int32)
15import Data.Int (Int16, Int32)
17import Data.Monoid ((<>))
16import Data.Monoid ((<>))
@@ -39,6 +38,7 @@ type Schema =
39 , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
38 , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
40 , "email" ::: 'NoDef :=> 'Null 'PGtext
39 , "email" ::: 'NoDef :=> 'Null 'PGtext
41 ])
40 ])
41+ , "positive" ::: 'Typedef 'PGfloat4
42 ]
42 ]
43
43
44type Schemas = Public Schema
44type Schemas = Public Schema
@@ -53,23 +53,25 @@ setup =
53 >>>
53 >>>
54 createTable #emails
54 createTable #emails
55 ( serial `as` #id :*
55 ( serial `as` #id :*
56− (int & notNullable) `as` #user_id :*
56+ hask @Int32 `as` #user_id :*
57− (text & nullable) `as` #email )
57+ hask @(Maybe Text) `as` #email )
58 ( primaryKey #id `as` #pk_emails :*
58 ( primaryKey #id `as` #pk_emails :*
59 foreignKey #user_id #users #id
59 foreignKey #user_id #users #id
60 OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
60 OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
61+ >>>
62+ createDomain #positive real (#value .> 0 .&& (#value & isNotNull))
61
63
62teardown :: Definition Schemas (Public '[])
64teardown :: Definition Schemas (Public '[])
63−teardown = dropTable #emails >>> dropTable #users
65+teardown = dropType #positive >>> dropTable #emails >>> dropTable #users
64
66
65insertUser :: Manipulation_ Schemas (Text, VarArray (Vector (Maybe Int16))) (Only Int32)
67insertUser :: Manipulation_ Schemas (Text, VarArray (Vector (Maybe Int16))) (Only Int32)
66insertUser = insertInto #users
68insertUser = 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))
68 (OnConflict (OnConstraint #pk_users) DoNothing) (Returning_ (#id `as` #fromOnly))
70 (OnConflict (OnConstraint #pk_users) DoNothing) (Returning_ (#id `as` #fromOnly))
69
71
70insertEmail :: Manipulation_ Schemas (Int32, Maybe Text) ()
72insertEmail :: Manipulation_ Schemas (Int32, Maybe Text) ()
71insertEmail = insertInto_ #emails
73insertEmail = 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))
73
75
74getUsers :: Query_ Schemas () User
76getUsers :: Query_ Schemas () User
75getUsers = select_
77getUsers = select_
@@ -117,7 +119,7 @@ main = do
117
119
118main2 :: IO ()
120main2 :: IO ()
119main2 =
121main2 =
120− void . withConnection "host=localhost port=5432 dbname=exampledb" $
122+ withConnection "host=localhost port=5432 dbname=exampledb" $
121 define setup
123 define setup
122 & pqThen session
124 & pqThen session
123 & pqThen (define teardown)
125 & pqThen (define teardown)
squeal-postgresql/squeal-postgresql.cabal+41−11
@@ -1,5 +1,5 @@
1name: squeal-postgresql
1name: squeal-postgresql
2−version: 0.4.9.0
2+version: 0.5.1.0
3synopsis: Squeal PostgreSQL Library
3synopsis: Squeal PostgreSQL Library
4description: Squeal is a type-safe embedding of PostgreSQL in Haskell
4description: Squeal is a type-safe embedding of PostgreSQL in Haskell
5homepage: https://github.com/morphismtech/squeal
5homepage: https://github.com/morphismtech/squeal
@@ -25,18 +25,31 @@ library
25 Squeal.PostgreSQL.Alias
25 Squeal.PostgreSQL.Alias
26 Squeal.PostgreSQL.Binary
26 Squeal.PostgreSQL.Binary
27 Squeal.PostgreSQL.Definition
27 Squeal.PostgreSQL.Definition
28+ Squeal.PostgreSQL.Definition.Function
29+ Squeal.PostgreSQL.Definition.Index
30+ Squeal.PostgreSQL.Definition.Table
31+ Squeal.PostgreSQL.Definition.Table.Constraint
32+ Squeal.PostgreSQL.Definition.Type
33+ Squeal.PostgreSQL.Definition.Schema
34+ Squeal.PostgreSQL.Definition.View
28 Squeal.PostgreSQL.Expression
35 Squeal.PostgreSQL.Expression
29 Squeal.PostgreSQL.Expression.Aggregate
36 Squeal.PostgreSQL.Expression.Aggregate
30 Squeal.PostgreSQL.Expression.Collection
37 Squeal.PostgreSQL.Expression.Collection
31 Squeal.PostgreSQL.Expression.Comparison
38 Squeal.PostgreSQL.Expression.Comparison
32 Squeal.PostgreSQL.Expression.Json
39 Squeal.PostgreSQL.Expression.Json
40+ Squeal.PostgreSQL.Expression.Literal
33 Squeal.PostgreSQL.Expression.Logic
41 Squeal.PostgreSQL.Expression.Logic
34 Squeal.PostgreSQL.Expression.Math
42 Squeal.PostgreSQL.Expression.Math
35 Squeal.PostgreSQL.Expression.Null
43 Squeal.PostgreSQL.Expression.Null
44+ Squeal.PostgreSQL.Expression.Parameter
45+ Squeal.PostgreSQL.Expression.Range
46+ Squeal.PostgreSQL.Expression.Set
36 Squeal.PostgreSQL.Expression.Sort
47 Squeal.PostgreSQL.Expression.Sort
48+ Squeal.PostgreSQL.Expression.Subquery
37 Squeal.PostgreSQL.Expression.Text
49 Squeal.PostgreSQL.Expression.Text
38 Squeal.PostgreSQL.Expression.TextSearch
50 Squeal.PostgreSQL.Expression.TextSearch
39 Squeal.PostgreSQL.Expression.Time
51 Squeal.PostgreSQL.Expression.Time
52+ Squeal.PostgreSQL.Expression.Type
40 Squeal.PostgreSQL.Expression.Window
53 Squeal.PostgreSQL.Expression.Window
41 Squeal.PostgreSQL.List
54 Squeal.PostgreSQL.List
42 Squeal.PostgreSQL.Manipulation
55 Squeal.PostgreSQL.Manipulation
@@ -57,7 +70,8 @@ library
57 , bytestring >= 0.10.8.2
70 , bytestring >= 0.10.8.2
58 , bytestring-strict-builder >= 0.4.5
71 , bytestring-strict-builder >= 0.4.5
59 , deepseq >= 1.4.3.0
72 , deepseq >= 1.4.3.0
73+ , free-categories >= 0.1.0.0
60− , generics-sop >= 0.3.2.0
74+ , generics-sop >= 0.3.2.0 && < 0.5.0.0
61 , mmorph >= 1.1.1
75 , mmorph >= 1.1.1
62 , mtl >= 2.2.2
76 , mtl >= 2.2.2
63 , network-ip >= 0.3.0.2
77 , network-ip >= 0.3.0.2
@@ -74,34 +88,50 @@ library
74 , uuid-types >= 1.0.3
88 , uuid-types >= 1.0.3
75 , vector >= 0.12.0.1
89 , vector >= 0.12.0.1
76
90
77−test-suite squeal-postgresql-doctest
91+test-suite doctest
78 default-language: Haskell2010
92 default-language: Haskell2010
79 type: exitcode-stdio-1.0
93 type: exitcode-stdio-1.0
80 hs-source-dirs: test
94 hs-source-dirs: test
81 ghc-options: -Wall
95 ghc-options: -Wall
82− main-is: DocTest.hs
96+ main-is: Doc.hs
83 build-depends:
97 build-depends:
84 base >= 4.10.0.0
98 base >= 4.10.0.0
85 , doctest >= 0.11.4
99 , doctest >= 0.11.4
100+ , squeal-postgresql
86
101
87−test-suite squeal-postgresql-specs
102+test-suite properties
88 default-language: Haskell2010
103 default-language: Haskell2010
89 type: exitcode-stdio-1.0
104 type: exitcode-stdio-1.0
90− hs-source-dirs: test/Specs
105+ hs-source-dirs: test
91− ghc-options: -Wall -main-is Specs
106+ ghc-options: -Wall
92− main-is: Specs.hs
107+ main-is: Property.hs
93− other-modules: ExceptionHandling
94 build-depends:
108 build-depends:
95 base >= 4.10.0.0
109 base >= 4.10.0.0
96 , bytestring >= 0.10.8.2
110 , bytestring >= 0.10.8.2
111+ , hedgehog >= 1.0
112+ , mtl >= 2.2.2
113+ , scientific >= 0.3.5.3
114+ , squeal-postgresql
115+ , time >= 1.8.0.2
116+
117+test-suite spec
118+ default-language: Haskell2010
119+ type: exitcode-stdio-1.0
120+ hs-source-dirs: test
121+ ghc-options: -Wall
122+ main-is: Spec.hs
123+ build-depends:
124+ base >= 4.10.0.0
125+ , async >= 2.2.2
126+ , bytestring >= 0.10.8.2
97 , generics-sop >= 0.3.1.0
127 , generics-sop >= 0.3.1.0
98 , hspec >= 2.4.8
128 , hspec >= 2.4.8
129+ , mtl >= 2.2.2
99 , squeal-postgresql
130 , squeal-postgresql
100 , text >= 1.2.2.2
131 , text >= 1.2.2.2
101− , transformers >= 0.5.2.0
102 , vector >= 0.12.0.1
132 , vector >= 0.12.0.1
103
133
104−executable squeal-postgresql-example
134+executable example
105 default-language: Haskell2010
135 default-language: Haskell2010
106 hs-source-dirs: exe
136 hs-source-dirs: exe
107 ghc-options: -Wall
137 ghc-options: -Wall
squeal-postgresql/src/Squeal/PostgreSQL.hs+64−73
@@ -1,7 +1,7 @@
1{-|
1{-|
2Module: Squeal.PostgreSQL
2Module: Squeal.PostgreSQL
3Description: Squeal export module
3Description: Squeal export module
4−Copyright: (c) Eitan Chatav, 2017
4+Copyright: (c) Eitan Chatav, 2019
5Maintainer: eitan@morphism.tech
5Maintainer: eitan@morphism.tech
6Stability: experimental
6Stability: experimental
7
7
@@ -11,17 +11,15 @@ Let's see an example!
11First, we need some language extensions because Squeal uses modern GHC
11First, we need some language extensions because Squeal uses modern GHC
12features.
12features.
13
13
14−>>> :set -XDataKinds -XDeriveGeneric -XOverloadedLabels
14+>>> :set -XDataKinds -XDeriveGeneric -XOverloadedLabels -XFlexibleContexts
15>>> :set -XOverloadedStrings -XTypeApplications -XTypeOperators -XGADTs
15>>> :set -XOverloadedStrings -XTypeApplications -XTypeOperators -XGADTs
16
16
17We'll need some imports.
17We'll need some imports.
18
18
19−>>> import Control.Monad (void)
20>>> import Control.Monad.IO.Class (liftIO)
19>>> import Control.Monad.IO.Class (liftIO)
21>>> import Data.Int (Int32)
20>>> import Data.Int (Int32)
22>>> import Data.Text (Text)
21>>> import Data.Text (Text)
23>>> import Squeal.PostgreSQL
22>>> import Squeal.PostgreSQL
24−>>> import Squeal.PostgreSQL.Render
25
23
26We'll use generics to easily convert between Haskell and PostgreSQL values.
24We'll use generics to easily convert between Haskell and PostgreSQL values.
27
25
@@ -104,45 +102,44 @@ let
104DROP TABLE "emails";
102DROP TABLE "emails";
105DROP TABLE "users";
103DROP TABLE "users";
106
104
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
105+We'll need a Haskell type for @User@s. We give the type `Generics.SOP.Generic` and
119−`Generics.SOP.HasDatatypeInfo` instances so that we can decode the rows
106+`Generics.SOP.HasDatatypeInfo` instances so that we can encode and decode @User@s.
120−we receive when we run @getUsers@. Notice that the record fields of the
121−@User@ type match the column names of @getUsers@.
122
107
123>>> data User = User { userName :: Text, userEmail :: Maybe Text } deriving (Show, GHC.Generic)
108>>> data User = User { userName :: Text, userEmail :: Maybe Text } deriving (Show, GHC.Generic)
124>>> instance SOP.Generic User
109>>> instance SOP.Generic User
125>>> instance SOP.HasDatatypeInfo User
110>>> instance SOP.HasDatatypeInfo User
126
111
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+
127>>> :{
123>>> :{
128let
124let
129 insertUser :: Manipulation_ Schemas User ()
125 insertUser :: Manipulation_ Schemas User ()
130 insertUser = with (u `as` #u) e
126 insertUser = with (u `as` #u) e
131 where
127 where
132 u = insertInto #users
128 u = insertInto #users
133− (Values_ (defaultAs #id :* param @1 `as` #name))
129+ (Values_ (Default `as` #id :* Set (param @1) `as` #name))
134 OnConflictDoRaise (Returning_ (#id :* param @2 `as` #email))
130 OnConflictDoRaise (Returning_ (#id :* param @2 `as` #email))
135− e = insertInto_ #emails
131+ e = insertInto_ #emails $ Select
136− (Select (defaultAs #id :* #u ! #id `as` #user_id :* #u ! #email) (from (common #u)))
132+ (Default `as` #id :* Set (#u ! #id) `as` #user_id :* Set (#u ! #email) `as` #email)
133+ (from (common #u))
137:}
134:}
138
135
139>>> printSQL insertUser
136>>> printSQL insertUser
140WITH "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"
137WITH "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"
141
138
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
143interested in the ids here, just the usernames and email addresses. We
140interested 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
141+need to use an `innerJoin` to get the right result. A `Query_` is like a
145−`Manipulation` with the same kind of type parameters.
142+`Manipulation_` with the same kind of type parameters.
146
143
147>>> :{
144>>> :{
148let
145let
@@ -186,57 +183,51 @@ let
186 usersRows <- getRows usersResult
183 usersRows <- getRows usersResult
187 liftIO $ print (usersRows :: [User])
184 liftIO $ print (usersRows :: [User])
188in
185in
189− void . withConnection "host=localhost port=5432 dbname=exampledb" $
186+ withConnection "host=localhost port=5432 dbname=exampledb" $
190 define setup
187 define setup
191 & pqThen session
188 & pqThen session
192 & pqThen (define teardown)
189 & pqThen (define teardown)
193:}
190:}
194[User {userName = "Alice", userEmail = Just "alice@gmail.com"},User {userName = "Bob", userEmail = Nothing},User {userName = "Carole", userEmail = Just "carole@hotmail.com"}]
191[User {userName = "Alice", userEmail = Just "alice@gmail.com"},User {userName = "Bob", userEmail = Nothing},User {userName = "Carole", userEmail = Just "carole@hotmail.com"}]
195-}
192-}
196−module Squeal.PostgreSQL
193+module Squeal.PostgreSQL (module X, RenderSQL(..), printSQL) where
197− ( module Squeal.PostgreSQL.Alias
194+
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.Logic
206− , module Squeal.PostgreSQL.Expression.Math
207− , module Squeal.PostgreSQL.Expression.Null
208− , module Squeal.PostgreSQL.Expression.Text
209− , module Squeal.PostgreSQL.Expression.TextSearch
210− , module Squeal.PostgreSQL.Expression.Time
211− , module Squeal.PostgreSQL.Expression.Window
212− , module Squeal.PostgreSQL.List
213− , module Squeal.PostgreSQL.Manipulation
214− , module Squeal.PostgreSQL.PG
215− , module Squeal.PostgreSQL.PQ
216− , module Squeal.PostgreSQL.Query
217− , module Squeal.PostgreSQL.Schema
218− , module Squeal.PostgreSQL.Transaction
219− ) where
220−
221−import Squeal.PostgreSQL.Alias
195+import Squeal.PostgreSQL.Alias as X
222−import Squeal.PostgreSQL.Binary
196+import Squeal.PostgreSQL.Binary as X
197+import Squeal.PostgreSQL.Definition as X
198+import Squeal.PostgreSQL.Definition.Function as X
223−import Squeal.PostgreSQL.Definition
199+import Squeal.PostgreSQL.Definition.Index as X
224−import Squeal.PostgreSQL.Expression
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
225−import Squeal.PostgreSQL.Expression.Aggregate
206+import Squeal.PostgreSQL.Expression.Aggregate as X
226−import Squeal.PostgreSQL.Expression.Collection
207+import Squeal.PostgreSQL.Expression.Collection as X
227−import Squeal.PostgreSQL.Expression.Comparison
208+import Squeal.PostgreSQL.Expression.Comparison as X
228−import Squeal.PostgreSQL.Expression.Json
209+import Squeal.PostgreSQL.Expression.Json as X
229−import Squeal.PostgreSQL.Expression.Logic
210+import Squeal.PostgreSQL.Expression.Literal as X
211+import Squeal.PostgreSQL.Expression.Logic as X
230−import Squeal.PostgreSQL.Expression.Math
212+import Squeal.PostgreSQL.Expression.Math as X
231−import Squeal.PostgreSQL.Expression.Null
213+import Squeal.PostgreSQL.Expression.Null as X
232−import Squeal.PostgreSQL.Expression.Text
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
233−import Squeal.PostgreSQL.Expression.TextSearch
220+import Squeal.PostgreSQL.Expression.TextSearch as X
234−import Squeal.PostgreSQL.Expression.Time
221+import Squeal.PostgreSQL.Expression.Time as X
222+import Squeal.PostgreSQL.Expression.Type as X
235−import Squeal.PostgreSQL.Expression.Window
223+import Squeal.PostgreSQL.Expression.Window as X
236−import Squeal.PostgreSQL.List
224+import Squeal.PostgreSQL.List as X
237−import Squeal.PostgreSQL.Manipulation
225+import Squeal.PostgreSQL.Manipulation as X
238−import Squeal.PostgreSQL.PG
226+import Squeal.PostgreSQL.Migration as X
227+import Squeal.PostgreSQL.PG as X
228+import Squeal.PostgreSQL.Pool as X
239−import Squeal.PostgreSQL.PQ
229+import Squeal.PostgreSQL.PQ as X
240−import Squeal.PostgreSQL.Query
230+import Squeal.PostgreSQL.Query as X
241−import Squeal.PostgreSQL.Schema
231+import Squeal.PostgreSQL.Render (RenderSQL(..), printSQL)
232+import Squeal.PostgreSQL.Schema as X
242−import Squeal.PostgreSQL.Transaction
233+import Squeal.PostgreSQL.Transaction as X
squeal-postgresql/src/Squeal/PostgreSQL/Alias.hs+18−12
@@ -1,3 +1,15 @@
1+{-|
2+Module: Squeal.PostgreSQL.Alias
3+Description: Aliases
4+Copyright: (c) Eitan Chatav, 2019
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+This module embeds Postgres's alias system in Haskell in
9+a typesafe fashion. Thanks to GHC's @OverloadedLabels@ extension,
10+Squeal can reference aliases by prepending with a @#@.
11+-}
12+
1{-# LANGUAGE
13{-# LANGUAGE
2 AllowAmbiguousTypes
14 AllowAmbiguousTypes
3 , ConstraintKinds
15 , ConstraintKinds
@@ -34,7 +46,6 @@ module Squeal.PostgreSQL.Alias
34 , HasIn
46 , HasIn
35 , QualifiedAlias (..)
47 , QualifiedAlias (..)
36 , IsQualified (..)
48 , IsQualified (..)
37− , DefaultAliasable (..)
38 -- * Grouping
49 -- * Grouping
39 , Grouping (..)
50 , Grouping (..)
40 , GroupedBy
51 , GroupedBy
@@ -52,6 +63,9 @@ import qualified GHC.Generics as GHC
52import Squeal.PostgreSQL.List
63import Squeal.PostgreSQL.List
53import Squeal.PostgreSQL.Render
64import Squeal.PostgreSQL.Render
54
65
66+-- $setup
67+-- >>> import Squeal.PostgreSQL
68+
55-- | The alias operator `:::` is like a promoted version of `As`,
69-- | The alias operator `:::` is like a promoted version of `As`,
56-- a type level pair between an alias and some type.
70-- a type level pair between an alias and some type.
57type (:::) (alias :: Symbol) ty = '(alias,ty)
71type (:::) (alias :: Symbol) ty = '(alias,ty)
@@ -96,8 +110,7 @@ instance aliases ~ '[alias] => IsLabel alias (NP Alias aliases) where
96instance KnownSymbol alias => RenderSQL (Alias alias) where
110instance KnownSymbol alias => RenderSQL (Alias alias) where
97 renderSQL = doubleQuoted . fromString . symbolVal
111 renderSQL = doubleQuoted . fromString . symbolVal
98
112
99−-- | >>> import Generics.SOP (NP(..))
100−-- >>> printSQL (#jimbob SOP.:* #kandi :: NP Alias '["jimbob", "kandi"])
113+-- >>> printSQL (#jimbob :* #kandi :: NP Alias '["jimbob", "kandi"])
101-- "jimbob", "kandi"
114-- "jimbob", "kandi"
102instance SOP.All KnownSymbol aliases => RenderSQL (NP Alias aliases) where
115instance SOP.All KnownSymbol aliases => RenderSQL (NP Alias aliases) where
103 renderSQL
116 renderSQL
@@ -175,14 +188,6 @@ choose which subfields to update.
175class HasIn fields field where
188class HasIn fields field where
176instance (Has alias fields field) => HasIn fields (alias ::: field) where
189instance (Has alias fields field) => HasIn fields (alias ::: field) where
177
190
178−{- |
179−The `DefaultAliasable` class is intended to help with Scrap your Nils
180−for default inserts and updates.
181−-}
182−class KnownSymbol alias
183− => DefaultAliasable alias aliased | aliased -> alias where
184− defaultAs :: Alias alias -> aliased
185−
186-- | `HasAll` extends `Has` to take lists of @aliases@ and @fields@ and infer
191-- | `HasAll` extends `Has` to take lists of @aliases@ and @fields@ and infer
187-- a list of @subfields@.
192-- a list of @subfields@.
188class
193class
@@ -206,7 +211,8 @@ class IsQualified table column expression where
206instance IsQualified table column (Alias table, Alias column) where (!) = (,)
211instance IsQualified table column (Alias table, Alias column) where (!) = (,)
207
212
208{-| `QualifiedAlias`es enables multi-schema support by allowing a reference
213{-| `QualifiedAlias`es enables multi-schema support by allowing a reference
214+to a `Squeal.PostgreSQL.Schema.Table`, `Squeal.PostgreSQL.Schema.Typedef`
209−to a `Table`, `Typedef` or `View` to be qualified by their schemas. By default,
215+or `Squeal.PostgreSQL.Schema.View` to be qualified by their schemas. By default,
210a qualifier of @public@ is provided.
216a qualifier of @public@ is provided.
211
217
212>>> :{
218>>> :{
squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs+213−71
@@ -39,7 +39,7 @@ the input and output should be equal.
39
39
40>>> let input = Row 2 "hi" (Just True)
40>>> let input = Row 2 "hi" (Just True)
41>>> :{
41>>> :{
42−void . withConnection "host=localhost port=5432 dbname=exampledb" $ do
42+withConnection "host=localhost port=5432 dbname=exampledb" $ do
43 result <- runQueryParams roundTrip input
43 result <- runQueryParams roundTrip input
44 Just output <- firstRow result
44 Just output <- firstRow result
45 liftIO . print $ input == output
45 liftIO . print $ input == output
@@ -78,7 +78,7 @@ let
78>>> :set -XOverloadedLists
78>>> :set -XOverloadedLists
79>>> let input = Row (VarArray [1,2]) (FixArray (Just 1,Nothing)) (FixArray ((1,2),(3,4),(5,6)))
79>>> let input = Row (VarArray [1,2]) (FixArray (Just 1,Nothing)) (FixArray ((1,2),(3,4),(5,6)))
80>>> :{
80>>> :{
81−void . withConnection "host=localhost port=5432 dbname=exampledb" $ do
81+withConnection "host=localhost port=5432 dbname=exampledb" $ do
82 result <- runQueryParams roundTrip input
82 result <- runQueryParams roundTrip input
83 Just output <- firstRow result
83 Just output <- firstRow result
84 liftIO . print $ input == output
84 liftIO . print $ input == output
@@ -170,7 +170,7 @@ let
170 Just output <- firstRow result
170 Just output <- firstRow result
171 liftIO . print $ input == output
171 liftIO . print $ input == output
172in
172in
173− void . withConnection "host=localhost port=5432 dbname=exampledb" $
173+ withConnection "host=localhost port=5432 dbname=exampledb" $
174 define setup
174 define setup
175 & pqThen session
175 & pqThen session
176 & pqThen (define teardown)
176 & pqThen (define teardown)
@@ -205,14 +205,20 @@ module Squeal.PostgreSQL.Binary
205 ( -- * Encoding
205 ( -- * Encoding
206 ToParam (..)
206 ToParam (..)
207 , ToParams (..)
207 , ToParams (..)
208− , ToNullityParam
208+ , ToNullityParam (..)
209− , ToField
209+ , ToField (..)
210− , ToFixArray
210+ , ToFixArray (..)
211 -- * Decoding
211 -- * Decoding
212 , FromValue (..)
212 , FromValue (..)
213 , FromRow (..)
213 , FromRow (..)
214+ , FromField (..)
215+ , FromFixArray (..)
214 -- * Only
216 -- * Only
215 , Only (..)
217 , Only (..)
218+ -- * Oid
219+ , OidOf (..)
220+ , OidOfParam (..)
221+ , OidOfField (..)
216 ) where
222 ) where
217
223
218import BinaryParser
224import BinaryParser
@@ -226,6 +232,7 @@ import Data.Time
226import Data.UUID.Types
232import Data.UUID.Types
227import Data.Vector (Vector)
233import Data.Vector (Vector)
228import Data.Word
234import Data.Word
235+import Foreign.C.Types (CUInt(CUInt))
229import Generics.SOP
236import Generics.SOP
230import Generics.SOP.Record
237import Generics.SOP.Record
231import GHC.TypeLits
238import GHC.TypeLits
@@ -239,6 +246,7 @@ import qualified Data.Text.Lazy as Lazy (Text)
239import qualified Data.Text as Strict (Text)
246import qualified Data.Text as Strict (Text)
240import qualified Data.Text as Strict.Text
247import qualified Data.Text as Strict.Text
241import qualified Data.Vector as Vector
248import qualified Data.Vector as Vector
249+import qualified Database.PostgreSQL.LibPQ as LibPQ
242import qualified GHC.Generics as GHC
250import qualified GHC.Generics as GHC
243import qualified PostgreSQL.Binary.Decoding as Decoding
251import qualified PostgreSQL.Binary.Decoding as Decoding
244import qualified PostgreSQL.Binary.Encoding as Encoding
252import qualified PostgreSQL.Binary.Encoding as Encoding
@@ -269,11 +277,9 @@ class ToParam (x :: Type) (pg :: PGType) where
269 toParam :: x -> K Encoding.Encoding pg
277 toParam :: x -> K Encoding.Encoding pg
270instance ToParam Bool 'PGbool where toParam = K . Encoding.bool
278instance ToParam Bool 'PGbool where toParam = K . Encoding.bool
271instance ToParam Int16 'PGint2 where toParam = K . Encoding.int2_int16
279instance ToParam Int16 'PGint2 where toParam = K . Encoding.int2_int16
272−instance ToParam Word16 'PGint2 where toParam = K . Encoding.int2_word16
273instance ToParam Int32 'PGint4 where toParam = K . Encoding.int4_int32
280instance ToParam Int32 'PGint4 where toParam = K . Encoding.int4_int32
274−instance ToParam Word32 'PGint4 where toParam = K . Encoding.int4_word32
275instance ToParam Int64 'PGint8 where toParam = K . Encoding.int8_int64
281instance ToParam Int64 'PGint8 where toParam = K . Encoding.int8_int64
276−instance ToParam Word64 'PGint8 where toParam = K . Encoding.int8_word64
282+instance ToParam Oid 'PGoid where toParam = K . Encoding.int4_word32 . getOid
277instance ToParam Float 'PGfloat4 where toParam = K . Encoding.float4
283instance ToParam Float 'PGfloat4 where toParam = K . Encoding.float4
278instance ToParam Double 'PGfloat8 where toParam = K . Encoding.float8
284instance ToParam Double 'PGfloat8 where toParam = K . Encoding.float8
279instance ToParam Scientific 'PGnumeric where toParam = K . Encoding.numeric
285instance ToParam Scientific 'PGnumeric where toParam = K . Encoding.numeric
@@ -306,24 +312,26 @@ instance Aeson.ToJSON x => ToParam (Json x) 'PGjson where
306instance Aeson.ToJSON x => ToParam (Jsonb x) 'PGjsonb where
312instance Aeson.ToJSON x => ToParam (Jsonb x) 'PGjsonb where
307 toParam = K . Encoding.jsonb_bytes
313 toParam = K . Encoding.jsonb_bytes
308 . Lazy.ByteString.toStrict . Aeson.encode . getJsonb
314 . Lazy.ByteString.toStrict . Aeson.encode . getJsonb
309−instance (ToNullityParam x ty, ty ~ nullity pg, HasOid pg)
315+instance (ToNullityParam x ty, ty ~ nullity pg, OidOf pg)
310 => ToParam (VarArray [x]) ('PGvararray ty) where
316 => ToParam (VarArray [x]) ('PGvararray ty) where
311 toParam = K
317 toParam = K
312− . Encoding.array_foldable (oid @pg) (unK . toNullityParam @x @ty)
318+ . Encoding.array_foldable
319+ (getOid (oidOf @pg)) (unK . toNullityParam @x @ty)
313 . getVarArray
320 . getVarArray
314−instance (ToParam x pg, HasOid pg)
321+instance (ToParam x pg, OidOf pg)
315 => ToParam (VarArray (Vector x)) ('PGvararray ('NotNull pg)) where
322 => ToParam (VarArray (Vector x)) ('PGvararray ('NotNull pg)) where
316 toParam = K
323 toParam = K
317− . Encoding.array_vector (oid @pg) (unK . toParam @x @pg)
324+ . Encoding.array_vector (getOid (oidOf @pg)) (unK . toParam @x @pg)
318 . getVarArray
325 . getVarArray
319−instance (ToParam x pg, HasOid pg)
326+instance (ToParam x pg, OidOf pg)
320 => ToParam (VarArray (Vector (Maybe x))) ('PGvararray ('Null pg)) where
327 => ToParam (VarArray (Vector (Maybe x))) ('PGvararray ('Null pg)) where
321 toParam = K
328 toParam = K
322− . Encoding.nullableArray_vector (oid @pg) (unK . toParam @x @pg)
329+ . Encoding.nullableArray_vector
330+ (getOid (oidOf @pg)) (unK . toParam @x @pg)
323 . getVarArray
331 . getVarArray
324−instance (ToFixArray x dims ty, ty ~ nullity pg, HasOid pg)
332+instance (ToFixArray x dims ty, ty ~ nullity pg, OidOf pg)
325 => ToParam (FixArray x) ('PGfixarray dims ty) where
333 => ToParam (FixArray x) ('PGfixarray dims ty) where
326− toParam = K . Encoding.array (oid @pg)
334+ toParam = K . Encoding.array (getOid (oidOf @pg))
327 . unK . unK . toFixArray @x @dims @ty . getFixArray
335 . unK . unK . toFixArray @x @dims @ty . getFixArray
328instance
336instance
329 ( IsEnumType x
337 ( IsEnumType x
@@ -348,7 +356,7 @@ instance
348 ( SListI fields
356 ( SListI fields
349 , IsRecord x xs
357 , IsRecord x xs
350 , AllZip ToField xs fields
358 , AllZip ToField xs fields
351− , All HasAliasedOid fields
359+ , All OidOfField fields
352 ) => ToParam (Composite x) ('PGcomposite fields) where
360 ) => ToParam (Composite x) ('PGcomposite fields) where
353 toParam =
361 toParam =
354 let
362 let
@@ -356,7 +364,7 @@ instance
356 encoders = htrans (Proxy @ToField) toField
364 encoders = htrans (Proxy @ToField) toField
357
365
358 composite
366 composite
359− :: All HasAliasedOid row
367+ :: All OidOfField row
360 => NP (K (Maybe Encoding.Encoding)) row
368 => NP (K (Maybe Encoding.Encoding)) row
361 -> K Encoding.Encoding ('PGcomposite row)
369 -> K Encoding.Encoding ('PGcomposite row)
362 composite fields = K $
370 composite fields = K $
@@ -373,27 +381,142 @@ instance
373 int32BE (fromIntegral (lengthSList (Proxy @xs))) <>
381 int32BE (fromIntegral (lengthSList (Proxy @xs))) <>
374 let
382 let
375 each
383 each
376− :: HasAliasedOid field
384+ :: OidOfField field
377 => K (Maybe Encoding.Encoding) field
385 => K (Maybe Encoding.Encoding) field
378 -> Encoding.Encoding
386 -> Encoding.Encoding
379 each (K field :: K (Maybe Encoding.Encoding) field) =
387 each (K field :: K (Maybe Encoding.Encoding) field) =
380− word32BE (aliasedOid @field)
388+ word32BE (getOid (oidOfField @field))
381 <> case field of
389 <> case field of
382 Nothing -> int64BE (-1)
390 Nothing -> int64BE (-1)
383 Just value ->
391 Just value ->
384 int32BE (fromIntegral (builderLength value))
392 int32BE (fromIntegral (builderLength value))
385 <> value
393 <> value
386 in
394 in
387− hcfoldMap (Proxy @HasAliasedOid) each fields
395+ hcfoldMap (Proxy @OidOfField) each fields
388
396
389 in
397 in
390 composite . encoders . toRecord . getComposite
398 composite . encoders . toRecord . getComposite
391
399
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.
392−class HasAliasedOid (field :: (Symbol, NullityType)) where
513+class OidOfField (field :: (Symbol, NullityType)) where
393− aliasedOid :: Word32
514+ oidOfField :: Oid
394−instance HasOid ty => HasAliasedOid (alias ::: nullity ty) where
515+instance OidOf ty => OidOfField (alias ::: nullity ty) where
395− aliasedOid = oid @ty
516+ oidOfField = oidOf @ty
396−
517+
518+-- | A `ToNullityParam` constraint gives an encoding of a Haskell `Type` into
519+-- into the binary format of a PostgreSQL `NullityType`.
397class ToNullityParam (x :: Type) (ty :: NullityType) where
520class ToNullityParam (x :: Type) (ty :: NullityType) where
398 toNullityParam :: x -> K (Maybe Encoding.Encoding) ty
521 toNullityParam :: x -> K (Maybe Encoding.Encoding) ty
399instance ToParam x pg => ToNullityParam x ('NotNull pg) where
522instance ToParam x pg => ToNullityParam x ('NotNull pg) where
@@ -401,11 +524,19 @@ instance ToParam x pg => ToNullityParam x ('NotNull pg) where
401instance ToParam x pg => ToNullityParam (Maybe x) ('Null pg) where
524instance ToParam x pg => ToNullityParam (Maybe x) ('Null pg) where
402 toNullityParam = K . fmap (unK . toParam @x @pg)
525 toNullityParam = K . fmap (unK . toParam @x @pg)
403
526
527+-- | A `ToField` constraint lifts the `ToParam` parser
528+-- to an encoding of a @(Symbol, Type)@ to a @(Symbol, NullityType)@,
529+-- encoding `Null`s to `Maybe`s. You should not define instances for
530+-- `FromField`, just use the provided instances.
404class ToField (x :: (Symbol, Type)) (field :: (Symbol, NullityType)) where
531class ToField (x :: (Symbol, Type)) (field :: (Symbol, NullityType)) where
405 toField :: P x -> K (Maybe Encoding.Encoding) field
532 toField :: P x -> K (Maybe Encoding.Encoding) field
406instance ToNullityParam x ty => ToField (alias ::: x) (alias ::: ty) where
533instance ToNullityParam x ty => ToField (alias ::: x) (alias ::: ty) where
407 toField (P x) = K . unK $ toNullityParam @x @ty x
534 toField (P x) = K . unK $ toNullityParam @x @ty x
408
535
536+-- | A `ToFixArray` constraint gives an encoding of a Haskell `Type`
537+-- into the binary format of a PostgreSQL fixed-length array.
538+-- You should not define instances for
539+-- `ToFixArray`, just use the provided instances.
409class ToFixArray (x :: Type) (dims :: [Nat]) (array :: NullityType) where
540class ToFixArray (x :: Type) (dims :: [Nat]) (array :: NullityType) where
410 toFixArray :: x -> K (K Encoding.Array dims) array
541 toFixArray :: x -> K (K Encoding.Array dims) array
411instance ToNullityParam x ty => ToFixArray x '[] ty where
542instance ToNullityParam x ty => ToFixArray x '[] ty where
@@ -451,6 +582,7 @@ instance FromValue 'PGbool Bool where fromValue = Decoding.bool
451instance FromValue 'PGint2 Int16 where fromValue = Decoding.int
582instance FromValue 'PGint2 Int16 where fromValue = Decoding.int
452instance FromValue 'PGint4 Int32 where fromValue = Decoding.int
583instance FromValue 'PGint4 Int32 where fromValue = Decoding.int
453instance FromValue 'PGint8 Int64 where fromValue = Decoding.int
584instance FromValue 'PGint8 Int64 where fromValue = Decoding.int
585+instance FromValue 'PGoid Word32 where fromValue = Decoding.int
454instance FromValue 'PGfloat4 Float where fromValue = Decoding.float4
586instance FromValue 'PGfloat4 Float where fromValue = Decoding.float4
455instance FromValue 'PGfloat8 Double where fromValue = Decoding.float8
587instance FromValue 'PGfloat8 Double where fromValue = Decoding.float8
456instance FromValue 'PGnumeric Scientific where fromValue = Decoding.numeric
588instance FromValue 'PGnumeric Scientific where fromValue = Decoding.numeric
@@ -589,6 +721,10 @@ instance FromValue pg y
589 K (Just bytestring) -> P . Just <$>
721 K (Just bytestring) -> P . Just <$>
590 Decoding.valueParser (fromValue @pg) bytestring
722 Decoding.valueParser (fromValue @pg) bytestring
591
723
724+-- | A `FromFixArray` constraint gives a decoding to a Haskell `Type`
725+-- from the binary format of a PostgreSQL fixed-length array.
726+-- You should not define instances for
727+-- `FromFixArray`, just use the provided instances.
592class FromFixArray (dims :: [Nat]) (ty :: NullityType) (y :: Type) where
728class FromFixArray (dims :: [Nat]) (ty :: NullityType) (y :: Type) where
593 fromFixArray :: Decoding.Array y
729 fromFixArray :: Decoding.Array y
594instance FromValue pg y => FromFixArray '[] ('NotNull pg) y where
730instance FromValue pg y => FromFixArray '[] ('NotNull pg) y where
@@ -633,50 +769,53 @@ instance
633 = fmap fromRecord
769 = fmap fromRecord
634 . hsequence'
770 . hsequence'
635 . htrans (Proxy @FromField) fromField
771 . htrans (Proxy @FromField) fromField
772+------------------------------------------------------
773+-- P records
774+------------------------------------------------------
636−instance (FromField (col ::: pg) (col ::: hask))
775+-- instance (FromField (col ::: pg) (col ::: hask))
637− => FromRow '[col ::: pg] (P (col ::: hask)) where
776+-- => FromRow '[col ::: pg] (P (col ::: hask)) where
638− fromRow (pg :* Nil) = (unComp . fromField) pg
777+-- fromRow (pg :* Nil) = (unComp . fromField) pg
639−instance
778+-- instance
640− ( row ~ Join row1 row2
779+-- ( row ~ Join row1 row2
641− , FromRow row1 hask1
780+-- , FromRow row1 hask1
642− , FromRow row2 hask2
781+-- , FromRow row2 hask2
643− , SListI row
782+-- , SListI row
644− ) => FromRow row (hask1, hask2) where
783+-- ) => FromRow row (hask1, hask2) where
645− fromRow row = case disjoin @row1 @row2 row of
784+-- fromRow row = case disjoin @row1 @row2 row of
646− (row1, row2) -> (,) <$> fromRow row1 <*> fromRow row2
785+-- (row1, row2) -> (,) <$> fromRow row1 <*> fromRow row2
647−instance
786+-- instance
648− ( row ~ Join row1 row23
787+-- ( row ~ Join row1 row23
649− , FromRow row1 hask1
788+-- , FromRow row1 hask1
650− , FromRow row23 (hask2, hask3)
789+-- , FromRow row23 (hask2, hask3)
651− , SListI row
790+-- , SListI row
652− ) => FromRow row (hask1, hask2, hask3) where
791+-- ) => FromRow row (hask1, hask2, hask3) where
653− fromRow row = case disjoin @row1 @row23 row of
792+-- fromRow row = case disjoin @row1 @row23 row of
654− (row1, row23) -> do
793+-- (row1, row23) -> do
655− hask1 <- fromRow row1
794+-- hask1 <- fromRow row1
656− (hask2, hask3) <- fromRow row23
795+-- (hask2, hask3) <- fromRow row23
657− return (hask1, hask2, hask3)
796+-- return (hask1, hask2, hask3)
658−instance
797+-- instance
659− ( row ~ Join row1 row234
798+-- ( row ~ Join row1 row234
660− , FromRow row1 hask1
799+-- , FromRow row1 hask1
661− , FromRow row234 (hask2, hask3, hask4)
800+-- , FromRow row234 (hask2, hask3, hask4)
662− , SListI row
801+-- , SListI row
663− ) => FromRow row (hask1, hask2, hask3, hask4) where
802+-- ) => FromRow row (hask1, hask2, hask3, hask4) where
664− fromRow row = case disjoin @row1 @row234 row of
803+-- fromRow row = case disjoin @row1 @row234 row of
665− (row1, row234) -> do
804+-- (row1, row234) -> do
666− hask1 <- fromRow row1
805+-- hask1 <- fromRow row1
667− (hask2, hask3, hask4) <- fromRow row234
806+-- (hask2, hask3, hask4) <- fromRow row234
668− return (hask1, hask2, hask3, hask4)
807+-- return (hask1, hask2, hask3, hask4)
669−instance
808+-- instance
670− ( row ~ Join row1 row2345
809+-- ( row ~ Join row1 row2345
671− , FromRow row1 hask1
810+-- , FromRow row1 hask1
672− , FromRow row2345 (hask2, hask3, hask4, hask5)
811+-- , FromRow row2345 (hask2, hask3, hask4, hask5)
673− , SListI row
812+-- , SListI row
674− ) => FromRow row (hask1, hask2, hask3, hask4, hask5) where
813+-- ) => FromRow row (hask1, hask2, hask3, hask4, hask5) where
675− fromRow row = case disjoin @row1 @row2345 row of
814+-- fromRow row = case disjoin @row1 @row2345 row of
676− (row1, row2345) -> do
815+-- (row1, row2345) -> do
677− hask1 <- fromRow row1
816+-- hask1 <- fromRow row1
678− (hask2, hask3, hask4, hask5) <- fromRow row2345
817+-- (hask2, hask3, hask4, hask5) <- fromRow row2345
679− return (hask1, hask2, hask3, hask4, hask5)
818+-- return (hask1, hask2, hask3, hask4, hask5)
680
819
681-- | `Only` is a 1-tuple type, useful for encoding a single parameter with
820-- | `Only` is a 1-tuple type, useful for encoding a single parameter with
682-- `toParams` or decoding a single value with `fromRow`.
821-- `toParams` or decoding a single value with `fromRow`.
@@ -704,3 +843,6 @@ replicateMN
704 => m x -> m (NP I xs)
843 => m x -> m (NP I xs)
705replicateMN mx = hsequence' $
844replicateMN mx = hsequence' $
706 hcpure (Proxy :: Proxy ((~) x)) (Comp (I <$> mx))
845 hcpure (Proxy :: Proxy ((~) x)) (Comp (I <$> mx))
846+
847+getOid :: LibPQ.Oid -> Word32
848+getOid (LibPQ.Oid (CUInt oid)) = oid
squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs+12−1015
@@ -11,13 +11,15 @@ Squeal data definition language.
11{-# LANGUAGE
11{-# LANGUAGE
12 AllowAmbiguousTypes
12 AllowAmbiguousTypes
13 , ConstraintKinds
13 , ConstraintKinds
14+ , DeriveAnyClass
14 , DeriveGeneric
15 , DeriveGeneric
16+ , DerivingStrategies
15 , FlexibleContexts
17 , FlexibleContexts
16 , FlexibleInstances
18 , FlexibleInstances
17 , GADTs
19 , GADTs
18− , GeneralizedNewtypeDeriving
19 , LambdaCase
20 , LambdaCase
20 , MultiParamTypeClasses
21 , MultiParamTypeClasses
22+ , OverloadedLabels
21 , OverloadedStrings
23 , OverloadedStrings
22 , RankNTypes
24 , RankNTypes
23 , ScopedTypeVariables
25 , ScopedTypeVariables
@@ -25,82 +27,25 @@ Squeal data definition language.
25 , TypeInType
27 , TypeInType
26 , TypeOperators
28 , TypeOperators
27 , UndecidableSuperClasses
29 , UndecidableSuperClasses
30+ , UndecidableInstances
28#-}
31#-}
29
32
30module Squeal.PostgreSQL.Definition
33module Squeal.PostgreSQL.Definition
31 ( -- * Definition
34 ( -- * Definition
32 Definition (..)
35 Definition (..)
33 , (>>>)
36 , (>>>)
34− -- * Tables
37+ , manipDefinition
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
86 ) where
38 ) where
87
39
88import Control.Category
40import Control.Category
89import Control.DeepSeq
41import Control.DeepSeq
90import Data.ByteString
42import Data.ByteString
91import Data.Monoid
43import Data.Monoid
92−import GHC.TypeLits
93import Prelude hiding ((.), id)
44import Prelude hiding ((.), id)
94
45
95−import qualified Generics.SOP as SOP
96import qualified GHC.Generics as GHC
46import qualified GHC.Generics as GHC
97
47
98−import Squeal.PostgreSQL.Alias
48+import Squeal.PostgreSQL.Manipulation
99−import Squeal.PostgreSQL.Expression
100−import Squeal.PostgreSQL.Expression.Logic
101−import Squeal.PostgreSQL.List
102−import Squeal.PostgreSQL.PG
103−import Squeal.PostgreSQL.Query
104import Squeal.PostgreSQL.Render
49import Squeal.PostgreSQL.Render
105import Squeal.PostgreSQL.Schema
50import Squeal.PostgreSQL.Schema
106
51
@@ -128,958 +73,10 @@ instance Category Definition where
128 ddl1 . ddl0 = UnsafeDefinition $
73 ddl1 . ddl0 = UnsafeDefinition $
129 renderSQL ddl0 <> "\n" <> renderSQL ddl1
74 renderSQL ddl0 <> "\n" <> renderSQL ddl1
130
75
131−{-----------------------------------------
76+-- | A `Manipulation` without input or output can be run as a statement
132−CREATE statements
77+-- along with other `Definition`s, by embedding it using `manipDefinition`.
133−-----------------------------------------}
78+manipDefinition
134−
79+ :: Manipulation '[] schemas '[] '[]
135−createSchema
80+ -- ^ no input or output
136− :: KnownSymbol sch
137− => Alias sch
138− -> Definition schemas (Create sch '[] schemas)
139−createSchema sch = UnsafeDefinition $
140− "CREATE" <+> "SCHEMA" <+> renderSQL sch <> ";"
141−
142−createSchemaIfNotExists
143− :: (KnownSymbol sch, Has sch schemas schema)
144− => Alias sch
145 -> Definition schemas schemas
81 -> Definition schemas schemas
146−createSchemaIfNotExists sch = UnsafeDefinition $
82+manipDefinition = UnsafeDefinition . (<> ";") . renderSQL
147− "CREATE" <+> "SCHEMA" <+> "IF" <+> "NOT" <+> "EXISTS"
148− <+> renderSQL sch <> ";"
149−
150−{- | `createTable` adds a table to the schema.
151−
152−>>> :set -XOverloadedLabels
153−>>> :{
154−type Table = '[] :=>
155− '[ "a" ::: 'NoDef :=> 'Null 'PGint4
156− , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]
157−:}
158−
159−>>> :{
160−let
161− setup :: Definition (Public '[]) (Public '["tab" ::: 'Table Table])
162− setup = createTable #tab
163− (nullable int `as` #a :* nullable real `as` #b) Nil
164−in printSQL setup
165−:}
166−CREATE TABLE "tab" ("a" int NULL, "b" real NULL);
167−-}
168−createTable
169− :: ( KnownSymbol sch
170− , KnownSymbol tab
171− , columns ~ (col ': cols)
172− , SOP.SListI columns
173− , SOP.SListI constraints
174− , Has sch schemas0 schema0
175− , schemas1 ~ Alter sch (Create tab ('Table (constraints :=> columns)) schema0) schemas0 )
176− => QualifiedAlias sch tab -- ^ the name of the table to add
177− -> NP (Aliased (ColumnTypeExpression schemas0)) columns
178− -- ^ the names and datatype of each column
179− -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints
180− -- ^ constraints that must hold for the table
181− -> Definition schemas0 schemas1
182−createTable tab columns constraints = UnsafeDefinition $
183− "CREATE TABLE" <+> renderCreation tab columns constraints
184−
185−{-| `createTableIfNotExists` creates a table if it doesn't exist, but does not add it to the schema.
186−Instead, the schema already has the table so if the table did not yet exist, the schema was wrong.
187−`createTableIfNotExists` fixes this. Interestingly, this property makes it an idempotent in
188−the `Category` of `Definition`s.
189−
190−>>> :set -XOverloadedLabels -XTypeApplications
191−>>> :{
192−type Table = '[] :=>
193− '[ "a" ::: 'NoDef :=> 'Null 'PGint4
194− , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]
195−:}
196−
197−>>> type Schemas = Public '["tab" ::: 'Table Table]
198−
199−>>> :{
200−let
201− setup :: Definition Schemas Schemas
202− setup = createTableIfNotExists #tab
203− (nullable int `as` #a :* nullable real `as` #b) Nil
204−in printSQL setup
205−:}
206−CREATE TABLE IF NOT EXISTS "tab" ("a" int NULL, "b" real NULL);
207−-}
208−createTableIfNotExists
209− :: ( Has sch schemas schema
210− , Has tab schema ('Table (constraints :=> columns))
211− , SOP.SListI columns
212− , SOP.SListI constraints )
213− => QualifiedAlias sch tab -- ^ the name of the table to add
214− -> NP (Aliased (ColumnTypeExpression schemas)) columns
215− -- ^ the names and datatype of each column
216− -> NP (Aliased (TableConstraintExpression sch tab schemas)) constraints
217− -- ^ constraints that must hold for the table
218− -> Definition schemas schemas
219−createTableIfNotExists tab columns constraints = UnsafeDefinition $
220− "CREATE TABLE IF NOT EXISTS"
221− <+> renderCreation tab columns constraints
222−
223−-- helper function for `createTable` and `createTableIfNotExists`
224−renderCreation
225− :: ( KnownSymbol sch
226− , KnownSymbol tab
227− , SOP.SListI columns
228− , SOP.SListI constraints )
229− => QualifiedAlias sch tab -- ^ the name of the table to add
230− -> NP (Aliased (ColumnTypeExpression schemas0)) columns
231− -- ^ the names and datatype of each column
232− -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints
233− -- ^ constraints that must hold for the table
234− -> ByteString
235−renderCreation tab columns constraints = renderSQL tab
236− <+> parenthesized
237− ( renderCommaSeparated renderColumnDef columns
238− <> ( case constraints of
239− Nil -> ""
240− _ -> ", " <>
241− renderCommaSeparated renderConstraint constraints ) )
242− <> ";"
243− where
244− renderColumnDef :: Aliased (ColumnTypeExpression schemas) x -> ByteString
245− renderColumnDef (ty `As` column) =
246− renderSQL column <+> renderColumnTypeExpression ty
247− renderConstraint
248− :: Aliased (TableConstraintExpression sch tab schemas) constraint
249− -> ByteString
250− renderConstraint (constraint `As` alias) =
251− "CONSTRAINT" <+> renderSQL alias <+> renderSQL constraint
252−
253−-- | Data types are a way to limit the kind of data that can be stored in a
254−-- table. For many applications, however, the constraint they provide is
255−-- too coarse. For example, a column containing a product price should
256−-- probably only accept positive values. But there is no standard data type
257−-- that accepts only positive numbers. Another issue is that you might want
258−-- to constrain column data with respect to other columns or rows.
259−-- For example, in a table containing product information,
260−-- there should be only one row for each product number.
261−-- `TableConstraint`s give you as much control over the data in your tables
262−-- as you wish. If a user attempts to store data in a column that would
263−-- violate a constraint, an error is raised. This applies
264−-- even if the value came from the default value definition.
265−newtype TableConstraintExpression
266− (sch :: Symbol)
267− (tab :: Symbol)
268− (schemas :: SchemasType)
269− (constraint :: TableConstraint)
270− = UnsafeTableConstraintExpression
271− { renderTableConstraintExpression :: ByteString }
272− deriving (GHC.Generic,Show,Eq,Ord,NFData)
273−instance RenderSQL
274− (TableConstraintExpression sch tab schemas constraint) where
275− renderSQL = renderTableConstraintExpression
276−
277−{-| A `check` constraint is the most generic `TableConstraint` type.
278−It allows you to specify that the value in a certain column must satisfy
279−a Boolean (truth-value) expression.
280−
281−>>> :{
282−type Schema = '[
283− "tab" ::: 'Table ('[ "inequality" ::: 'Check '["a","b"]] :=> '[
284− "a" ::: 'NoDef :=> 'NotNull 'PGint4,
285− "b" ::: 'NoDef :=> 'NotNull 'PGint4
286− ])]
287−:}
288−
289−>>> :{
290−let
291− definition :: Definition (Public '[]) (Public Schema)
292− definition = createTable #tab
293− ( (int & notNullable) `as` #a :*
294− (int & notNullable) `as` #b )
295− ( check (#a :* #b) (#a .> #b) `as` #inequality )
296−:}
297−
298−>>> printSQL definition
299−CREATE TABLE "tab" ("a" int NOT NULL, "b" int NOT NULL, CONSTRAINT "inequality" CHECK (("a" > "b")));
300−-}
301−check
302− :: ( Has sch schemas schema
303− , Has tab schema ('Table table)
304− , HasAll aliases (TableToRow table) subcolumns )
305− => NP Alias aliases
306− -- ^ specify the subcolumns which are getting checked
307− -> (forall t. Condition '[] '[] 'Ungrouped schemas '[] '[t ::: subcolumns])
308− -- ^ a closed `Condition` on those subcolumns
309− -> TableConstraintExpression sch tab schemas ('Check aliases)
310−check _cols condition = UnsafeTableConstraintExpression $
311− "CHECK" <+> parenthesized (renderSQL condition)
312−
313−{-| A `unique` constraint ensure that the data contained in a column,
314−or a group of columns, is unique among all the rows in the table.
315−
316−>>> :{
317−type Schema = '[
318− "tab" ::: 'Table( '[ "uq_a_b" ::: 'Unique '["a","b"]] :=> '[
319− "a" ::: 'NoDef :=> 'Null 'PGint4,
320− "b" ::: 'NoDef :=> 'Null 'PGint4
321− ])]
322−:}
323−
324−>>> :{
325−let
326− definition :: Definition (Public '[]) (Public Schema)
327− definition = createTable #tab
328− ( (int & nullable) `as` #a :*
329− (int & nullable) `as` #b )
330− ( unique (#a :* #b) `as` #uq_a_b )
331−:}
332−
333−>>> printSQL definition
334−CREATE TABLE "tab" ("a" int NULL, "b" int NULL, CONSTRAINT "uq_a_b" UNIQUE ("a", "b"));
335−-}
336−unique
337− :: ( Has sch schemas schema
338− , Has tab schema('Table table)
339− , HasAll aliases (TableToRow table) subcolumns )
340− => NP Alias aliases
341− -- ^ specify subcolumns which together are unique for each row
342− -> TableConstraintExpression sch tab schemas ('Unique aliases)
343−unique columns = UnsafeTableConstraintExpression $
344− "UNIQUE" <+> parenthesized (renderSQL columns)
345−
346−{-| A `primaryKey` constraint indicates that a column, or group of columns,
347−can be used as a unique identifier for rows in the table.
348−This requires that the values be both unique and not null.
349−
350−>>> :{
351−type Schema = '[
352− "tab" ::: 'Table ('[ "pk_id" ::: 'PrimaryKey '["id"]] :=> '[
353− "id" ::: 'Def :=> 'NotNull 'PGint4,
354− "name" ::: 'NoDef :=> 'NotNull 'PGtext
355− ])]
356−:}
357−
358−>>> :{
359−let
360− definition :: Definition (Public '[]) (Public Schema)
361− definition = createTable #tab
362− ( serial `as` #id :*
363− (text & notNullable) `as` #name )
364− ( primaryKey #id `as` #pk_id )
365−:}
366−
367−>>> printSQL definition
368−CREATE TABLE "tab" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_id" PRIMARY KEY ("id"));
369−-}
370−primaryKey
371− :: ( Has sch schemas schema
372− , Has tab schema ('Table table)
373− , HasAll aliases (TableToColumns table) subcolumns
374− , AllNotNull subcolumns )
375− => NP Alias aliases
376− -- ^ specify the subcolumns which together form a primary key.
377− -> TableConstraintExpression sch tab schemas ('PrimaryKey aliases)
378−primaryKey columns = UnsafeTableConstraintExpression $
379− "PRIMARY KEY" <+> parenthesized (renderSQL columns)
380−
381−{-| A `foreignKey` specifies that the values in a column
382−(or a group of columns) must match the values appearing in some row of
383−another table. We say this maintains the referential integrity
384−between two related tables.
385−
386−>>> :{
387−type Schema =
388− '[ "users" ::: 'Table (
389− '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
390− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
391− , "name" ::: 'NoDef :=> 'NotNull 'PGtext
392− ])
393− , "emails" ::: 'Table (
394− '[ "pk_emails" ::: 'PrimaryKey '["id"]
395− , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
396− ] :=>
397− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
398− , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
399− , "email" ::: 'NoDef :=> 'Null 'PGtext
400− ])
401− ]
402−:}
403−
404−>>> :{
405−let
406− setup :: Definition (Public '[]) (Public Schema)
407− setup =
408− createTable #users
409− ( serial `as` #id :*
410− (text & notNullable) `as` #name )
411− ( primaryKey #id `as` #pk_users ) >>>
412− createTable #emails
413− ( serial `as` #id :*
414− (int & notNullable) `as` #user_id :*
415− (text & nullable) `as` #email )
416− ( primaryKey #id `as` #pk_emails :*
417− foreignKey #user_id #users #id
418− OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
419−in printSQL setup
420−:}
421−CREATE TABLE "users" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_users" PRIMARY KEY ("id"));
422−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);
423−
424−A `foreignKey` can even be a table self-reference.
425−
426−>>> :{
427−type Schema =
428− '[ "employees" ::: 'Table (
429− '[ "employees_pk" ::: 'PrimaryKey '["id"]
430− , "employees_employer_fk" ::: 'ForeignKey '["employer_id"] "employees" '["id"]
431− ] :=>
432− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
433− , "name" ::: 'NoDef :=> 'NotNull 'PGtext
434− , "employer_id" ::: 'NoDef :=> 'Null 'PGint4
435− ])
436− ]
437−:}
438−
439−>>> :{
440−let
441− setup :: Definition (Public '[]) (Public Schema)
442− setup =
443− createTable #employees
444− ( serial `as` #id :*
445− (text & notNullable) `as` #name :*
446− (integer & nullable) `as` #employer_id )
447− ( primaryKey #id `as` #employees_pk :*
448− foreignKey #employer_id #employees #id
449− OnDeleteCascade OnUpdateCascade `as` #employees_employer_fk )
450−in printSQL setup
451−:}
452−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);
453−-}
454−foreignKey
455− :: (ForeignKeyed schemas sch schema child parent
456− table reftable
457− columns refcolumns
458− constraints cols
459− reftys tys )
460− => NP Alias columns
461− -- ^ column or columns in the table
462− -> Alias parent
463− -- ^ reference table
464− -> NP Alias refcolumns
465− -- ^ reference column or columns in the reference table
466− -> OnDeleteClause
467− -- ^ what to do when reference is deleted
468− -> OnUpdateClause
469− -- ^ what to do when reference is updated
470− -> TableConstraintExpression sch child schemas
471− ('ForeignKey columns parent refcolumns)
472−foreignKey keys parent refs ondel onupd = UnsafeTableConstraintExpression $
473− "FOREIGN KEY" <+> parenthesized (renderSQL keys)
474− <+> "REFERENCES" <+> renderSQL parent
475− <+> parenthesized (renderSQL refs)
476− <+> renderSQL ondel
477− <+> renderSQL onupd
478−
479−-- | A constraint synonym between types involved in a foreign key constraint.
480−type ForeignKeyed schemas
481− sch
482− schema
483− child parent
484− table reftable
485− columns refcolumns
486− constraints cols
487− reftys tys =
488− ( Has sch schemas schema
489− , Has child schema ('Table table)
490− , Has parent schema ('Table reftable)
491− , HasAll columns (TableToColumns table) tys
492− , reftable ~ (constraints :=> cols)
493− , HasAll refcolumns cols reftys
494− , SOP.AllZip SamePGType tys reftys
495− , Uniquely refcolumns constraints )
496−
497−-- | `OnDeleteClause` indicates what to do with rows that reference a deleted row.
498−data OnDeleteClause
499− = OnDeleteNoAction
500− -- ^ if any referencing rows still exist when the constraint is checked,
501− -- an error is raised
502− | OnDeleteRestrict -- ^ prevents deletion of a referenced row
503− | OnDeleteCascade
504− -- ^ specifies that when a referenced row is deleted,
505− -- row(s) referencing it should be automatically deleted as well
506− deriving (GHC.Generic,Show,Eq,Ord)
507−instance NFData OnDeleteClause
508−-- | Render `OnDeleteClause`.
509−instance RenderSQL OnDeleteClause where
510− renderSQL = \case
511− OnDeleteNoAction -> "ON DELETE NO ACTION"
512− OnDeleteRestrict -> "ON DELETE RESTRICT"
513− OnDeleteCascade -> "ON DELETE CASCADE"
514−
515−-- | Analagous to `OnDeleteClause` there is also `OnUpdateClause` which is invoked
516−-- when a referenced column is changed (updated).
517−data OnUpdateClause
518− = OnUpdateNoAction
519− -- ^ if any referencing rows has not changed when the constraint is checked,
520− -- an error is raised
521− | OnUpdateRestrict -- ^ prevents update of a referenced row
522− | OnUpdateCascade
523− -- ^ the updated values of the referenced column(s) should be copied
524− -- into the referencing row(s)
525− deriving (GHC.Generic,Show,Eq,Ord)
526−instance NFData OnUpdateClause
527−
528−-- | Render `OnUpdateClause`.
529−instance RenderSQL OnUpdateClause where
530− renderSQL = \case
531− OnUpdateNoAction -> "ON UPDATE NO ACTION"
532− OnUpdateRestrict -> "ON UPDATE RESTRICT"
533− OnUpdateCascade -> "ON UPDATE CASCADE"
534−
535−{-----------------------------------------
536−DROP statements
537−-----------------------------------------}
538−
539−-- >>> :{
540−-- let
541−-- definition :: Definition '["muh_schema" ::: schema, "public" ::: public] '["public" ::: public]
542−-- definition = dropSchema #muh_schema
543−-- :}
544−--
545−-- >>> printSQL definition
546−-- DROP SCHEMA "muh_schema";
547−dropSchema
548− :: Has sch schemas schema
549− => Alias sch
550− -> Definition schemas (Drop sch schemas)
551−dropSchema sch = UnsafeDefinition $ "DROP SCHEMA" <+> renderSQL sch <> ";"
552−
553−-- | `dropTable` removes a table from the schema.
554−--
555−-- >>> :{
556−-- let
557−-- definition :: Definition '["public" ::: '["muh_table" ::: 'Table t]] (Public '[])
558−-- definition = dropTable #muh_table
559−-- :}
560−--
561−-- >>> printSQL definition
562−-- DROP TABLE "muh_table";
563−dropTable
564− :: ( Has sch schemas schema
565− , Has tab schema ('Table table))
566− => QualifiedAlias sch tab -- ^ table to remove
567− -> Definition schemas (Alter sch (Drop tab schema) schemas)
568−dropTable tab = UnsafeDefinition $ "DROP TABLE" <+> renderSQL tab <> ";"
569−
570−{-----------------------------------------
571−ALTER statements
572−-----------------------------------------}
573−
574−-- | `alterTable` changes the definition of a table from the schema.
575−alterTable
576− :: (Has sch schemas schema, Has tab schema ('Table table0))
577− => QualifiedAlias sch tab -- ^ table to alter
578− -> AlterTable sch tab schemas table1 -- ^ alteration to perform
579− -> Definition schemas (Alter sch (Alter tab ('Table table1) schema) schemas)
580−alterTable tab alteration = UnsafeDefinition $
581− "ALTER TABLE"
582− <+> renderSQL tab
583− <+> renderAlterTable alteration
584− <> ";"
585−
586−-- | `alterTableRename` changes the name of a table from the schema.
587−--
588−-- >>> printSQL $ alterTableRename #foo #bar
589−-- ALTER TABLE "foo" RENAME TO "bar";
590−alterTableRename
591− :: (KnownSymbol table0, KnownSymbol table1)
592− => Alias table0 -- ^ table to rename
593− -> Alias table1 -- ^ what to rename it
594− -> Definition schema (Rename table0 table1 schema)
595−alterTableRename table0 table1 = UnsafeDefinition $
596− "ALTER TABLE" <+> renderSQL table0
597− <+> "RENAME TO" <+> renderSQL table1 <> ";"
598−
599−-- | An `AlterTable` describes the alteration to perform on the columns
600−-- of a table.
601−newtype AlterTable
602− (sch :: Symbol)
603− (tab :: Symbol)
604− (schemas :: SchemasType)
605− (table :: TableType) =
606− UnsafeAlterTable {renderAlterTable :: ByteString}
607− deriving (GHC.Generic,Show,Eq,Ord,NFData)
608−
609−-- | An `addConstraint` adds a table constraint.
610−--
611−-- >>> :{
612−-- let
613−-- definition :: Definition
614−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
615−-- '["public" ::: '["tab" ::: 'Table ('["positive" ::: 'Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
616−-- definition = alterTable #tab (addConstraint #positive (check #col (#col .> 0)))
617−-- in printSQL definition
618−-- :}
619−-- ALTER TABLE "tab" ADD CONSTRAINT "positive" CHECK (("col" > 0));
620−addConstraint
621− :: ( KnownSymbol alias
622− , Has sch schemas schema
623− , Has tab schema ('Table table0)
624− , table0 ~ (constraints :=> columns)
625− , table1 ~ (Create alias constraint constraints :=> columns) )
626− => Alias alias
627− -> TableConstraintExpression sch tab schemas constraint
628− -- ^ constraint to add
629− -> AlterTable sch tab schemas table1
630−addConstraint alias constraint = UnsafeAlterTable $
631− "ADD" <+> "CONSTRAINT" <+> renderSQL alias
632− <+> renderSQL constraint
633−
634−-- | A `dropConstraint` drops a table constraint.
635−--
636−-- >>> :{
637−-- let
638−-- definition :: Definition
639−-- '["public" ::: '["tab" ::: 'Table ('["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
640−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
641−-- definition = alterTable #tab (dropConstraint #positive)
642−-- in printSQL definition
643−-- :}
644−-- ALTER TABLE "tab" DROP CONSTRAINT "positive";
645−dropConstraint
646− :: ( KnownSymbol constraint
647− , Has sch schemas schema
648− , Has tab schema ('Table table0)
649− , table0 ~ (constraints :=> columns)
650− , table1 ~ (Drop constraint constraints :=> columns) )
651− => Alias constraint
652− -- ^ constraint to drop
653− -> AlterTable sch tab schemas table1
654−dropConstraint constraint = UnsafeAlterTable $
655− "DROP" <+> "CONSTRAINT" <+> renderSQL constraint
656−
657−-- | An `AddColumn` is either @NULL@ or has @DEFAULT@.
658−class AddColumn ty where
659− -- | `addColumn` adds a new column, initially filled with whatever
660− -- default value is given or with @NULL@.
661− --
662− -- >>> :{
663− -- let
664− -- definition :: Definition
665− -- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]
666− -- '["public" ::: '["tab" ::: 'Table ('[] :=>
667− -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
668− -- , "col2" ::: 'Def :=> 'Null 'PGtext ])]]
669− -- definition = alterTable #tab (addColumn #col2 (text & nullable & default_ "foo"))
670− -- in printSQL definition
671− -- :}
672− -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL DEFAULT E'foo';
673− --
674− -- >>> :{
675− -- let
676− -- definition :: Definition
677− -- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]
678− -- '["public" ::: '["tab" ::: 'Table ('[] :=>
679− -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
680− -- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]]
681− -- definition = alterTable #tab (addColumn #col2 (text & nullable))
682− -- in printSQL definition
683− -- :}
684− -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL;
685− addColumn
686− :: ( KnownSymbol column
687− , Has sch schemas schema
688− , Has tab schema ('Table table0)
689− , table0 ~ (constraints :=> columns) )
690− => Alias column -- ^ column to add
691− -> ColumnTypeExpression schemas ty -- ^ type of the new column
692− -> AlterTable sch tab schemas (constraints :=> Create column ty columns)
693− addColumn column ty = UnsafeAlterTable $
694− "ADD COLUMN" <+> renderSQL column <+> renderColumnTypeExpression ty
695−instance {-# OVERLAPPING #-} AddColumn ('Def :=> ty)
696−instance {-# OVERLAPPABLE #-} AddColumn ('NoDef :=> 'Null ty)
697−
698−-- | A `dropColumn` removes a column. Whatever data was in the column
699−-- disappears. Table constraints involving the column are dropped, too.
700−-- However, if the column is referenced by a foreign key constraint of
701−-- another table, PostgreSQL will not silently drop that constraint.
702−--
703−-- >>> :{
704−-- let
705−-- definition :: Definition
706−-- '["public" ::: '["tab" ::: 'Table ('[] :=>
707−-- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
708−-- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]]
709−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]
710−-- definition = alterTable #tab (dropColumn #col2)
711−-- in printSQL definition
712−-- :}
713−-- ALTER TABLE "tab" DROP COLUMN "col2";
714−dropColumn
715− :: ( KnownSymbol column
716− , Has sch schemas schema
717− , Has tab schema ('Table table0)
718− , table0 ~ (constraints :=> columns)
719− , table1 ~ (constraints :=> Drop column columns) )
720− => Alias column -- ^ column to remove
721− -> AlterTable sch tab schemas table1
722−dropColumn column = UnsafeAlterTable $
723− "DROP COLUMN" <+> renderSQL column
724−
725−-- | A `renameColumn` renames a column.
726−--
727−-- >>> :{
728−-- let
729−-- definition :: Definition
730−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["foo" ::: 'NoDef :=> 'Null 'PGint4])]]
731−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["bar" ::: 'NoDef :=> 'Null 'PGint4])]]
732−-- definition = alterTable #tab (renameColumn #foo #bar)
733−-- in printSQL definition
734−-- :}
735−-- ALTER TABLE "tab" RENAME COLUMN "foo" TO "bar";
736−renameColumn
737− :: ( KnownSymbol column0
738− , KnownSymbol column1
739− , Has sch schemas schema
740− , Has tab schema ('Table table0)
741− , table0 ~ (constraints :=> columns)
742− , table1 ~ (constraints :=> Rename column0 column1 columns) )
743− => Alias column0 -- ^ column to rename
744− -> Alias column1 -- ^ what to rename the column
745− -> AlterTable sch tab schemas table1
746−renameColumn column0 column1 = UnsafeAlterTable $
747− "RENAME COLUMN" <+> renderSQL column0 <+> "TO" <+> renderSQL column1
748−
749−-- | An `alterColumn` alters a single column.
750−alterColumn
751− :: ( KnownSymbol column
752− , Has sch schemas schema
753− , Has tab schema ('Table table0)
754− , table0 ~ (constraints :=> columns)
755− , Has column columns ty0
756− , table1 ~ (constraints :=> Alter column ty1 columns))
757− => Alias column -- ^ column to alter
758− -> AlterColumn schemas ty0 ty1 -- ^ alteration to perform
759− -> AlterTable sch tab schemas table1
760−alterColumn column alteration = UnsafeAlterTable $
761− "ALTER COLUMN" <+> renderSQL column <+> renderAlterColumn alteration
762−
763−-- | An `AlterColumn` describes the alteration to perform on a single column.
764−newtype AlterColumn (schemas :: SchemasType) (ty0 :: ColumnType) (ty1 :: ColumnType) =
765− UnsafeAlterColumn {renderAlterColumn :: ByteString}
766− deriving (GHC.Generic,Show,Eq,Ord,NFData)
767−
768−-- | A `setDefault` sets a new default for a column. Note that this doesn't
769−-- affect any existing rows in the table, it just changes the default for
770−-- future insert and update commands.
771−--
772−-- >>> :{
773−-- let
774−-- definition :: Definition
775−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
776−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]]
777−-- definition = alterTable #tab (alterColumn #col (setDefault 5))
778−-- in printSQL definition
779−-- :}
780−-- ALTER TABLE "tab" ALTER COLUMN "col" SET DEFAULT 5;
781−setDefault
782− :: Expression '[] '[] 'Ungrouped schemas '[] '[] ty -- ^ default value to set
783− -> AlterColumn schemas (constraint :=> ty) ('Def :=> ty)
784−setDefault expression = UnsafeAlterColumn $
785− "SET DEFAULT" <+> renderExpression expression
786−
787−-- | A `dropDefault` removes any default value for a column.
788−--
789−-- >>> :{
790−-- let
791−-- definition :: Definition
792−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]]
793−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
794−-- definition = alterTable #tab (alterColumn #col dropDefault)
795−-- in printSQL definition
796−-- :}
797−-- ALTER TABLE "tab" ALTER COLUMN "col" DROP DEFAULT;
798−dropDefault :: AlterColumn schemas ('Def :=> ty) ('NoDef :=> ty)
799−dropDefault = UnsafeAlterColumn $ "DROP DEFAULT"
800−
801−-- | A `setNotNull` adds a @NOT NULL@ constraint to a column.
802−-- The constraint will be checked immediately, so the table data must satisfy
803−-- the constraint before it can be added.
804−--
805−-- >>> :{
806−-- let
807−-- definition :: Definition
808−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
809−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
810−-- definition = alterTable #tab (alterColumn #col setNotNull)
811−-- in printSQL definition
812−-- :}
813−-- ALTER TABLE "tab" ALTER COLUMN "col" SET NOT NULL;
814−setNotNull
815− :: AlterColumn schemas (constraint :=> 'Null ty) (constraint :=> 'NotNull ty)
816−setNotNull = UnsafeAlterColumn $ "SET NOT NULL"
817−
818−-- | A `dropNotNull` drops a @NOT NULL@ constraint from a column.
819−--
820−-- >>> :{
821−-- let
822−-- definition :: Definition
823−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
824−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
825−-- definition = alterTable #tab (alterColumn #col dropNotNull)
826−-- in printSQL definition
827−-- :}
828−-- ALTER TABLE "tab" ALTER COLUMN "col" DROP NOT NULL;
829−dropNotNull
830− :: AlterColumn schemas (constraint :=> 'NotNull ty) (constraint :=> 'Null ty)
831−dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL"
832−
833−-- | An `alterType` converts a column to a different data type.
834−-- This will succeed only if each existing entry in the column can be
835−-- converted to the new type by an implicit cast.
836−--
837−-- >>> :{
838−-- let
839−-- definition :: Definition
840−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
841−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGnumeric])]]
842−-- definition =
843−-- alterTable #tab (alterColumn #col (alterType (numeric & notNullable)))
844−-- in printSQL definition
845−-- :}
846−-- ALTER TABLE "tab" ALTER COLUMN "col" TYPE numeric NOT NULL;
847−alterType :: ColumnTypeExpression schemas ty -> AlterColumn schemas ty0 ty
848−alterType ty = UnsafeAlterColumn $ "TYPE" <+> renderColumnTypeExpression ty
849−
850−{- | Create a view.
851−>>> type ABC = '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4]
852−>>> type BC = '["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4]
853−>>> :{
854−let
855− definition :: Definition
856− '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC)]]
857− '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC), "bc" ::: 'View BC]]
858− definition =
859− createView #bc (select_ (#b :* #c) (from (table #abc)))
860−in printSQL definition
861−:}
862−CREATE VIEW "bc" AS SELECT "b" AS "b", "c" AS "c" FROM "abc" AS "abc";
863−-}
864−createView
865− :: (KnownSymbol sch, KnownSymbol vw, Has sch schemas schema)
866− => QualifiedAlias sch vw -- ^ the name of the view to add
867− -> Query '[] '[] schemas '[] view -- ^ query
868− -> Definition schemas (Alter sch (Create vw ('View view) schema) schemas)
869−createView alias query = UnsafeDefinition $
870− "CREATE" <+> "VIEW" <+> renderSQL alias <+> "AS"
871− <+> renderQuery query <> ";"
872−
873−-- | Drop a view.
874−--
875−-- >>> :{
876−-- let
877−-- definition :: Definition
878−-- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])
879−-- , "bc" ::: 'View ('["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4])]]
880−-- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])]]
881−-- definition = dropView #bc
882−-- in printSQL definition
883−-- :}
884−-- DROP VIEW "bc";
885−dropView
886− :: (Has sch schemas schema, Has vw schema ('View view))
887− => QualifiedAlias sch vw -- ^ view to remove
888− -> Definition schemas (Alter sch (Drop vw schema) schemas)
889−dropView vw = UnsafeDefinition $ "DROP VIEW" <+> renderSQL vw <> ";"
890−
891−-- | Enumerated types are created using the `createTypeEnum` command, for example
892−--
893−-- >>> printSQL $ (createTypeEnum #mood (label @"sad" :* label @"ok" :* label @"happy") :: Definition (Public '[]) '["public" ::: '["mood" ::: 'Typedef ('PGenum '["sad","ok","happy"])]])
894−-- CREATE TYPE "mood" AS ENUM ('sad', 'ok', 'happy');
895−createTypeEnum
896− :: (KnownSymbol enum, Has sch schemas schema, SOP.All KnownSymbol labels)
897− => QualifiedAlias sch enum
898− -- ^ name of the user defined enumerated type
899− -> NP PGlabel labels
900− -- ^ labels of the enumerated type
901− -> Definition schemas (Alter sch (Create enum ('Typedef ('PGenum labels)) schema) schemas)
902−createTypeEnum enum labels = UnsafeDefinition $
903− "CREATE" <+> "TYPE" <+> renderSQL enum <+> "AS" <+> "ENUM" <+>
904− parenthesized (renderSQL labels) <> ";"
905−
906−-- | Enumerated types can also be generated from a Haskell type, for example
907−--
908−-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic
909−-- >>> instance SOP.Generic Schwarma
910−-- >>> instance SOP.HasDatatypeInfo Schwarma
911−-- >>> :{
912−-- let
913−-- createSchwarma :: Definition (Public '[]) '["public" ::: '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))]]
914−-- createSchwarma = createTypeEnumFrom @Schwarma #schwarma
915−-- in
916−-- printSQL createSchwarma
917−-- :}
918−-- CREATE TYPE "schwarma" AS ENUM ('Beef', 'Lamb', 'Chicken');
919−createTypeEnumFrom
920− :: forall hask sch enum schemas schema.
921− ( SOP.Generic hask
922− , SOP.All KnownSymbol (LabelsPG hask)
923− , KnownSymbol enum
924− , Has sch schemas schema )
925− => QualifiedAlias sch enum
926− -- ^ name of the user defined enumerated type
927− -> Definition schemas (Alter sch (Create enum ('Typedef (PG (Enumerated hask))) schema) schemas)
928−createTypeEnumFrom enum = createTypeEnum enum
929− (SOP.hpure label :: NP PGlabel (LabelsPG hask))
930−
931−{- | `createTypeComposite` creates a composite type. The composite type is
932−specified by a list of attribute names and data types.
933−
934−>>> :{
935−type PGcomplex = 'PGcomposite
936− '[ "real" ::: 'NotNull 'PGfloat8
937− , "imaginary" ::: 'NotNull 'PGfloat8 ]
938−:}
939−
940−>>> :{
941−let
942− setup :: Definition (Public '[]) '["public" ::: '["complex" ::: 'Typedef PGcomplex]]
943− setup = createTypeComposite #complex
944− (float8 `as` #real :* float8 `as` #imaginary)
945−in printSQL setup
946−:}
947−CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);
948−-}
949−createTypeComposite
950− :: (KnownSymbol ty, Has sch schemas schema, SOP.SListI fields)
951− => QualifiedAlias sch ty
952− -- ^ name of the user defined composite type
953− -> NP (Aliased (TypeExpression schemas)) fields
954− -- ^ list of attribute names and data types
955− -> Definition schemas (Alter sch (Create ty ('Typedef ('PGcomposite fields)) schema) schemas)
956−createTypeComposite ty fields = UnsafeDefinition $
957− "CREATE" <+> "TYPE" <+> renderSQL ty <+> "AS" <+> parenthesized
958− (renderCommaSeparated renderField fields) <> ";"
959− where
960− renderField :: Aliased (TypeExpression schemas) x -> ByteString
961− renderField (typ `As` alias) =
962− renderSQL alias <+> renderSQL typ
963−
964−-- | Composite types can also be generated from a Haskell type, for example
965−--
966−-- >>> data Complex = Complex {real :: Double, imaginary :: Double} deriving GHC.Generic
967−-- >>> instance SOP.Generic Complex
968−-- >>> instance SOP.HasDatatypeInfo Complex
969−-- >>> type Schema = '["complex" ::: 'Typedef (PG (Composite Complex))]
970−-- >>> :{
971−-- let
972−-- createComplex :: Definition (Public '[]) (Public Schema)
973−-- createComplex = createTypeCompositeFrom @Complex #complex
974−-- in
975−-- printSQL createComplex
976−-- :}
977−-- CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);
978−createTypeCompositeFrom
979− :: forall hask sch ty schemas schema.
980− ( SOP.All (FieldTyped schemas) (RowPG hask)
981− , KnownSymbol ty
982− , Has sch schemas schema )
983− => QualifiedAlias sch ty
984− -- ^ name of the user defined composite type
985− -> Definition schemas (Alter sch (Create ty ( 'Typedef (PG (Composite hask))) schema) schemas)
986−createTypeCompositeFrom ty = createTypeComposite ty
987− (SOP.hcpure (SOP.Proxy :: SOP.Proxy (FieldTyped schemas)) fieldtype
988− :: NP (Aliased (TypeExpression schemas)) (RowPG hask))
989−
990−{-|
991−`createDomain` creates a new domain. A domain is essentially a data type
992−with constraints (restrictions on the allowed set of values).
993−
994−Domains are useful for abstracting common constraints on fields
995−into a single location for maintenance. For example, several tables might
996−contain email address columns, all requiring the same `check` constraint
997−to verify the address syntax. Define a domain rather than setting up
998−each table's constraint individually.
999−
1000−>>> :{
1001−let
1002− createPositive :: Definition (Public '[]) (Public '["positive" ::: 'Typedef 'PGfloat4])
1003− createPositive = createDomain #positive real (#value .> 0 .&& (#value & isNotNull))
1004−in printSQL createPositive
1005−:}
1006−CREATE DOMAIN "positive" AS real CHECK ((("value" > 0) AND "value" IS NOT NULL));
1007−-}
1008−createDomain
1009− :: (Has sch schemas schema, KnownSymbol dom)
1010− => QualifiedAlias sch dom
1011− -> (forall nullity. TypeExpression schemas (nullity ty))
1012− -> (forall tab. Condition '[] '[] 'Ungrouped schemas '[] '[tab ::: '["value" ::: 'Null ty]])
1013− -> Definition schemas (Alter sch (Create alias ('Typedef ty) schema) schemas)
1014−createDomain dom ty condition =
1015− UnsafeDefinition $ "CREATE DOMAIN" <+> renderSQL dom
1016− <+> "AS" <+> renderTypeExpression ty
1017− <+> "CHECK" <+> parenthesized (renderSQL condition) <> ";"
1018−
1019−class FieldTyped schemas ty where
1020− fieldtype :: Aliased (TypeExpression schemas) ty
1021−instance (KnownSymbol alias, PGTyped schemas ty)
1022− => FieldTyped schemas (alias ::: ty) where
1023− fieldtype = pgtype `As` Alias
1024−
1025−-- | Drop a type.
1026−--
1027−-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic
1028−-- >>> instance SOP.Generic Schwarma
1029−-- >>> instance SOP.HasDatatypeInfo Schwarma
1030−-- >>> printSQL (dropType #schwarma :: Definition '["public" ::: '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))]] (Public '[]))
1031−-- DROP TYPE "schwarma";
1032−dropType
1033− :: (Has sch schemas schema, Has td schema ('Typedef ty))
1034− => QualifiedAlias sch td
1035− -- ^ name of the user defined type
1036− -> Definition schemas (Alter sch (Drop td schema) schemas)
1037−dropType tydef = UnsafeDefinition $ "DROP" <+> "TYPE" <+> renderSQL tydef <> ";"
1038−
1039−-- | `ColumnTypeExpression`s are used in `createTable` commands.
1040−newtype ColumnTypeExpression (schemas :: SchemasType) (ty :: ColumnType)
1041− = UnsafeColumnTypeExpression { renderColumnTypeExpression :: ByteString }
1042− deriving (GHC.Generic,Show,Eq,Ord,NFData)
1043−instance RenderSQL (ColumnTypeExpression schemas ty) where
1044− renderSQL = renderColumnTypeExpression
1045−
1046−-- | used in `createTable` commands as a column constraint to note that
1047−-- @NULL@ may be present in a column
1048−nullable
1049− :: TypeExpression schemas (nullity ty)
1050− -> ColumnTypeExpression schemas ('NoDef :=> 'Null ty)
1051−nullable ty = UnsafeColumnTypeExpression $ renderSQL ty <+> "NULL"
1052−
1053−-- | used in `createTable` commands as a column constraint to ensure
1054−-- @NULL@ is not present in a column
1055−notNullable
1056− :: TypeExpression schemas (nullity ty)
1057− -> ColumnTypeExpression schemas ('NoDef :=> 'NotNull ty)
1058−notNullable ty = UnsafeColumnTypeExpression $ renderSQL ty <+> "NOT NULL"
1059−
1060−-- | used in `createTable` commands as a column constraint to give a default
1061−default_
1062− :: Expression '[] '[] 'Ungrouped schemas '[] '[] ty
1063− -> ColumnTypeExpression schemas ('NoDef :=> ty)
1064− -> ColumnTypeExpression schemas ('Def :=> ty)
1065−default_ x ty = UnsafeColumnTypeExpression $
1066− renderSQL ty <+> "DEFAULT" <+> renderExpression x
1067−
1068−-- | not a true type, but merely a notational convenience for creating
1069−-- unique identifier columns with type `PGint2`
1070−serial2, smallserial
1071− :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint2)
1072−serial2 = UnsafeColumnTypeExpression "serial2"
1073−smallserial = UnsafeColumnTypeExpression "smallserial"
1074−-- | not a true type, but merely a notational convenience for creating
1075−-- unique identifier columns with type `PGint4`
1076−serial4, serial
1077− :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint4)
1078−serial4 = UnsafeColumnTypeExpression "serial4"
1079−serial = UnsafeColumnTypeExpression "serial"
1080−-- | not a true type, but merely a notational convenience for creating
1081−-- unique identifier columns with type `PGint8`
1082−serial8, bigserial
1083− :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint8)
1084−serial8 = UnsafeColumnTypeExpression "serial8"
1085−bigserial = UnsafeColumnTypeExpression "bigserial"
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Function.hsnew file+238
@@ -0,0 +1,238 @@
1+{-|
2+Module: Squeal.PostgreSQL.Definition.Function
3+Description: Create and drop function and operator definitions
4+Copyright: (c) Eitan Chatav, 2017
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Create and drop function and operator definitions.
9+-}
10+
11+{-# LANGUAGE
12+ AllowAmbiguousTypes
13+ , ConstraintKinds
14+ , DeriveAnyClass
15+ , DeriveGeneric
16+ , DerivingStrategies
17+ , FlexibleContexts
18+ , FlexibleInstances
19+ , GADTs
20+ , LambdaCase
21+ , MultiParamTypeClasses
22+ , OverloadedLabels
23+ , OverloadedStrings
24+ , RankNTypes
25+ , ScopedTypeVariables
26+ , TypeApplications
27+ , TypeInType
28+ , TypeOperators
29+ , UndecidableSuperClasses
30+#-}
31+
32+module Squeal.PostgreSQL.Definition.Function
33+ ( createFunction
34+ , createOrReplaceFunction
35+ , createSetFunction
36+ , createOrReplaceSetFunction
37+ , createBinaryOp
38+ , createLeftOp
39+ , createRightOp
40+ , dropFunction
41+ , dropFunctionIfExists
42+ , dropOperator
43+ , dropOperatorIfExists
44+ , FunctionDefinition(..)
45+ , languageSqlExpr
46+ , languageSqlQuery
47+ ) where
48+
49+import Control.DeepSeq
50+import Data.ByteString
51+import GHC.TypeLits
52+
53+import qualified Generics.SOP as SOP
54+import qualified GHC.Generics as GHC
55+
56+import Squeal.PostgreSQL.Alias
57+import Squeal.PostgreSQL.Definition
58+import Squeal.PostgreSQL.Expression
59+import Squeal.PostgreSQL.Expression.Type
60+import Squeal.PostgreSQL.List
61+import Squeal.PostgreSQL.Query
62+import Squeal.PostgreSQL.Render
63+import Squeal.PostgreSQL.Schema
64+
65+-- $setup
66+-- >>> import Squeal.PostgreSQL
67+
68+createFunction
69+ :: ( Has sch schemas schema
70+ , KnownSymbol fun
71+ , SOP.SListI args )
72+ => QualifiedAlias sch fun
73+ -> NP (TypeExpression schemas) args
74+ -> TypeExpression schemas ret
75+ -> FunctionDefinition schemas args ('Returns ret)
76+ -> Definition schemas (Alter sch (Create fun ('Function (args :=> 'Returns ret)) schema) schemas)
77+createFunction fun args ret fundef = UnsafeDefinition $
78+ "CREATE" <+> "FUNCTION" <+> renderSQL fun
79+ <+> parenthesized (renderCommaSeparated renderSQL args)
80+ <+> "RETURNS" <+> renderSQL ret <+> renderSQL fundef <> ";"
81+
82+createOrReplaceFunction
83+ :: ( Has sch schemas schema
84+ , KnownSymbol fun
85+ , SOP.SListI args )
86+ => QualifiedAlias sch fun
87+ -> NP (TypeExpression schemas) args
88+ -> TypeExpression schemas ret
89+ -> FunctionDefinition schemas args ('Returns ret)
90+ -> Definition schemas (Alter sch (CreateOrReplace fun ('Function (args :=> 'Returns ret)) schema) schemas)
91+createOrReplaceFunction fun args ret fundef = UnsafeDefinition $
92+ "CREATE" <+> "OR" <+> "REPLACE" <+> "FUNCTION" <+> renderSQL fun
93+ <+> parenthesized (renderCommaSeparated renderSQL args)
94+ <+> "RETURNS" <+> renderSQL ret <+> renderSQL fundef <> ";"
95+
96+languageSqlExpr
97+ :: Expression '[] '[] 'Ungrouped schemas args '[] ret
98+ -> FunctionDefinition schemas args ('Returns ret)
99+languageSqlExpr expr = UnsafeFunctionDefinition $
100+ "language sql as"
101+ <+> "$$" <+> renderSQL (values_ (expr `as` #ret)) <+> "$$"
102+
103+languageSqlQuery
104+ :: Query '[] '[] schemas args rets
105+ -> FunctionDefinition schemas args ('ReturnsTable rets)
106+languageSqlQuery qry = UnsafeFunctionDefinition $
107+ "language sql as" <+> "$$" <+> renderSQL qry <+> "$$"
108+
109+createSetFunction
110+ :: ( Has sch schemas schema
111+ , KnownSymbol fun
112+ , SOP.SListI args
113+ , SOP.SListI rets )
114+ => QualifiedAlias sch fun
115+ -> NP (TypeExpression schemas) args
116+ -> NP (Aliased (TypeExpression schemas)) rets
117+ -> FunctionDefinition schemas args ('ReturnsTable rets)
118+ -> Definition schemas (Alter sch (Create fun ('Function (args :=> 'ReturnsTable rets)) schema) schemas)
119+createSetFunction fun args rets fundef = UnsafeDefinition $
120+ "CREATE" <+> "FUNCTION" <+> renderSQL fun
121+ <+> parenthesized (renderCommaSeparated renderSQL args)
122+ <+> "RETURNS" <+> "TABLE"
123+ <+> parenthesized (renderCommaSeparated renderRet rets)
124+ <+> renderSQL fundef <> ";"
125+ where
126+ renderRet :: Aliased (TypeExpression s) r -> ByteString
127+ renderRet (ty `As` col) = renderSQL col <+> renderSQL ty
128+
129+createOrReplaceSetFunction
130+ :: ( Has sch schemas schema
131+ , KnownSymbol fun
132+ , SOP.SListI args
133+ , SOP.SListI rets )
134+ => QualifiedAlias sch fun
135+ -> NP (TypeExpression schemas) args
136+ -> NP (Aliased (TypeExpression schemas)) rets
137+ -> FunctionDefinition schemas args ('ReturnsTable rets)
138+ -> Definition schemas (Alter sch (CreateOrReplace fun ('Function (args :=> 'ReturnsTable rets)) schema) schemas)
139+createOrReplaceSetFunction fun args rets fundef = UnsafeDefinition $
140+ "CREATE" <+> "OR" <+> "REPLACE" <+> "FUNCTION" <+> renderSQL fun
141+ <+> parenthesized (renderCommaSeparated renderSQL args)
142+ <+> "RETURNS" <+> "TABLE"
143+ <+> parenthesized (renderCommaSeparated renderRet rets)
144+ <+> renderSQL fundef <> ";"
145+ where
146+ renderRet :: Aliased (TypeExpression s) r -> ByteString
147+ renderRet (ty `As` col) = renderSQL col <+> renderSQL ty
148+
149+createBinaryOp
150+ :: forall op fun sch schemas schema x y z.
151+ ( Has sch schemas schema
152+ , Has fun schema ('Function ('[x,y] :=> 'Returns z))
153+ , KnownSymbol op )
154+ => QualifiedAlias sch fun
155+ -> TypeExpression schemas x
156+ -> TypeExpression schemas y
157+ -> Definition schemas
158+ (Alter sch (Create op ('Operator ('BinaryOp x y z)) schema) schemas)
159+createBinaryOp fun x y = UnsafeDefinition $
160+ "CREATE" <+> "OPERATOR" <+> renderSymbol @op
161+ <+> parenthesized (commaSeparated opdef)
162+ where
163+ opdef =
164+ [ "FUNCTION" <+> "=" <+> renderSQL fun
165+ , "LEFTARG" <+> "=" <+> renderSQL x
166+ , "RIGHTARG" <+> "=" <+> renderSQL y ]
167+
168+createLeftOp
169+ :: forall op fun sch schemas schema x y.
170+ ( Has sch schemas schema
171+ , Has fun schema ('Function ('[x] :=> 'Returns y))
172+ , KnownSymbol op )
173+ => QualifiedAlias sch fun
174+ -> TypeExpression schemas x
175+ -> Definition schemas
176+ (Alter sch (Create op ('Operator ('LeftOp x y)) schema) schemas)
177+createLeftOp fun x = UnsafeDefinition $
178+ "CREATE" <+> "OPERATOR" <+> renderSymbol @op
179+ <+> parenthesized (commaSeparated opdef)
180+ where
181+ opdef =
182+ [ "FUNCTION" <+> "=" <+> renderSQL fun
183+ , "RIGHTARG" <+> "=" <+> renderSQL x ]
184+
185+createRightOp
186+ :: forall op fun sch schemas schema x y.
187+ ( Has sch schemas schema
188+ , Has fun schema ('Function ('[x] :=> 'Returns y))
189+ , KnownSymbol op )
190+ => QualifiedAlias sch fun
191+ -> TypeExpression schemas x
192+ -> Definition schemas
193+ (Alter sch (Create op ('Operator ('RightOp x y)) schema) schemas)
194+createRightOp fun x = UnsafeDefinition $
195+ "CREATE" <+> "OPERATOR" <+> renderSymbol @op
196+ <+> parenthesized (commaSeparated opdef)
197+ where
198+ opdef =
199+ [ "FUNCTION" <+> "=" <+> renderSQL fun
200+ , "LEFTARG" <+> "=" <+> renderSQL x ]
201+
202+dropFunction
203+ :: (Has sch schemas schema, KnownSymbol fun)
204+ => QualifiedAlias sch fun
205+ -- ^ name of the user defined function
206+ -> Definition schemas (Alter sch (DropSchemum fun 'Function schema) schemas)
207+dropFunction fun = UnsafeDefinition $
208+ "DROP" <+> "FUNCTION" <+> renderSQL fun <> ";"
209+
210+dropFunctionIfExists
211+ :: (Has sch schemas schema, KnownSymbol fun)
212+ => QualifiedAlias sch fun
213+ -- ^ name of the user defined function
214+ -> Definition schemas (Alter sch (DropSchemumIfExists fun 'Function schema) schemas)
215+dropFunctionIfExists fun = UnsafeDefinition $
216+ "DROP FUNCTION IF EXISTS" <+> renderSQL fun <> ";"
217+
218+dropOperator
219+ :: (Has sch schemas schema, KnownSymbol op)
220+ => QualifiedAlias sch op
221+ -- ^ name of the user defined operator
222+ -> Definition schemas (Alter sch (DropSchemum op 'Operator schema) schemas)
223+dropOperator op = UnsafeDefinition $
224+ "DROP" <+> "OPERATOR" <+> renderSQL op <> ";"
225+
226+dropOperatorIfExists
227+ :: (Has sch schemas schema, KnownSymbol op)
228+ => QualifiedAlias sch op
229+ -- ^ name of the user defined operator
230+ -> Definition schemas (Alter sch (DropSchemumIfExists op 'Operator schema) schemas)
231+dropOperatorIfExists op = UnsafeDefinition $
232+ "DROP OPERATOR IF EXISTS" <+> renderSQL op <> ";"
233+
234+newtype FunctionDefinition schemas args ret = UnsafeFunctionDefinition
235+ { renderFunctionDefinition :: ByteString }
236+ deriving (Eq,Show,GHC.Generic,NFData)
237+instance RenderSQL (FunctionDefinition schemas args ret) where
238+ renderSQL = renderFunctionDefinition
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Index.hsnew file+159
@@ -0,0 +1,159 @@
1+{-|
2+Module: Squeal.PostgreSQL.Definition.Index
3+Description: Create and drop index definitions
4+Copyright: (c) Eitan Chatav, 2017
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Create and drop index definitions.
9+-}
10+
11+{-# LANGUAGE
12+ AllowAmbiguousTypes
13+ , ConstraintKinds
14+ , DeriveAnyClass
15+ , DeriveGeneric
16+ , DerivingStrategies
17+ , FlexibleContexts
18+ , FlexibleInstances
19+ , GADTs
20+ , LambdaCase
21+ , MultiParamTypeClasses
22+ , OverloadedLabels
23+ , OverloadedStrings
24+ , RankNTypes
25+ , ScopedTypeVariables
26+ , TypeApplications
27+ , TypeInType
28+ , TypeOperators
29+ , UndecidableSuperClasses
30+#-}
31+
32+module Squeal.PostgreSQL.Definition.Index
33+ ( createIndex
34+ , createIndexIfNotExists
35+ , dropIndex
36+ , dropIndexIfExists
37+ , IndexMethod (..)
38+ , btree
39+ , hash
40+ , gist
41+ , spgist
42+ , gin
43+ , brin
44+ ) where
45+
46+import Data.ByteString
47+import GHC.TypeLits
48+
49+import qualified GHC.Generics as GHC
50+
51+import Squeal.PostgreSQL.Alias
52+import Squeal.PostgreSQL.Definition
53+import Squeal.PostgreSQL.Expression.Sort
54+import Squeal.PostgreSQL.Render
55+import Squeal.PostgreSQL.Schema
56+
57+-- $setup
58+-- >>> import Squeal.PostgreSQL
59+
60+{- |
61+>>> :{
62+type Table = '[] :=>
63+ '[ "a" ::: 'NoDef :=> 'Null 'PGint4
64+ , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]
65+:}
66+
67+>>> :{
68+let
69+ setup :: Definition (Public '[]) (Public '["tab" ::: 'Table Table, "ix" ::: 'Index 'Btree])
70+ setup =
71+ createTable #tab (nullable int `as` #a :* nullable real `as` #b) Nil >>>
72+ createIndex #ix #tab btree [#a & AscNullsFirst, #b & AscNullsLast]
73+in printSQL setup
74+:}
75+CREATE TABLE "tab" ("a" int NULL, "b" real NULL);
76+CREATE INDEX "ix" ON "tab" USING btree (("a") ASC NULLS FIRST, ("b") ASC NULLS LAST);
77+-}
78+createIndex
79+ :: (Has sch schemas schema, Has tab schema ('Table table), KnownSymbol ix)
80+ => Alias ix
81+ -> QualifiedAlias sch tab
82+ -> IndexMethod method
83+ -> [SortExpression '[] '[] 'Ungrouped schemas '[] '[tab ::: TableToRow table]]
84+ -> Definition schemas (Alter sch (Create ix ('Index method) schema) schemas)
85+createIndex ix tab method cols = UnsafeDefinition $
86+ "CREATE" <+> "INDEX" <+> renderSQL ix <+> "ON" <+> renderSQL tab
87+ <+> "USING" <+> renderSQL method
88+ <+> parenthesized (commaSeparated (renderIndex <$> cols))
89+ <> ";"
90+ where
91+ renderIndex = \case
92+ Asc expression -> parenthesized (renderSQL expression) <+> "ASC"
93+ Desc expression -> parenthesized (renderSQL expression) <+> "DESC"
94+ AscNullsFirst expression -> parenthesized (renderSQL expression)
95+ <+> "ASC NULLS FIRST"
96+ DescNullsFirst expression -> parenthesized (renderSQL expression)
97+ <+> "DESC NULLS FIRST"
98+ AscNullsLast expression -> parenthesized (renderSQL expression)
99+ <+> "ASC NULLS LAST"
100+ DescNullsLast expression -> parenthesized (renderSQL expression)
101+ <+> "DESC NULLS LAST"
102+
103+createIndexIfNotExists
104+ :: (Has sch schemas schema, Has tab schema ('Table table), KnownSymbol ix)
105+ => Alias ix
106+ -> QualifiedAlias sch tab
107+ -> IndexMethod method
108+ -> [SortExpression '[] '[] 'Ungrouped schemas '[] '[tab ::: TableToRow table]]
109+ -> Definition schemas (Alter sch (CreateIfNotExists ix ('Index method) schema) schemas)
110+createIndexIfNotExists ix tab method cols = UnsafeDefinition $
111+ "CREATE INDEX IF NOT EXISTS" <+> renderSQL ix <+> "ON" <+> renderSQL tab
112+ <+> "USING" <+> renderSQL method
113+ <+> parenthesized (commaSeparated (renderIndex <$> cols))
114+ <> ";"
115+ where
116+ renderIndex = \case
117+ Asc expression -> parenthesized (renderSQL expression) <+> "ASC"
118+ Desc expression -> parenthesized (renderSQL expression) <+> "DESC"
119+ AscNullsFirst expression -> parenthesized (renderSQL expression)
120+ <+> "ASC NULLS FIRST"
121+ DescNullsFirst expression -> parenthesized (renderSQL expression)
122+ <+> "DESC NULLS FIRST"
123+ AscNullsLast expression -> parenthesized (renderSQL expression)
124+ <+> "ASC NULLS LAST"
125+ DescNullsLast expression -> parenthesized (renderSQL expression)
126+ <+> "DESC NULLS LAST"
127+
128+newtype IndexMethod ty = UnsafeIndexMethod {renderIndexMethod :: ByteString}
129+ deriving stock (Eq, Ord, Show, GHC.Generic)
130+instance RenderSQL (IndexMethod ty) where renderSQL = renderIndexMethod
131+btree :: IndexMethod 'Btree
132+btree = UnsafeIndexMethod "btree"
133+hash :: IndexMethod 'Hash
134+hash = UnsafeIndexMethod "hash"
135+gist :: IndexMethod 'Gist
136+gist = UnsafeIndexMethod "gist"
137+spgist :: IndexMethod 'Spgist
138+spgist = UnsafeIndexMethod "spgist"
139+gin :: IndexMethod 'Gin
140+gin = UnsafeIndexMethod "gin"
141+brin :: IndexMethod 'Brin
142+brin = UnsafeIndexMethod "brin"
143+
144+-- |
145+-- >>> printSQL (dropIndex #ix :: Definition (Public '["ix" ::: 'Index 'Btree]) (Public '[]))
146+-- DROP INDEX "ix";
147+dropIndex
148+ :: (Has sch schemas schema, KnownSymbol ix)
149+ => QualifiedAlias sch ix
150+ -- ^ name of the user defined index
151+ -> Definition schemas (Alter sch (DropSchemum ix 'Index schema) schemas)
152+dropIndex ix = UnsafeDefinition $ "DROP" <+> "INDEX" <+> renderSQL ix <> ";"
153+
154+dropIndexIfExists
155+ :: (Has sch schemas schema, KnownSymbol ix)
156+ => QualifiedAlias sch ix
157+ -- ^ name of the user defined index
158+ -> Definition schemas (Alter sch (DropSchemumIfExists ix 'Index schema) schemas)
159+dropIndexIfExists ix = UnsafeDefinition $ "DROP INDEX IF EXISTS" <+> renderSQL ix <> ";"
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Schema.hsnew file+96
@@ -0,0 +1,96 @@
1+{-|
2+Module: Squeal.PostgreSQL.Definition.Schema
3+Description: Create and drop schema definitions
4+Copyright: (c) Eitan Chatav, 2017
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Create and drop schema definitions.
9+-}
10+
11+{-# LANGUAGE
12+ AllowAmbiguousTypes
13+ , ConstraintKinds
14+ , DeriveAnyClass
15+ , DeriveGeneric
16+ , DerivingStrategies
17+ , FlexibleContexts
18+ , FlexibleInstances
19+ , GADTs
20+ , LambdaCase
21+ , MultiParamTypeClasses
22+ , OverloadedLabels
23+ , OverloadedStrings
24+ , RankNTypes
25+ , ScopedTypeVariables
26+ , TypeApplications
27+ , TypeInType
28+ , TypeOperators
29+ , UndecidableSuperClasses
30+#-}
31+
32+module Squeal.PostgreSQL.Definition.Schema
33+ ( createSchema
34+ , createSchemaIfNotExists
35+ , dropSchema
36+ , dropSchemaIfExists
37+ ) where
38+
39+import GHC.TypeLits
40+
41+import Squeal.PostgreSQL.Alias
42+import Squeal.PostgreSQL.Definition
43+import Squeal.PostgreSQL.Render
44+import Squeal.PostgreSQL.Schema
45+
46+-- $setup
47+-- >>> import Squeal.PostgreSQL
48+
49+{- |
50+`createSchema` enters a new schema into the current database.
51+The schema name must be distinct from the name of any existing schema
52+in the current database.
53+
54+A schema is essentially a namespace: it contains named objects
55+(tables, data types, functions, and operators) whose names
56+can duplicate those of other objects existing in other schemas.
57+Named objects are accessed by `QualifiedAlias`es with the schema
58+name as a prefix.
59+-}
60+createSchema
61+ :: KnownSymbol sch
62+ => Alias sch
63+ -> Definition schemas (Create sch '[] schemas)
64+createSchema sch = UnsafeDefinition $
65+ "CREATE" <+> "SCHEMA" <+> renderSQL sch <> ";"
66+
67+{- | Idempotent version of `createSchema`. -}
68+createSchemaIfNotExists
69+ :: (KnownSymbol sch, Has sch schemas schema)
70+ => Alias sch
71+ -> Definition schemas (CreateIfNotExists sch '[] schemas)
72+createSchemaIfNotExists sch = UnsafeDefinition $
73+ "CREATE" <+> "SCHEMA" <+> "IF" <+> "NOT" <+> "EXISTS"
74+ <+> renderSQL sch <> ";"
75+
76+-- | >>> :{
77+-- let
78+-- definition :: Definition '["muh_schema" ::: schema, "public" ::: public] '["public" ::: public]
79+-- definition = dropSchema #muh_schema
80+-- :}
81+--
82+-- >>> printSQL definition
83+-- DROP SCHEMA "muh_schema";
84+dropSchema
85+ :: KnownSymbol sch
86+ => Alias sch
87+ -- ^ user defined schema
88+ -> Definition schemas (Drop sch schemas)
89+dropSchema sch = UnsafeDefinition $ "DROP SCHEMA" <+> renderSQL sch <> ";"
90+
91+dropSchemaIfExists
92+ :: KnownSymbol sch
93+ => Alias sch
94+ -- ^ user defined schema
95+ -> Definition schemas (DropIfExists sch schemas)
96+dropSchemaIfExists sch = UnsafeDefinition $ "DROP SCHEMA" <+> renderSQL sch <> ";"
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Table.hsnew file+500
@@ -0,0 +1,500 @@
1+{-|
2+Module: Squeal.PostgreSQL.Definition.Table
3+Description: Create, drop and alter table definitions
4+Copyright: (c) Eitan Chatav, 2017
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Create, drop and alter table definitions.
9+-}
10+
11+{-# LANGUAGE
12+ AllowAmbiguousTypes
13+ , ConstraintKinds
14+ , DeriveAnyClass
15+ , DeriveGeneric
16+ , DerivingStrategies
17+ , FlexibleContexts
18+ , FlexibleInstances
19+ , GADTs
20+ , LambdaCase
21+ , MultiParamTypeClasses
22+ , OverloadedLabels
23+ , OverloadedStrings
24+ , RankNTypes
25+ , ScopedTypeVariables
26+ , TypeApplications
27+ , TypeInType
28+ , TypeOperators
29+ , UndecidableSuperClasses
30+#-}
31+
32+module Squeal.PostgreSQL.Definition.Table
33+ ( createTable
34+ , createTableIfNotExists
35+ , dropTable
36+ , dropTableIfExists
37+ , alterTable
38+ , alterTableIfExists
39+ , alterTableRename
40+ , alterTableIfExistsRename
41+ , AlterTable (..)
42+ , addConstraint
43+ , dropConstraint
44+ , AddColumn (..)
45+ , dropColumn
46+ , renameColumn
47+ , alterColumn
48+ , AlterColumn (..)
49+ , setDefault
50+ , dropDefault
51+ , setNotNull
52+ , dropNotNull
53+ , alterType
54+ ) where
55+
56+import Control.DeepSeq
57+import Data.ByteString
58+import GHC.TypeLits
59+
60+import qualified Generics.SOP as SOP
61+import qualified GHC.Generics as GHC
62+
63+import Squeal.PostgreSQL.Alias
64+import Squeal.PostgreSQL.Definition
65+import Squeal.PostgreSQL.Definition.Table.Constraint
66+import Squeal.PostgreSQL.Expression
67+import Squeal.PostgreSQL.Expression.Type
68+import Squeal.PostgreSQL.List
69+import Squeal.PostgreSQL.Render
70+import Squeal.PostgreSQL.Schema
71+
72+-- $setup
73+-- >>> import Squeal.PostgreSQL
74+
75+{- | `createTable` adds a table to the schema.
76+
77+>>> :set -XOverloadedLabels
78+>>> :{
79+type Table = '[] :=>
80+ '[ "a" ::: 'NoDef :=> 'Null 'PGint4
81+ , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]
82+:}
83+
84+>>> :{
85+let
86+ setup :: Definition (Public '[]) (Public '["tab" ::: 'Table Table])
87+ setup = createTable #tab
88+ (nullable int `as` #a :* nullable real `as` #b) Nil
89+in printSQL setup
90+:}
91+CREATE TABLE "tab" ("a" int NULL, "b" real NULL);
92+-}
93+createTable
94+ :: ( KnownSymbol sch
95+ , KnownSymbol tab
96+ , columns ~ (col ': cols)
97+ , SOP.SListI columns
98+ , SOP.SListI constraints
99+ , Has sch schemas0 schema0
100+ , schemas1 ~ Alter sch (Create tab ('Table (constraints :=> columns)) schema0) schemas0 )
101+ => QualifiedAlias sch tab -- ^ the name of the table to add
102+ -> NP (Aliased (ColumnTypeExpression schemas0)) columns
103+ -- ^ the names and datatype of each column
104+ -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints
105+ -- ^ constraints that must hold for the table
106+ -> Definition schemas0 schemas1
107+createTable tab columns constraints = UnsafeDefinition $
108+ "CREATE TABLE" <+> renderCreation tab columns constraints
109+
110+{-| `createTableIfNotExists` creates a table if it doesn't exist, but does not add it to the schema.
111+Instead, the schema already has the table so if the table did not yet exist, the schema was wrong.
112+`createTableIfNotExists` fixes this. Interestingly, this property makes it an idempotent in
113+the `Category` of `Definition`s.
114+
115+>>> :set -XOverloadedLabels -XTypeApplications
116+>>> :{
117+type Table = '[] :=>
118+ '[ "a" ::: 'NoDef :=> 'Null 'PGint4
119+ , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]
120+:}
121+
122+>>> type Schemas = Public '["tab" ::: 'Table Table]
123+
124+>>> :{
125+let
126+ setup :: Definition Schemas Schemas
127+ setup = createTableIfNotExists #tab
128+ (nullable int `as` #a :* nullable real `as` #b) Nil
129+in printSQL setup
130+:}
131+CREATE TABLE IF NOT EXISTS "tab" ("a" int NULL, "b" real NULL);
132+-}
133+createTableIfNotExists
134+ :: ( KnownSymbol sch
135+ , KnownSymbol tab
136+ , columns ~ (col ': cols)
137+ , SOP.SListI columns
138+ , SOP.SListI constraints
139+ , Has sch schemas0 schema0
140+ , schemas1 ~ Alter sch (CreateIfNotExists tab ('Table (constraints :=> columns)) schema0) schemas0 )
141+ => QualifiedAlias sch tab -- ^ the name of the table to add
142+ -> NP (Aliased (ColumnTypeExpression schemas0)) columns
143+ -- ^ the names and datatype of each column
144+ -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints
145+ -- ^ constraints that must hold for the table
146+ -> Definition schemas0 schemas1
147+createTableIfNotExists tab columns constraints = UnsafeDefinition $
148+ "CREATE TABLE IF NOT EXISTS"
149+ <+> renderCreation tab columns constraints
150+
151+-- helper function for `createTable` and `createTableIfNotExists`
152+renderCreation
153+ :: ( KnownSymbol sch
154+ , KnownSymbol tab
155+ , SOP.SListI columns
156+ , SOP.SListI constraints )
157+ => QualifiedAlias sch tab -- ^ the name of the table to add
158+ -> NP (Aliased (ColumnTypeExpression schemas0)) columns
159+ -- ^ the names and datatype of each column
160+ -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints
161+ -- ^ constraints that must hold for the table
162+ -> ByteString
163+renderCreation tab columns constraints = renderSQL tab
164+ <+> parenthesized
165+ ( renderCommaSeparated renderColumnDef columns
166+ <> ( case constraints of
167+ Nil -> ""
168+ _ -> ", " <>
169+ renderCommaSeparated renderConstraint constraints ) )
170+ <> ";"
171+ where
172+ renderColumnDef :: Aliased (ColumnTypeExpression schemas) x -> ByteString
173+ renderColumnDef (ty `As` column) =
174+ renderSQL column <+> renderColumnTypeExpression ty
175+ renderConstraint
176+ :: Aliased (TableConstraintExpression sch tab schemas) constraint
177+ -> ByteString
178+ renderConstraint (constraint `As` alias) =
179+ "CONSTRAINT" <+> renderSQL alias <+> renderSQL constraint
180+
181+-- | `dropTable` removes a table from the schema.
182+--
183+-- >>> :{
184+-- let
185+-- definition :: Definition '["public" ::: '["muh_table" ::: 'Table t]] (Public '[])
186+-- definition = dropTable #muh_table
187+-- :}
188+--
189+-- >>> printSQL definition
190+-- DROP TABLE "muh_table";
191+dropTable
192+ :: ( Has sch schemas schema
193+ , KnownSymbol tab )
194+ => QualifiedAlias sch tab -- ^ table to remove
195+ -> Definition schemas (Alter sch (DropSchemum tab 'Table schema) schemas)
196+dropTable tab = UnsafeDefinition $ "DROP TABLE" <+> renderSQL tab <> ";"
197+
198+dropTableIfExists
199+ :: ( Has sch schemas schema
200+ , KnownSymbol tab)
201+ => QualifiedAlias sch tab -- ^ table to remove
202+ -> Definition schemas (Alter sch (DropSchemumIfExists tab 'Table schema) schemas)
203+dropTableIfExists tab = UnsafeDefinition $ "DROP TABLE IF EXISTS" <+> renderSQL tab <> ";"
204+
205+-- | `alterTable` changes the definition of a table from the schema.
206+alterTable
207+ :: (Has sch schemas schema, KnownSymbol tab)
208+ => QualifiedAlias sch tab -- ^ table to alter
209+ -> AlterTable sch tab schemas table -- ^ alteration to perform
210+ -> Definition schemas (Alter sch (Alter tab ('Table table) schema) schemas)
211+alterTable tab alteration = UnsafeDefinition $
212+ "ALTER TABLE"
213+ <+> renderSQL tab
214+ <+> renderAlterTable alteration
215+ <> ";"
216+
217+-- | `alterTable` changes the definition of a table from the schema.
218+alterTableIfExists
219+ :: (Has sch schemas schema, KnownSymbol tab)
220+ => QualifiedAlias sch tab -- ^ table to alter
221+ -> AlterTable sch tab schemas table -- ^ alteration to perform
222+ -> Definition schemas (Alter sch (AlterIfExists tab ('Table table) schema) schemas)
223+alterTableIfExists tab alteration = UnsafeDefinition $
224+ "ALTER TABLE IF EXISTS"
225+ <+> renderSQL tab
226+ <+> renderAlterTable alteration
227+ <> ";"
228+
229+-- | `alterTableRename` changes the name of a table from the schema.
230+--
231+-- >>> printSQL $ alterTableRename #foo #bar
232+-- ALTER TABLE "foo" RENAME TO "bar";
233+alterTableRename
234+ :: (KnownSymbol tab0, KnownSymbol tab1)
235+ => Alias tab0 -- ^ table to rename
236+ -> Alias tab1 -- ^ what to rename it
237+ -> Definition schema (Rename tab0 tab1 schema)
238+alterTableRename tab0 tab1 = UnsafeDefinition $
239+ "ALTER TABLE" <+> renderSQL tab0
240+ <+> "RENAME TO" <+> renderSQL tab1 <> ";"
241+
242+alterTableIfExistsRename
243+ :: (KnownSymbol tab0, KnownSymbol tab1)
244+ => Alias tab0 -- ^ table to rename
245+ -> Alias tab1 -- ^ what to rename it
246+ -> Definition schema (RenameIfExists tab0 tab1 schema)
247+alterTableIfExistsRename tab0 tab1 = UnsafeDefinition $
248+ "ALTER TABLE IF EXISTS" <+> renderSQL tab0
249+ <+> "RENAME TO" <+> renderSQL tab1 <> ";"
250+
251+-- | An `AlterTable` describes the alteration to perform on the columns
252+-- of a table.
253+newtype AlterTable
254+ (sch :: Symbol)
255+ (tab :: Symbol)
256+ (schemas :: SchemasType)
257+ (table :: TableType) =
258+ UnsafeAlterTable {renderAlterTable :: ByteString}
259+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
260+
261+-- | An `addConstraint` adds a table constraint.
262+--
263+-- >>> :{
264+-- let
265+-- definition :: Definition
266+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
267+-- '["public" ::: '["tab" ::: 'Table ('["positive" ::: 'Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
268+-- definition = alterTable #tab (addConstraint #positive (check #col (#col .> 0)))
269+-- in printSQL definition
270+-- :}
271+-- ALTER TABLE "tab" ADD CONSTRAINT "positive" CHECK (("col" > 0));
272+addConstraint
273+ :: ( KnownSymbol alias
274+ , Has sch schemas schema
275+ , Has tab schema ('Table table0)
276+ , table0 ~ (constraints :=> columns)
277+ , table1 ~ (Create alias constraint constraints :=> columns) )
278+ => Alias alias
279+ -> TableConstraintExpression sch tab schemas constraint
280+ -- ^ constraint to add
281+ -> AlterTable sch tab schemas table1
282+addConstraint alias constraint = UnsafeAlterTable $
283+ "ADD" <+> "CONSTRAINT" <+> renderSQL alias
284+ <+> renderSQL constraint
285+
286+-- | A `dropConstraint` drops a table constraint.
287+--
288+-- >>> :{
289+-- let
290+-- definition :: Definition
291+-- '["public" ::: '["tab" ::: 'Table ('["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
292+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
293+-- definition = alterTable #tab (dropConstraint #positive)
294+-- in printSQL definition
295+-- :}
296+-- ALTER TABLE "tab" DROP CONSTRAINT "positive";
297+dropConstraint
298+ :: ( KnownSymbol constraint
299+ , Has sch schemas schema
300+ , Has tab schema ('Table table0)
301+ , table0 ~ (constraints :=> columns)
302+ , table1 ~ (Drop constraint constraints :=> columns) )
303+ => Alias constraint
304+ -- ^ constraint to drop
305+ -> AlterTable sch tab schemas table1
306+dropConstraint constraint = UnsafeAlterTable $
307+ "DROP" <+> "CONSTRAINT" <+> renderSQL constraint
308+
309+-- | An `AddColumn` is either @NULL@ or has @DEFAULT@.
310+class AddColumn ty where
311+ -- | `addColumn` adds a new column, initially filled with whatever
312+ -- default value is given or with @NULL@.
313+ --
314+ -- >>> :{
315+ -- let
316+ -- definition :: Definition
317+ -- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]
318+ -- '["public" ::: '["tab" ::: 'Table ('[] :=>
319+ -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
320+ -- , "col2" ::: 'Def :=> 'Null 'PGtext ])]]
321+ -- definition = alterTable #tab (addColumn #col2 (text & nullable & default_ "foo"))
322+ -- in printSQL definition
323+ -- :}
324+ -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL DEFAULT E'foo';
325+ --
326+ -- >>> :{
327+ -- let
328+ -- definition :: Definition
329+ -- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]
330+ -- '["public" ::: '["tab" ::: 'Table ('[] :=>
331+ -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
332+ -- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]]
333+ -- definition = alterTable #tab (addColumn #col2 (text & nullable))
334+ -- in printSQL definition
335+ -- :}
336+ -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL;
337+ addColumn
338+ :: ( KnownSymbol column
339+ , Has sch schemas schema
340+ , Has tab schema ('Table table0)
341+ , table0 ~ (constraints :=> columns) )
342+ => Alias column -- ^ column to add
343+ -> ColumnTypeExpression schemas ty -- ^ type of the new column
344+ -> AlterTable sch tab schemas (constraints :=> Create column ty columns)
345+ addColumn column ty = UnsafeAlterTable $
346+ "ADD COLUMN" <+> renderSQL column <+> renderColumnTypeExpression ty
347+instance {-# OVERLAPPING #-} AddColumn ('Def :=> ty)
348+instance {-# OVERLAPPABLE #-} AddColumn ('NoDef :=> 'Null ty)
349+
350+-- | A `dropColumn` removes a column. Whatever data was in the column
351+-- disappears. Table constraints involving the column are dropped, too.
352+-- However, if the column is referenced by a foreign key constraint of
353+-- another table, PostgreSQL will not silently drop that constraint.
354+--
355+-- >>> :{
356+-- let
357+-- definition :: Definition
358+-- '["public" ::: '["tab" ::: 'Table ('[] :=>
359+-- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
360+-- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]]
361+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]
362+-- definition = alterTable #tab (dropColumn #col2)
363+-- in printSQL definition
364+-- :}
365+-- ALTER TABLE "tab" DROP COLUMN "col2";
366+dropColumn
367+ :: ( KnownSymbol column
368+ , Has sch schemas schema
369+ , Has tab schema ('Table table0)
370+ , table0 ~ (constraints :=> columns)
371+ , table1 ~ (constraints :=> Drop column columns) )
372+ => Alias column -- ^ column to remove
373+ -> AlterTable sch tab schemas table1
374+dropColumn column = UnsafeAlterTable $
375+ "DROP COLUMN" <+> renderSQL column
376+
377+-- | A `renameColumn` renames a column.
378+--
379+-- >>> :{
380+-- let
381+-- definition :: Definition
382+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["foo" ::: 'NoDef :=> 'Null 'PGint4])]]
383+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["bar" ::: 'NoDef :=> 'Null 'PGint4])]]
384+-- definition = alterTable #tab (renameColumn #foo #bar)
385+-- in printSQL definition
386+-- :}
387+-- ALTER TABLE "tab" RENAME COLUMN "foo" TO "bar";
388+renameColumn
389+ :: ( KnownSymbol column0
390+ , KnownSymbol column1
391+ , Has sch schemas schema
392+ , Has tab schema ('Table table0)
393+ , table0 ~ (constraints :=> columns)
394+ , table1 ~ (constraints :=> Rename column0 column1 columns) )
395+ => Alias column0 -- ^ column to rename
396+ -> Alias column1 -- ^ what to rename the column
397+ -> AlterTable sch tab schemas table1
398+renameColumn column0 column1 = UnsafeAlterTable $
399+ "RENAME COLUMN" <+> renderSQL column0 <+> "TO" <+> renderSQL column1
400+
401+-- | An `alterColumn` alters a single column.
402+alterColumn
403+ :: ( KnownSymbol column
404+ , Has sch schemas schema
405+ , Has tab schema ('Table table0)
406+ , table0 ~ (constraints :=> columns)
407+ , Has column columns ty0
408+ , table1 ~ (constraints :=> Alter column ty1 columns))
409+ => Alias column -- ^ column to alter
410+ -> AlterColumn schemas ty0 ty1 -- ^ alteration to perform
411+ -> AlterTable sch tab schemas table1
412+alterColumn column alteration = UnsafeAlterTable $
413+ "ALTER COLUMN" <+> renderSQL column <+> renderAlterColumn alteration
414+
415+-- | An `AlterColumn` describes the alteration to perform on a single column.
416+newtype AlterColumn (schemas :: SchemasType) (ty0 :: ColumnType) (ty1 :: ColumnType) =
417+ UnsafeAlterColumn {renderAlterColumn :: ByteString}
418+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
419+
420+-- | A `setDefault` sets a new default for a column. Note that this doesn't
421+-- affect any existing rows in the table, it just changes the default for
422+-- future insert and update commands.
423+--
424+-- >>> :{
425+-- let
426+-- definition :: Definition
427+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
428+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]]
429+-- definition = alterTable #tab (alterColumn #col (setDefault 5))
430+-- in printSQL definition
431+-- :}
432+-- ALTER TABLE "tab" ALTER COLUMN "col" SET DEFAULT 5;
433+setDefault
434+ :: Expression '[] '[] 'Ungrouped schemas '[] '[] ty -- ^ default value to set
435+ -> AlterColumn schemas (constraint :=> ty) ('Def :=> ty)
436+setDefault expression = UnsafeAlterColumn $
437+ "SET DEFAULT" <+> renderExpression expression
438+
439+-- | A `dropDefault` removes any default value for a column.
440+--
441+-- >>> :{
442+-- let
443+-- definition :: Definition
444+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]]
445+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
446+-- definition = alterTable #tab (alterColumn #col dropDefault)
447+-- in printSQL definition
448+-- :}
449+-- ALTER TABLE "tab" ALTER COLUMN "col" DROP DEFAULT;
450+dropDefault :: AlterColumn schemas ('Def :=> ty) ('NoDef :=> ty)
451+dropDefault = UnsafeAlterColumn $ "DROP DEFAULT"
452+
453+-- | A `setNotNull` adds a @NOT NULL@ constraint to a column.
454+-- The constraint will be checked immediately, so the table data must satisfy
455+-- the constraint before it can be added.
456+--
457+-- >>> :{
458+-- let
459+-- definition :: Definition
460+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
461+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
462+-- definition = alterTable #tab (alterColumn #col setNotNull)
463+-- in printSQL definition
464+-- :}
465+-- ALTER TABLE "tab" ALTER COLUMN "col" SET NOT NULL;
466+setNotNull
467+ :: AlterColumn schemas (constraint :=> 'Null ty) (constraint :=> 'NotNull ty)
468+setNotNull = UnsafeAlterColumn $ "SET NOT NULL"
469+
470+-- | A `dropNotNull` drops a @NOT NULL@ constraint from a column.
471+--
472+-- >>> :{
473+-- let
474+-- definition :: Definition
475+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
476+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
477+-- definition = alterTable #tab (alterColumn #col dropNotNull)
478+-- in printSQL definition
479+-- :}
480+-- ALTER TABLE "tab" ALTER COLUMN "col" DROP NOT NULL;
481+dropNotNull
482+ :: AlterColumn schemas (constraint :=> 'NotNull ty) (constraint :=> 'Null ty)
483+dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL"
484+
485+-- | An `alterType` converts a column to a different data type.
486+-- This will succeed only if each existing entry in the column can be
487+-- converted to the new type by an implicit cast.
488+--
489+-- >>> :{
490+-- let
491+-- definition :: Definition
492+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
493+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGnumeric])]]
494+-- definition =
495+-- alterTable #tab (alterColumn #col (alterType (numeric & notNullable)))
496+-- in printSQL definition
497+-- :}
498+-- ALTER TABLE "tab" ALTER COLUMN "col" TYPE numeric NOT NULL;
499+alterType :: ColumnTypeExpression schemas ty -> AlterColumn schemas ty0 ty
500+alterType ty = UnsafeAlterColumn $ "TYPE" <+> renderColumnTypeExpression ty
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Table/Constraint.hsnew file+339
@@ -0,0 +1,339 @@
1+{-|
2+Module: Squeal.PostgreSQL.Definition.Table.Constraint
3+Description: Table constraint expressions
4+Copyright: (c) Eitan Chatav, 2017
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Table constraint expressions.
9+-}
10+
11+{-# LANGUAGE
12+ AllowAmbiguousTypes
13+ , ConstraintKinds
14+ , DeriveAnyClass
15+ , DeriveGeneric
16+ , DerivingStrategies
17+ , FlexibleContexts
18+ , FlexibleInstances
19+ , GADTs
20+ , LambdaCase
21+ , MultiParamTypeClasses
22+ , OverloadedLabels
23+ , OverloadedStrings
24+ , RankNTypes
25+ , ScopedTypeVariables
26+ , TypeApplications
27+ , TypeInType
28+ , TypeOperators
29+ , UndecidableSuperClasses
30+#-}
31+
32+module Squeal.PostgreSQL.Definition.Table.Constraint
33+ ( TableConstraintExpression (..)
34+ , check
35+ , unique
36+ , primaryKey
37+ , foreignKey
38+ , ForeignKeyed
39+ , OnDeleteClause (..)
40+ , OnUpdateClause (..)
41+ ) where
42+
43+import Control.DeepSeq
44+import Data.ByteString
45+import GHC.TypeLits
46+
47+import qualified Generics.SOP as SOP
48+import qualified GHC.Generics as GHC
49+
50+import Squeal.PostgreSQL.Alias
51+import Squeal.PostgreSQL.Expression.Logic
52+import Squeal.PostgreSQL.List
53+import Squeal.PostgreSQL.Render
54+import Squeal.PostgreSQL.Schema
55+
56+-- $setup
57+-- >>> import Squeal.PostgreSQL
58+
59+-- | Data types are a way to limit the kind of data that can be stored in a
60+-- table. For many applications, however, the constraint they provide is
61+-- too coarse. For example, a column containing a product price should
62+-- probably only accept positive values. But there is no standard data type
63+-- that accepts only positive numbers. Another issue is that you might want
64+-- to constrain column data with respect to other columns or rows.
65+-- For example, in a table containing product information,
66+-- there should be only one row for each product number.
67+-- `TableConstraint`s give you as much control over the data in your tables
68+-- as you wish. If a user attempts to store data in a column that would
69+-- violate a constraint, an error is raised. This applies
70+-- even if the value came from the default value definition.
71+newtype TableConstraintExpression
72+ (sch :: Symbol)
73+ (tab :: Symbol)
74+ (schemas :: SchemasType)
75+ (constraint :: TableConstraint)
76+ = UnsafeTableConstraintExpression
77+ { renderTableConstraintExpression :: ByteString }
78+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
79+instance RenderSQL
80+ (TableConstraintExpression sch tab schemas constraint) where
81+ renderSQL = renderTableConstraintExpression
82+
83+{-| A `check` constraint is the most generic `TableConstraint` type.
84+It allows you to specify that the value in a certain column must satisfy
85+a Boolean (truth-value) expression.
86+
87+>>> :{
88+type Schema = '[
89+ "tab" ::: 'Table ('[ "inequality" ::: 'Check '["a","b"]] :=> '[
90+ "a" ::: 'NoDef :=> 'NotNull 'PGint4,
91+ "b" ::: 'NoDef :=> 'NotNull 'PGint4
92+ ])]
93+:}
94+
95+>>> :{
96+let
97+ definition :: Definition (Public '[]) (Public Schema)
98+ definition = createTable #tab
99+ ( (int & notNullable) `as` #a :*
100+ (int & notNullable) `as` #b )
101+ ( check (#a :* #b) (#a .> #b) `as` #inequality )
102+:}
103+
104+>>> printSQL definition
105+CREATE TABLE "tab" ("a" int NOT NULL, "b" int NOT NULL, CONSTRAINT "inequality" CHECK (("a" > "b")));
106+-}
107+check
108+ :: ( Has sch schemas schema
109+ , Has tab schema ('Table table)
110+ , HasAll aliases (TableToRow table) subcolumns )
111+ => NP Alias aliases
112+ -- ^ specify the subcolumns which are getting checked
113+ -> (forall t. Condition '[] '[] 'Ungrouped schemas '[] '[t ::: subcolumns])
114+ -- ^ a closed `Condition` on those subcolumns
115+ -> TableConstraintExpression sch tab schemas ('Check aliases)
116+check _cols condition = UnsafeTableConstraintExpression $
117+ "CHECK" <+> parenthesized (renderSQL condition)
118+
119+{-| A `unique` constraint ensure that the data contained in a column,
120+or a group of columns, is unique among all the rows in the table.
121+
122+>>> :{
123+type Schema = '[
124+ "tab" ::: 'Table( '[ "uq_a_b" ::: 'Unique '["a","b"]] :=> '[
125+ "a" ::: 'NoDef :=> 'Null 'PGint4,
126+ "b" ::: 'NoDef :=> 'Null 'PGint4
127+ ])]
128+:}
129+
130+>>> :{
131+let
132+ definition :: Definition (Public '[]) (Public Schema)
133+ definition = createTable #tab
134+ ( (int & nullable) `as` #a :*
135+ (int & nullable) `as` #b )
136+ ( unique (#a :* #b) `as` #uq_a_b )
137+:}
138+
139+>>> printSQL definition
140+CREATE TABLE "tab" ("a" int NULL, "b" int NULL, CONSTRAINT "uq_a_b" UNIQUE ("a", "b"));
141+-}
142+unique
143+ :: ( Has sch schemas schema
144+ , Has tab schema('Table table)
145+ , HasAll aliases (TableToRow table) subcolumns )
146+ => NP Alias aliases
147+ -- ^ specify subcolumns which together are unique for each row
148+ -> TableConstraintExpression sch tab schemas ('Unique aliases)
149+unique columns = UnsafeTableConstraintExpression $
150+ "UNIQUE" <+> parenthesized (renderSQL columns)
151+
152+{-| A `primaryKey` constraint indicates that a column, or group of columns,
153+can be used as a unique identifier for rows in the table.
154+This requires that the values be both unique and not null.
155+
156+>>> :{
157+type Schema = '[
158+ "tab" ::: 'Table ('[ "pk_id" ::: 'PrimaryKey '["id"]] :=> '[
159+ "id" ::: 'Def :=> 'NotNull 'PGint4,
160+ "name" ::: 'NoDef :=> 'NotNull 'PGtext
161+ ])]
162+:}
163+
164+>>> :{
165+let
166+ definition :: Definition (Public '[]) (Public Schema)
167+ definition = createTable #tab
168+ ( serial `as` #id :*
169+ (text & notNullable) `as` #name )
170+ ( primaryKey #id `as` #pk_id )
171+:}
172+
173+>>> printSQL definition
174+CREATE TABLE "tab" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_id" PRIMARY KEY ("id"));
175+-}
176+primaryKey
177+ :: ( Has sch schemas schema
178+ , Has tab schema ('Table table)
179+ , HasAll aliases (TableToColumns table) subcolumns
180+ , AllNotNull subcolumns )
181+ => NP Alias aliases
182+ -- ^ specify the subcolumns which together form a primary key.
183+ -> TableConstraintExpression sch tab schemas ('PrimaryKey aliases)
184+primaryKey columns = UnsafeTableConstraintExpression $
185+ "PRIMARY KEY" <+> parenthesized (renderSQL columns)
186+
187+{-| A `foreignKey` specifies that the values in a column
188+(or a group of columns) must match the values appearing in some row of
189+another table. We say this maintains the referential integrity
190+between two related tables.
191+
192+>>> :{
193+type Schema =
194+ '[ "users" ::: 'Table (
195+ '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
196+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
197+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext
198+ ])
199+ , "emails" ::: 'Table (
200+ '[ "pk_emails" ::: 'PrimaryKey '["id"]
201+ , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
202+ ] :=>
203+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
204+ , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
205+ , "email" ::: 'NoDef :=> 'Null 'PGtext
206+ ])
207+ ]
208+:}
209+
210+>>> :{
211+let
212+ setup :: Definition (Public '[]) (Public Schema)
213+ setup =
214+ createTable #users
215+ ( serial `as` #id :*
216+ (text & notNullable) `as` #name )
217+ ( primaryKey #id `as` #pk_users ) >>>
218+ createTable #emails
219+ ( serial `as` #id :*
220+ (int & notNullable) `as` #user_id :*
221+ (text & nullable) `as` #email )
222+ ( primaryKey #id `as` #pk_emails :*
223+ foreignKey #user_id #users #id
224+ OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
225+in printSQL setup
226+:}
227+CREATE TABLE "users" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_users" PRIMARY KEY ("id"));
228+CREATE TABLE "emails" ("id" serial, "user_id" int NOT NULL, "email" text NULL, CONSTRAINT "pk_emails" PRIMARY KEY ("id"), CONSTRAINT "fk_user_id" FOREIGN KEY ("user_id") REFERENCES "users" ("id") ON DELETE CASCADE ON UPDATE CASCADE);
229+
230+A `foreignKey` can even be a table self-reference.
231+
232+>>> :{
233+type Schema =
234+ '[ "employees" ::: 'Table (
235+ '[ "employees_pk" ::: 'PrimaryKey '["id"]
236+ , "employees_employer_fk" ::: 'ForeignKey '["employer_id"] "employees" '["id"]
237+ ] :=>
238+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
239+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext
240+ , "employer_id" ::: 'NoDef :=> 'Null 'PGint4
241+ ])
242+ ]
243+:}
244+
245+>>> :{
246+let
247+ setup :: Definition (Public '[]) (Public Schema)
248+ setup =
249+ createTable #employees
250+ ( serial `as` #id :*
251+ (text & notNullable) `as` #name :*
252+ (integer & nullable) `as` #employer_id )
253+ ( primaryKey #id `as` #employees_pk :*
254+ foreignKey #employer_id #employees #id
255+ OnDeleteCascade OnUpdateCascade `as` #employees_employer_fk )
256+in printSQL setup
257+:}
258+CREATE TABLE "employees" ("id" serial, "name" text NOT NULL, "employer_id" integer NULL, CONSTRAINT "employees_pk" PRIMARY KEY ("id"), CONSTRAINT "employees_employer_fk" FOREIGN KEY ("employer_id") REFERENCES "employees" ("id") ON DELETE CASCADE ON UPDATE CASCADE);
259+-}
260+foreignKey
261+ :: (ForeignKeyed schemas sch schema child parent
262+ table reftable
263+ columns refcolumns
264+ constraints cols
265+ reftys tys )
266+ => NP Alias columns
267+ -- ^ column or columns in the table
268+ -> Alias parent
269+ -- ^ reference table
270+ -> NP Alias refcolumns
271+ -- ^ reference column or columns in the reference table
272+ -> OnDeleteClause
273+ -- ^ what to do when reference is deleted
274+ -> OnUpdateClause
275+ -- ^ what to do when reference is updated
276+ -> TableConstraintExpression sch child schemas
277+ ('ForeignKey columns parent refcolumns)
278+foreignKey keys parent refs ondel onupd = UnsafeTableConstraintExpression $
279+ "FOREIGN KEY" <+> parenthesized (renderSQL keys)
280+ <+> "REFERENCES" <+> renderSQL parent
281+ <+> parenthesized (renderSQL refs)
282+ <+> renderSQL ondel
283+ <+> renderSQL onupd
284+
285+-- | A constraint synonym between types involved in a foreign key constraint.
286+type ForeignKeyed schemas
287+ sch
288+ schema
289+ child parent
290+ table reftable
291+ columns refcolumns
292+ constraints cols
293+ reftys tys =
294+ ( Has sch schemas schema
295+ , Has child schema ('Table table)
296+ , Has parent schema ('Table reftable)
297+ , HasAll columns (TableToColumns table) tys
298+ , reftable ~ (constraints :=> cols)
299+ , HasAll refcolumns cols reftys
300+ , SOP.AllZip SamePGType tys reftys
301+ , Uniquely refcolumns constraints )
302+
303+-- | `OnDeleteClause` indicates what to do with rows that reference a deleted row.
304+data OnDeleteClause
305+ = OnDeleteNoAction
306+ -- ^ if any referencing rows still exist when the constraint is checked,
307+ -- an error is raised
308+ | OnDeleteRestrict -- ^ prevents deletion of a referenced row
309+ | OnDeleteCascade
310+ -- ^ specifies that when a referenced row is deleted,
311+ -- row(s) referencing it should be automatically deleted as well
312+ deriving (GHC.Generic,Show,Eq,Ord)
313+instance NFData OnDeleteClause
314+-- | Render `OnDeleteClause`.
315+instance RenderSQL OnDeleteClause where
316+ renderSQL = \case
317+ OnDeleteNoAction -> "ON DELETE NO ACTION"
318+ OnDeleteRestrict -> "ON DELETE RESTRICT"
319+ OnDeleteCascade -> "ON DELETE CASCADE"
320+
321+-- | Analagous to `OnDeleteClause` there is also `OnUpdateClause` which is invoked
322+-- when a referenced column is changed (updated).
323+data OnUpdateClause
324+ = OnUpdateNoAction
325+ -- ^ if any referencing rows has not changed when the constraint is checked,
326+ -- an error is raised
327+ | OnUpdateRestrict -- ^ prevents update of a referenced row
328+ | OnUpdateCascade
329+ -- ^ the updated values of the referenced column(s) should be copied
330+ -- into the referencing row(s)
331+ deriving (GHC.Generic,Show,Eq,Ord)
332+instance NFData OnUpdateClause
333+
334+-- | Render `OnUpdateClause`.
335+instance RenderSQL OnUpdateClause where
336+ renderSQL = \case
337+ OnUpdateNoAction -> "ON UPDATE NO ACTION"
338+ OnUpdateRestrict -> "ON UPDATE RESTRICT"
339+ OnUpdateCascade -> "ON UPDATE CASCADE"
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Type.hsnew file+229
@@ -0,0 +1,229 @@
1+{-|
2+Module: Squeal.PostgreSQL.Definition.Type
3+Description: Create and drop type definitions
4+Copyright: (c) Eitan Chatav, 2017
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Create and drop type definitions.
9+-}
10+
11+{-# LANGUAGE
12+ AllowAmbiguousTypes
13+ , ConstraintKinds
14+ , DeriveAnyClass
15+ , DeriveGeneric
16+ , DerivingStrategies
17+ , FlexibleContexts
18+ , FlexibleInstances
19+ , GADTs
20+ , LambdaCase
21+ , MultiParamTypeClasses
22+ , OverloadedLabels
23+ , OverloadedStrings
24+ , RankNTypes
25+ , ScopedTypeVariables
26+ , TypeApplications
27+ , TypeInType
28+ , TypeOperators
29+ , UndecidableSuperClasses
30+#-}
31+
32+module Squeal.PostgreSQL.Definition.Type
33+ ( createTypeEnum
34+ , createTypeEnumFrom
35+ , createTypeComposite
36+ , createTypeCompositeFrom
37+ , createTypeRange
38+ , createDomain
39+ , dropType
40+ , dropTypeIfExists
41+ ) where
42+
43+import Data.ByteString
44+import Data.Monoid
45+import GHC.TypeLits
46+import Prelude hiding ((.), id)
47+
48+import qualified Generics.SOP as SOP
49+
50+import Squeal.PostgreSQL.Alias
51+import Squeal.PostgreSQL.Expression.Logic
52+import Squeal.PostgreSQL.Expression.Type
53+import Squeal.PostgreSQL.Definition
54+import Squeal.PostgreSQL.List
55+import Squeal.PostgreSQL.PG
56+import Squeal.PostgreSQL.Render
57+import Squeal.PostgreSQL.Schema
58+
59+-- $setup
60+-- >>> import Squeal.PostgreSQL
61+-- >>> import qualified GHC.Generics as GHC
62+-- >>> import qualified Generics.SOP as SOP
63+
64+-- | Enumerated types are created using the `createTypeEnum` command, for example
65+--
66+-- >>> printSQL $ (createTypeEnum #mood (label @"sad" :* label @"ok" :* label @"happy") :: Definition (Public '[]) '["public" ::: '["mood" ::: 'Typedef ('PGenum '["sad","ok","happy"])]])
67+-- CREATE TYPE "mood" AS ENUM ('sad', 'ok', 'happy');
68+createTypeEnum
69+ :: (KnownSymbol enum, Has sch schemas schema, SOP.All KnownSymbol labels)
70+ => QualifiedAlias sch enum
71+ -- ^ name of the user defined enumerated type
72+ -> NP PGlabel labels
73+ -- ^ labels of the enumerated type
74+ -> Definition schemas (Alter sch (Create enum ('Typedef ('PGenum labels)) schema) schemas)
75+createTypeEnum enum labels = UnsafeDefinition $
76+ "CREATE" <+> "TYPE" <+> renderSQL enum <+> "AS" <+> "ENUM" <+>
77+ parenthesized (renderSQL labels) <> ";"
78+
79+-- | Enumerated types can also be generated from a Haskell type, for example
80+--
81+-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic
82+-- >>> instance SOP.Generic Schwarma
83+-- >>> instance SOP.HasDatatypeInfo Schwarma
84+-- >>> :{
85+-- let
86+-- createSchwarma :: Definition (Public '[]) '["public" ::: '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))]]
87+-- createSchwarma = createTypeEnumFrom @Schwarma #schwarma
88+-- in
89+-- printSQL createSchwarma
90+-- :}
91+-- CREATE TYPE "schwarma" AS ENUM ('Beef', 'Lamb', 'Chicken');
92+createTypeEnumFrom
93+ :: forall hask sch enum schemas schema.
94+ ( SOP.Generic hask
95+ , SOP.All KnownSymbol (LabelsPG hask)
96+ , KnownSymbol enum
97+ , Has sch schemas schema )
98+ => QualifiedAlias sch enum
99+ -- ^ name of the user defined enumerated type
100+ -> Definition schemas (Alter sch (Create enum ('Typedef (PG (Enumerated hask))) schema) schemas)
101+createTypeEnumFrom enum = createTypeEnum enum
102+ (SOP.hpure label :: NP PGlabel (LabelsPG hask))
103+
104+{- | `createTypeComposite` creates a composite type. The composite type is
105+specified by a list of attribute names and data types.
106+
107+>>> :{
108+type PGcomplex = 'PGcomposite
109+ '[ "real" ::: 'NotNull 'PGfloat8
110+ , "imaginary" ::: 'NotNull 'PGfloat8 ]
111+:}
112+
113+>>> :{
114+let
115+ setup :: Definition (Public '[]) '["public" ::: '["complex" ::: 'Typedef PGcomplex]]
116+ setup = createTypeComposite #complex
117+ (float8 `as` #real :* float8 `as` #imaginary)
118+in printSQL setup
119+:}
120+CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);
121+-}
122+createTypeComposite
123+ :: (KnownSymbol ty, Has sch schemas schema, SOP.SListI fields)
124+ => QualifiedAlias sch ty
125+ -- ^ name of the user defined composite type
126+ -> NP (Aliased (TypeExpression schemas)) fields
127+ -- ^ list of attribute names and data types
128+ -> Definition schemas (Alter sch (Create ty ('Typedef ('PGcomposite fields)) schema) schemas)
129+createTypeComposite ty fields = UnsafeDefinition $
130+ "CREATE" <+> "TYPE" <+> renderSQL ty <+> "AS" <+> parenthesized
131+ (renderCommaSeparated renderField fields) <> ";"
132+ where
133+ renderField :: Aliased (TypeExpression schemas) x -> ByteString
134+ renderField (typ `As` alias) =
135+ renderSQL alias <+> renderSQL typ
136+
137+-- | Composite types can also be generated from a Haskell type, for example
138+--
139+-- >>> data Complex = Complex {real :: Double, imaginary :: Double} deriving GHC.Generic
140+-- >>> instance SOP.Generic Complex
141+-- >>> instance SOP.HasDatatypeInfo Complex
142+-- >>> type Schema = '["complex" ::: 'Typedef (PG (Composite Complex))]
143+-- >>> :{
144+-- let
145+-- createComplex :: Definition (Public '[]) (Public Schema)
146+-- createComplex = createTypeCompositeFrom @Complex #complex
147+-- in
148+-- printSQL createComplex
149+-- :}
150+-- CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);
151+createTypeCompositeFrom
152+ :: forall hask sch ty schemas schema.
153+ ( SOP.All (FieldTyped schemas) (RowPG hask)
154+ , KnownSymbol ty
155+ , Has sch schemas schema )
156+ => QualifiedAlias sch ty
157+ -- ^ name of the user defined composite type
158+ -> Definition schemas (Alter sch (Create ty ( 'Typedef (PG (Composite hask))) schema) schemas)
159+createTypeCompositeFrom ty = createTypeComposite ty
160+ (SOP.hcpure (SOP.Proxy :: SOP.Proxy (FieldTyped schemas)) fieldtype
161+ :: NP (Aliased (TypeExpression schemas)) (RowPG hask))
162+
163+{-|
164+`createDomain` creates a new domain. A domain is essentially a data type
165+with constraints (restrictions on the allowed set of values).
166+
167+Domains are useful for abstracting common constraints on fields
168+into a single location for maintenance. For example, several tables might
169+contain email address columns, all requiring the same `check` constraint
170+to verify the address syntax. Define a domain rather than setting up
171+each table's constraint individually.
172+
173+>>> :{
174+let
175+ createPositive :: Definition (Public '[]) (Public '["positive" ::: 'Typedef 'PGfloat4])
176+ createPositive = createDomain #positive real (#value .> 0 .&& (#value & isNotNull))
177+in printSQL createPositive
178+:}
179+CREATE DOMAIN "positive" AS real CHECK ((("value" > 0) AND "value" IS NOT NULL));
180+-}
181+createDomain
182+ :: (Has sch schemas schema, KnownSymbol dom)
183+ => QualifiedAlias sch dom
184+ -> (forall null. TypeExpression schemas (null ty))
185+ -> (forall tab. Condition '[] '[] 'Ungrouped schemas '[] '[tab ::: '["value" ::: 'Null ty]])
186+ -> Definition schemas (Alter sch (Create dom ('Typedef ty) schema) schemas)
187+createDomain dom ty condition =
188+ UnsafeDefinition $ "CREATE DOMAIN" <+> renderSQL dom
189+ <+> "AS" <+> renderTypeExpression ty
190+ <+> "CHECK" <+> parenthesized (renderSQL condition) <> ";"
191+
192+{- |
193+>>> :{
194+let
195+ createSmallIntRange :: Definition (Public '[]) (Public '["int2range" ::: 'Typedef ('PGrange 'PGint2)])
196+ createSmallIntRange = createTypeRange #int2range int2
197+in printSQL createSmallIntRange
198+:}
199+CREATE TYPE "int2range" AS RANGE (subtype = int2);
200+-}
201+createTypeRange
202+ :: (Has sch schemas schema, KnownSymbol range)
203+ => QualifiedAlias sch range
204+ -> (forall null. TypeExpression schemas (null ty))
205+ -> Definition schemas (Alter sch (Create range ('Typedef ('PGrange ty)) schema) schemas)
206+createTypeRange range ty = UnsafeDefinition $
207+ "CREATE" <+> "TYPE" <+> renderSQL range <+> "AS" <+> "RANGE" <+>
208+ parenthesized ("subtype" <+> "=" <+> renderTypeExpression ty) <> ";"
209+
210+-- | Drop a type.
211+--
212+-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic
213+-- >>> instance SOP.Generic Schwarma
214+-- >>> instance SOP.HasDatatypeInfo Schwarma
215+-- >>> printSQL (dropType #schwarma :: Definition '["public" ::: '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))]] (Public '[]))
216+-- DROP TYPE "schwarma";
217+dropType
218+ :: (Has sch schemas schema, KnownSymbol td)
219+ => QualifiedAlias sch td
220+ -- ^ name of the user defined type
221+ -> Definition schemas (Alter sch (DropSchemum td 'Typedef schema) schemas)
222+dropType tydef = UnsafeDefinition $ "DROP" <+> "TYPE" <+> renderSQL tydef <> ";"
223+
224+dropTypeIfExists
225+ :: (Has sch schemas schema, KnownSymbol td)
226+ => QualifiedAlias sch td
227+ -- ^ name of the user defined type
228+ -> Definition schemas (Alter sch (DropSchemumIfExists td 'Typedef schema) schemas)
229+dropTypeIfExists tydef = UnsafeDefinition $ "DROP" <+> "TYPE" <+> renderSQL tydef <> ";"
squeal-postgresql/src/Squeal/PostgreSQL/Definition/View.hsnew file+104
@@ -0,0 +1,104 @@
1+{-|
2+Module: Squeal.PostgreSQL.Definition.View
3+Description: Create and drop view definitions
4+Copyright: (c) Eitan Chatav, 2017
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Create and drop view definitions.
9+-}
10+
11+{-# LANGUAGE
12+ AllowAmbiguousTypes
13+ , ConstraintKinds
14+ , DeriveAnyClass
15+ , DeriveGeneric
16+ , DerivingStrategies
17+ , FlexibleContexts
18+ , FlexibleInstances
19+ , GADTs
20+ , LambdaCase
21+ , MultiParamTypeClasses
22+ , OverloadedLabels
23+ , OverloadedStrings
24+ , RankNTypes
25+ , ScopedTypeVariables
26+ , TypeApplications
27+ , TypeInType
28+ , TypeOperators
29+ , UndecidableSuperClasses
30+#-}
31+
32+module Squeal.PostgreSQL.Definition.View
33+ ( createView
34+ , createOrReplaceView
35+ , dropView
36+ , dropViewIfExists
37+ ) where
38+
39+import GHC.TypeLits
40+
41+import Squeal.PostgreSQL.Alias
42+import Squeal.PostgreSQL.Definition
43+import Squeal.PostgreSQL.Query
44+import Squeal.PostgreSQL.Render
45+import Squeal.PostgreSQL.Schema
46+
47+-- $setup
48+-- >>> import Squeal.PostgreSQL
49+
50+{- | Create a view.
51+>>> type ABC = '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4]
52+>>> type BC = '["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4]
53+>>> :{
54+let
55+ definition :: Definition
56+ '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC)]]
57+ '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC), "bc" ::: 'View BC]]
58+ definition =
59+ createView #bc (select_ (#b :* #c) (from (table #abc)))
60+in printSQL definition
61+:}
62+CREATE VIEW "bc" AS SELECT "b" AS "b", "c" AS "c" FROM "abc" AS "abc";
63+-}
64+createView
65+ :: (Has sch schemas schema, KnownSymbol vw)
66+ => QualifiedAlias sch vw -- ^ the name of the view to add
67+ -> Query '[] '[] schemas '[] view -- ^ query
68+ -> Definition schemas (Alter sch (Create vw ('View view) schema) schemas)
69+createView alias query = UnsafeDefinition $
70+ "CREATE" <+> "VIEW" <+> renderSQL alias <+> "AS"
71+ <+> renderQuery query <> ";"
72+
73+createOrReplaceView
74+ :: (Has sch schemas schema, KnownSymbol vw)
75+ => QualifiedAlias sch vw -- ^ the name of the view to add
76+ -> Query '[] '[] schemas '[] view -- ^ query
77+ -> Definition schemas (Alter sch (CreateOrReplace vw ('View view) schema) schemas)
78+createOrReplaceView alias query = UnsafeDefinition $
79+ "CREATE OR REPLACE VIEW" <+> renderSQL alias <+> "AS"
80+ <+> renderQuery query <> ";"
81+
82+-- | Drop a view.
83+--
84+-- >>> :{
85+-- let
86+-- definition :: Definition
87+-- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])
88+-- , "bc" ::: 'View ('["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4])]]
89+-- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])]]
90+-- definition = dropView #bc
91+-- in printSQL definition
92+-- :}
93+-- DROP VIEW "bc";
94+dropView
95+ :: (Has sch schemas schema, KnownSymbol vw)
96+ => QualifiedAlias sch vw -- ^ view to remove
97+ -> Definition schemas (Alter sch (DropSchemum vw 'View schema) schemas)
98+dropView vw = UnsafeDefinition $ "DROP VIEW" <+> renderSQL vw <> ";"
99+
100+dropViewIfExists
101+ :: (Has sch schemas schema, KnownSymbol vw)
102+ => QualifiedAlias sch vw -- ^ view to remove
103+ -> Definition schemas (Alter sch (DropIfExists vw schema) schemas)
104+dropViewIfExists vw = UnsafeDefinition $ "DROP VIEW IF EXISTS" <+> renderSQL vw <> ";"
squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs+101−348
@@ -1,14 +1,13 @@
1{-|
1{-|
2Module: Squeal.PostgreSQL.Expression
2Module: Squeal.PostgreSQL.Expression
3Description: Squeal expressions
3Description: Squeal expressions
4−Copyright: (c) Eitan Chatav, 2017
4+Copyright: (c) Eitan Chatav, 2019
5Maintainer: eitan@morphism.tech
5Maintainer: eitan@morphism.tech
6Stability: experimental
6Stability: experimental
7
7
8Squeal expressions are the atoms used to build statements.
8Squeal expressions are the atoms used to build statements.
9-}
9-}
10
10
11−{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
12{-# LANGUAGE
11{-# LANGUAGE
13 AllowAmbiguousTypes
12 AllowAmbiguousTypes
14 , ConstraintKinds
13 , ConstraintKinds
@@ -35,94 +34,48 @@ module Squeal.PostgreSQL.Expression
35 ( -- * Expression
34 ( -- * Expression
36 Expression (..)
35 Expression (..)
37 , Expr
36 , Expr
38− , (:-->)
37+ , type (-->)
38+ , FunctionDB
39 , unsafeFunction
39 , unsafeFunction
40− , unsafeUnaryOpL
40+ , function
41− , unsafeUnaryOpR
41+ , unsafeLeftOp
42+ , leftOp
43+ , unsafeRightOp
44+ , rightOp
42 , Operator
45 , Operator
46+ , OperatorDB
43 , unsafeBinaryOp
47 , unsafeBinaryOp
48+ , binaryOp
44 , FunctionVar
49 , FunctionVar
45 , unsafeFunctionVar
50 , unsafeFunctionVar
46− , FunctionN
51+ , type (--->)
52+ , FunctionNDB
47 , unsafeFunctionN
53 , unsafeFunctionN
48− , Literal (..)
54+ , functionN
49− , HasParameter (parameter)
50− , param
51 , PGSubset (..)
55 , PGSubset (..)
52− -- * Types
56+ , PGIntersect (..)
53− , TypeExpression (..)
54− , cast
55− , PGTyped (..)
56− , typedef
57− , typetable
58− , typeview
59− , bool
60− , int2
61− , smallint
62− , int4
63− , int
64− , integer
65− , int8
66− , bigint
67− , numeric
68− , float4
69− , real
70− , float8
71− , doublePrecision
72− , money
73− , text
74− , char
75− , character
76− , varchar
77− , characterVarying
78− , bytea
79− , timestamp
80− , timestampWithTimeZone
81− , date
82− , time
83− , timeWithTimeZone
84− , interval
85− , uuid
86− , inet
87− , json
88− , jsonb
89− , vararray
90− , fixarray
91− , tsvector
92− , tsquery
93 -- * Re-export
57 -- * Re-export
94 , (&)
58 , (&)
95 , K (..)
59 , K (..)
60+ , unK
96 ) where
61 ) where
97
62
98import Control.Category
63import Control.Category
99import Control.DeepSeq
64import Control.DeepSeq
100import Data.ByteString (ByteString)
65import Data.ByteString (ByteString)
101−import Data.ByteString.Lazy (toStrict)
102−import ByteString.StrictBuilder (builderBytes)
103import Data.Function ((&))
66import Data.Function ((&))
104import Data.Semigroup hiding (All)
67import Data.Semigroup hiding (All)
105−import qualified Data.Aeson as JSON
106−import Data.Int
107import Data.String
68import Data.String
108−import Data.Text (Text)
109import Generics.SOP hiding (All, from)
69import Generics.SOP hiding (All, from)
110import GHC.OverloadedLabels
70import GHC.OverloadedLabels
111import GHC.TypeLits
71import GHC.TypeLits
112import Numeric
72import Numeric
113import Prelude hiding (id, (.))
73import Prelude hiding (id, (.))
114
74
115−import qualified Data.ByteString as ByteString
116−import qualified Data.Text as Text
117−import qualified Data.Text.Lazy as Lazy (Text)
118−import qualified Data.Text.Lazy as Lazy.Text
119import qualified GHC.Generics as GHC
75import qualified GHC.Generics as GHC
120−import qualified Generics.SOP as SOP
121
76
122import Squeal.PostgreSQL.Alias
77import Squeal.PostgreSQL.Alias
123−import Squeal.PostgreSQL.Binary
124import Squeal.PostgreSQL.List
78import Squeal.PostgreSQL.List
125−import Squeal.PostgreSQL.PG
126import Squeal.PostgreSQL.Render
79import Squeal.PostgreSQL.Render
127import Squeal.PostgreSQL.Schema
80import Squeal.PostgreSQL.Schema
128
81
@@ -138,7 +91,7 @@ such as in the target `Squeal.PostgreSQL.Query.List` of the
138`Squeal.PostgreSQL.Query.select` command,
91`Squeal.PostgreSQL.Query.select` command,
139as new column values in `Squeal.PostgreSQL.Manipulation.insertRow` or
92as new column values in `Squeal.PostgreSQL.Manipulation.insertRow` or
140`Squeal.PostgreSQL.Manipulation.update`,
93`Squeal.PostgreSQL.Manipulation.update`,
141−or in search `Condition`s in a number of commands.
94+or in search `Squeal.PostgreSQL.Logic.Condition`s in a number of commands.
142
95
143The expression syntax allows the calculation of
96The expression syntax allows the calculation of
144values from primitive expression using arithmetic, logical,
97values from primitive expression using arithmetic, logical,
@@ -172,7 +125,7 @@ instance RenderSQL (Expression outer commons grp schemas params from ty) where
172 renderSQL = renderExpression
125 renderSQL = renderExpression
173
126
174-- | An `Expr` is a closed `Expression`.
127-- | An `Expr` is a closed `Expression`.
175−-- It is a F`RankNType` but don't be scared.
128+-- It is a F@RankNType@ but don't be scared.
176-- Think of it as an expression which sees no
129-- Think of it as an expression which sees no
177-- namespaces, so you can't use parameters
130-- namespaces, so you can't use parameters
178-- or alias references. It can be used as
131-- or alias references. It can be used as
@@ -182,7 +135,7 @@ type Expr x
182 . Expression outer commons grp schemas params from x
135 . Expression outer commons grp schemas params from x
183 -- ^ cannot reference aliases
136 -- ^ cannot reference aliases
184
137
185−-- | A `RankNType` for binary operators.
138+-- | A @RankNType@ for binary operators.
186type Operator x1 x2 y
139type Operator x1 x2 y
187 = forall outer commons grp schemas params from
140 = forall outer commons grp schemas params from
188 . Expression outer commons grp schemas params from x1
141 . Expression outer commons grp schemas params from x1
@@ -192,32 +145,55 @@ type Operator x1 x2 y
192 -> Expression outer commons grp schemas params from y
145 -> Expression outer commons grp schemas params from y
193 -- ^ output
146 -- ^ output
194
147
148+type OperatorDB schemas x1 x2 y
149+ = forall outer commons grp params from
150+ . Expression outer commons grp schemas params from x1
151+ -- ^ left input
152+ -> Expression outer commons grp schemas params from x2
153+ -- ^ right input
154+ -> Expression outer commons grp schemas params from y
155+ -- ^ output
156+
195−-- | A `RankNType` for functions with a single argument.
157+-- | A @RankNType@ for functions with a single argument.
196-- These could be either function calls or unary operators.
158-- These could be either function calls or unary operators.
197-- This is a subtype of the usual Haskell function type `Prelude.->`,
159-- This is a subtype of the usual Haskell function type `Prelude.->`,
198-- indeed a subcategory as it is closed under the usual
160-- indeed a subcategory as it is closed under the usual
199-- `Prelude..` and `Prelude.id`.
161-- `Prelude..` and `Prelude.id`.
200−type (:-->) x y
162+type (-->) x y
201 = forall outer commons grp schemas params from
163 = forall outer commons grp schemas params from
202 . Expression outer commons grp schemas params from x
164 . Expression outer commons grp schemas params from x
203 -- ^ input
165 -- ^ input
204 -> Expression outer commons grp schemas params from y
166 -> Expression outer commons grp schemas params from y
205 -- ^ output
167 -- ^ output
206
168
169+type FunctionDB schemas x y
170+ = forall outer commons grp params from
171+ . Expression outer commons grp schemas params from x
172+ -- ^ input
173+ -> Expression outer commons grp schemas params from y
174+ -- ^ output
175+
207−{- | A `RankNType` for functions with a fixed-length list of heterogeneous arguments.
176+{- | A @RankNType@ for functions with a fixed-length list of heterogeneous arguments.
208Use the `*:` operator to end your argument lists, like so.
177Use the `*:` operator to end your argument lists, like so.
209
178
210>>> printSQL (unsafeFunctionN "fun" (true :* false :* localTime *: true))
179>>> printSQL (unsafeFunctionN "fun" (true :* false :* localTime *: true))
211fun(TRUE, FALSE, LOCALTIME, TRUE)
180fun(TRUE, FALSE, LOCALTIME, TRUE)
212-}
181-}
213−type FunctionN xs y
182+type (--->) xs y
214 = forall outer commons grp schemas params from
183 = forall outer commons grp schemas params from
215 . NP (Expression outer commons grp schemas params from) xs
184 . NP (Expression outer commons grp schemas params from) xs
216 -- ^ inputs
185 -- ^ inputs
217 -> Expression outer commons grp schemas params from y
186 -> Expression outer commons grp schemas params from y
218 -- ^ output
187 -- ^ output
219
188
189+type FunctionNDB schemas xs y
190+ = forall outer commons grp params from
191+ . NP (Expression outer commons grp schemas params from) xs
192+ -- ^ inputs
193+ -> Expression outer commons grp schemas params from y
194+ -- ^ output
195+
220−{- | A `RankNType` for functions with a variable-length list of
196+{- | A @RankNType@ for functions with a variable-length list of
221homogeneous arguments and at least 1 more argument.
197homogeneous arguments and at least 1 more argument.
222-}
198-}
223type FunctionVar x0 x1 y
199type FunctionVar x0 x1 y
@@ -236,46 +212,6 @@ unsafeFunctionVar :: ByteString -> FunctionVar x0 x1 y
236unsafeFunctionVar fun xs x = UnsafeExpression $ fun <> parenthesized
212unsafeFunctionVar fun xs x = UnsafeExpression $ fun <> parenthesized
237 (commaSeparated (renderSQL <$> xs) <> ", " <> renderSQL x)
213 (commaSeparated (renderSQL <$> xs) <> ", " <> renderSQL x)
238
214
239−{- | A `HasParameter` constraint is used to indicate a value that is
240−supplied externally to a SQL statement.
241−`Squeal.PostgreSQL.PQ.manipulateParams`,
242−`Squeal.PostgreSQL.PQ.queryParams` and
243−`Squeal.PostgreSQL.PQ.traversePrepared` support specifying data values
244−separately from the SQL command string, in which case `param`s are used to
245−refer to the out-of-line data values.
246−-}
247−class KnownNat n => HasParameter
248− (n :: Nat)
249− (params :: [NullityType])
250− (ty :: NullityType)
251− | n params -> ty where
252− -- | `parameter` takes a `Nat` using type application and a `TypeExpression`.
253− --
254− -- >>> let expr = parameter @1 int4 :: Expression outer '[] grp schemas '[ 'Null 'PGint4] from ('Null 'PGint4)
255− -- >>> printSQL expr
256− -- ($1 :: int4)
257− parameter
258− :: TypeExpression schemas ty
259− -> Expression outer commons grp schemas params from ty
260− parameter ty = UnsafeExpression $ parenthesized $
261− "$" <> renderNat @n <+> "::"
262− <+> renderSQL ty
263−instance {-# OVERLAPPING #-} HasParameter 1 (ty1:tys) ty1
264−instance {-# OVERLAPPABLE #-} (KnownNat n, HasParameter (n-1) params ty)
265− => HasParameter n (ty' : params) ty
266−
267−-- | `param` takes a `Nat` using type application and for basic types,
268−-- infers a `TypeExpression`.
269−--
270−-- >>> let expr = param @1 :: Expression outer commons grp schemas '[ 'Null 'PGint4] from ('Null 'PGint4)
271−-- >>> printSQL expr
272−-- ($1 :: int4)
273−param
274− :: forall n outer commons schemas params from grp ty
275− . (PGTyped schemas ty, HasParameter n params ty)
276− => Expression outer commons grp schemas params from ty -- ^ param
277−param = parameter @n (pgtype @schemas)
278−
279instance (HasUnique tab (Join outer from) row, Has col row ty)
215instance (HasUnique tab (Join outer from) row, Has col row ty)
280 => IsLabel col (Expression outer commons 'Ungrouped schemas params from ty) where
216 => IsLabel col (Expression outer commons 'Ungrouped schemas params from ty) where
281 fromLabel = UnsafeExpression $ renderSQL (Alias @col)
217 fromLabel = UnsafeExpression $ renderSQL (Alias @col)
@@ -382,28 +318,63 @@ unsafeBinaryOp :: ByteString -> Operator ty0 ty1 ty2
382unsafeBinaryOp op x y = UnsafeExpression $ parenthesized $
318unsafeBinaryOp op x y = UnsafeExpression $ parenthesized $
383 renderSQL x <+> op <+> renderSQL y
319 renderSQL x <+> op <+> renderSQL y
384
320
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+
385−-- | >>> printSQL $ unsafeUnaryOpL "NOT" true
328+-- | >>> printSQL $ unsafeLeftOp "NOT" true
386-- (NOT TRUE)
329-- (NOT TRUE)
387−unsafeUnaryOpL :: ByteString -> x :--> y
330+unsafeLeftOp :: ByteString -> x --> y
388−unsafeUnaryOpL op x = UnsafeExpression $ parenthesized $ op <+> renderSQL x
331+unsafeLeftOp op x = UnsafeExpression $ parenthesized $ op <+> renderSQL x
389
332
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+
390−-- | >>> printSQL $ true & unsafeUnaryOpR "IS NOT TRUE"
340+-- | >>> printSQL $ true & unsafeRightOp "IS NOT TRUE"
391-- (TRUE IS NOT TRUE)
341-- (TRUE IS NOT TRUE)
392−unsafeUnaryOpR :: ByteString -> x :--> y
342+unsafeRightOp :: ByteString -> x --> y
393−unsafeUnaryOpR op x = UnsafeExpression $ parenthesized $ renderSQL x <+> op
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
394
351
395-- | >>> printSQL $ unsafeFunction "f" true
352-- | >>> printSQL $ unsafeFunction "f" true
396-- f(TRUE)
353-- f(TRUE)
397−unsafeFunction :: ByteString -> x :--> y
354+unsafeFunction :: ByteString -> x --> y
398unsafeFunction fun x = UnsafeExpression $
355unsafeFunction fun x = UnsafeExpression $
399 fun <> parenthesized (renderSQL x)
356 fun <> parenthesized (renderSQL x)
400
357
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+
401-- | >>> printSQL $ unsafeFunctionN "f" (currentTime :* localTimestamp :* false *: literal 'a')
364-- | >>> printSQL $ unsafeFunctionN "f" (currentTime :* localTimestamp :* false *: literal 'a')
402-- f(CURRENT_TIME, LOCALTIMESTAMP, FALSE, E'a')
365-- f(CURRENT_TIME, LOCALTIMESTAMP, FALSE, E'a')
403−unsafeFunctionN :: SListI xs => ByteString -> FunctionN xs y
366+unsafeFunctionN :: SListI xs => ByteString -> xs ---> y
404unsafeFunctionN fun xs = UnsafeExpression $
367unsafeFunctionN fun xs = UnsafeExpression $
405 fun <> parenthesized (renderCommaSeparated renderSQL xs)
368 fun <> parenthesized (renderCommaSeparated renderSQL xs)
406
369
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+
407instance ty `In` PGNum
378instance ty `In` PGNum
408 => Num (Expression outer commons grp schemas params from (null ty)) where
379 => Num (Expression outer commons grp schemas params from (null ty)) where
409 (+) = unsafeBinaryOp "+"
380 (+) = unsafeBinaryOp "+"
@@ -448,33 +419,22 @@ instance (ty `In` PGNum, ty `In` PGFloating) => Floating
448 acosh x = log (x + sqrt (x*x - 1))
419 acosh x = log (x + sqrt (x*x - 1))
449 atanh x = log ((1 + x) / (1 - x)) / 2
420 atanh x = log ((1 + x) / (1 - x)) / 2
450
421
422+-- | Contained by operators
451−class PGSubset container where
423+class PGSubset ty where
452− (@>) :: Operator (null0 container) (null1 container) ('Null 'PGbool)
424+ (@>) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
453 (@>) = unsafeBinaryOp "@>"
425 (@>) = unsafeBinaryOp "@>"
454− (<@) :: Operator (null0 container) (null1 container) ('Null 'PGbool)
426+ (<@) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
455 (<@) = unsafeBinaryOp "<@"
427 (<@) = unsafeBinaryOp "<@"
456instance PGSubset 'PGjsonb
428instance PGSubset 'PGjsonb
457instance PGSubset 'PGtsquery
429instance PGSubset 'PGtsquery
458instance PGSubset ('PGvararray ty)
430instance PGSubset ('PGvararray ty)
431+instance PGSubset ('PGrange ty)
459
432
460−-- When a `cast` is applied to an `Expression` of a known type, it
433+class PGIntersect ty where
461−-- represents a run-time type conversion. The cast will succeed only if a
434+ (@&&) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
462−-- suitable type conversion operation has been defined.
435+ (@&&) = unsafeBinaryOp "&&"
463−--
436+instance PGIntersect ('PGvararray ty)
464−-- | >>> printSQL $ true & cast int4
437+instance PGIntersect ('PGrange ty)
465−-- (TRUE :: int4)
466−cast
467− :: TypeExpression schemas ty1
468− -- ^ type to cast as
469− -> Expression outer commons grp schemas params from ty0
470− -- ^ value to convert
471− -> Expression outer commons grp schemas params from ty1
472−cast ty x = UnsafeExpression $ parenthesized $
473− renderSQL x <+> "::" <+> renderSQL ty
474−
475−{-----------------------------------------
476−text
477−-----------------------------------------}
478
438
479instance IsString
439instance IsString
480 (Expression outer commons grp schemas params from (null 'PGtext)) where
440 (Expression outer commons grp schemas params from (null 'PGtext)) where
@@ -482,11 +442,11 @@ instance IsString
482 "E\'" <> fromString (escape =<< str) <> "\'"
442 "E\'" <> fromString (escape =<< str) <> "\'"
483instance IsString
443instance IsString
484 (Expression outer commons grp schemas params from (null 'PGtsvector)) where
444 (Expression outer commons grp schemas params from (null 'PGtsvector)) where
485− fromString str = cast tsvector . UnsafeExpression $
445+ fromString str = UnsafeExpression . parenthesized . (<> " :: tsvector") $
486 "E\'" <> fromString (escape =<< str) <> "\'"
446 "E\'" <> fromString (escape =<< str) <> "\'"
487instance IsString
447instance IsString
488 (Expression outer commons grp schemas params from (null 'PGtsquery)) where
448 (Expression outer commons grp schemas params from (null 'PGtsquery)) where
489− fromString str = cast tsquery . UnsafeExpression $
449+ fromString str = UnsafeExpression . parenthesized . (<> " :: tsquery") $
490 "E\'" <> fromString (escape =<< str) <> "\'"
450 "E\'" <> fromString (escape =<< str) <> "\'"
491
451
492instance Semigroup
452instance Semigroup
@@ -510,210 +470,3 @@ instance Monoid
510 (Expression outer commons grp schemas params from (null 'PGtsvector)) where
470 (Expression outer commons grp schemas params from (null 'PGtsvector)) where
511 mempty = fromString ""
471 mempty = fromString ""
512 mappend = (<>)
472 mappend = (<>)
513−
514−{-----------------------------------------
515−type expressions
516−-----------------------------------------}
517−
518−-- | `TypeExpression`s are used in `cast`s and
519−-- `Squeal.PostgreSQL.Definition.createTable` commands.
520−newtype TypeExpression (schemas :: SchemasType) (ty :: NullityType)
521− = UnsafeTypeExpression { renderTypeExpression :: ByteString }
522− deriving (GHC.Generic,Show,Eq,Ord,NFData)
523−instance RenderSQL (TypeExpression schemas ty) where
524− renderSQL = renderTypeExpression
525−
526−-- | The enum or composite type in a `Typedef` can be expressed by its alias.
527−typedef
528− :: (Has sch schemas schema, Has td schema ('Typedef ty))
529− => QualifiedAlias sch td
530− -> TypeExpression schemas (null ty)
531−typedef = UnsafeTypeExpression . renderSQL
532−
533−-- | The composite type corresponding to a `Table` definition can be expressed
534−-- by its alias.
535−typetable
536− :: (Has sch schemas schema, Has tab schema ('Table table))
537− => QualifiedAlias sch tab
538− -> TypeExpression schemas (null ('PGcomposite (TableToRow table)))
539−typetable = UnsafeTypeExpression . renderSQL
540−
541−-- | The composite type corresponding to a `View` definition can be expressed
542−-- by its alias.
543−typeview
544− :: (Has sch schemas schema, Has vw schema ('View view))
545− => QualifiedAlias sch vw
546− -> TypeExpression schemas (null ('PGcomposite view))
547−typeview = UnsafeTypeExpression . renderSQL
548−
549−-- | logical Boolean (true/false)
550−bool :: TypeExpression schemas (null 'PGbool)
551−bool = UnsafeTypeExpression "bool"
552−-- | signed two-byte integer
553−int2, smallint :: TypeExpression schemas (null 'PGint2)
554−int2 = UnsafeTypeExpression "int2"
555−smallint = UnsafeTypeExpression "smallint"
556−-- | signed four-byte integer
557−int4, int, integer :: TypeExpression schemas (null 'PGint4)
558−int4 = UnsafeTypeExpression "int4"
559−int = UnsafeTypeExpression "int"
560−integer = UnsafeTypeExpression "integer"
561−-- | signed eight-byte integer
562−int8, bigint :: TypeExpression schemas (null 'PGint8)
563−int8 = UnsafeTypeExpression "int8"
564−bigint = UnsafeTypeExpression "bigint"
565−-- | arbitrary precision numeric type
566−numeric :: TypeExpression schemas (null 'PGnumeric)
567−numeric = UnsafeTypeExpression "numeric"
568−-- | single precision floating-point number (4 bytes)
569−float4, real :: TypeExpression schemas (null 'PGfloat4)
570−float4 = UnsafeTypeExpression "float4"
571−real = UnsafeTypeExpression "real"
572−-- | double precision floating-point number (8 bytes)
573−float8, doublePrecision :: TypeExpression schemas (null 'PGfloat8)
574−float8 = UnsafeTypeExpression "float8"
575−doublePrecision = UnsafeTypeExpression "double precision"
576−-- | currency amount
577−money :: TypeExpression schema (null 'PGmoney)
578−money = UnsafeTypeExpression "money"
579−-- | variable-length character string
580−text :: TypeExpression schemas (null 'PGtext)
581−text = UnsafeTypeExpression "text"
582−-- | fixed-length character string
583−char, character
584− :: forall n schemas null. (KnownNat n, 1 <= n)
585− => TypeExpression schemas (null ('PGchar n))
586−char = UnsafeTypeExpression $ "char(" <> renderNat @n <> ")"
587−character = UnsafeTypeExpression $ "character(" <> renderNat @n <> ")"
588−-- | variable-length character string
589−varchar, characterVarying
590− :: forall n schemas null. (KnownNat n, 1 <= n)
591− => TypeExpression schemas (null ('PGvarchar n))
592−varchar = UnsafeTypeExpression $ "varchar(" <> renderNat @n <> ")"
593−characterVarying = UnsafeTypeExpression $
594− "character varying(" <> renderNat @n <> ")"
595−-- | binary data ("byte array")
596−bytea :: TypeExpression schemas (null 'PGbytea)
597−bytea = UnsafeTypeExpression "bytea"
598−-- | date and time (no time zone)
599−timestamp :: TypeExpression schemas (null 'PGtimestamp)
600−timestamp = UnsafeTypeExpression "timestamp"
601−-- | date and time, including time zone
602−timestampWithTimeZone :: TypeExpression schemas (null 'PGtimestamptz)
603−timestampWithTimeZone = UnsafeTypeExpression "timestamp with time zone"
604−-- | calendar date (year, month, day)
605−date :: TypeExpression schemas (null 'PGdate)
606−date = UnsafeTypeExpression "date"
607−-- | time of day (no time zone)
608−time :: TypeExpression schemas (null 'PGtime)
609−time = UnsafeTypeExpression "time"
610−-- | time of day, including time zone
611−timeWithTimeZone :: TypeExpression schemas (null 'PGtimetz)
612−timeWithTimeZone = UnsafeTypeExpression "time with time zone"
613−-- | time span
614−interval :: TypeExpression schemas (null 'PGinterval)
615−interval = UnsafeTypeExpression "interval"
616−-- | universally unique identifier
617−uuid :: TypeExpression schemas (null 'PGuuid)
618−uuid = UnsafeTypeExpression "uuid"
619−-- | IPv4 or IPv6 host address
620−inet :: TypeExpression schemas (null 'PGinet)
621−inet = UnsafeTypeExpression "inet"
622−-- | textual JSON data
623−json :: TypeExpression schemas (null 'PGjson)
624−json = UnsafeTypeExpression "json"
625−-- | binary JSON data, decomposed
626−jsonb :: TypeExpression schemas (null 'PGjsonb)
627−jsonb = UnsafeTypeExpression "jsonb"
628−-- | variable length array
629−vararray
630− :: TypeExpression schemas pg
631− -> TypeExpression schemas (null ('PGvararray pg))
632−vararray ty = UnsafeTypeExpression $ renderSQL ty <> "[]"
633−-- | fixed length array
634−--
635−-- >>> renderSQL (fixarray @'[2] json)
636−-- "json[2]"
637−fixarray
638− :: forall dims schemas null pg. SOP.All KnownNat dims
639− => TypeExpression schemas pg
640− -> TypeExpression schemas (null ('PGfixarray dims pg))
641−fixarray ty = UnsafeTypeExpression $
642− renderSQL ty <> renderDims @dims
643− where
644− renderDims :: forall ns. SOP.All KnownNat ns => ByteString
645− renderDims =
646− ("[" <>)
647− . (<> "]")
648− . ByteString.intercalate "]["
649− . hcollapse
650− $ hcmap (SOP.Proxy @KnownNat)
651− (K . fromString . show . natVal)
652− (hpure SOP.Proxy :: NP SOP.Proxy ns)
653−tsvector :: TypeExpression schemas (null 'PGtsvector)
654−tsvector = UnsafeTypeExpression "tsvector"
655−tsquery :: TypeExpression schemas (null 'PGtsquery)
656−tsquery = UnsafeTypeExpression "tsquery"
657−
658−-- | `pgtype` is a demoted version of a `PGType`
659−class PGTyped schemas (ty :: NullityType) where
660− pgtype :: TypeExpression schemas ty
661−instance PGTyped schemas (null 'PGbool) where pgtype = bool
662−instance PGTyped schemas (null 'PGint2) where pgtype = int2
663−instance PGTyped schemas (null 'PGint4) where pgtype = int4
664−instance PGTyped schemas (null 'PGint8) where pgtype = int8
665−instance PGTyped schemas (null 'PGnumeric) where pgtype = numeric
666−instance PGTyped schemas (null 'PGfloat4) where pgtype = float4
667−instance PGTyped schemas (null 'PGfloat8) where pgtype = float8
668−instance PGTyped schemas (null 'PGmoney) where pgtype = money
669−instance PGTyped schemas (null 'PGtext) where pgtype = text
670−instance (KnownNat n, 1 <= n)
671− => PGTyped schemas (null ('PGchar n)) where pgtype = char @n
672−instance (KnownNat n, 1 <= n)
673− => PGTyped schemas (null ('PGvarchar n)) where pgtype = varchar @n
674−instance PGTyped schemas (null 'PGbytea) where pgtype = bytea
675−instance PGTyped schemas (null 'PGtimestamp) where pgtype = timestamp
676−instance PGTyped schemas (null 'PGtimestamptz) where pgtype = timestampWithTimeZone
677−instance PGTyped schemas (null 'PGdate) where pgtype = date
678−instance PGTyped schemas (null 'PGtime) where pgtype = time
679−instance PGTyped schemas (null 'PGtimetz) where pgtype = timeWithTimeZone
680−instance PGTyped schemas (null 'PGinterval) where pgtype = interval
681−instance PGTyped schemas (null 'PGuuid) where pgtype = uuid
682−instance PGTyped schemas (null 'PGjson) where pgtype = json
683−instance PGTyped schemas (null 'PGjsonb) where pgtype = jsonb
684−instance PGTyped schemas ty
685− => PGTyped schemas (null ('PGvararray ty)) where
686− pgtype = vararray (pgtype @schemas @ty)
687−instance (SOP.All KnownNat dims, PGTyped schemas ty)
688− => PGTyped schemas (null ('PGfixarray dims ty)) where
689− pgtype = fixarray @dims (pgtype @schemas @ty)
690−instance PGTyped schemas (null 'PGtsvector) where pgtype = tsvector
691−instance PGTyped schemas (null 'PGtsquery) where pgtype = tsquery
692−
693−class Literal hask where
694− literal :: hask -> Expr (null (PG hask))
695−instance JSON.ToJSON hask => Literal (Json hask) where
696− literal = cast json . UnsafeExpression
697− . singleQuotedUtf8 . toStrict . JSON.encode . getJson
698−instance JSON.ToJSON hask => Literal (Jsonb hask) where
699− literal = cast jsonb . UnsafeExpression
700− . singleQuotedUtf8 . toStrict . JSON.encode . getJsonb
701−instance Literal Char where
702− literal chr = UnsafeExpression $
703− "E\'" <> fromString (escape chr) <> "\'"
704−instance Literal String where literal = fromString
705−instance Literal Int16 where literal = fromIntegral
706−instance Literal Int32 where literal = fromIntegral
707−instance Literal Int64 where literal = fromIntegral
708−instance Literal Float where literal = fromRational . toRational
709−instance Literal Double where literal = fromRational . toRational
710−instance Literal Text where literal = fromString . Text.unpack
711−instance Literal Lazy.Text where literal = fromString . Lazy.Text.unpack
712−instance ToParam (Enumerated enum) (PG (Enumerated enum))
713− => Literal (Enumerated enum) where
714− literal
715− = UnsafeExpression
716− . singleQuotedUtf8
717− . builderBytes
718− . unK
719− . toParam @(Enumerated enum) @(PG (Enumerated enum))
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Aggregate.hs+37−5
@@ -1,3 +1,13 @@
1+{-|
2+Module: Squeal.PostgreSQL.Expression.Aggregate
3+Description: Aggregate functions
4+Copyright: (c) Eitan Chatav, 2019
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Aggregate functions
9+-}
10+
1{-# LANGUAGE
11{-# LANGUAGE
2 DataKinds
12 DataKinds
3 , DeriveGeneric
13 , DeriveGeneric
@@ -16,6 +26,7 @@
16module Squeal.PostgreSQL.Expression.Aggregate
26module Squeal.PostgreSQL.Expression.Aggregate
17 ( Aggregate (..)
27 ( Aggregate (..)
18 , Distinction (..)
28 , Distinction (..)
29+ , PGSum
19 , PGAvg
30 , PGAvg
20 ) where
31 ) where
21
32
@@ -39,7 +50,7 @@ import Squeal.PostgreSQL.Schema
39{- |
50{- |
40`Aggregate` functions compute a single result from a set of input values.
51`Aggregate` functions compute a single result from a set of input values.
41`Aggregate` functions can be used as `GroupedBy` `Expression`s as well
52`Aggregate` functions can be used as `GroupedBy` `Expression`s as well
42−as `WindowFunction`s.
53+as `Squeal.PostgreSQL.Expression.Window.WindowFunction`s.
43-}
54-}
44class Aggregate expr1 exprN aggr
55class Aggregate expr1 exprN aggr
45 | aggr -> expr1, aggr -> exprN where
56 | aggr -> expr1, aggr -> exprN where
@@ -69,15 +80,14 @@ class Aggregate expr1 exprN aggr
69
80
70 -- | >>> :{
81 -- | >>> :{
71 -- let
82 -- let
72− -- 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)
73 -- expression = sum_ (Distinct #col)
84 -- expression = sum_ (Distinct #col)
74 -- in printSQL expression
85 -- in printSQL expression
75 -- :}
86 -- :}
76 -- sum(DISTINCT "col")
87 -- sum(DISTINCT "col")
77 sum_
88 sum_
78− :: ty `In` PGNum
79− => expr1 (null ty)
89+ :: expr1 (null ty)
80− -> aggr ('NotNull ty)
90+ -> aggr ('Null (PGSum ty))
81
91
82 -- | input values, including nulls, concatenated into an array
92 -- | input values, including nulls, concatenated into an array
83 arrayAgg
93 arrayAgg
@@ -96,6 +106,7 @@ class Aggregate expr1 exprN aggr
96
106
97 {- |
107 {- |
98 the bitwise AND of all non-null input values, or null if none
108 the bitwise AND of all non-null input values, or null if none
109+
99 >>> :{
110 >>> :{
100 let
111 let
101 expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: null 'PGint4]] ('Null 'PGint4)
112 expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: null 'PGint4]] ('Null 'PGint4)
@@ -194,6 +205,7 @@ class Aggregate expr1 exprN aggr
194 -> aggr ('Null (PGAvg ty))
205 -> aggr ('Null (PGAvg ty))
195
206
196 {- | correlation coefficient
207 {- | correlation coefficient
208+
197 >>> :{
209 >>> :{
198 let
210 let
199 expression :: Expression '[] c ('Grouped g) s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)
211 expression :: Expression '[] c ('Grouped g) s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)
@@ -207,6 +219,7 @@ class Aggregate expr1 exprN aggr
207 -> aggr ('Null 'PGfloat8)
219 -> aggr ('Null 'PGfloat8)
208
220
209 {- | population covariance
221 {- | population covariance
222+
210 >>> :{
223 >>> :{
211 let
224 let
212 expression :: Expression '[] c ('Grouped g) s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)
225 expression :: Expression '[] c ('Grouped g) s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)
@@ -220,6 +233,7 @@ class Aggregate expr1 exprN aggr
220 -> aggr ('Null 'PGfloat8)
233 -> aggr ('Null 'PGfloat8)
221
234
222 {- | sample covariance
235 {- | sample covariance
236+
223 >>> :{
237 >>> :{
224 let
238 let
225 winFun :: WindowFunction '[] c 'Ungrouped s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)
239 winFun :: WindowFunction '[] c 'Ungrouped s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)
@@ -233,6 +247,7 @@ class Aggregate expr1 exprN aggr
233 -> aggr ('Null 'PGfloat8)
247 -> aggr ('Null 'PGfloat8)
234
248
235 {- | average of the independent variable (sum(X)/N)
249 {- | average of the independent variable (sum(X)/N)
250+
236 >>> :{
251 >>> :{
237 let
252 let
238 expression :: Expression '[] c ('Grouped g) s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)
253 expression :: Expression '[] c ('Grouped g) s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)
@@ -246,6 +261,7 @@ class Aggregate expr1 exprN aggr
246 -> aggr ('Null 'PGfloat8)
261 -> aggr ('Null 'PGfloat8)
247
262
248 {- | average of the dependent variable (sum(Y)/N)
263 {- | average of the dependent variable (sum(Y)/N)
264+
249 >>> :{
265 >>> :{
250 let
266 let
251 winFun :: WindowFunction '[] c 'Ungrouped s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)
267 winFun :: WindowFunction '[] c 'Ungrouped s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)
@@ -259,6 +275,7 @@ class Aggregate expr1 exprN aggr
259 -> aggr ('Null 'PGfloat8)
275 -> aggr ('Null 'PGfloat8)
260
276
261 {- | number of input rows in which both expressions are nonnull
277 {- | number of input rows in which both expressions are nonnull
278+
262 >>> :{
279 >>> :{
263 let
280 let
264 winFun :: WindowFunction '[] c 'Ungrouped s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGint8)
281 winFun :: WindowFunction '[] c 'Ungrouped s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGint8)
@@ -417,6 +434,21 @@ unsafeAggregateN
417 -> Expression outer commons ('Grouped bys) schemas params from y
434 -> Expression outer commons ('Grouped bys) schemas params from y
418unsafeAggregateN fun xs = UnsafeExpression $ fun <> parenthesized (renderSQL xs)
435unsafeAggregateN fun xs = UnsafeExpression $ fun <> parenthesized (renderSQL xs)
419
436
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+
420-- | A type family that calculates `PGAvg` type of a `PGType`.
452-- | A type family that calculates `PGAvg` type of a `PGType`.
421type family PGAvg ty where
453type family PGAvg ty where
422 PGAvg 'PGint2 = 'PGnumeric
454 PGAvg 'PGint2 = 'PGnumeric
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Collection.hs+19−2
@@ -1,9 +1,20 @@
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+
1{-# LANGUAGE
11{-# LANGUAGE
2 AllowAmbiguousTypes
12 AllowAmbiguousTypes
3 , DataKinds
13 , DataKinds
4 , FlexibleContexts
14 , FlexibleContexts
5 , FlexibleInstances
15 , FlexibleInstances
6 , MultiParamTypeClasses
16 , MultiParamTypeClasses
17+ , OverloadedLabels
7 , OverloadedStrings
18 , OverloadedStrings
8 , RankNTypes
19 , RankNTypes
9 , ScopedTypeVariables
20 , ScopedTypeVariables
@@ -19,6 +30,7 @@ module Squeal.PostgreSQL.Expression.Collection
19 , array2
30 , array2
20 , cardinality
31 , cardinality
21 , index
32 , index
33+ , unnest
22 , row
34 , row
23 , field
35 , field
24 ) where
36 ) where
@@ -30,6 +42,7 @@ import qualified Generics.SOP as SOP
30
42
31import Squeal.PostgreSQL.Alias
43import Squeal.PostgreSQL.Alias
32import Squeal.PostgreSQL.Expression
44import Squeal.PostgreSQL.Expression
45+import Squeal.PostgreSQL.Expression.Set
33import Squeal.PostgreSQL.List
46import Squeal.PostgreSQL.List
34import Squeal.PostgreSQL.Render
47import Squeal.PostgreSQL.Render
35import Squeal.PostgreSQL.Schema
48import Squeal.PostgreSQL.Schema
@@ -98,17 +111,21 @@ array2 xss = UnsafeExpression $ "ARRAY" <>
98
111
99-- | >>> printSQL $ cardinality (array [null_, false, true])
112-- | >>> printSQL $ cardinality (array [null_, false, true])
100-- cardinality(ARRAY[NULL, FALSE, TRUE])
113-- cardinality(ARRAY[NULL, FALSE, TRUE])
101−cardinality :: null ('PGvararray ty) :--> null 'PGint8
114+cardinality :: null ('PGvararray ty) --> null 'PGint8
102cardinality = unsafeFunction "cardinality"
115cardinality = unsafeFunction "cardinality"
103
116
104-- | >>> printSQL $ array [null_, false, true] & index 2
117-- | >>> printSQL $ array [null_, false, true] & index 2
105-- (ARRAY[NULL, FALSE, TRUE])[2]
118-- (ARRAY[NULL, FALSE, TRUE])[2]
106index
119index
107 :: Word64 -- ^ index
120 :: Word64 -- ^ index
108− -> null ('PGvararray ty) :--> NullifyType ty
121+ -> null ('PGvararray ty) --> NullifyType ty
109index n expr = UnsafeExpression $
122index n expr = UnsafeExpression $
110 parenthesized (renderSQL expr) <> "[" <> fromString (show n) <> "]"
123 parenthesized (renderSQL expr) <> "[" <> fromString (show n) <> "]"
111
124
125+-- | Expand an array to a set of rows
126+unnest :: SetFunction "unnest" (null ('PGvararray ty)) '["unnest" ::: ty]
127+unnest = unsafeSetFunction
128+
112-- | A row constructor is an expression that builds a row value
129-- | A row constructor is an expression that builds a row value
113-- (also called a composite value) using values for its member fields.
130-- (also called a composite value) using values for its member fields.
114--
131--
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Comparison.hs+48−40
@@ -1,5 +1,16 @@
1+{-|
2+Module: Squeal.PostgreSQL.Expression.Comparison
3+Description: Comparison expressions
4+Copyright: (c) Eitan Chatav, 2019
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Comparison functions and operators
9+-}
10+
1{-# LANGUAGE
11{-# LANGUAGE
2 OverloadedStrings
12 OverloadedStrings
13+ , RankNTypes
3 , TypeInType
14 , TypeInType
4 , TypeOperators
15 , TypeOperators
5#-}
16#-}
@@ -13,6 +24,7 @@ module Squeal.PostgreSQL.Expression.Comparison
13 , (.>)
24 , (.>)
14 , greatest
25 , greatest
15 , least
26 , least
27+ , BetweenExpr
16 , between
28 , between
17 , notBetween
29 , notBetween
18 , betweenSymmetric
30 , betweenSymmetric
@@ -27,6 +39,8 @@ module Squeal.PostgreSQL.Expression.Comparison
27 , isNotUnknown
39 , isNotUnknown
28 ) where
40 ) where
29
41
42+import Data.ByteString
43+
30import Squeal.PostgreSQL.Expression
44import Squeal.PostgreSQL.Expression
31import Squeal.PostgreSQL.Expression.Logic
45import Squeal.PostgreSQL.Expression.Logic
32import Squeal.PostgreSQL.Render
46import Squeal.PostgreSQL.Render
@@ -85,53 +99,47 @@ greatest = unsafeFunctionVar "GREATEST"
85least :: FunctionVar ty ty ty
99least :: FunctionVar ty ty ty
86least = unsafeFunctionVar "LEAST"
100least = unsafeFunctionVar "LEAST"
87
101
102+{- |
103+A @RankNType@ for comparison expressions like `between`.
104+-}
105+type BetweenExpr
106+ = forall outer commons grp schemas params from ty
107+ . Expression outer commons grp schemas params from ty
108+ -> ( Expression outer commons grp schemas params from ty
109+ , Expression outer commons grp schemas params from ty ) -- ^ bounds
110+ -> Condition outer commons grp schemas params from
111+
112+unsafeBetweenExpr :: ByteString -> BetweenExpr
113+unsafeBetweenExpr fun a (x,y) = UnsafeExpression $
114+ renderSQL a <+> fun <+> renderSQL x <+> "AND" <+> renderSQL y
115+
88{- | >>> printSQL $ true `between` (null_, false)
116{- | >>> printSQL $ true `between` (null_, false)
89TRUE BETWEEN NULL AND FALSE
117TRUE BETWEEN NULL AND FALSE
90-}
118-}
91−between
119+between :: BetweenExpr
92− :: Expression outer commons grp schemas params from (null ty)
120+between = unsafeBetweenExpr "BETWEEN"
93− -> ( Expression outer commons grp schemas params from (null ty)
94− , Expression outer commons grp schemas params from (null ty) ) -- ^ bounds
95− -> Condition outer commons grp schemas params from
96−between a (x,y) = UnsafeExpression $ renderSQL a <+> "BETWEEN"
97− <+> renderSQL x <+> "AND" <+> renderSQL y
98
121
99{- | >>> printSQL $ true `notBetween` (null_, false)
122{- | >>> printSQL $ true `notBetween` (null_, false)
100TRUE NOT BETWEEN NULL AND FALSE
123TRUE NOT BETWEEN NULL AND FALSE
101-}
124-}
102−notBetween
125+notBetween :: BetweenExpr
103− :: Expression outer commons grp schemas params from (null ty)
104− -> ( Expression outer commons grp schemas params from (null ty)
105− , Expression outer commons grp schemas params from (null ty) ) -- ^ bounds
106− -> Condition outer commons grp schemas params from
107−notBetween a (x,y) = UnsafeExpression $ renderSQL a <+> "NOT BETWEEN"
126+notBetween = unsafeBetweenExpr "NOT BETWEEN"
108− <+> renderSQL x <+> "AND" <+> renderSQL y
109
127
110{- | between, after sorting the comparison values
128{- | between, after sorting the comparison values
111
129
112>>> printSQL $ true `betweenSymmetric` (null_, false)
130>>> printSQL $ true `betweenSymmetric` (null_, false)
113TRUE BETWEEN SYMMETRIC NULL AND FALSE
131TRUE BETWEEN SYMMETRIC NULL AND FALSE
114-}
132-}
115−betweenSymmetric
133+betweenSymmetric :: BetweenExpr
116− :: Expression outer commons grp schemas params from (null ty)
134+betweenSymmetric = unsafeBetweenExpr "BETWEEN SYMMETRIC"
117− -> ( Expression outer commons grp schemas params from (null ty)
118− , Expression outer commons grp schemas params from (null ty) ) -- ^ bounds
119− -> Condition outer commons grp schemas params from
120−betweenSymmetric a (x,y) = UnsafeExpression $ renderSQL a
121− <+> "BETWEEN SYMMETRIC" <+> renderSQL x <+> "AND" <+> renderSQL y
122
135
123{- | not between, after sorting the comparison values
136{- | not between, after sorting the comparison values
124
137
125>>> printSQL $ true `notBetweenSymmetric` (null_, false)
138>>> printSQL $ true `notBetweenSymmetric` (null_, false)
126TRUE NOT BETWEEN SYMMETRIC NULL AND FALSE
139TRUE NOT BETWEEN SYMMETRIC NULL AND FALSE
127-}
140-}
128−notBetweenSymmetric
141+notBetweenSymmetric :: BetweenExpr
129− :: Expression outer commons grp schemas params from (null ty)
142+notBetweenSymmetric = unsafeBetweenExpr "NOT BETWEEN SYMMETRIC"
130− -> ( Expression outer commons grp schemas params from (null ty)
131− , Expression outer commons grp schemas params from (null ty) ) -- ^ bounds
132− -> Condition outer commons grp schemas params from
133−notBetweenSymmetric a (x,y) = UnsafeExpression $ renderSQL a
134− <+> "NOT BETWEEN SYMMETRIC" <+> renderSQL x <+> "AND" <+> renderSQL y
135
143
136{- | not equal, treating null like an ordinary value
144{- | not equal, treating null like an ordinary value
137
145
@@ -154,45 +162,45 @@ isNotDistinctFrom = unsafeBinaryOp "IS NOT DISTINCT FROM"
154>>> printSQL $ true & isTrue
162>>> printSQL $ true & isTrue
155(TRUE IS TRUE)
163(TRUE IS TRUE)
156-}
164-}
157−isTrue :: null0 'PGbool :--> null1 'PGbool
165+isTrue :: null0 'PGbool --> null1 'PGbool
158−isTrue = unsafeUnaryOpR "IS TRUE"
166+isTrue = unsafeRightOp "IS TRUE"
159
167
160{- | is false or unknown
168{- | is false or unknown
161
169
162>>> printSQL $ true & isNotTrue
170>>> printSQL $ true & isNotTrue
163(TRUE IS NOT TRUE)
171(TRUE IS NOT TRUE)
164-}
172-}
165−isNotTrue :: null0 'PGbool :--> null1 'PGbool
173+isNotTrue :: null0 'PGbool --> null1 'PGbool
166−isNotTrue = unsafeUnaryOpR "IS NOT TRUE"
174+isNotTrue = unsafeRightOp "IS NOT TRUE"
167
175
168{- | is false
176{- | is false
169
177
170>>> printSQL $ true & isFalse
178>>> printSQL $ true & isFalse
171(TRUE IS FALSE)
179(TRUE IS FALSE)
172-}
180-}
173−isFalse :: null0 'PGbool :--> null1 'PGbool
181+isFalse :: null0 'PGbool --> null1 'PGbool
174−isFalse = unsafeUnaryOpR "IS FALSE"
182+isFalse = unsafeRightOp "IS FALSE"
175
183
176{- | is true or unknown
184{- | is true or unknown
177
185
178>>> printSQL $ true & isNotFalse
186>>> printSQL $ true & isNotFalse
179(TRUE IS NOT FALSE)
187(TRUE IS NOT FALSE)
180-}
188-}
181−isNotFalse :: null0 'PGbool :--> null1 'PGbool
189+isNotFalse :: null0 'PGbool --> null1 'PGbool
182−isNotFalse = unsafeUnaryOpR "IS NOT FALSE"
190+isNotFalse = unsafeRightOp "IS NOT FALSE"
183
191
184{- | is unknown
192{- | is unknown
185
193
186>>> printSQL $ true & isUnknown
194>>> printSQL $ true & isUnknown
187(TRUE IS UNKNOWN)
195(TRUE IS UNKNOWN)
188-}
196-}
189−isUnknown :: null0 'PGbool :--> null1 'PGbool
197+isUnknown :: null0 'PGbool --> null1 'PGbool
190−isUnknown = unsafeUnaryOpR "IS UNKNOWN"
198+isUnknown = unsafeRightOp "IS UNKNOWN"
191
199
192{- | is true or false
200{- | is true or false
193
201
194>>> printSQL $ true & isNotUnknown
202>>> printSQL $ true & isNotUnknown
195(TRUE IS NOT UNKNOWN)
203(TRUE IS NOT UNKNOWN)
196-}
204-}
197−isNotUnknown :: null0 'PGbool :--> null1 'PGbool
205+isNotUnknown :: null0 'PGbool --> null1 'PGbool
198−isNotUnknown = unsafeUnaryOpR "IS NOT UNKNOWN"
206+isNotUnknown = unsafeRightOp "IS NOT UNKNOWN"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Json.hs+227−113
@@ -1,11 +1,27 @@
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+
1{-# LANGUAGE
11{-# LANGUAGE
2 DataKinds
12 DataKinds
3 , FlexibleContexts
13 , FlexibleContexts
4 , FlexibleInstances
14 , FlexibleInstances
15+ , GADTs
16+ , OverloadedLabels
5 , OverloadedStrings
17 , OverloadedStrings
6 , PolyKinds
18 , PolyKinds
19+ , RankNTypes
20+ , ScopedTypeVariables
21+ , TypeApplications
7 , TypeOperators
22 , TypeOperators
8 , UndecidableInstances
23 , UndecidableInstances
24+ , UndecidableSuperClasses
9#-}
25#-}
10
26
11module Squeal.PostgreSQL.Expression.Json
27module Squeal.PostgreSQL.Expression.Json
@@ -27,19 +43,13 @@ module Squeal.PostgreSQL.Expression.Json
27 , rowToJson
43 , rowToJson
28 , jsonBuildArray
44 , jsonBuildArray
29 , jsonbBuildArray
45 , jsonbBuildArray
30− , PGBuildObject
46+ , JsonBuildObject (..)
31− , jsonBuildObject
32− , jsonbBuildObject
33 , jsonObject
47 , jsonObject
34 , jsonbObject
48 , jsonbObject
35 , jsonZipObject
49 , jsonZipObject
36 , jsonbZipObject
50 , jsonbZipObject
37 , jsonArrayLength
51 , jsonArrayLength
38 , jsonbArrayLength
52 , jsonbArrayLength
39− , jsonExtractPath
40− , jsonbExtractPath
41− , jsonExtractPathAsText
42− , jsonbExtractPathAsText
43 , jsonTypeof
53 , jsonTypeof
44 , jsonbTypeof
54 , jsonbTypeof
45 , jsonStripNulls
55 , jsonStripNulls
@@ -47,14 +57,43 @@ module Squeal.PostgreSQL.Expression.Json
47 , jsonbSet
57 , jsonbSet
48 , jsonbInsert
58 , jsonbInsert
49 , jsonbPretty
59 , jsonbPretty
60+ -- * Json and Jsonb set returning functions
61+ , jsonEach
62+ , jsonbEach
63+ , jsonEachText
64+ , jsonbEachText
65+ , jsonObjectKeys
66+ , jsonbObjectKeys
67+ , JsonPopulateFunction
68+ , jsonPopulateRecord
69+ , jsonbPopulateRecord
70+ , jsonPopulateRecordSet
71+ , jsonbPopulateRecordSet
72+ , JsonToRecordFunction
73+ , jsonToRecord
74+ , jsonbToRecord
75+ , jsonToRecordSet
76+ , jsonbToRecordSet
50 ) where
77 ) where
51
78
79+import Data.ByteString (ByteString)
80+import GHC.TypeLits
81+
82+import Squeal.PostgreSQL.Alias
52import Squeal.PostgreSQL.Expression
83import Squeal.PostgreSQL.Expression
84+import Squeal.PostgreSQL.Expression.Set
85+import Squeal.PostgreSQL.Expression.Type
53import Squeal.PostgreSQL.List
86import Squeal.PostgreSQL.List
87+import Squeal.PostgreSQL.Query
88+import Squeal.PostgreSQL.Render
54import Squeal.PostgreSQL.Schema
89import Squeal.PostgreSQL.Schema
55
90
56import qualified Generics.SOP as SOP
91import qualified Generics.SOP as SOP
57
92
93+-- $setup
94+-- >>> import Squeal.PostgreSQL
95+-- >>> import Data.Aeson
96+
58{-----------------------------------------
97{-----------------------------------------
59 -- json and jsonb support
98 -- json and jsonb support
60
99
@@ -117,18 +156,18 @@ infixl 9 .?&
117
156
118-- | Delete a key or keys from a JSON object, or remove an array element.
157-- | Delete a key or keys from a JSON object, or remove an array element.
119--
158--
120−-- If the right operand is..
159+-- If the right operand is
121--
160--
122−-- @ text @: Delete key/value pair or string element from left operand. Key/value pairs
161+-- @ text @: Delete key / value pair or string element from left operand.
123−-- are matched based on their key value.
162+-- Key / value pairs are matched based on their key value,
124--
163--
125−-- @ text[] @: Delete multiple key/value pairs or string elements
164+-- @ text[] @: Delete multiple key / value pairs or string elements
126−-- from left operand. Key/value pairs are matched based on their key value.
165+-- from left operand. Key / value pairs are matched based on their key value,
127--
166--
128-- @ integer @: Delete the array element with specified index (Negative integers
167-- @ integer @: Delete the array element with specified index (Negative integers
129-- count from the end). Throws an error if top level container is not an array.
168-- count from the end). Throws an error if top level container is not an array.
130(.-.)
169(.-.)
131− :: (key `In` '[ 'PGtext, 'PGvararray ('NotNull 'PGtext), 'PGint4, 'PGint2 ]) -- hlint error without parens here
170+ :: key `In` '[ 'PGtext, 'PGvararray ('NotNull 'PGtext), 'PGint4, 'PGint2 ]
132 => Operator (null 'PGjsonb) (null key) (null 'PGjsonb)
171 => Operator (null 'PGjsonb) (null key) (null 'PGjsonb)
133infixl 6 .-.
172infixl 6 .-.
134(.-.) = unsafeBinaryOp "-"
173(.-.) = unsafeBinaryOp "-"
@@ -149,7 +188,7 @@ Table 9.45: JSON creation functions
149-- otherwise, a scalar value is produced. For any scalar type other than a
188-- otherwise, a scalar value is produced. For any scalar type other than a
150-- number, a Boolean, or a null value, the text representation will be used, in
189-- number, a Boolean, or a null value, the text representation will be used, in
151-- such a fashion that it is a valid json value.
190-- such a fashion that it is a valid json value.
152−toJson :: null ty :--> null 'PGjson
191+toJson :: null ty --> null 'PGjson
153toJson = unsafeFunction "to_json"
192toJson = unsafeFunction "to_json"
154
193
155-- | Returns the value as jsonb. Arrays and composites are converted
194-- | Returns the value as jsonb. Arrays and composites are converted
@@ -158,48 +197,42 @@ toJson = unsafeFunction "to_json"
158-- otherwise, a scalar value is produced. For any scalar type other than a
197-- otherwise, a scalar value is produced. For any scalar type other than a
159-- number, a Boolean, or a null value, the text representation will be used, in
198-- number, a Boolean, or a null value, the text representation will be used, in
160-- such a fashion that it is a valid jsonb value.
199-- such a fashion that it is a valid jsonb value.
161−toJsonb :: null ty :--> null 'PGjsonb
200+toJsonb :: null ty --> null 'PGjsonb
162toJsonb = unsafeFunction "to_jsonb"
201toJsonb = unsafeFunction "to_jsonb"
163
202
164-- | Returns the array as a JSON array. A PostgreSQL multidimensional array
203-- | Returns the array as a JSON array. A PostgreSQL multidimensional array
165-- becomes a JSON array of arrays.
204-- becomes a JSON array of arrays.
166−arrayToJson :: null ('PGvararray ty) :--> null 'PGjson
205+arrayToJson :: null ('PGvararray ty) --> null 'PGjson
167arrayToJson = unsafeFunction "array_to_json"
206arrayToJson = unsafeFunction "array_to_json"
168
207
169-- | Returns the row as a JSON object.
208-- | Returns the row as a JSON object.
170−rowToJson :: null ('PGcomposite ty) :--> null 'PGjson
209+rowToJson :: null ('PGcomposite ty) --> null 'PGjson
171rowToJson = unsafeFunction "row_to_json"
210rowToJson = unsafeFunction "row_to_json"
172
211
173-- | Builds a possibly-heterogeneously-typed JSON array out of a variadic
212-- | Builds a possibly-heterogeneously-typed JSON array out of a variadic
174-- argument list.
213-- argument list.
175−jsonBuildArray :: SOP.SListI tuple => FunctionN tuple (null 'PGjson)
214+jsonBuildArray :: SOP.SListI tuple => tuple ---> null 'PGjson
176jsonBuildArray = unsafeFunctionN "json_build_array"
215jsonBuildArray = unsafeFunctionN "json_build_array"
177
216
178-- | Builds a possibly-heterogeneously-typed (binary) JSON array out of a
217-- | Builds a possibly-heterogeneously-typed (binary) JSON array out of a
179-- variadic argument list.
218-- variadic argument list.
180−jsonbBuildArray :: SOP.SListI tuple => FunctionN tuple (null 'PGjsonb)
219+jsonbBuildArray :: SOP.SListI tuple => tuple ---> null 'PGjsonb
181jsonbBuildArray = unsafeFunctionN "jsonb_build_array"
220jsonbBuildArray = unsafeFunctionN "jsonb_build_array"
182
221
183−class PGBuildObject tys where
184−instance PGBuildObject '[]
185−instance (PGBuildObject tys, key `In` PGJsonKey)
186− => PGBuildObject ('NotNull key ': value ': tys)
187−
188-- | Builds a possibly-heterogeneously-typed JSON object out of a variadic
222-- | Builds a possibly-heterogeneously-typed JSON object out of a variadic
189-- argument list. The elements of the argument list must alternate between text
223-- argument list. The elements of the argument list must alternate between text
190-- and values.
224-- and values.
191−jsonBuildObject
225+class SOP.SListI tys => JsonBuildObject tys where
192− :: (SOP.SListI elems, PGBuildObject elems)
226+
193− => FunctionN elems (null 'PGjson)
227+ jsonBuildObject :: tys ---> null 'PGjson
194−jsonBuildObject = unsafeFunctionN "json_build_object"
228+ jsonBuildObject = unsafeFunctionN "json_build_object"
195−
229+
196−-- | Builds a possibly-heterogeneously-typed (binary) JSON object out of a
197−-- variadic argument list. The elements of the argument list must alternate
198−-- between keys and values.
199−jsonbBuildObject
200− :: (SOP.SListI elems, PGBuildObject elems)
201− => FunctionN elems (null 'PGjsonb)
230+ jsonbBuildObject :: tys ---> null 'PGjsonb
202−jsonbBuildObject = unsafeFunctionN "jsonb_build_object"
231+ jsonbBuildObject = unsafeFunctionN "jsonb_build_object"
232+
233+instance JsonBuildObject '[]
234+instance (JsonBuildObject tys, key `In` PGJsonKey)
235+ => JsonBuildObject ('NotNull key ': value ': tys)
203
236
204-- | Builds a JSON object out of a text array.
237-- | Builds a JSON object out of a text array.
205-- The array must have two dimensions
238-- The array must have two dimensions
@@ -207,7 +240,7 @@ jsonbBuildObject = unsafeFunctionN "jsonb_build_object"
207-- which are taken as a key/value pair.
240-- which are taken as a key/value pair.
208jsonObject
241jsonObject
209 :: null ('PGfixarray '[n,2] ('NotNull 'PGtext))
242 :: null ('PGfixarray '[n,2] ('NotNull 'PGtext))
210− :--> null 'PGjson
243+ --> null 'PGjson
211jsonObject = unsafeFunction "json_object"
244jsonObject = unsafeFunction "json_object"
212
245
213-- | Builds a binary JSON object out of a text array.
246-- | Builds a binary JSON object out of a text array.
@@ -216,24 +249,24 @@ jsonObject = unsafeFunction "json_object"
216-- which are taken as a key/value pair.
249-- which are taken as a key/value pair.
217jsonbObject
250jsonbObject
218 :: null ('PGfixarray '[n,2] ('NotNull 'PGtext))
251 :: null ('PGfixarray '[n,2] ('NotNull 'PGtext))
219− :--> null 'PGjsonb
252+ --> null 'PGjsonb
220jsonbObject = unsafeFunction "jsonb_object"
253jsonbObject = unsafeFunction "jsonb_object"
221
254
222-- | This is an alternate form of 'jsonObject' that takes two arrays; one for
255-- | This is an alternate form of 'jsonObject' that takes two arrays; one for
223-- keys and one for values, that are zipped pairwise to create a JSON object.
256-- keys and one for values, that are zipped pairwise to create a JSON object.
224−jsonZipObject :: FunctionN
257+jsonZipObject ::
225 '[ null ('PGvararray ('NotNull 'PGtext))
258 '[ null ('PGvararray ('NotNull 'PGtext))
226 , null ('PGvararray ('NotNull 'PGtext)) ]
259 , null ('PGvararray ('NotNull 'PGtext)) ]
227− ( null 'PGjson )
260+ ---> null 'PGjson
228jsonZipObject = unsafeFunctionN "json_object"
261jsonZipObject = unsafeFunctionN "json_object"
229
262
230-- | This is an alternate form of 'jsonbObject' that takes two arrays; one for
263-- | This is an alternate form of 'jsonbObject' that takes two arrays; one for
231-- keys and one for values, that are zipped pairwise to create a binary JSON
264-- keys and one for values, that are zipped pairwise to create a binary JSON
232-- object.
265-- object.
233−jsonbZipObject :: FunctionN
266+jsonbZipObject ::
234 '[ null ('PGvararray ('NotNull 'PGtext))
267 '[ null ('PGvararray ('NotNull 'PGtext))
235 , null ('PGvararray ('NotNull 'PGtext)) ]
268 , null ('PGvararray ('NotNull 'PGtext)) ]
236− ( null 'PGjsonb )
269+ ---> null 'PGjsonb
237jsonbZipObject = unsafeFunctionN "jsonb_object"
270jsonbZipObject = unsafeFunctionN "jsonb_object"
238
271
239{-----------------------------------------
272{-----------------------------------------
@@ -241,108 +274,189 @@ Table 9.46: JSON processing functions
241-----------------------------------------}
274-----------------------------------------}
242
275
243-- | Returns the number of elements in the outermost JSON array.
276-- | Returns the number of elements in the outermost JSON array.
244−jsonArrayLength :: null 'PGjson :--> null 'PGint4
277+jsonArrayLength :: null 'PGjson --> null 'PGint4
245jsonArrayLength = unsafeFunction "json_array_length"
278jsonArrayLength = unsafeFunction "json_array_length"
246
279
247-- | Returns the number of elements in the outermost binary JSON array.
280-- | Returns the number of elements in the outermost binary JSON array.
248−jsonbArrayLength :: null 'PGjsonb :--> null 'PGint4
281+jsonbArrayLength :: null 'PGjsonb --> null 'PGint4
249jsonbArrayLength = unsafeFunction "jsonb_array_length"
282jsonbArrayLength = unsafeFunction "jsonb_array_length"
250
283
251−-- | Returns JSON value pointed to by the given path (equivalent to #>
252−-- operator).
253−jsonExtractPath
254− :: SOP.SListI elems
255− => Expression outer commons grp schemas params from (null 'PGjson)
256− -> NP (Expression outer commons grp schemas params from) elems
257− -> Expression outer commons grp schemas params from (null 'PGjsonb)
258−jsonExtractPath x xs =
259− unsafeFunctionN "json_extract_path" (x :* xs)
260−
261−-- | Returns JSON value pointed to by the given path (equivalent to #>
262−-- operator).
263−jsonbExtractPath
264− :: SOP.SListI elems
265− => Expression outer commons grp schemas params from (null 'PGjsonb)
266− -> NP (Expression outer commons grp schemas params from) elems
267− -> Expression outer commons grp schemas params from (null 'PGjsonb)
268−jsonbExtractPath x xs =
269− unsafeFunctionN "jsonb_extract_path" (x :* xs)
270−
271−-- | Returns JSON value pointed to by the given path (equivalent to #>
272−-- operator), as text.
273−jsonExtractPathAsText
274− :: SOP.SListI elems
275− => Expression outer commons grp schemas params from (null 'PGjson)
276− -> NP (Expression outer commons grp schemas params from) elems
277− -> Expression outer commons grp schemas params from (null 'PGjson)
278−jsonExtractPathAsText x xs =
279− unsafeFunctionN "json_extract_path_text" (x :* xs)
280−
281−-- | Returns JSON value pointed to by the given path (equivalent to #>
282−-- operator), as text.
283−jsonbExtractPathAsText
284− :: SOP.SListI elems
285− => Expression outer commons grp schemas params from (null 'PGjsonb)
286− -> NP (Expression outer commons grp schemas params from) elems
287− -> Expression outer commons grp schemas params from (null 'PGjsonb)
288−jsonbExtractPathAsText x xs =
289− unsafeFunctionN "jsonb_extract_path_text" (x :* xs)
290−
291-- | Returns the type of the outermost JSON value as a text string. Possible
284-- | Returns the type of the outermost JSON value as a text string. Possible
292-- types are object, array, string, number, boolean, and null.
285-- types are object, array, string, number, boolean, and null.
293−jsonTypeof :: null 'PGjson :--> null 'PGtext
286+jsonTypeof :: null 'PGjson --> null 'PGtext
294jsonTypeof = unsafeFunction "json_typeof"
287jsonTypeof = unsafeFunction "json_typeof"
295
288
296-- | Returns the type of the outermost binary JSON value as a text string.
289-- | Returns the type of the outermost binary JSON value as a text string.
297-- Possible types are object, array, string, number, boolean, and null.
290-- Possible types are object, array, string, number, boolean, and null.
298−jsonbTypeof :: null 'PGjsonb :--> null 'PGtext
291+jsonbTypeof :: null 'PGjsonb --> null 'PGtext
299jsonbTypeof = unsafeFunction "jsonb_typeof"
292jsonbTypeof = unsafeFunction "jsonb_typeof"
300
293
301-- | Returns its argument with all object fields that have null values omitted.
294-- | Returns its argument with all object fields that have null values omitted.
302-- Other null values are untouched.
295-- Other null values are untouched.
303−jsonStripNulls :: null 'PGjson :--> null 'PGjson
296+jsonStripNulls :: null 'PGjson --> null 'PGjson
304jsonStripNulls = unsafeFunction "json_strip_nulls"
297jsonStripNulls = unsafeFunction "json_strip_nulls"
305
298
306-- | Returns its argument with all object fields that have null values omitted.
299-- | Returns its argument with all object fields that have null values omitted.
307-- Other null values are untouched.
300-- Other null values are untouched.
308−jsonbStripNulls :: null 'PGjsonb :--> null 'PGjsonb
301+jsonbStripNulls :: null 'PGjsonb --> null 'PGjsonb
309jsonbStripNulls = unsafeFunction "jsonb_strip_nulls"
302jsonbStripNulls = unsafeFunction "jsonb_strip_nulls"
310
303
311-- | @ jsonbSet target path new_value create_missing @
304-- | @ jsonbSet target path new_value create_missing @
312--
305--
313−-- Returns target with the section designated by path replaced by new_value,
306+-- Returns target with the section designated by path replaced by @new_value@,
314−-- or with new_value added if create_missing is true ( default is true) and the
307+-- or with @new_value@ added if create_missing is
308+-- `Squeal.PostgreSQL.Expression.Logic.true` and the
315-- item designated by path does not exist. As with the path orientated
309-- item designated by path does not exist. As with the path orientated
316-- operators, negative integers that appear in path count from the end of JSON
310-- operators, negative integers that appear in path count from the end of JSON
317-- arrays.
311-- arrays.
318−jsonbSet
312+jsonbSet ::
319− :: Expression outer commons grp schemas params from (null 'PGjsonb)
320− -> Expression outer commons grp schemas params from (null ('PGvararray ('NotNull 'PGtext)))
313+ '[ null 'PGjsonb, null ('PGvararray ('NotNull 'PGtext))
321− -> Expression outer commons grp schemas params from (null 'PGjsonb)
314+ , null 'PGjsonb, null 'PGbool ] ---> null 'PGjsonb
322− -> Maybe (Expression outer commons grp schemas params from (null 'PGbool))
323− -> Expression outer commons grp schemas params from (null 'PGjsonb)
324−jsonbSet tgt path val createMissing = case createMissing of
325− Just m -> unsafeFunctionN "jsonb_set" (tgt :* path :* val :* m :* Nil)
315+jsonbSet = unsafeFunctionN "jsonbSet"
326− Nothing -> unsafeFunctionN "jsonb_set" (tgt :* path :* val :* Nil)
327
316
328-- | @ jsonbInsert target path new_value insert_after @
317-- | @ jsonbInsert target path new_value insert_after @
329--
318--
330−-- Returns target with new_value inserted. If target section designated by
319+-- Returns target with @new_value@ inserted. If target section designated by
331−-- path is in a JSONB array, new_value will be inserted before target or after
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`.
332−-- if insert_after is true (default is false). If target section designated by
322+-- If target section designated by
333−-- path is in JSONB object, new_value will be inserted only if target does not
323+-- path is in JSONB object, @new_value@ will be inserted only if target does not
334-- exist. As with the path orientated operators, negative integers that appear
324-- exist. As with the path orientated operators, negative integers that appear
335-- in path count from the end of JSON arrays.
325-- in path count from the end of JSON arrays.
336−jsonbInsert
326+jsonbInsert ::
337− :: Expression outer commons grp schemas params from (null 'PGjsonb)
338− -> Expression outer commons grp schemas params from (null ('PGvararray ('NotNull 'PGtext)))
327+ '[ null 'PGjsonb, null ('PGvararray ('NotNull 'PGtext))
339− -> Expression outer commons grp schemas params from (null 'PGjsonb)
328+ , null 'PGjsonb, null 'PGbool ] ---> null 'PGjsonb
340− -> Maybe (Expression outer commons grp schemas params from (null 'PGbool))
341− -> Expression outer commons grp schemas params from (null 'PGjsonb)
342−jsonbInsert tgt path val insertAfter = case insertAfter of
343− Just i -> unsafeFunctionN "jsonb_insert" (tgt :* path :* val :* i :* Nil)
344− Nothing -> unsafeFunctionN "jsonb_insert" (tgt :* path :* val :* Nil)
329+jsonbInsert = unsafeFunctionN "jsonb_insert"
345
330
346-- | Returns its argument as indented JSON text.
331-- | Returns its argument as indented JSON text.
347−jsonbPretty :: null 'PGjsonb :--> null 'PGtext
332+jsonbPretty :: null 'PGjsonb --> null 'PGtext
348jsonbPretty = unsafeFunction "jsonb_pretty"
333jsonbPretty = unsafeFunction "jsonb_pretty"
334+
335+{- | Expands the outermost JSON object into a set of key/value pairs.
336+
337+>>> printSQL (select Star (from (jsonEach (literal (Json (object ["a" .= "foo", "b" .= "bar"]))))))
338+SELECT * FROM json_each(('{"a":"foo","b":"bar"}' :: json))
339+-}
340+jsonEach :: SetFunction "json_each" (null 'PGjson)
341+ '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGjson]
342+jsonEach = unsafeSetFunction
343+
344+{- | Expands the outermost binary JSON object into a set of key/value pairs.
345+
346+>>> printSQL (select Star (from (jsonbEach (literal (Jsonb (object ["a" .= "foo", "b" .= "bar"]))))))
347+SELECT * FROM jsonb_each(('{"a":"foo","b":"bar"}' :: jsonb))
348+-}
349+jsonbEach
350+ :: SetFunction "jsonb_each" (nullity 'PGjsonb)
351+ '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGjson]
352+jsonbEach = unsafeSetFunction
353+
354+{- | Expands the outermost JSON object into a set of key/value pairs.
355+
356+>>> printSQL (select Star (from (jsonEachText (literal (Json (object ["a" .= "foo", "b" .= "bar"]))))))
357+SELECT * FROM json_each_text(('{"a":"foo","b":"bar"}' :: json))
358+-}
359+jsonEachText
360+ :: SetFunction "json_each_text" (null 'PGjson)
361+ '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext]
362+jsonEachText = unsafeSetFunction
363+
364+{- | Expands the outermost binary JSON object into a set of key/value pairs.
365+
366+>>> printSQL (select Star (from (jsonbEachText (literal (Jsonb (object ["a" .= "foo", "b" .= "bar"]))))))
367+SELECT * FROM jsonb_each_text(('{"a":"foo","b":"bar"}' :: jsonb))
368+-}
369+jsonbEachText
370+ :: SetFunction "jsonb_each_text" (null 'PGjsonb)
371+ '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext]
372+jsonbEachText = unsafeSetFunction
373+
374+{- | Returns set of keys in the outermost JSON object.
375+
376+>>> printSQL (jsonObjectKeys (literal (Json (object ["a" .= "foo", "b" .= "bar"]))))
377+json_object_keys(('{"a":"foo","b":"bar"}' :: json))
378+-}
379+jsonObjectKeys
380+ :: SetFunction "json_object_keys" (nullity 'PGjson)
381+ '["json_object_keys" ::: 'NotNull 'PGtext]
382+jsonObjectKeys = unsafeSetFunction
383+
384+{- | Returns set of keys in the outermost JSON object.
385+
386+>>> printSQL (jsonbObjectKeys (literal (Jsonb (object ["a" .= "foo", "b" .= "bar"]))))
387+jsonb_object_keys(('{"a":"foo","b":"bar"}' :: jsonb))
388+-}
389+jsonbObjectKeys
390+ :: SetFunction "jsonb_object_keys" (null 'PGjsonb)
391+ '["jsonb_object_keys" ::: 'NotNull 'PGtext]
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]
402+
403+unsafePopulateFunction
404+ :: forall fun ty
405+ . KnownSymbol fun => Alias fun -> JsonPopulateFunction fun ty
406+unsafePopulateFunction _fun ty expr = UnsafeFromClause $ renderSymbol @fun
407+ <> parenthesized ("null::" <> renderSQL ty <> ", " <> renderSQL expr)
408+
409+-- | Expands the JSON expression to a row whose columns match the record
410+-- type defined by the given table.
411+jsonPopulateRecord :: JsonPopulateFunction "json_populate_record" 'PGjson
412+jsonPopulateRecord = unsafePopulateFunction #json_populate_record
413+
414+-- | Expands the binary JSON expression to a row whose columns match the record
415+-- type defined by the given table.
416+jsonbPopulateRecord :: JsonPopulateFunction "jsonb_populate_record" 'PGjsonb
417+jsonbPopulateRecord = unsafePopulateFunction #jsonb_populate_record
418+
419+-- | Expands the outermost array of objects in the given JSON expression to a
420+-- set of rows whose columns match the record type defined by the given table.
421+jsonPopulateRecordSet :: JsonPopulateFunction "json_populate_record_set" 'PGjson
422+jsonPopulateRecordSet = unsafePopulateFunction #json_populate_record_set
423+
424+-- | Expands the outermost array of objects in the given binary JSON expression
425+-- to a set of rows whose columns match the record type defined by the given
426+-- table.
427+jsonbPopulateRecordSet :: JsonPopulateFunction "jsonb_populate_record_set" 'PGjsonb
428+jsonbPopulateRecordSet = unsafePopulateFunction #jsonb_populate_record_set
429+
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
441+unsafeRecordFunction fun expr (types `As` tab) = UnsafeFromClause $
442+ fun <> parenthesized (renderSQL expr) <+> "AS" <+> renderSQL tab
443+ <> parenthesized (renderCommaSeparated renderTy types)
444+ where
445+ renderTy :: Aliased (TypeExpression schemas) ty -> ByteString
446+ renderTy (ty `As` alias) = renderSQL alias <+> renderSQL ty
447+
448+-- | Builds an arbitrary record from a JSON object.
449+jsonToRecord :: JsonToRecordFunction 'PGjson
450+jsonToRecord = unsafeRecordFunction "json_to_record"
451+
452+-- | Builds an arbitrary record from a binary JSON object.
453+jsonbToRecord :: JsonToRecordFunction 'PGjsonb
454+jsonbToRecord = unsafeRecordFunction "jsonb_to_record"
455+
456+-- | Builds an arbitrary set of records from a JSON array of objects.
457+jsonToRecordSet :: JsonToRecordFunction 'PGjson
458+jsonToRecordSet = unsafeRecordFunction "json_to_record_set"
459+
460+-- | Builds an arbitrary set of records from a binary JSON array of objects.
461+jsonbToRecordSet :: JsonToRecordFunction 'PGjsonb
462+jsonbToRecordSet = unsafeRecordFunction "jsonb_to_record_set"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Literal.hsnew file+87
@@ -0,0 +1,87 @@
1+{-|
2+Module: Squeal.PostgreSQL.Expression.Literal
3+Description: Literal expressions
4+Copyright: (c) Eitan Chatav, 2019
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Literal expressions
9+-}
10+
11+{-# LANGUAGE
12+ FlexibleContexts
13+ , FlexibleInstances
14+ , LambdaCase
15+ , OverloadedStrings
16+ , RankNTypes
17+ , ScopedTypeVariables
18+ , TypeApplications
19+ , TypeSynonymInstances
20+ , UndecidableInstances
21+#-}
22+
23+module Squeal.PostgreSQL.Expression.Literal (Literal (..)) where
24+
25+import ByteString.StrictBuilder (builderBytes)
26+import Data.ByteString.Lazy (toStrict)
27+import Data.Int
28+import Data.String
29+import Data.Text (Text)
30+
31+import qualified Data.Aeson as JSON
32+import qualified Data.Text as Text
33+import qualified Data.Text.Lazy as Lazy (Text)
34+import qualified Data.Text.Lazy as Lazy.Text
35+
36+import Squeal.PostgreSQL.Binary
37+import Squeal.PostgreSQL.Expression
38+import Squeal.PostgreSQL.Expression.Logic
39+import Squeal.PostgreSQL.PG
40+import Squeal.PostgreSQL.Render
41+
42+{- |
43+The `Literal` class allows embedding a Haskell value directly
44+as an `Expression` using `literal`.
45+
46+>>> printSQL (literal 'a')
47+E'a'
48+
49+>>> printSQL (literal (1 :: Double))
50+1.0
51+
52+>>> printSQL (literal (Json [1 :: Double, 2]))
53+('[1.0,2.0]' :: json)
54+
55+>>> printSQL (literal (Enumerated GT))
56+'GT'
57+-}
58+class Literal hask where literal :: hask -> Expr (null (PG hask))
59+instance Literal Bool where
60+ literal = \case
61+ True -> true
62+ False -> false
63+instance JSON.ToJSON hask => Literal (Json hask) where
64+ literal = UnsafeExpression . parenthesized . (<> " :: json")
65+ . singleQuotedUtf8 . toStrict . JSON.encode . getJson
66+instance JSON.ToJSON hask => Literal (Jsonb hask) where
67+ literal = UnsafeExpression . parenthesized . (<> " :: jsonb")
68+ . singleQuotedUtf8 . toStrict . JSON.encode . getJsonb
69+instance Literal Char where
70+ literal chr = UnsafeExpression $
71+ "E\'" <> fromString (escape chr) <> "\'"
72+instance Literal String where literal = fromString
73+instance Literal Int16 where literal = fromIntegral
74+instance Literal Int32 where literal = fromIntegral
75+instance Literal Int64 where literal = fromIntegral
76+instance Literal Float where literal = fromRational . toRational
77+instance Literal Double where literal = fromRational . toRational
78+instance Literal Text where literal = fromString . Text.unpack
79+instance Literal Lazy.Text where literal = fromString . Lazy.Text.unpack
80+instance ToParam (Enumerated enum) (PG (Enumerated enum))
81+ => Literal (Enumerated enum) where
82+ literal
83+ = UnsafeExpression
84+ . singleQuotedUtf8
85+ . builderBytes
86+ . unK
87+ . toParam @(Enumerated enum) @(PG (Enumerated enum))
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Logic.hs+13−3
@@ -1,3 +1,13 @@
1+{-|
2+Module: Squeal.PostgreSQL.Expression.Logic
3+Description: Logical expressions
4+Copyright: (c) Eitan Chatav, 2019
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Logical expressions and operators
9+-}
10+
1{-# LANGUAGE
11{-# LANGUAGE
2 DataKinds
12 DataKinds
3 , OverloadedStrings
13 , OverloadedStrings
@@ -20,7 +30,7 @@ import Squeal.PostgreSQL.Render
20import Squeal.PostgreSQL.Schema
30import Squeal.PostgreSQL.Schema
21
31
22-- | A `Condition` is an `Expression`, which can evaluate
32-- | A `Condition` is an `Expression`, which can evaluate
23−-- to `true`, `false` or `null_`. This is because SQL uses
33+-- to `true`, `false` or `Squeal.PostgreSQL.Null.null_`. This is because SQL uses
24-- a three valued logic.
34-- a three valued logic.
25type Condition outer commons grp schemas params from =
35type Condition outer commons grp schemas params from =
26 Expression outer commons grp schemas params from ('Null 'PGbool)
36 Expression outer commons grp schemas params from ('Null 'PGbool)
@@ -37,8 +47,8 @@ false = UnsafeExpression "FALSE"
37
47
38-- | >>> printSQL $ not_ true
48-- | >>> printSQL $ not_ true
39-- (NOT TRUE)
49-- (NOT TRUE)
40−not_ :: null 'PGbool :--> null 'PGbool
50+not_ :: null 'PGbool --> null 'PGbool
41−not_ = unsafeUnaryOpL "NOT"
51+not_ = unsafeLeftOp "NOT"
42
52
43-- | >>> printSQL $ true .&& false
53-- | >>> printSQL $ true .&& false
44-- (TRUE AND FALSE)
54-- (TRUE AND FALSE)
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Math.hs+14−7
@@ -1,3 +1,13 @@
1+{-|
2+Module: Squeal.PostgreSQL.Expression.Math
3+Description: Math expressions
4+Copyright: (c) Eitan Chatav, 2019
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Mathematical functions and operators
9+-}
10+
1{-# LANGUAGE
11{-# LANGUAGE
2 DataKinds
12 DataKinds
3 , OverloadedStrings
13 , OverloadedStrings
@@ -19,7 +29,6 @@ import Squeal.PostgreSQL.Schema
19
29
20-- $setup
30-- $setup
21-- >>> import Squeal.PostgreSQL
31-- >>> import Squeal.PostgreSQL
22−-- >>> import Squeal.PostgreSQL.Render
23
32
24-- | >>> :{
33-- | >>> :{
25-- let
34-- let
@@ -28,9 +37,7 @@ import Squeal.PostgreSQL.Schema
28-- in printSQL expression
37-- in printSQL expression
29-- :}
38-- :}
30-- atan2(pi(), 2)
39-- atan2(pi(), 2)
31−atan2_
32− :: float `In` PGFloating
33− => FunctionN '[ null float, null float] (null float)
40+atan2_ :: float `In` PGFloating => '[ null float, null float] ---> null float
34atan2_ = unsafeFunctionN "atan2"
41atan2_ = unsafeFunctionN "atan2"
35
42
36
43
@@ -69,7 +76,7 @@ rem_ = unsafeBinaryOp "%"
69-- in printSQL expression
76-- in printSQL expression
70-- :}
77-- :}
71-- trunc(pi())
78-- trunc(pi())
72−trunc :: frac `In` PGFloating => null frac :--> null frac
79+trunc :: frac `In` PGFloating => null frac --> null frac
73trunc = unsafeFunction "trunc"
80trunc = unsafeFunction "trunc"
74
81
75-- | >>> :{
82-- | >>> :{
@@ -79,7 +86,7 @@ trunc = unsafeFunction "trunc"
79-- in printSQL expression
86-- in printSQL expression
80-- :}
87-- :}
81-- round(pi())
88-- round(pi())
82−round_ :: frac `In` PGFloating => null frac :--> null frac
89+round_ :: frac `In` PGFloating => null frac --> null frac
83round_ = unsafeFunction "round"
90round_ = unsafeFunction "round"
84
91
85-- | >>> :{
92-- | >>> :{
@@ -89,5 +96,5 @@ round_ = unsafeFunction "round"
89-- in printSQL expression
96-- in printSQL expression
90-- :}
97-- :}
91-- ceiling(pi())
98-- ceiling(pi())
92−ceiling_ :: frac `In` PGFloating => null frac :--> null frac
99+ceiling_ :: frac `In` PGFloating => null frac --> null frac
93ceiling_ = unsafeFunction "ceiling"
100ceiling_ = unsafeFunction "ceiling"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Null.hs+14−4
@@ -1,3 +1,13 @@
1+{-|
2+Module: Squeal.PostgreSQL.Expression.Null
3+Description: Null
4+Copyright: (c) Eitan Chatav, 2019
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Null values and null handling functions
9+-}
10+
1{-# LANGUAGE
11{-# LANGUAGE
2 DataKinds
12 DataKinds
3 , OverloadedStrings
13 , OverloadedStrings
@@ -34,7 +44,7 @@ null_ = UnsafeExpression "NULL"
34--
44--
35-- >>> printSQL $ notNull true
45-- >>> printSQL $ notNull true
36-- TRUE
46-- TRUE
37−notNull :: 'NotNull ty :--> 'Null ty
47+notNull :: 'NotNull ty --> 'Null ty
38notNull = UnsafeExpression . renderSQL
48notNull = UnsafeExpression . renderSQL
39
49
40-- | return the leftmost value which is not NULL
50-- | return the leftmost value which is not NULL
@@ -59,12 +69,12 @@ fromNull notNullx nullx = coalesce [nullx] notNullx
59
69
60-- | >>> printSQL $ null_ & isNull
70-- | >>> printSQL $ null_ & isNull
61-- NULL IS NULL
71-- NULL IS NULL
62−isNull :: 'Null ty :--> null 'PGbool
72+isNull :: 'Null ty --> null 'PGbool
63isNull x = UnsafeExpression $ renderSQL x <+> "IS NULL"
73isNull x = UnsafeExpression $ renderSQL x <+> "IS NULL"
64
74
65-- | >>> printSQL $ null_ & isNotNull
75-- | >>> printSQL $ null_ & isNotNull
66-- NULL IS NOT NULL
76-- NULL IS NOT NULL
67−isNotNull :: 'Null ty :--> null 'PGbool
77+isNotNull :: 'Null ty --> null 'PGbool
68isNotNull x = UnsafeExpression $ renderSQL x <+> "IS NOT NULL"
78isNotNull x = UnsafeExpression $ renderSQL x <+> "IS NOT NULL"
69
79
70-- | analagous to `maybe` using @IS NULL@
80-- | analagous to `maybe` using @IS NULL@
@@ -90,5 +100,5 @@ matchNull y f x = ifThenElse (isNull x) y
90>>> printSQL expr
100>>> printSQL expr
91NULLIF(FALSE, ($1 :: bool))
101NULLIF(FALSE, ($1 :: bool))
92-}
102-}
93−nullIf :: FunctionN '[ 'NotNull ty, 'NotNull ty] ('Null ty)
103+nullIf :: '[ 'NotNull ty, 'NotNull ty] ---> 'Null ty
94nullIf = unsafeFunctionN "NULLIF"
104nullIf = unsafeFunctionN "NULLIF"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Parameter.hsnew file+80
@@ -0,0 +1,80 @@
1+{-|
2+Module: Squeal.PostgreSQL.Expression.Parameter
3+Description: Parameters
4+Copyright: (c) Eitan Chatav, 2019
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Parameters, out-of-line data values
9+-}
10+
11+{-# LANGUAGE
12+ AllowAmbiguousTypes
13+ , DataKinds
14+ , FlexibleContexts
15+ , FlexibleInstances
16+ , FunctionalDependencies
17+ , KindSignatures
18+ , MultiParamTypeClasses
19+ , OverloadedStrings
20+ , RankNTypes
21+ , ScopedTypeVariables
22+ , TypeApplications
23+ , TypeOperators
24+ , UndecidableInstances
25+#-}
26+
27+module Squeal.PostgreSQL.Expression.Parameter
28+ ( HasParameter (parameter)
29+ , param
30+ ) where
31+
32+import GHC.TypeLits
33+
34+import Squeal.PostgreSQL.Expression
35+import Squeal.PostgreSQL.Expression.Type
36+import Squeal.PostgreSQL.Render
37+import Squeal.PostgreSQL.Schema
38+
39+-- $setup
40+-- >>> import Squeal.PostgreSQL
41+
42+{- | A `HasParameter` constraint is used to indicate a value that is
43+supplied externally to a SQL statement.
44+`Squeal.PostgreSQL.PQ.manipulateParams`,
45+`Squeal.PostgreSQL.PQ.queryParams` and
46+`Squeal.PostgreSQL.PQ.traversePrepared` support specifying data values
47+separately from the SQL command string, in which case `param`s are used to
48+refer to the out-of-line data values.
49+-}
50+class KnownNat n => HasParameter
51+ (n :: Nat)
52+ (params :: [NullityType])
53+ (ty :: NullityType)
54+ | n params -> ty where
55+ -- | `parameter` takes a `Nat` using type application and a `TypeExpression`.
56+ --
57+ -- >>> let expr = parameter @1 int4 :: Expression outer '[] grp schemas '[ 'Null 'PGint4] from ('Null 'PGint4)
58+ -- >>> printSQL expr
59+ -- ($1 :: int4)
60+ parameter
61+ :: TypeExpression schemas ty
62+ -> Expression outer commons grp schemas params from ty
63+ parameter ty = UnsafeExpression $ parenthesized $
64+ "$" <> renderNat @n <+> "::"
65+ <+> renderSQL ty
66+instance {-# OVERLAPPING #-} HasParameter 1 (ty1:tys) ty1
67+instance {-# OVERLAPPABLE #-} (KnownNat n, HasParameter (n-1) params ty)
68+ => HasParameter n (ty' : params) ty
69+
70+-- | `param` takes a `Nat` using type application and for basic types,
71+-- infers a `TypeExpression`.
72+--
73+-- >>> let expr = param @1 :: Expression outer commons grp schemas '[ 'Null 'PGint4] from ('Null 'PGint4)
74+-- >>> printSQL expr
75+-- ($1 :: int4)
76+param
77+ :: forall n outer commons schemas params from grp ty
78+ . (PGTyped schemas ty, HasParameter n params ty)
79+ => Expression outer commons grp schemas params from ty -- ^ param
80+param = parameter @n (pgtype @schemas)
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/Set.hsnew file+139
@@ -0,0 +1,139 @@
1+{-|
2+Module: Squeal.PostgreSQL.Expression.Set
3+Description: Set returning functions
4+Copyright: (c) Eitan Chatav, 2019
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Set returning functions
9+-}
10+
11+{-# LANGUAGE
12+ AllowAmbiguousTypes
13+ , DataKinds
14+ , FlexibleContexts
15+ , OverloadedStrings
16+ , PolyKinds
17+ , RankNTypes
18+ , ScopedTypeVariables
19+ , TypeApplications
20+ , TypeOperators
21+#-}
22+
23+module Squeal.PostgreSQL.Expression.Set
24+ ( generateSeries
25+ , generateSeriesStep
26+ , generateSeriesTimestamp
27+ , SetFunction
28+ , unsafeSetFunction
29+ , SetFunctionDB
30+ , setFunction
31+ , SetFunctionN
32+ , unsafeSetFunctionN
33+ , SetFunctionNDB
34+ , setFunctionN
35+ ) where
36+
37+import GHC.TypeLits
38+
39+import qualified Generics.SOP as SOP
40+
41+import Squeal.PostgreSQL.Alias
42+import Squeal.PostgreSQL.Expression
43+import Squeal.PostgreSQL.List
44+import Squeal.PostgreSQL.Render
45+import Squeal.PostgreSQL.Query
46+import Squeal.PostgreSQL.Schema
47+
48+{- |
49+A @RankNType@ for set returning functions with 1 argument.
50+-}
51+type SetFunction fun ty row
52+ = forall outer commons schemas params
53+ . Expression outer commons 'Ungrouped schemas params '[] ty
54+ -- ^ input
55+ -> FromClause outer commons schemas params '[fun ::: row]
56+ -- ^ output
57+
58+type SetFunctionDB fun schemas ty row
59+ = forall outer commons params
60+ . Expression outer commons 'Ungrouped schemas params '[] ty
61+ -- ^ input
62+ -> FromClause outer commons schemas params '[fun ::: row]
63+ -- ^ output
64+
65+-- | Escape hatch for a set returning function with 1 argument.
66+unsafeSetFunction
67+ :: forall fun ty row. KnownSymbol fun
68+ => SetFunction fun ty row -- ^ set returning function
69+unsafeSetFunction x = UnsafeFromClause $
70+ renderSymbol @fun <> parenthesized (renderSQL x)
71+
72+setFunction
73+ :: ( Has sch schemas schema
74+ , Has fun schema ('Function ('[ty] :=> 'ReturnsTable row)) )
75+ => QualifiedAlias sch fun
76+ -> SetFunctionDB fun schemas ty row
77+setFunction _ = unsafeSetFunction
78+
79+{- |
80+A @RankNType@ for set returning functions with multiple argument.
81+-}
82+type SetFunctionN fun tys row
83+ = forall outer commons schemas params
84+ . NP (Expression outer commons 'Ungrouped schemas params '[]) tys
85+ -- ^ inputs
86+ -> FromClause outer commons schemas params '[fun ::: row]
87+ -- ^ output
88+
89+-- | Escape hatch for a set returning function with multiple argument.
90+unsafeSetFunctionN
91+ :: forall fun tys row. (SOP.SListI tys, KnownSymbol fun)
92+ => SetFunctionN fun tys row -- ^ set returning function
93+unsafeSetFunctionN xs = UnsafeFromClause $
94+ renderSymbol @fun <> parenthesized (renderCommaSeparated renderSQL xs)
95+
96+type SetFunctionNDB fun schemas tys row
97+ = forall outer commons params
98+ . NP (Expression outer commons 'Ungrouped schemas params '[]) tys
99+ -- ^ inputs
100+ -> FromClause outer commons schemas params '[fun ::: row]
101+ -- ^ output
102+
103+setFunctionN
104+ :: ( Has sch schemas schema
105+ , Has fun schema ('Function (tys :=> 'ReturnsTable row))
106+ , SOP.SListI tys )
107+ => QualifiedAlias sch fun
108+ -> SetFunctionNDB fun schemas tys row
109+setFunctionN _ = unsafeSetFunctionN
110+
111+{- | @generateSeries (start *: stop)@
112+
113+Generate a series of values, from @start@ to @stop@ with a step size of one
114+-}
115+generateSeries
116+ :: ty `In` '[ 'PGint4, 'PGint8, 'PGnumeric]
117+ => SetFunctionN "generate_series" '[ null ty, null ty]
118+ '["generate_series" ::: null ty] -- ^ set returning function
119+generateSeries = unsafeSetFunctionN
120+
121+{- | @generateSeries (start :* stop *: step)@
122+
123+Generate a series of values, from @start@ to @stop@ with a step size of @step@
124+-}
125+generateSeriesStep
126+ :: ty `In` '[ 'PGint4, 'PGint8, 'PGnumeric]
127+ => SetFunctionN "generate_series" '[null ty, null ty, null ty]
128+ '["generate_series" ::: null ty] -- ^ set returning function
129+generateSeriesStep = unsafeSetFunctionN
130+
131+{- | @generateSeries (start :* stop *: step)@
132+
133+Generate a series of values, from @start@ to @stop@ with a step size of @step@
134+-}
135+generateSeriesTimestamp
136+ :: ty `In` '[ 'PGtimestamp, 'PGtimestamptz]
137+ => SetFunctionN "generate_series" '[null ty, null ty, null 'PGinterval]
138+ '["generate_series" ::: null ty] -- ^ set returning function
139+generateSeriesTimestamp = unsafeSetFunctionN
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Sort.hs+24−14
@@ -1,3 +1,13 @@
1+{-|
2+Module: Squeal.PostgreSQL.Expression.Sort
3+Description: Sort expressions
4+Copyright: (c) Eitan Chatav, 2019
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Sort expressions
9+-}
10+
1{-# LANGUAGE
11{-# LANGUAGE
2 DataKinds
12 DataKinds
3 , GADTs
13 , GADTs
@@ -19,8 +29,10 @@ import Squeal.PostgreSQL.Schema
19-- of a `Squeal.PostgreSQL.Query.Query`. `Asc` or `Desc`
29-- of a `Squeal.PostgreSQL.Query.Query`. `Asc` or `Desc`
20-- set the sort direction of a `NotNull` result
30-- set the sort direction of a `NotNull` result
21-- column to ascending or descending. Ascending order puts smaller values
31-- column to ascending or descending. Ascending order puts smaller values
22−-- first, where "smaller" is defined in terms of the `.<` operator. Similarly,
32+-- first, where "smaller" is defined in terms of the
33+-- `Squeal.PostgreSQL.Expression.Comparison..<` operator. Similarly,
23−-- descending order is determined with the `.>` operator. `AscNullsFirst`,
34+-- descending order is determined with the
35+-- `Squeal.PostgreSQL.Expression.Comparison..>` operator. `AscNullsFirst`,
24-- `AscNullsLast`, `DescNullsFirst` and `DescNullsLast` options are used to
36-- `AscNullsLast`, `DescNullsFirst` and `DescNullsLast` options are used to
25-- determine whether nulls appear before or after non-null values in the sort
37-- determine whether nulls appear before or after non-null values in the sort
26-- ordering of a `Null` result column.
38-- ordering of a `Null` result column.
@@ -44,6 +56,16 @@ data SortExpression outer commons grp schemas params from where
44 :: Expression outer commons grp schemas params from ('Null ty)
56 :: Expression outer commons grp schemas params from ('Null ty)
45 -> SortExpression outer commons grp schemas params from
57 -> SortExpression outer commons grp schemas params from
46deriving instance Show (SortExpression outer commons grp schemas params from)
58deriving instance Show (SortExpression outer commons grp schemas params from)
59+instance RenderSQL (SortExpression outer commons grp schemas params from) where
60+ renderSQL = \case
61+ Asc expression -> renderSQL expression <+> "ASC"
62+ Desc expression -> renderSQL expression <+> "DESC"
63+ AscNullsFirst expression -> renderSQL expression
64+ <+> "ASC NULLS FIRST"
65+ DescNullsFirst expression -> renderSQL expression
66+ <+> "DESC NULLS FIRST"
67+ AscNullsLast expression -> renderSQL expression <+> "ASC NULLS LAST"
68+ DescNullsLast expression -> renderSQL expression <+> "DESC NULLS LAST"
47
69
48{- |
70{- |
49The `orderBy` clause causes the result rows of a `Squeal.PostgreSQL.Query.TableExpression`
71The `orderBy` clause causes the result rows of a `Squeal.PostgreSQL.Query.TableExpression`
@@ -61,15 +83,3 @@ class OrderBy expr where
61 :: [SortExpression outer commons grp schemas params from]
83 :: [SortExpression outer commons grp schemas params from]
62 -> expr outer commons grp schemas params from
84 -> expr outer commons grp schemas params from
63 -> expr outer commons grp schemas params from
85 -> expr outer commons grp schemas params from
64−
65−-- | Render a `SortExpression`.
66−instance RenderSQL (SortExpression outer commons grp schemas params from) where
67− renderSQL = \case
68− Asc expression -> renderSQL expression <+> "ASC"
69− Desc expression -> renderSQL expression <+> "DESC"
70− AscNullsFirst expression -> renderSQL expression
71− <+> "ASC NULLS FIRST"
72− DescNullsFirst expression -> renderSQL expression
73− <+> "DESC NULLS FIRST"
74− AscNullsLast expression -> renderSQL expression <+> "ASC NULLS LAST"
75− DescNullsLast expression -> renderSQL expression <+> "DESC NULLS LAST"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Subquery.hsnew file+120
@@ -0,0 +1,120 @@
1+{-|
2+Module: Squeal.PostgreSQL.Expression.Subquery
3+Description: Subquery expressions
4+Copyright: (c) Eitan Chatav, 2019
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Subquery expressions
9+-}
10+
11+{-# LANGUAGE
12+ DataKinds
13+ , OverloadedStrings
14+ , RankNTypes
15+ , TypeOperators
16+#-}
17+
18+module Squeal.PostgreSQL.Expression.Subquery
19+ ( exists
20+ , in_
21+ , notIn
22+ , subAll
23+ , subAny
24+ ) where
25+
26+import Squeal.PostgreSQL.Alias
27+import Squeal.PostgreSQL.Expression
28+import Squeal.PostgreSQL.Expression.Logic
29+import Squeal.PostgreSQL.List
30+import Squeal.PostgreSQL.Query
31+import Squeal.PostgreSQL.Render
32+import Squeal.PostgreSQL.Schema
33+
34+-- $setup
35+-- >>> import Squeal.PostgreSQL
36+
37+{- |
38+The argument of `exists` is an arbitrary subquery. The subquery is evaluated
39+to determine whether it returns any rows. If it returns at least one row,
40+the result of `exists` is `true`; if the subquery returns no rows,
41+the result of `exists` is `false`.
42+
43+The subquery can refer to variables from the surrounding query,
44+which will act as constants during any one evaluation of the subquery.
45+
46+The subquery will generally only be executed long enough to determine whether
47+at least one row is returned, not all the way to completion.
48+-}
49+exists
50+ :: Query (Join outer from) commons schemas params row
51+ -> Condition outer commons grp schemas params from
52+exists query = UnsafeExpression $ "EXISTS" <+> parenthesized (renderSQL query)
53+
54+{- |
55+The right-hand side is a parenthesized subquery, which must return
56+exactly one column. The left-hand expression is evaluated and compared to each
57+row of the subquery result using the given `Operator`,
58+which must yield a Boolean result. The result of `subAll` is `true`
59+if all rows yield true (including the case where the subquery returns no rows).
60+The result is `false` if any `false` result is found.
61+The result is `Squeal.PostgreSQL.Expression.Null.null_` if
62+ no comparison with a subquery row returns `false`,
63+and at least one comparison returns `Squeal.PostgreSQL.Expression.Null.null_`.
64+
65+>>> printSQL $ subAll true (.==) (values_ (true `as` #foo))
66+(TRUE = ALL (SELECT * FROM (VALUES (TRUE)) AS t ("foo")))
67+-}
68+subAll
69+ :: Expression outer commons grp schemas params from ty1 -- ^ expression
70+ -> Operator ty1 ty2 ('Null 'PGbool) -- ^ operator
71+ -> Query (Join outer from) commons schemas params '[col ::: ty2] -- ^ subquery
72+ -> Condition outer commons grp schemas params from
73+subAll expr (?) qry = expr ?
74+ (UnsafeExpression $ "ALL" <+> parenthesized (renderSQL qry))
75+
76+{- |
77+The right-hand side is a parenthesized subquery, which must return exactly one column.
78+The left-hand expression is evaluated and compared to each row of the subquery result
79+using the given `Operator`, which must yield a Boolean result. The result of `subAny` is `true`
80+if any `true` result is obtained. The result is `false` if no true result is found
81+(including the case where the subquery returns no rows).
82+
83+>>> printSQL $ subAny "foo" like (values_ ("foobar" `as` #foo))
84+(E'foo' LIKE ANY (SELECT * FROM (VALUES (E'foobar')) AS t ("foo")))
85+-}
86+subAny
87+ :: Expression outer commons grp schemas params from ty1 -- ^ expression
88+ -> Operator ty1 ty2 ('Null 'PGbool) -- ^ operator
89+ -> Query (Join outer from) commons schemas params '[col ::: ty2] -- ^ subquery
90+ -> Condition outer commons grp schemas params from
91+subAny expr (?) qry = expr ?
92+ (UnsafeExpression $ "ANY" <+> parenthesized (renderSQL qry))
93+
94+{- |
95+The result is `true` if the left-hand expression's result is equal
96+to any of the right-hand expressions.
97+
98+>>> printSQL $ true `in_` [true, false, null_]
99+TRUE IN (TRUE, FALSE, NULL)
100+-}
101+in_
102+ :: Expression outer commons grp schemas params from ty -- ^ expression
103+ -> [Expression outer commons grp schemas params from ty]
104+ -> Condition outer commons grp schemas params from
105+expr `in_` exprs = UnsafeExpression $ renderSQL expr <+> "IN"
106+ <+> parenthesized (commaSeparated (renderSQL <$> exprs))
107+
108+{- |
109+The result is `true` if the left-hand expression's result is not equal
110+to any of the right-hand expressions.
111+
112+>>> printSQL $ true `notIn` [false, null_]
113+TRUE NOT IN (FALSE, NULL)
114+-}
115+notIn
116+ :: Expression outer commons grp schemas params from ty -- ^ expression
117+ -> [Expression outer commons grp schemas params from ty]
118+ -> Condition outer commons grp schemas params from
119+expr `notIn` exprs = UnsafeExpression $ renderSQL expr <+> "NOT IN"
120+ <+> parenthesized (commaSeparated (renderSQL <$> exprs))
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Text.hs+13−4
@@ -1,3 +1,13 @@
1+{-|
2+Module: Squeal.PostgreSQL.Expression.Text
3+Description: Text expressions
4+Copyright: (c) Eitan Chatav, 2019
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+String functions and operators
9+-}
10+
1{-# LANGUAGE
11{-# LANGUAGE
2 DataKinds
12 DataKinds
3 , OverloadedStrings
13 , OverloadedStrings
@@ -17,21 +27,20 @@ import Squeal.PostgreSQL.Schema
17
27
18-- $setup
28-- $setup
19-- >>> import Squeal.PostgreSQL
29-- >>> import Squeal.PostgreSQL
20−-- >>> import Squeal.PostgreSQL.Render
21
30
22-- | >>> printSQL $ lower "ARRRGGG"
31-- | >>> printSQL $ lower "ARRRGGG"
23-- lower(E'ARRRGGG')
32-- lower(E'ARRRGGG')
24−lower :: null 'PGtext :--> null 'PGtext
33+lower :: null 'PGtext --> null 'PGtext
25lower = unsafeFunction "lower"
34lower = unsafeFunction "lower"
26
35
27-- | >>> printSQL $ upper "eeee"
36-- | >>> printSQL $ upper "eeee"
28-- upper(E'eeee')
37-- upper(E'eeee')
29−upper :: null 'PGtext :--> null 'PGtext
38+upper :: null 'PGtext --> null 'PGtext
30upper = unsafeFunction "upper"
39upper = unsafeFunction "upper"
31
40
32-- | >>> printSQL $ charLength "four"
41-- | >>> printSQL $ charLength "four"
33-- char_length(E'four')
42-- char_length(E'four')
34−charLength :: null 'PGtext :--> null 'PGint4
43+charLength :: null 'PGtext --> null 'PGint4
35charLength = unsafeFunction "char_length"
44charLength = unsafeFunction "char_length"
36
45
37-- | The `like` expression returns true if the @string@ matches
46-- | The `like` expression returns true if the @string@ matches
squeal-postgresql/src/Squeal/PostgreSQL/Expression/TextSearch.hs+71−21
@@ -1,3 +1,13 @@
1+{-|
2+Module: Squeal.PostgreSQL.Expression.TextSearch
3+Description: Text search expressions
4+Copyright: (c) Eitan Chatav, 2019
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Text search functions and operators
9+-}
10+
1{-# LANGUAGE
11{-# LANGUAGE
2 DataKinds
12 DataKinds
3 , OverloadedStrings
13 , OverloadedStrings
@@ -32,76 +42,116 @@ import Squeal.PostgreSQL.Expression
32import Squeal.PostgreSQL.List
42import Squeal.PostgreSQL.List
33import Squeal.PostgreSQL.Schema
43import Squeal.PostgreSQL.Schema
34
44
45+-- | `Squeal.PostgreSQL.Expression.Type.tsvector` matches tsquery ?
35(@@) :: Operator (null 'PGtsvector) (null 'PGtsquery) ('Null 'PGbool)
46(@@) :: Operator (null 'PGtsvector) (null 'PGtsquery) ('Null 'PGbool)
36(@@) = unsafeBinaryOp "@@"
47(@@) = unsafeBinaryOp "@@"
37
48
49+-- | AND `Squeal.PostgreSQL.Expression.Type.tsquery`s together
38(.&) :: Operator (null 'PGtsquery) (null 'PGtsquery) (null 'PGtsquery)
50(.&) :: Operator (null 'PGtsquery) (null 'PGtsquery) (null 'PGtsquery)
39(.&) = unsafeBinaryOp "&&"
51(.&) = unsafeBinaryOp "&&"
40
52
53+-- | OR `Squeal.PostgreSQL.Expression.Type.tsquery`s together
41(.|) :: Operator (null 'PGtsquery) (null 'PGtsquery) (null 'PGtsquery)
54(.|) :: Operator (null 'PGtsquery) (null 'PGtsquery) (null 'PGtsquery)
42(.|) = unsafeBinaryOp "||"
55(.|) = unsafeBinaryOp "||"
43
56
57+-- | negate a `Squeal.PostgreSQL.Expression.Type.tsquery`
44−(.!) :: null 'PGtsquery :--> null 'PGtsquery
58+(.!) :: null 'PGtsquery --> null 'PGtsquery
45−(.!) = unsafeUnaryOpL "!!"
59+(.!) = unsafeLeftOp "!!"
46
60
61+-- | `Squeal.PostgreSQL.Expression.Type.tsquery` followed by
62+-- `Squeal.PostgreSQL.Expression.Type.tsquery`
47(<->) :: Operator (null 'PGtsquery) (null 'PGtsquery) (null 'PGtsquery)
63(<->) :: Operator (null 'PGtsquery) (null 'PGtsquery) (null 'PGtsquery)
48(<->) = unsafeBinaryOp "<->"
64(<->) = unsafeBinaryOp "<->"
49
65
66+-- | convert array of lexemes to `Squeal.PostgreSQL.Expression.Type.tsvector`
50arrayToTSvector
67arrayToTSvector
51 :: null ('PGvararray ('NotNull 'PGtext))
68 :: null ('PGvararray ('NotNull 'PGtext))
52− :--> null 'PGtsvector
69+ --> null 'PGtsvector
53arrayToTSvector = unsafeFunction "array_to_tsvector"
70arrayToTSvector = unsafeFunction "array_to_tsvector"
54
71
72+-- | number of lexemes in `Squeal.PostgreSQL.Expression.Type.tsvector`
55−tsvectorLength :: null 'PGtsvector :--> null 'PGint4
73+tsvectorLength :: null 'PGtsvector --> null 'PGint4
56tsvectorLength = unsafeFunction "length"
74tsvectorLength = unsafeFunction "length"
57
75
76+-- | number of lexemes plus operators in `Squeal.PostgreSQL.Expression.Type.tsquery`
58−numnode :: null 'PGtsquery :--> null 'PGint4
77+numnode :: null 'PGtsquery --> null 'PGint4
59numnode = unsafeFunction "numnode"
78numnode = unsafeFunction "numnode"
60
79
80+-- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` ignoring punctuation
61−plainToTSquery :: null 'PGtext :--> null 'PGtsquery
81+plainToTSquery :: null 'PGtext --> null 'PGtsquery
62plainToTSquery = unsafeFunction "plainto_tsquery"
82plainToTSquery = unsafeFunction "plainto_tsquery"
63
83
84+-- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` that searches for a phrase,
85+-- ignoring punctuation
64−phraseToTSquery :: null 'PGtext :--> null 'PGtsquery
86+phraseToTSquery :: null 'PGtext --> null 'PGtsquery
65phraseToTSquery = unsafeFunction "phraseto_tsquery"
87phraseToTSquery = unsafeFunction "phraseto_tsquery"
66
88
89+-- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` from a web search style query
67−websearchToTSquery :: null 'PGtext :--> null 'PGtsquery
90+websearchToTSquery :: null 'PGtext --> null 'PGtsquery
68websearchToTSquery = unsafeFunction "websearch_to_tsquery"
91websearchToTSquery = unsafeFunction "websearch_to_tsquery"
69
92
93+-- | get indexable part of a `Squeal.PostgreSQL.Expression.Type.tsquery`
70−queryTree :: null 'PGtsquery :--> null 'PGtext
94+queryTree :: null 'PGtsquery --> null 'PGtext
71queryTree = unsafeFunction "query_tree"
95queryTree = unsafeFunction "query_tree"
72
96
97+-- | normalize words and convert to `Squeal.PostgreSQL.Expression.Type.tsquery`
73−toTSquery :: null 'PGtext :--> null 'PGtsquery
98+toTSquery :: null 'PGtext --> null 'PGtsquery
74toTSquery = unsafeFunction "to_tsquery"
99toTSquery = unsafeFunction "to_tsquery"
75
100
101+-- | reduce document text to `Squeal.PostgreSQL.Expression.Type.tsvector`
76toTSvector
102toTSvector
77 :: ty `In` '[ 'PGtext, 'PGjson, 'PGjsonb]
103 :: ty `In` '[ 'PGtext, 'PGjson, 'PGjsonb]
78− => null ty :--> null 'PGtsvector
104+ => null ty --> null 'PGtsvector
79toTSvector = unsafeFunction "to_tsvector"
105toTSvector = unsafeFunction "to_tsvector"
80
106
81−setWeight
107+-- | assign weight to each element of `Squeal.PostgreSQL.Expression.Type.tsvector`
82− :: FunctionN '[null 'PGtsvector, null ('PGchar 1)] (null 'PGtsvector)
108+setWeight :: '[null 'PGtsvector, null ('PGchar 1)] ---> null 'PGtsvector
83setWeight = unsafeFunctionN "set_weight"
109setWeight = unsafeFunctionN "set_weight"
84
110
111+-- | remove positions and weights from `Squeal.PostgreSQL.Expression.Type.tsvector`
85−strip :: null 'PGtsvector :--> null 'PGtsvector
112+strip :: null 'PGtsvector --> null 'PGtsvector
86strip = unsafeFunction "strip"
113strip = unsafeFunction "strip"
87
114
115+-- | @jsonToTSvector (document *: filter)@
116+-- reduce each value in the document, specified by filter to a `Squeal.PostgreSQL.Expression.Type.tsvector`,
117+-- and then concatenate those in document order to produce a single `Squeal.PostgreSQL.Expression.Type.tsvector`.
118+-- filter is a `Squeal.PostgreSQL.Expression.Type.json` array, that enumerates what kind of elements
119+-- need to be included into the resulting `Squeal.PostgreSQL.Expression.Type.tsvector`.
120+-- Possible values for filter are "string" (to include all string values),
121+-- "numeric" (to include all numeric values in the string format),
122+-- "boolean" (to include all Boolean values in the string format "true"/"false"),
123+-- "key" (to include all keys) or "all" (to include all above).
124+-- These values can be combined together to include, e.g. all string and numeric values.
88−jsonToTSvector :: FunctionN '[null 'PGjson, null 'PGjson] (null 'PGtsvector)
125+jsonToTSvector :: '[null 'PGjson, null 'PGjson] ---> null 'PGtsvector
89jsonToTSvector = unsafeFunctionN "json_to_tsvector"
126jsonToTSvector = unsafeFunctionN "json_to_tsvector"
90
127
128+-- | @jsonbToTSvector (document *: filter)@
129+-- reduce each value in the document, specified by filter to a `Squeal.PostgreSQL.Expression.Type.tsvector`,
130+-- and then concatenate those in document order to produce a single `Squeal.PostgreSQL.Expression.Type.tsvector`.
131+-- filter is a `Squeal.PostgreSQL.Expression.Type.jsonb` array, that enumerates what kind of elements
132+-- need to be included into the resulting `Squeal.PostgreSQL.Expression.Type.tsvector`.
133+-- Possible values for filter are "string" (to include all string values),
134+-- "numeric" (to include all numeric values in the string format),
135+-- "boolean" (to include all Boolean values in the string format "true"/"false"),
136+-- "key" (to include all keys) or "all" (to include all above).
137+-- These values can be combined together to include, e.g. all string and numeric values.
91−jsonbToTSvector :: FunctionN '[null 'PGjsonb, null 'PGjsonb] (null 'PGtsvector)
138+jsonbToTSvector :: '[null 'PGjsonb, null 'PGjsonb] ---> null 'PGtsvector
92jsonbToTSvector = unsafeFunctionN "jsonb_to_tsvector"
139jsonbToTSvector = unsafeFunctionN "jsonb_to_tsvector"
93
140
141+-- | remove given lexeme from `Squeal.PostgreSQL.Expression.Type.tsvector`
94−tsDelete :: FunctionN
142+tsDelete ::
95 '[null 'PGtsvector, null ('PGvararray ('NotNull 'PGtext))]
143 '[null 'PGtsvector, null ('PGvararray ('NotNull 'PGtext))]
96− (null 'PGtsvector)
144+ ---> null 'PGtsvector
97tsDelete = unsafeFunctionN "ts_delete"
145tsDelete = unsafeFunctionN "ts_delete"
98
146
147+-- | select only elements with given weights from `Squeal.PostgreSQL.Expression.Type.tsvector`
99−tsFilter :: FunctionN
148+tsFilter ::
100 '[null 'PGtsvector, null ('PGvararray ('NotNull ('PGchar 1)))]
149 '[null 'PGtsvector, null ('PGvararray ('NotNull ('PGchar 1)))]
101− (null 'PGtsvector)
150+ ---> null 'PGtsvector
102tsFilter = unsafeFunctionN "ts_filter"
151tsFilter = unsafeFunctionN "ts_filter"
103
152
153+-- | display a `Squeal.PostgreSQL.Expression.Type.tsquery` match
104tsHeadline
154tsHeadline
105 :: document `In` '[ 'PGtext, 'PGjson, 'PGjsonb]
155 :: document `In` '[ 'PGtext, 'PGjson, 'PGjsonb]
106− => FunctionN '[null document, null 'PGtsquery] (null 'PGtext)
156+ => '[null document, null 'PGtsquery] ---> null 'PGtext
107tsHeadline = unsafeFunctionN "ts_headline"
157tsHeadline = unsafeFunctionN "ts_headline"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Time.hs+18−12
@@ -1,3 +1,13 @@
1+{-|
2+Module: Squeal.PostgreSQL.Expression.Time
3+Description: Date/Time expressions
4+Copyright: (c) Eitan Chatav, 2019
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Date/Time functions and operators
9+-}
10+
1{-# LANGUAGE
11{-# LANGUAGE
2 DataKinds
12 DataKinds
3 , DeriveGeneric
13 , DeriveGeneric
@@ -7,6 +17,7 @@
7 , OverloadedStrings
17 , OverloadedStrings
8 , PolyKinds
18 , PolyKinds
9 , RankNTypes
19 , RankNTypes
20+ , TypeOperators
10#-}
21#-}
11
22
12module Squeal.PostgreSQL.Expression.Time
23module Squeal.PostgreSQL.Expression.Time
@@ -75,9 +86,7 @@ Create date from year, month and day fields
75>>> printSQL (makeDate (1984 :* 7 *: 3))
86>>> printSQL (makeDate (1984 :* 7 *: 3))
76make_date(1984, 7, 3)
87make_date(1984, 7, 3)
77-}
88-}
78−makeDate :: FunctionN
79− '[ null 'PGint4, null 'PGint4, null 'PGint4 ]
89+makeDate :: '[ null 'PGint4, null 'PGint4, null 'PGint4 ] ---> null 'PGdate
80− ( null 'PGdate )
81makeDate = unsafeFunctionN "make_date"
90makeDate = unsafeFunctionN "make_date"
82
91
83{-|
92{-|
@@ -86,9 +95,7 @@ Create time from hour, minute and seconds fields
86>>> printSQL (makeTime (8 :* 15 *: 23.5))
95>>> printSQL (makeTime (8 :* 15 *: 23.5))
87make_time(8, 15, 23.5)
96make_time(8, 15, 23.5)
88-}
97-}
89−makeTime :: FunctionN
90− '[ null 'PGint4, null 'PGint4, null 'PGfloat8 ]
98+makeTime :: '[ null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtime
91− ( null 'PGtime )
92makeTime = unsafeFunctionN "make_time"
99makeTime = unsafeFunctionN "make_time"
93
100
94{-|
101{-|
@@ -97,10 +104,9 @@ Create timestamp from year, month, day, hour, minute and seconds fields
97>>> printSQL (makeTimestamp (2013 :* 7 :* 15 :* 8 :* 15 *: 23.5))
104>>> printSQL (makeTimestamp (2013 :* 7 :* 15 :* 8 :* 15 *: 23.5))
98make_timestamp(2013, 7, 15, 8, 15, 23.5)
105make_timestamp(2013, 7, 15, 8, 15, 23.5)
99-}
106-}
100−makeTimestamp :: FunctionN
107+makeTimestamp ::
101 '[ null 'PGint4, null 'PGint4, null 'PGint4
108 '[ null 'PGint4, null 'PGint4, null 'PGint4
102− , null 'PGint4, null 'PGint4, null 'PGfloat8 ]
109+ , null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtimestamp
103− ( null 'PGtimestamp )
104makeTimestamp = unsafeFunctionN "make_timestamp"
110makeTimestamp = unsafeFunctionN "make_timestamp"
105
111
106{-|
112{-|
@@ -111,10 +117,9 @@ the current time zone is used
111>>> printSQL (makeTimestamptz (2013 :* 7 :* 15 :* 8 :* 15 *: 23.5))
117>>> printSQL (makeTimestamptz (2013 :* 7 :* 15 :* 8 :* 15 *: 23.5))
112make_timestamptz(2013, 7, 15, 8, 15, 23.5)
118make_timestamptz(2013, 7, 15, 8, 15, 23.5)
113-}
119-}
114−makeTimestamptz :: FunctionN
120+makeTimestamptz ::
115 '[ null 'PGint4, null 'PGint4, null 'PGint4
121 '[ null 'PGint4, null 'PGint4, null 'PGint4
116− , null 'PGint4, null 'PGint4, null 'PGfloat8 ]
122+ , null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtimestamptz
117− ( null 'PGtimestamptz )
118makeTimestamptz = unsafeFunctionN "make_timestamptz"
123makeTimestamptz = unsafeFunctionN "make_timestamptz"
119
124
120{-|
125{-|
@@ -156,6 +161,7 @@ infixl 6 +!
156infixl 6 !-
161infixl 6 !-
157infixl 6 !-!
162infixl 6 !-!
158
163
164+-- | A `TimeUnit` to use in `interval_` construction.
159data TimeUnit
165data TimeUnit
160 = Years | Months | Weeks | Days
166 = Years | Months | Weeks | Days
161 | Hours | Minutes | Seconds
167 | Hours | Minutes | Seconds
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Type.hsnew file+446
@@ -0,0 +1,446 @@
1+{-|
2+Module: Squeal.PostgreSQL.Expression
3+Description: Type expressions
4+Copyright: (c) Eitan Chatav, 2019
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Type expressions.
9+-}
10+
11+{-# LANGUAGE
12+ AllowAmbiguousTypes
13+ , DataKinds
14+ , DeriveGeneric
15+ , FlexibleContexts
16+ , FlexibleInstances
17+ , GADTs
18+ , GeneralizedNewtypeDeriving
19+ , KindSignatures
20+ , MultiParamTypeClasses
21+ , OverloadedStrings
22+ , RankNTypes
23+ , ScopedTypeVariables
24+ , TypeApplications
25+ , TypeOperators
26+ , UndecidableInstances
27+#-}
28+
29+module Squeal.PostgreSQL.Expression.Type
30+ ( -- * type casting
31+ cast
32+ , astype
33+ , inferredtype
34+ -- * type expressions
35+ , TypeExpression (..)
36+ , typedef
37+ , typetable
38+ , typeview
39+ , bool
40+ , int2
41+ , smallint
42+ , int4
43+ , int
44+ , integer
45+ , int8
46+ , bigint
47+ , numeric
48+ , float4
49+ , real
50+ , float8
51+ , doublePrecision
52+ , money
53+ , text
54+ , char
55+ , character
56+ , varchar
57+ , characterVarying
58+ , bytea
59+ , timestamp
60+ , timestampWithTimeZone
61+ , timestamptz
62+ , date
63+ , time
64+ , timeWithTimeZone
65+ , timetz
66+ , interval
67+ , uuid
68+ , inet
69+ , json
70+ , jsonb
71+ , vararray
72+ , fixarray
73+ , tsvector
74+ , 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 (..)
98+ ) where
99+
100+import Control.DeepSeq
101+import Data.ByteString
102+import Data.String
103+import GHC.TypeLits
104+
105+import qualified Data.ByteString as ByteString
106+import qualified GHC.Generics as GHC
107+import qualified Generics.SOP as SOP
108+
109+import Squeal.PostgreSQL.Alias
110+import Squeal.PostgreSQL.Expression
111+import Squeal.PostgreSQL.PG
112+import Squeal.PostgreSQL.Render
113+import Squeal.PostgreSQL.Schema
114+
115+-- $setup
116+-- >>> import Squeal.PostgreSQL
117+
118+-- When a `cast` is applied to an `Expression` of a known type, it
119+-- represents a run-time type conversion. The cast will succeed only if a
120+-- suitable type conversion operation has been defined.
121+--
122+-- | >>> printSQL $ true & cast int4
123+-- (TRUE :: int4)
124+cast
125+ :: TypeExpression schemas ty1
126+ -- ^ type to cast as
127+ -> Expression outer commons grp schemas params from ty0
128+ -- ^ value to convert
129+ -> Expression outer commons grp schemas params from ty1
130+cast ty x = UnsafeExpression $ parenthesized $
131+ renderSQL x <+> "::" <+> renderSQL ty
132+
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
156+
157+{-----------------------------------------
158+type expressions
159+-----------------------------------------}
160+
161+-- | `TypeExpression`s are used in `cast`s and
162+-- `Squeal.PostgreSQL.Definition.createTable` commands.
163+newtype TypeExpression (schemas :: SchemasType) (ty :: NullityType)
164+ = UnsafeTypeExpression { renderTypeExpression :: ByteString }
165+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
166+instance RenderSQL (TypeExpression schemas ty) where
167+ renderSQL = renderTypeExpression
168+
169+-- | The enum or composite type in a `Typedef` can be expressed by its alias.
170+typedef
171+ :: (Has sch schemas schema, Has td schema ('Typedef ty))
172+ => QualifiedAlias sch td
173+ -- ^ type alias
174+ -> TypeExpression schemas (null ty)
175+typedef = UnsafeTypeExpression . renderSQL
176+
177+-- | The composite type corresponding to a `Table` definition can be expressed
178+-- by its alias.
179+typetable
180+ :: (Has sch schemas schema, Has tab schema ('Table table))
181+ => QualifiedAlias sch tab
182+ -- ^ table alias
183+ -> TypeExpression schemas (null ('PGcomposite (TableToRow table)))
184+typetable = UnsafeTypeExpression . renderSQL
185+
186+-- | The composite type corresponding to a `View` definition can be expressed
187+-- by its alias.
188+typeview
189+ :: (Has sch schemas schema, Has vw schema ('View view))
190+ => QualifiedAlias sch vw
191+ -- ^ view alias
192+ -> TypeExpression schemas (null ('PGcomposite view))
193+typeview = UnsafeTypeExpression . renderSQL
194+
195+-- | logical Boolean (true/false)
196+bool :: TypeExpression schemas (null 'PGbool)
197+bool = UnsafeTypeExpression "bool"
198+-- | signed two-byte integer
199+int2, smallint :: TypeExpression schemas (null 'PGint2)
200+int2 = UnsafeTypeExpression "int2"
201+smallint = UnsafeTypeExpression "smallint"
202+-- | signed four-byte integer
203+int4, int, integer :: TypeExpression schemas (null 'PGint4)
204+int4 = UnsafeTypeExpression "int4"
205+int = UnsafeTypeExpression "int"
206+integer = UnsafeTypeExpression "integer"
207+-- | signed eight-byte integer
208+int8, bigint :: TypeExpression schemas (null 'PGint8)
209+int8 = UnsafeTypeExpression "int8"
210+bigint = UnsafeTypeExpression "bigint"
211+-- | arbitrary precision numeric type
212+numeric :: TypeExpression schemas (null 'PGnumeric)
213+numeric = UnsafeTypeExpression "numeric"
214+-- | single precision floating-point number (4 bytes)
215+float4, real :: TypeExpression schemas (null 'PGfloat4)
216+float4 = UnsafeTypeExpression "float4"
217+real = UnsafeTypeExpression "real"
218+-- | double precision floating-point number (8 bytes)
219+float8, doublePrecision :: TypeExpression schemas (null 'PGfloat8)
220+float8 = UnsafeTypeExpression "float8"
221+doublePrecision = UnsafeTypeExpression "double precision"
222+-- | currency amount
223+money :: TypeExpression schema (null 'PGmoney)
224+money = UnsafeTypeExpression "money"
225+-- | variable-length character string
226+text :: TypeExpression schemas (null 'PGtext)
227+text = UnsafeTypeExpression "text"
228+-- | fixed-length character string
229+char, character
230+ :: forall n schemas null. (KnownNat n, 1 <= n)
231+ => TypeExpression schemas (null ('PGchar n))
232+char = UnsafeTypeExpression $ "char(" <> renderNat @n <> ")"
233+character = UnsafeTypeExpression $ "character(" <> renderNat @n <> ")"
234+-- | variable-length character string
235+varchar, characterVarying
236+ :: forall n schemas null. (KnownNat n, 1 <= n)
237+ => TypeExpression schemas (null ('PGvarchar n))
238+varchar = UnsafeTypeExpression $ "varchar(" <> renderNat @n <> ")"
239+characterVarying = UnsafeTypeExpression $
240+ "character varying(" <> renderNat @n <> ")"
241+-- | binary data ("byte array")
242+bytea :: TypeExpression schemas (null 'PGbytea)
243+bytea = UnsafeTypeExpression "bytea"
244+-- | date and time (no time zone)
245+timestamp :: TypeExpression schemas (null 'PGtimestamp)
246+timestamp = UnsafeTypeExpression "timestamp"
247+-- | date and time, including time zone
248+timestampWithTimeZone, timestamptz :: TypeExpression schemas (null 'PGtimestamptz)
249+timestampWithTimeZone = UnsafeTypeExpression "timestamp with time zone"
250+timestamptz = UnsafeTypeExpression "timestamptz"
251+-- | calendar date (year, month, day)
252+date :: TypeExpression schemas (null 'PGdate)
253+date = UnsafeTypeExpression "date"
254+-- | time of day (no time zone)
255+time :: TypeExpression schemas (null 'PGtime)
256+time = UnsafeTypeExpression "time"
257+-- | time of day, including time zone
258+timeWithTimeZone, timetz :: TypeExpression schemas (null 'PGtimetz)
259+timeWithTimeZone = UnsafeTypeExpression "time with time zone"
260+timetz = UnsafeTypeExpression "timetz"
261+-- | time span
262+interval :: TypeExpression schemas (null 'PGinterval)
263+interval = UnsafeTypeExpression "interval"
264+-- | universally unique identifier
265+uuid :: TypeExpression schemas (null 'PGuuid)
266+uuid = UnsafeTypeExpression "uuid"
267+-- | IPv4 or IPv6 host address
268+inet :: TypeExpression schemas (null 'PGinet)
269+inet = UnsafeTypeExpression "inet"
270+-- | textual JSON data
271+json :: TypeExpression schemas (null 'PGjson)
272+json = UnsafeTypeExpression "json"
273+-- | binary JSON data, decomposed
274+jsonb :: TypeExpression schemas (null 'PGjsonb)
275+jsonb = UnsafeTypeExpression "jsonb"
276+-- | variable length array
277+vararray
278+ :: TypeExpression schemas pg
279+ -> TypeExpression schemas (null ('PGvararray pg))
280+vararray ty = UnsafeTypeExpression $ renderSQL ty <> "[]"
281+-- | fixed length array
282+--
283+-- >>> renderSQL (fixarray @'[2] json)
284+-- "json[2]"
285+fixarray
286+ :: forall dims schemas null pg. SOP.All KnownNat dims
287+ => TypeExpression schemas pg
288+ -> TypeExpression schemas (null ('PGfixarray dims pg))
289+fixarray ty = UnsafeTypeExpression $
290+ renderSQL ty <> renderDims @dims
291+ where
292+ renderDims :: forall ns. SOP.All KnownNat ns => ByteString
293+ renderDims =
294+ ("[" <>)
295+ . (<> "]")
296+ . ByteString.intercalate "]["
297+ . SOP.hcollapse
298+ $ SOP.hcmap (SOP.Proxy @KnownNat)
299+ (K . fromString . show . natVal)
300+ (SOP.hpure SOP.Proxy :: SOP.NP SOP.Proxy ns)
301+-- | text search query
302+tsvector :: TypeExpression schemas (null 'PGtsvector)
303+tsvector = UnsafeTypeExpression "tsvector"
304+-- | text search document
305+tsquery :: TypeExpression schemas (null 'PGtsquery)
306+tsquery = 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"
329+
330+-- | `pgtype` is a demoted version of a `PGType`
331+class PGTyped schemas (ty :: NullityType) where
332+ pgtype :: TypeExpression schemas ty
333+instance PGTyped schemas (null 'PGbool) where pgtype = bool
334+instance PGTyped schemas (null 'PGint2) where pgtype = int2
335+instance PGTyped schemas (null 'PGint4) where pgtype = int4
336+instance PGTyped schemas (null 'PGint8) where pgtype = int8
337+instance PGTyped schemas (null 'PGnumeric) where pgtype = numeric
338+instance PGTyped schemas (null 'PGfloat4) where pgtype = float4
339+instance PGTyped schemas (null 'PGfloat8) where pgtype = float8
340+instance PGTyped schemas (null 'PGmoney) where pgtype = money
341+instance PGTyped schemas (null 'PGtext) where pgtype = text
342+instance (KnownNat n, 1 <= n)
343+ => PGTyped schemas (null ('PGchar n)) where pgtype = char @n
344+instance (KnownNat n, 1 <= n)
345+ => PGTyped schemas (null ('PGvarchar n)) where pgtype = varchar @n
346+instance PGTyped schemas (null 'PGbytea) where pgtype = bytea
347+instance PGTyped schemas (null 'PGtimestamp) where pgtype = timestamp
348+instance PGTyped schemas (null 'PGtimestamptz) where pgtype = timestampWithTimeZone
349+instance PGTyped schemas (null 'PGdate) where pgtype = date
350+instance PGTyped schemas (null 'PGtime) where pgtype = time
351+instance PGTyped schemas (null 'PGtimetz) where pgtype = timeWithTimeZone
352+instance PGTyped schemas (null 'PGinterval) where pgtype = interval
353+instance PGTyped schemas (null 'PGuuid) where pgtype = uuid
354+instance PGTyped schemas (null 'PGjson) where pgtype = json
355+instance PGTyped schemas (null 'PGjsonb) where pgtype = jsonb
356+instance PGTyped schemas ty
357+ => PGTyped schemas (null ('PGvararray ty)) where
358+ pgtype = vararray (pgtype @schemas @ty)
359+instance (SOP.All KnownNat dims, PGTyped schemas ty)
360+ => PGTyped schemas (null ('PGfixarray dims ty)) where
361+ pgtype = fixarray @dims (pgtype @schemas @ty)
362+instance PGTyped schemas (null 'PGtsvector) where pgtype = tsvector
363+instance 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/Expression/Window.hs+44−6
@@ -1,3 +1,13 @@
1+{-|
2+Module: Squeal.PostgreSQL.Expression.Window
3+Description: Window functions
4+Copyright: (c) Eitan Chatav, 2019
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Window functions and definitions
9+-}
10+
1{-# LANGUAGE
11{-# LANGUAGE
2 DataKinds
12 DataKinds
3 , DeriveGeneric
13 , DeriveGeneric
@@ -13,9 +23,8 @@
13#-}
23#-}
14
24
15module Squeal.PostgreSQL.Expression.Window
25module Squeal.PostgreSQL.Expression.Window
16− ( WindowDefinition (..)
26+ ( -- * functions
17− , partitionBy
27+ partitionBy
18− , WindowFunction (..)
19 , rank
28 , rank
20 , rowNumber
29 , rowNumber
21 , denseRank
30 , denseRank
@@ -27,6 +36,14 @@ module Squeal.PostgreSQL.Expression.Window
27 , firstValue
36 , firstValue
28 , lastValue
37 , lastValue
29 , nthValue
38 , nthValue
39+ , unsafeWindowFunction1
40+ , unsafeWindowFunctionN
41+ -- * types
42+ , WindowFunction (..)
43+ , WindowDefinition (..)
44+ , WinFun0
45+ , WinFun1
46+ , WinFunN
30 ) where
47 ) where
31
48
32import Control.DeepSeq
49import Control.DeepSeq
@@ -80,14 +97,15 @@ instance Aggregate
80 varPop = unsafeWindowFunction1 "var_pop"
97 varPop = unsafeWindowFunction1 "var_pop"
81 varSamp = unsafeWindowFunction1 "var_samp"
98 varSamp = unsafeWindowFunction1 "var_samp"
82
99
83−
84-- | A `WindowDefinition` is a set of table rows that are somehow related
100-- | A `WindowDefinition` is a set of table rows that are somehow related
85-- to the current row
101-- to the current row
86data WindowDefinition outer commons grp schemas params from where
102data WindowDefinition outer commons grp schemas params from where
87 WindowDefinition
103 WindowDefinition
88 :: SOP.SListI bys
104 :: SOP.SListI bys
89 => NP (Expression outer commons grp schemas params from) bys
105 => NP (Expression outer commons grp schemas params from) bys
106+ -- ^ `partitionBy` clause
90 -> [SortExpression outer commons grp schemas params from]
107 -> [SortExpression outer commons grp schemas params from]
108+ -- ^ `Squeal.PostgreSQL.Expression.Sort.orderBy` clause
91 -> WindowDefinition outer commons grp schemas params from
109 -> WindowDefinition outer commons grp schemas params from
92
110
93instance OrderBy WindowDefinition where
111instance OrderBy WindowDefinition where
@@ -114,7 +132,7 @@ the same partition as the current row.
114-}
132-}
115partitionBy
133partitionBy
116 :: SOP.SListI bys
134 :: SOP.SListI bys
117− => NP (Expression outer commons grp schemas params from) bys
135+ => NP (Expression outer commons grp schemas params from) bys -- ^ partitions
118 -> WindowDefinition outer commons grp schemas params from
136 -> WindowDefinition outer commons grp schemas params from
119partitionBy bys = WindowDefinition bys []
137partitionBy bys = WindowDefinition bys []
120
138
@@ -142,11 +160,17 @@ newtype WindowFunction
142instance RenderSQL (WindowFunction outer commons grp schemas params from ty) where
160instance RenderSQL (WindowFunction outer commons grp schemas params from ty) where
143 renderSQL = renderWindowFunction
161 renderSQL = renderWindowFunction
144
162
163+{- |
164+A @RankNType@ for window functions with no arguments.
165+-}
145type WinFun0 x
166type WinFun0 x
146 = forall outer commons grp schemas params from
167 = forall outer commons grp schemas params from
147 . WindowFunction outer commons grp schemas params from x
168 . WindowFunction outer commons grp schemas params from x
148 -- ^ cannot reference aliases
169 -- ^ cannot reference aliases
149
170
171+{- |
172+A @RankNType@ for window functions with 1 argument.
173+-}
150type WinFun1 x y
174type WinFun1 x y
151 = forall outer commons grp schemas params from
175 = forall outer commons grp schemas params from
152 . Expression outer commons grp schemas params from x
176 . Expression outer commons grp schemas params from x
@@ -154,6 +178,10 @@ type WinFun1 x y
154 -> WindowFunction outer commons grp schemas params from y
178 -> WindowFunction outer commons grp schemas params from y
155 -- ^ output
179 -- ^ output
156
180
181+{- | A @RankNType@ for window functions with a fixed-length
182+list of heterogeneous arguments.
183+Use the `*:` operator to end your argument lists.
184+-}
157type WinFunN xs y
185type WinFunN xs y
158 = forall outer commons grp schemas params from
186 = forall outer commons grp schemas params from
159 . NP (Expression outer commons grp schemas params from) xs
187 . NP (Expression outer commons grp schemas params from) xs
@@ -161,15 +189,18 @@ type WinFunN xs y
161 -> WindowFunction outer commons grp schemas params from y
189 -> WindowFunction outer commons grp schemas params from y
162 -- ^ output
190 -- ^ output
163
191
192+-- | escape hatch for defining window functions
164unsafeWindowFunction1 :: ByteString -> WinFun1 x y
193unsafeWindowFunction1 :: ByteString -> WinFun1 x y
165unsafeWindowFunction1 fun x
194unsafeWindowFunction1 fun x
166 = UnsafeWindowFunction $ fun <> parenthesized (renderSQL x)
195 = UnsafeWindowFunction $ fun <> parenthesized (renderSQL x)
167
196
197+-- | escape hatch for defining multi-argument window functions
168unsafeWindowFunctionN :: SOP.SListI xs => ByteString -> WinFunN xs y
198unsafeWindowFunctionN :: SOP.SListI xs => ByteString -> WinFunN xs y
169unsafeWindowFunctionN fun xs = UnsafeWindowFunction $ fun <>
199unsafeWindowFunctionN fun xs = UnsafeWindowFunction $ fun <>
170 parenthesized (renderCommaSeparated renderSQL xs)
200 parenthesized (renderCommaSeparated renderSQL xs)
171
201
172{- | rank of the current row with gaps; same as `rowNumber` of its first peer
202{- | rank of the current row with gaps; same as `rowNumber` of its first peer
203+
173>>> printSQL rank
204>>> printSQL rank
174rank()
205rank()
175-}
206-}
@@ -177,6 +208,7 @@ rank :: WinFun0 ('NotNull 'PGint8)
177rank = UnsafeWindowFunction "rank()"
208rank = UnsafeWindowFunction "rank()"
178
209
179{- | number of the current row within its partition, counting from 1
210{- | number of the current row within its partition, counting from 1
211+
180>>> printSQL rowNumber
212>>> printSQL rowNumber
181row_number()
213row_number()
182-}
214-}
@@ -184,6 +216,7 @@ rowNumber :: WinFun0 ('NotNull 'PGint8)
184rowNumber = UnsafeWindowFunction "row_number()"
216rowNumber = UnsafeWindowFunction "row_number()"
185
217
186{- | rank of the current row without gaps; this function counts peer groups
218{- | rank of the current row without gaps; this function counts peer groups
219+
187>>> printSQL denseRank
220>>> printSQL denseRank
188dense_rank()
221dense_rank()
189-}
222-}
@@ -191,6 +224,7 @@ denseRank :: WinFun0 ('NotNull 'PGint8)
191denseRank = UnsafeWindowFunction "dense_rank()"
224denseRank = UnsafeWindowFunction "dense_rank()"
192
225
193{- | relative rank of the current row: (rank - 1) / (total partition rows - 1)
226{- | relative rank of the current row: (rank - 1) / (total partition rows - 1)
227+
194>>> printSQL percentRank
228>>> printSQL percentRank
195percent_rank()
229percent_rank()
196-}
230-}
@@ -199,6 +233,7 @@ percentRank = UnsafeWindowFunction "percent_rank()"
199
233
200{- | cumulative distribution: (number of partition rows
234{- | cumulative distribution: (number of partition rows
201preceding or peer with current row) / total partition rows
235preceding or peer with current row) / total partition rows
236+
202>>> printSQL cumeDist
237>>> printSQL cumeDist
203cume_dist()
238cume_dist()
204-}
239-}
@@ -207,6 +242,9 @@ cumeDist = UnsafeWindowFunction "cume_dist()"
207
242
208{- | integer ranging from 1 to the argument value,
243{- | integer ranging from 1 to the argument value,
209dividing the partition as equally as possible
244dividing the partition as equally as possible
245+
246+>>> printSQL $ ntile 5
247+ntile(5)
210-}
248-}
211ntile :: WinFun1 ('NotNull 'PGint4) ('NotNull 'PGint4)
249ntile :: WinFun1 ('NotNull 'PGint4) ('NotNull 'PGint4)
212ntile = unsafeWindowFunction1 "ntile"
250ntile = unsafeWindowFunction1 "ntile"
@@ -225,7 +263,7 @@ row within the partition; if there is no such row, instead return default
225evaluated with respect to the current row.
263evaluated with respect to the current row.
226-}
264-}
227lead :: WinFunN '[ty, 'NotNull 'PGint4, ty] ty
265lead :: WinFunN '[ty, 'NotNull 'PGint4, ty] ty
228−lead = unsafeWindowFunctionN "lag"
266+lead = unsafeWindowFunctionN "lead"
229
267
230{- | returns value evaluated at the row that is the
268{- | returns value evaluated at the row that is the
231first row of the window frame
269first row of the window frame
squeal-postgresql/src/Squeal/PostgreSQL/List.hs+40−51
@@ -1,3 +1,15 @@
1+{-|
2+Module: Squeal.PostgreSQL.List
3+Description: List related types and functions
4+Copyright: (c) Eitan Chatav, 2019
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Haskell singly-linked lists are very powerful. This module
9+provides functionality for type-level lists, heterogeneous
10+lists and type aligned lists.
11+-}
12+
1{-# LANGUAGE
13{-# LANGUAGE
2 DataKinds
14 DataKinds
3 , FlexibleContexts
15 , FlexibleContexts
@@ -19,39 +31,31 @@ module Squeal.PostgreSQL.List
19 ( SOP.NP (..)
31 ( SOP.NP (..)
20 , (*:)
32 , (*:)
21 , Join
33 , Join
22− , (+++)
23 , disjoin
34 , disjoin
24− , AlignedList (..)
35+ , Additional (..)
25− , single
36+ , Path (..)
26− , extractList
37+ , CFunctor (..)
27− , alignedMap
38+ , CFoldable (..)
39+ , CFree (..)
28 , Elem
40 , Elem
29 , In
41 , In
30 , Length
42 , Length
31 ) where
43 ) where
32
44
33−import Control.Category
45+import Control.Category.Free
46+import Data.Function ((&))
34import Data.Kind
47import Data.Kind
35import Data.Type.Bool
48import Data.Type.Bool
36import GHC.TypeLits
49import GHC.TypeLits
37
50
38import Generics.SOP as SOP
51import Generics.SOP as SOP
39
52
40−import Squeal.PostgreSQL.Render
41−
42-- | `Join` is simply promoted `++` and is used in @JOIN@s in
53-- | `Join` is simply promoted `++` and is used in @JOIN@s in
43-- `Squeal.PostgreSQL.Query.FromClause`s.
54-- `Squeal.PostgreSQL.Query.FromClause`s.
44type family Join xs ys where
55type family Join xs ys where
45 Join '[] ys = ys
56 Join '[] ys = ys
46 Join (x ': xs) ys = x ': Join xs ys
57 Join (x ': xs) ys = x ': Join xs ys
47
58
48−-- | Concatenate `NP` lists.
49−(+++) :: NP f xs -> NP f ys -> NP f (Join xs ys)
50−xs +++ ys = case xs of
51− Nil -> ys
52− x :* xs' -> x :* (xs' +++ ys)
53−infixr 5 +++
54−
55-- | `disjoin` is a utility function for splitting an `NP` list into pieces.
59-- | `disjoin` is a utility function for splitting an `NP` list into pieces.
56disjoin
60disjoin
57 :: forall xs ys expr. SListI xs
61 :: forall xs ys expr. SListI xs
@@ -62,39 +66,15 @@ disjoin = case sList @xs of
62 SCons -> \(x :* xsys) ->
66 SCons -> \(x :* xsys) ->
63 case disjoin xsys of (xs,ys) -> (x :* xs, ys)
67 case disjoin xsys of (xs,ys) -> (x :* xs, ys)
64
68
65−-- | An `AlignedList` is a type-aligned list or free category.
69+-- | The `Additional` class is for appending
66−data AlignedList p x0 x1 where
70+-- type-level list parameterized constructors such as `NP`,
67− Done :: AlignedList p x x
71+-- `Squeal.PostgreSQL.Query.Selection`, and `Squeal.PostgreSQL.Query.FromClause`.
68− (:>>) :: p x0 x1 -> AlignedList p x1 x2 -> AlignedList p x0 x2
72+class Additional expr where
69−infixr 7 :>>
73+ also :: expr ys -> expr xs -> expr (Join xs ys)
70−instance Category (AlignedList p) where
74+instance Additional (NP expr) where
71− id = Done
75+ also ys = \case
72− (.) list = \case
76+ Nil -> ys
73− Done -> list
74− step :>> steps -> step :>> (steps >>> list)
75−instance (forall t0 t1. RenderSQL (p t0 t1))
76− => RenderSQL (AlignedList p x0 x1) where
77− renderSQL = \case
78− Done -> ""
79− step :>> Done -> renderSQL step
80− step :>> steps -> renderSQL step <> ", " <> renderSQL steps
81−
82−extractList :: (forall a0 a1. p a0 a1 -> b) -> AlignedList p x0 x1 -> [b]
83−extractList f = \case
84− Done -> []
85− step :>> steps -> (f step):extractList f steps
86−
87−alignedMap
88− :: (forall z0 z1. p z0 z1 -> q z0 z1)
89− -> AlignedList p x0 x1
90− -> AlignedList q x0 x1
91−alignedMap f = \case
92− Done -> Done
93− x :>> xs -> f x :>> alignedMap f xs
77+ x :* xs -> x :* (xs & also ys)
94−
95−-- | A `single` step.
96−single :: p x0 x1 -> AlignedList p x0 x1
97−single step = step :>> Done
98
78
99-- | A useful operator for ending an `NP` list of length at least 2 without `Nil`.
79-- | A useful operator for ending an `NP` list of length at least 2 without `Nil`.
100(*:) :: f x -> f y -> NP f '[x,y]
80(*:) :: f x -> f y -> NP f '[x,y]
@@ -104,13 +84,18 @@ infixl 9 *:
104-- | @Elem@ is a promoted `Data.List.elem`.
84-- | @Elem@ is a promoted `Data.List.elem`.
105type family Elem x xs where
85type family Elem x xs where
106 Elem x '[] = 'False
86 Elem x '[] = 'False
107− 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
108 Elem x (_ ': xs) = Elem x xs
93 Elem x (_ ': xs) = Elem x xs
109
94
110-- | @In x xs@ is a constraint that proves that @x@ is in @xs@.
95-- | @In x xs@ is a constraint that proves that @x@ is in @xs@.
111type family In x xs :: Constraint where
96type family In x xs :: Constraint where
112 In x xs = If (Elem x xs) (() :: Constraint)
97 In x xs = If (Elem x xs) (() :: Constraint)
113− (TypeError ('ShowType x ':<>: 'Text "is not in " ':<>: 'ShowType xs))
98+ (TypeError ('ShowType x ':<>: 'Text " is not in " ':<>: 'ShowType xs))
114
99
115{- | Calculate the `Length` of a type level list
100{- | Calculate the `Length` of a type level list
116
101
@@ -119,5 +104,9 @@ Length '[Char,String,Bool,Double] :: Nat
119= 4
104= 4
120-}
105-}
121type family Length (xs :: [k]) :: Nat where
106type family Length (xs :: [k]) :: Nat where
107+ Length (_ ': _ ': _ ': _ ': _ : xs) = 5 + Length xs
108+ Length (_ ': _ ': _ ': _ : xs) = 4 + Length xs
109+ Length (_ ': _ ': _ : xs) = 3 + Length xs
110+ Length (_ ': _ : xs) = 2 + Length xs
122− Length (x : xs) = 1 + Length xs
111+ Length (_ : xs) = 1 + Length xs
123 Length '[] = 0
112 Length '[] = 0
squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs+155−168
@@ -18,6 +18,7 @@ Squeal data manipulation language.
18 , MultiParamTypeClasses
18 , MultiParamTypeClasses
19 , OverloadedStrings
19 , OverloadedStrings
20 , PatternSynonyms
20 , PatternSynonyms
21+ , QuantifiedConstraints
21 , RankNTypes
22 , RankNTypes
22 , ScopedTypeVariables
23 , ScopedTypeVariables
23 , TypeApplications
24 , TypeApplications
@@ -29,19 +30,9 @@ Squeal data manipulation language.
29
30
30module Squeal.PostgreSQL.Manipulation
31module Squeal.PostgreSQL.Manipulation
31 ( -- * Manipulation
32 ( -- * Manipulation
33+ Manipulation_
32− Manipulation (..)
34+ , Manipulation (..)
33− , Manipulation_
34 , queryStatement
35 , queryStatement
35− , QueryClause (..)
36− , pattern Values_
37− , DefaultAliasable (..)
38− , ColumnExpression (..)
39− , ReturningClause (..)
40− , pattern Returning_
41− , ConflictClause (..)
42− , ConflictTarget (..)
43− , ConflictAction (..)
44− , UsingClause (..)
45 -- * Insert
36 -- * Insert
46 , insertInto
37 , insertInto
47 , insertInto_
38 , insertInto_
@@ -51,13 +42,21 @@ module Squeal.PostgreSQL.Manipulation
51 -- * Delete
42 -- * Delete
52 , deleteFrom
43 , deleteFrom
53 , deleteFrom_
44 , deleteFrom_
54− , also
45+ -- * Clauses
46+ , Optional (..)
47+ , QueryClause (..)
48+ , pattern Values_
49+ , ReturningClause (..)
50+ , pattern Returning_
51+ , ConflictClause (..)
52+ , ConflictTarget (..)
53+ , ConflictAction (..)
54+ , UsingClause (..)
55 ) where
55 ) where
56
56
57import Control.DeepSeq
57import Control.DeepSeq
58import Data.ByteString hiding (foldr)
58import Data.ByteString hiding (foldr)
59import Data.Kind (Type)
59import Data.Kind (Type)
60−import GHC.TypeLits (KnownSymbol)
61
60
62import qualified Generics.SOP as SOP
61import qualified Generics.SOP as SOP
63import qualified GHC.Generics as GHC
62import qualified GHC.Generics as GHC
@@ -73,21 +72,65 @@ import Squeal.PostgreSQL.Schema
73
72
74-- $setup
73-- $setup
75-- >>> import Squeal.PostgreSQL
74-- >>> import Squeal.PostgreSQL
75+-- >>> import Data.Int
76+-- >>> import Data.Time
76
77
77{- |
78{- |
78A `Manipulation` is a statement which may modify data in the database,
79A `Manipulation` is a statement which may modify data in the database,
79but does not alter its schemas. Examples are inserts, updates and deletes.
80but does not alter its schemas. Examples are inserts, updates and deletes.
80A `Query` is also considered a `Manipulation` even though it does not modify data.
81A `Query` is also considered a `Manipulation` even though it does not modify data.
81
82
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+
82simple insert:
125simple insert:
83
126
84>>> type Columns = '["col1" ::: 'NoDef :=> 'Null 'PGint4, "col2" ::: 'Def :=> 'NotNull 'PGint4]
127>>> type Columns = '["col1" ::: 'NoDef :=> 'Null 'PGint4, "col2" ::: 'Def :=> 'NotNull 'PGint4]
85>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]
128>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]
86>>> :{
129>>> :{
87let
130let
88− manipulation :: Manipulation '[] (Public Schema) '[] '[]
131+ manipulation :: Manipulation_ (Public Schema) () ()
89 manipulation =
132 manipulation =
90− insertInto_ #tab (Values_ (2 `as` #col1 :* defaultAs #col2))
133+ insertInto_ #tab (Values_ (Set 2 `as` #col1 :* Default `as` #col2))
91in printSQL manipulation
134in printSQL manipulation
92:}
135:}
93INSERT INTO "tab" ("col1", "col2") VALUES (2, DEFAULT)
136INSERT INTO "tab" ("col1", "col2") VALUES (2, DEFAULT)
@@ -98,9 +141,9 @@ parameterized insert:
98>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]
141>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]
99>>> :{
142>>> :{
100let
143let
101− manipulation :: Manipulation '[] (Public Schema) '[ 'NotNull 'PGint4, 'NotNull 'PGint4 ] '[]
144+ manipulation :: Manipulation_ (Public Schema) (Int32, Int32) ()
102 manipulation =
145 manipulation =
103− 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))
104in printSQL manipulation
147in printSQL manipulation
105:}
148:}
106INSERT INTO "tab" ("col1", "col2") VALUES (($1 :: int4), ($2 :: int4))
149INSERT INTO "tab" ("col1", "col2") VALUES (($1 :: int4), ($2 :: int4))
@@ -109,9 +152,9 @@ returning insert:
109
152
110>>> :{
153>>> :{
111let
154let
112− manipulation :: Manipulation '[] (Public Schema) '[] '["fromOnly" ::: 'NotNull 'PGint4]
155+ manipulation :: Manipulation_ (Public Schema) () (Only Int32)
113 manipulation =
156 manipulation =
114− insertInto #tab (Values_ (2 `as` #col1 :* 3 `as` #col2))
157+ insertInto #tab (Values_ (Set 2 `as` #col1 :* Set 3 `as` #col2))
115 OnConflictDoRaise (Returning (#col1 `as` #fromOnly))
158 OnConflictDoRaise (Returning (#col1 `as` #fromOnly))
116in printSQL manipulation
159in printSQL manipulation
117:}
160:}
@@ -124,12 +167,12 @@ upsert:
124>>> type CustomersSchema = '["customers" ::: 'Table (CustomersConstraints :=> CustomersColumns)]
167>>> type CustomersSchema = '["customers" ::: 'Table (CustomersConstraints :=> CustomersColumns)]
125>>> :{
168>>> :{
126let
169let
127− manipulation :: Manipulation '[] (Public CustomersSchema) '[] '[]
170+ manipulation :: Manipulation_ (Public CustomersSchema) () ()
128 manipulation =
171 manipulation =
129 insertInto #customers
172 insertInto #customers
130− (Values_ ("John Smith" `as` #name :* "john@smith.com" `as` #email))
173+ (Values_ (Set "John Smith" `as` #name :* Set "john@smith.com" `as` #email))
131 (OnConflict (OnConstraint #uq)
174 (OnConflict (OnConstraint #uq)
132− (DoUpdate (((#excluded ! #email) <> "; " <> (#customers ! #email)) `as` #email) []))
175+ (DoUpdate (Set (#excluded ! #email <> "; " <> #customers ! #email) `as` #email) []))
133 (Returning_ Nil)
176 (Returning_ Nil)
134in printSQL manipulation
177in printSQL manipulation
135:}
178:}
@@ -139,7 +182,7 @@ query insert:
139
182
140>>> :{
183>>> :{
141let
184let
142− manipulation :: Manipulation '[] (Public Schema) '[] '[]
185+ manipulation :: Manipulation_ (Public Schema) () ()
143 manipulation = insertInto_ #tab (Subquery (select Star (from (table #tab))))
186 manipulation = insertInto_ #tab (Subquery (select Star (from (table #tab))))
144in printSQL manipulation
187in printSQL manipulation
145:}
188:}
@@ -149,8 +192,8 @@ update:
149
192
150>>> :{
193>>> :{
151let
194let
152− manipulation :: Manipulation '[] (Public Schema) '[] '[]
195+ manipulation :: Manipulation_ (Public Schema) () ()
153− manipulation = update_ #tab (2 `as` #col1) (#col1 ./= #col2)
196+ manipulation = update_ #tab (Set 2 `as` #col1) (#col1 ./= #col2)
154in printSQL manipulation
197in printSQL manipulation
155:}
198:}
156UPDATE "tab" SET "col1" = 2 WHERE ("col1" <> "col2")
199UPDATE "tab" SET "col1" = 2 WHERE ("col1" <> "col2")
@@ -159,9 +202,7 @@ delete:
159
202
160>>> :{
203>>> :{
161let
204let
162− manipulation :: Manipulation '[] (Public Schema) '[]
205+ manipulation :: Manipulation_ (Public Schema) () (Row Int32 Int32)
163− '[ "col1" ::: 'NotNull 'PGint4
164− , "col2" ::: 'NotNull 'PGint4 ]
165 manipulation = deleteFrom #tab NoUsing (#col1 .== #col2) (Returning Star)
206 manipulation = deleteFrom #tab NoUsing (#col1 .== #col2) (Returning Star)
166in printSQL manipulation
207in printSQL manipulation
167:}
208:}
@@ -172,13 +213,13 @@ delete and using clause:
172>>> :{
213>>> :{
173type Schema3 =
214type Schema3 =
174 '[ "tab" ::: 'Table ('[] :=> Columns)
215 '[ "tab" ::: 'Table ('[] :=> Columns)
175− , "other_tab" ::: 'Table ('[] :=> Columns)
216+ , "other_tab" ::: 'Table ('[] :=> Columns)
176− , "third_tab" ::: 'Table ('[] :=> Columns) ]
217+ , "third_tab" ::: 'Table ('[] :=> Columns) ]
177:}
218:}
178
219
179>>> :{
220>>> :{
180let
221let
181− manipulation :: Manipulation '[] (Public Schema3) '[] '[]
222+ manipulation :: Manipulation_ (Public Schema3) () ()
182 manipulation =
223 manipulation =
183 deleteFrom #tab (Using (table #other_tab & also (table #third_tab)))
224 deleteFrom #tab (Using (table #other_tab & also (table #third_tab)))
184 ( (#tab ! #col2 .== #other_tab ! #col2)
225 ( (#tab ! #col2 .== #other_tab ! #col2)
@@ -194,7 +235,7 @@ with manipulation:
194>>> type ProductsSchema = '["products" ::: 'Table ('[] :=> ProductsColumns), "products_deleted" ::: 'Table ('[] :=> ProductsColumns)]
235>>> type ProductsSchema = '["products" ::: 'Table ('[] :=> ProductsColumns), "products_deleted" ::: 'Table ('[] :=> ProductsColumns)]
195>>> :{
236>>> :{
196let
237let
197− manipulation :: Manipulation '[] (Public ProductsSchema) '[ 'NotNull 'PGdate] '[]
238+ manipulation :: Manipulation_ (Public ProductsSchema) (Only Day) ()
198 manipulation = with
239 manipulation = with
199 (deleteFrom #products NoUsing (#date .< param @1) (Returning Star) `as` #del)
240 (deleteFrom #products NoUsing (#date .< param @1) (Returning Star) `as` #del)
200 (insertInto_ #products_deleted (Subquery (select Star (from (common #del)))))
241 (insertInto_ #products_deleted (Subquery (select Star (from (common #del)))))
@@ -202,26 +243,13 @@ in printSQL manipulation
202:}
243:}
203WITH "del" AS (DELETE FROM "products" WHERE ("date" < ($1 :: date)) RETURNING *) INSERT INTO "products_deleted" SELECT * FROM "del" AS "del"
244WITH "del" AS (DELETE FROM "products" WHERE ("date" < ($1 :: date)) RETURNING *) INSERT INTO "products_deleted" SELECT * FROM "del" AS "del"
204-}
245-}
205−newtype Manipulation
206− (commons :: FromType)
207− (schemas :: SchemasType)
208− (params :: [NullityType])
209− (columns :: RowType)
210− = UnsafeManipulation { renderManipulation :: ByteString }
211− deriving (GHC.Generic,Show,Eq,Ord,NFData)
212−instance RenderSQL (Manipulation commons schemas params columns) where
213− renderSQL = renderManipulation
214−instance With Manipulation where
215− with Done manip = manip
216− with ctes manip = UnsafeManipulation $
217− "WITH" <+> renderSQL ctes <+> renderSQL manip
218−
219type family Manipulation_ (schemas :: SchemasType) (params :: Type) (row :: Type) where
246type family Manipulation_ (schemas :: SchemasType) (params :: Type) (row :: Type) where
220 Manipulation_ schemas params row = Manipulation '[] schemas (TuplePG params) (RowPG row)
247 Manipulation_ schemas params row = Manipulation '[] schemas (TuplePG params) (RowPG row)
221
248
222-- | Convert a `Query` into a `Manipulation`.
249-- | Convert a `Query` into a `Manipulation`.
223queryStatement
250queryStatement
224 :: Query '[] commons schemas params columns
251 :: Query '[] commons schemas params columns
252+ -- ^ `Query` to embed as a `Manipulation`
225 -> Manipulation commons schemas params columns
253 -> Manipulation commons schemas params columns
226queryStatement q = UnsafeManipulation $ renderSQL q
254queryStatement q = UnsafeManipulation $ renderSQL q
227
255
@@ -244,9 +272,13 @@ insertInto
244 , SOP.SListI columns
272 , SOP.SListI columns
245 , SOP.SListI row1 )
273 , SOP.SListI row1 )
246 => QualifiedAlias sch tab
274 => QualifiedAlias sch tab
275+ -- ^ table
247 -> QueryClause commons schemas params columns
276 -> QueryClause commons schemas params columns
277+ -- ^ what to insert
248 -> ConflictClause tab commons schemas params table
278 -> ConflictClause tab commons schemas params table
279+ -- ^ what to do in case of conflict
249 -> ReturningClause commons schemas params '[tab ::: row0] row1
280 -> ReturningClause commons schemas params '[tab ::: row0] row1
281+ -- ^ what to return
250 -> Manipulation commons schemas params row1
282 -> Manipulation commons schemas params row1
251insertInto tab qry conflict ret = UnsafeManipulation $
283insertInto tab qry conflict ret = UnsafeManipulation $
252 "INSERT" <+> "INTO" <+> renderSQL tab
284 "INSERT" <+> "INTO" <+> renderSQL tab
@@ -254,6 +286,7 @@ insertInto tab qry conflict ret = UnsafeManipulation $
254 <> renderSQL conflict
286 <> renderSQL conflict
255 <> renderSQL ret
287 <> renderSQL ret
256
288
289+-- | Like `insertInto` but with `OnConflictDoRaise` and `no` `ReturningClause`.
257insertInto_
290insertInto_
258 :: ( Has sch schemas schema
291 :: ( Has sch schemas schema
259 , Has tab schema ('Table table)
292 , Has tab schema ('Table table)
@@ -261,25 +294,33 @@ insertInto_
261 , row ~ TableToRow table
294 , row ~ TableToRow table
262 , SOP.SListI columns )
295 , SOP.SListI columns )
263 => QualifiedAlias sch tab
296 => QualifiedAlias sch tab
297+ -- ^ table
264 -> QueryClause commons schemas params columns
298 -> QueryClause commons schemas params columns
299+ -- ^ what to insert
265 -> Manipulation commons schemas params '[]
300 -> Manipulation commons schemas params '[]
266insertInto_ tab qry =
301insertInto_ tab qry =
267 insertInto tab qry OnConflictDoRaise (Returning_ Nil)
302 insertInto tab qry OnConflictDoRaise (Returning_ Nil)
268
303
304+-- | A `QueryClause` describes what to `insertInto` a table.
269data QueryClause commons schemas params columns where
305data QueryClause commons schemas params columns where
270 Values
306 Values
271 :: SOP.SListI columns
307 :: SOP.SListI columns
272− => NP (ColumnExpression 'Ungrouped schemas params '[]) columns
308+ => NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[]))) columns
309+ -- ^ row of values
273− -> [NP (ColumnExpression 'Ungrouped schemas params '[]) columns]
310+ -> [NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[]))) columns]
311+ -- ^ additional rows of values
274 -> QueryClause commons schemas params columns
312 -> QueryClause commons schemas params columns
275 Select
313 Select
276 :: SOP.SListI columns
314 :: SOP.SListI columns
277− => NP (ColumnExpression grp schemas params from) columns
315+ => NP (Aliased (Optional (Expression '[] commons grp schemas params from))) columns
316+ -- ^ row of values
278 -> TableExpression '[] commons grp schemas params from
317 -> TableExpression '[] commons grp schemas params from
318+ -- ^ from a table expression
279 -> QueryClause commons schemas params columns
319 -> QueryClause commons schemas params columns
280 Subquery
320 Subquery
281 :: ColumnsToRow columns ~ row
321 :: ColumnsToRow columns ~ row
282 => Query '[] commons schemas params row
322 => Query '[] commons schemas params row
323+ -- ^ subquery to insert
283 -> QueryClause commons schemas params columns
324 -> QueryClause commons schemas params columns
284
325
285instance RenderSQL (QueryClause commons schemas params columns) where
326instance RenderSQL (QueryClause commons schemas params columns) where
@@ -298,109 +339,41 @@ instance RenderSQL (QueryClause commons schemas params columns) where
298 Subquery qry -> renderQuery qry
339 Subquery qry -> renderQuery qry
299 where
340 where
300 renderSQLPartMaybe, renderValuePartMaybe
341 renderSQLPartMaybe, renderValuePartMaybe
301− :: ColumnExpression grp schemas params from column -> Maybe ByteString
342+ :: Aliased (Optional (Expression '[] commons grp schemas params from)) column
343+ -> Maybe ByteString
302 renderSQLPartMaybe = \case
344 renderSQLPartMaybe = \case
303− DefaultAs _ -> Nothing
345+ Default `As` _ -> Nothing
304− Specific (_ `As` name) -> Just $ renderSQL name
346+ Set _ `As` name -> Just $ renderSQL name
305 renderValuePartMaybe = \case
347 renderValuePartMaybe = \case
306− DefaultAs _ -> Nothing
348+ Default `As` _ -> Nothing
307− Specific (value `As` _) -> Just $ renderExpression value
349+ Set value `As` _ -> Just $ renderExpression value
308 renderSQLPart, renderValuePart
350 renderSQLPart, renderValuePart
309− :: ColumnExpression grp schemas params from column -> ByteString
351+ :: Aliased (Optional (Expression '[] commons grp schemas params from)) column
310− renderSQLPart = \case
352+ -> ByteString
311− DefaultAs name -> renderSQL name
312− Specific (_ `As` name) -> renderSQL name
353+ renderSQLPart (_ `As` name) = renderSQL name
313− renderValuePart = \case
354+ renderValuePart (value `As` _) = renderSQL value
314− DefaultAs _ -> "DEFAULT"
315− Specific (value `As` _) -> renderExpression value
316
355
356+-- | `Values_` describes a single `NP` list of `Aliased` `Optional` `Expression`s
357+-- whose `ColumnsType` must match the tables'.
317pattern Values_
358pattern Values_
318 :: SOP.SListI columns
359 :: SOP.SListI columns
319− => NP (ColumnExpression 'Ungrouped schemas params '[]) columns
360+ => NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[]))) columns
361+ -- ^ row of values
320 -> QueryClause commons schemas params columns
362 -> QueryClause commons schemas params columns
321pattern Values_ vals = Values vals []
363pattern Values_ vals = Values vals []
322
364
323−data ColumnExpression grp schemas params from column where
365+-- | `Optional` is either `Default` or a value, parameterized by an appropriate
324− DefaultAs
366+-- `ColumnConstraint`.
325− :: KnownSymbol col
367+data Optional expr ty where
326− => Alias col
368+ -- | Use the `Default` value for a column.
327− -> ColumnExpression grp schemas params from (col ::: 'Def :=> ty)
369+ Default :: Optional expr ('Def :=> ty)
328− Specific
370+ -- | `Set` a value for a column.
329− :: Aliased (Expression '[] '[] grp schemas params from) (col ::: ty)
371+ Set :: expr ty -> Optional expr (def :=> ty)
330− -> ColumnExpression grp schemas params from (col ::: defness :=> ty)
372+
331−
373+instance (forall x. RenderSQL (expr x)) => RenderSQL (Optional expr ty) where
332−instance (KnownSymbol col, column ~ (col ::: defness :=> ty))
333− => Aliasable col
334− (Expression '[] '[] grp schemas params from ty)
335− (ColumnExpression grp schemas params from column) where
336− expression `as` col = Specific (expression `As` col)
337−instance (KnownSymbol col, columns ~ '[col ::: defness :=> ty])
338− => Aliasable col
339− (Expression '[] '[] grp schemas params from ty)
340− (NP (ColumnExpression grp schemas params from) columns) where
341− expression `as` col = expression `as` col :* Nil
342−instance (KnownSymbol col, column ~ (col ::: 'Def :=> ty))
343− => DefaultAliasable col (ColumnExpression grp schemas params from column) where
344− defaultAs = DefaultAs
345−instance (KnownSymbol col, columns ~ '[col ::: 'Def :=> ty])
346− => DefaultAliasable col (NP (ColumnExpression grp schemas params from) columns) where
347− defaultAs col = defaultAs col :* Nil
348−
349−instance (HasUnique tab from row, Has col row ty, column ~ (col ::: defness :=> ty))
350− => IsLabel col (ColumnExpression 'Ungrouped schemas params from column) where
351− fromLabel = fromLabel @col `as` Alias
352−instance (HasUnique tab from row, Has col row ty, columns ~ '[col ::: defness :=> ty])
353− => IsLabel col
354− (NP (ColumnExpression 'Ungrouped schemas params from) columns) where
355− fromLabel = fromLabel @col `as` Alias
356−
357−instance (Has tab from row, Has col row ty, column ~ (col ::: defness :=> ty))
358− => IsQualified tab col (ColumnExpression 'Ungrouped schemas params from column) where
359− tab ! col = tab ! col `as` col
360−instance (Has tab from row, Has col row ty, columns ~ '[col ::: defness :=> ty])
361− => IsQualified tab col (NP (ColumnExpression 'Ungrouped schemas params from) columns) where
362− tab ! col = tab ! col `as` col
363−
364−instance
365− ( HasUnique tab from row
366− , Has col row ty
367− , GroupedBy tab col bys
368− , column ~ (col ::: defness :=> ty)
369− ) => IsLabel col
370− (ColumnExpression ('Grouped bys) schemas params from column) where
371− fromLabel = fromLabel @col `as` Alias
372−instance
373− ( HasUnique tab from row
374− , Has col row ty
375− , GroupedBy tab col bys
376− , columns ~ '[col ::: defness :=> ty]
377− ) => IsLabel col
378− (NP (ColumnExpression ('Grouped bys) schemas params from) columns) where
379− fromLabel = fromLabel @col `as` Alias
380−
381−instance
382− ( Has tab from row
383− , Has col row ty
384− , GroupedBy tab col bys
385− , column ~ (col ::: defness :=> ty)
386− ) => IsQualified tab col
387− (ColumnExpression ('Grouped bys) schemas params from column) where
388− tab ! col = tab ! col `as` col
389−instance
390− ( Has tab from row
391− , Has col row ty
392− , GroupedBy tab col bys
393− , columns ~ '[col ::: defness :=> ty]
394− ) => IsQualified tab col
395− (NP (ColumnExpression ('Grouped bys) schemas params from) columns) where
396− tab ! col = tab ! col :* Nil
397−
398−instance RenderSQL (ColumnExpression grp schemas params from column) where
399 renderSQL = \case
374 renderSQL = \case
400− DefaultAs col ->
401− renderSQL col <+> "=" <+> "DEFAULT"
375+ Default -> "DEFAULT"
402− Specific (expression `As` col) ->
376+ Set expr -> renderSQL expr
403− renderSQL col <+> "=" <+> renderSQL expression
404
377
405-- | A `ReturningClause` computes and return value(s) based
378-- | A `ReturningClause` computes and return value(s) based
406-- on each row actually inserted, updated or deleted. This is primarily
379-- on each row actually inserted, updated or deleted. This is primarily
@@ -410,7 +383,7 @@ instance RenderSQL (ColumnExpression grp schemas params from column) where
410-- deleted will be returned. For example, if a row was locked
383-- deleted will be returned. For example, if a row was locked
411-- but not updated because an `OnConflict` `DoUpdate` condition was not satisfied,
384-- but not updated because an `OnConflict` `DoUpdate` condition was not satisfied,
412-- the row will not be returned. `Returning` `Star` will return all columns
385-- the row will not be returned. `Returning` `Star` will return all columns
413−-- 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
414-- values are desired.
387-- values are desired.
415newtype ReturningClause commons schemas params from row =
388newtype ReturningClause commons schemas params from row =
416 Returning (Selection '[] commons 'Ungrouped schemas params from row)
389 Returning (Selection '[] commons 'Ungrouped schemas params from row)
@@ -420,9 +393,11 @@ instance RenderSQL (ReturningClause commons schemas params from row) where
420 Returning (List Nil) -> ""
393 Returning (List Nil) -> ""
421 Returning selection -> " RETURNING" <+> renderSQL selection
394 Returning selection -> " RETURNING" <+> renderSQL selection
422
395
396+-- | `Returning` a `List`
423pattern Returning_
397pattern Returning_
424 :: SOP.SListI row
398 :: SOP.SListI row
425 => NP (Aliased (Expression '[] commons 'Ungrouped schemas params from)) row
399 => NP (Aliased (Expression '[] commons 'Ungrouped schemas params from)) row
400+ -- ^ row of values
426 -> ReturningClause commons schemas params from row
401 -> ReturningClause commons schemas params from row
427pattern Returning_ list = Returning (List list)
402pattern Returning_ list = Returning (List list)
428
403
@@ -435,7 +410,9 @@ data ConflictClause tab commons schemas params table where
435 OnConflictDoRaise :: ConflictClause tab commons schemas params table
410 OnConflictDoRaise :: ConflictClause tab commons schemas params table
436 OnConflict
411 OnConflict
437 :: ConflictTarget constraints
412 :: ConflictTarget constraints
413+ -- ^ conflict target
438 -> ConflictAction tab commons schemas params columns
414 -> ConflictAction tab commons schemas params columns
415+ -- ^ conflict action
439 -> ConflictClause tab commons schemas params (constraints :=> columns)
416 -> ConflictClause tab commons schemas params (constraints :=> columns)
440
417
441-- | Render a `ConflictClause`.
418-- | Render a `ConflictClause`.
@@ -446,6 +423,17 @@ instance SOP.SListI (TableToColumns table)
446 OnConflict target action -> " ON CONFLICT"
423 OnConflict target action -> " ON CONFLICT"
447 <+> renderSQL target <+> renderSQL action
424 <+> renderSQL target <+> renderSQL action
448
425
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+-}
449data ConflictAction tab commons schemas params columns where
437data ConflictAction tab commons schemas params columns where
450 DoNothing :: ConflictAction tab commons schemas params columns
438 DoNothing :: ConflictAction tab commons schemas params columns
451 DoUpdate
439 DoUpdate
@@ -454,8 +442,9 @@ data ConflictAction tab commons schemas params columns where
454 , columns ~ (col0 ': cols)
442 , columns ~ (col0 ': cols)
455 , SOP.All (HasIn columns) subcolumns
443 , SOP.All (HasIn columns) subcolumns
456 , AllUnique subcolumns )
444 , AllUnique subcolumns )
457− => NP (ColumnExpression 'Ungrouped schemas params '[tab ::: row, "excluded" ::: row]) subcolumns
445+ => NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[tab ::: row, "excluded" ::: row]))) subcolumns
458 -> [Condition '[] commons 'Ungrouped schemas params '[tab ::: row, "excluded" ::: row]]
446 -> [Condition '[] commons 'Ungrouped schemas params '[tab ::: row, "excluded" ::: row]]
447+ -- ^ WHERE `Condition`s
459 -> ConflictAction tab commons schemas params columns
448 -> ConflictAction tab commons schemas params columns
460
449
461instance RenderSQL (ConflictAction tab commons schemas params columns) where
450instance RenderSQL (ConflictAction tab commons schemas params columns) where
@@ -463,11 +452,17 @@ instance RenderSQL (ConflictAction tab commons schemas params columns) where
463 DoNothing -> "DO NOTHING"
452 DoNothing -> "DO NOTHING"
464 DoUpdate updates whs'
453 DoUpdate updates whs'
465 -> "DO UPDATE SET"
454 -> "DO UPDATE SET"
466− <+> renderCommaSeparated renderSQL updates
455+ <+> renderCommaSeparated renderUpdate updates
467 <> case whs' of
456 <> case whs' of
468 [] -> ""
457 [] -> ""
469 wh:whs -> " WHERE" <+> renderSQL (foldr (.&&) wh whs)
458 wh:whs -> " WHERE" <+> renderSQL (foldr (.&&) wh whs)
470
459
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+
471-- | A `ConflictTarget` specifies the constraint violation that triggers a
466-- | A `ConflictTarget` specifies the constraint violation that triggers a
472-- `ConflictAction`.
467-- `ConflictAction`.
473data ConflictTarget constraints where
468data ConflictTarget constraints where
@@ -490,7 +485,6 @@ UPDATE statements
490update
485update
491 :: ( SOP.SListI columns
486 :: ( SOP.SListI columns
492 , SOP.SListI row1
487 , SOP.SListI row1
493− , db ~ (commons :=> schemas)
494 , Has sch schemas schema
488 , Has sch schemas schema
495 , Has tab schema ('Table table)
489 , Has tab schema ('Table table)
496 , row0 ~ TableToRow table
490 , row0 ~ TableToRow table
@@ -498,7 +492,7 @@ update
498 , SOP.All (HasIn columns) subcolumns
492 , SOP.All (HasIn columns) subcolumns
499 , AllUnique subcolumns )
493 , AllUnique subcolumns )
500 => QualifiedAlias sch tab -- ^ table to update
494 => QualifiedAlias sch tab -- ^ table to update
501− -> NP (ColumnExpression 'Ungrouped schemas params '[tab ::: row0]) subcolumns
495+ -> NP (Aliased (Optional (Expression '[] '[] 'Ungrouped schemas params '[tab ::: row0]))) subcolumns
502 -- ^ modified values to replace old values
496 -- ^ modified values to replace old values
503 -> Condition '[] commons 'Ungrouped schemas params '[tab ::: row0]
497 -> Condition '[] commons 'Ungrouped schemas params '[tab ::: row0]
504 -- ^ condition under which to perform update on a row
498 -- ^ condition under which to perform update on a row
@@ -508,14 +502,13 @@ update tab columns wh returning = UnsafeManipulation $
508 "UPDATE"
502 "UPDATE"
509 <+> renderSQL tab
503 <+> renderSQL tab
510 <+> "SET"
504 <+> "SET"
511− <+> renderCommaSeparated renderSQL columns
505+ <+> renderCommaSeparated renderUpdate columns
512 <+> "WHERE" <+> renderSQL wh
506 <+> "WHERE" <+> renderSQL wh
513 <> renderSQL returning
507 <> renderSQL returning
514
508
515-- | Update a row returning `Nil`.
509-- | Update a row returning `Nil`.
516update_
510update_
517 :: ( SOP.SListI columns
511 :: ( SOP.SListI columns
518− , db ~ (commons :=> schemas)
519 , Has sch schemas schema
512 , Has sch schemas schema
520 , Has tab schema ('Table table)
513 , Has tab schema ('Table table)
521 , row ~ TableToRow table
514 , row ~ TableToRow table
@@ -523,7 +516,7 @@ update_
523 , SOP.All (HasIn columns) subcolumns
516 , SOP.All (HasIn columns) subcolumns
524 , AllUnique subcolumns )
517 , AllUnique subcolumns )
525 => QualifiedAlias sch tab -- ^ table to update
518 => QualifiedAlias sch tab -- ^ table to update
526− -> NP (ColumnExpression 'Ungrouped schemas params '[tab ::: row]) subcolumns
519+ -> NP (Aliased (Optional (Expression '[] '[] 'Ungrouped schemas params '[tab ::: row]))) subcolumns
527 -- ^ modified values to replace old values
520 -- ^ modified values to replace old values
528 -> Condition '[] commons 'Ungrouped schemas params '[tab ::: row]
521 -> Condition '[] commons 'Ungrouped schemas params '[tab ::: row]
529 -- ^ condition under which to perform update on a row
522 -- ^ condition under which to perform update on a row
@@ -534,16 +527,25 @@ update_ tab columns wh = update tab columns wh (Returning_ Nil)
534DELETE statements
527DELETE statements
535-----------------------------------------}
528-----------------------------------------}
536
529
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.
537data UsingClause commons schemas params from where
539data UsingClause commons schemas params from where
538 NoUsing :: UsingClause commons schemas params '[]
540 NoUsing :: UsingClause commons schemas params '[]
539 Using
541 Using
540 :: FromClause '[] commons schemas params from
542 :: FromClause '[] commons schemas params from
543+ -- ^ what to use
541 -> UsingClause commons schemas params from
544 -> UsingClause commons schemas params from
542
545
543-- | Delete rows from a table.
546-- | Delete rows from a table.
544deleteFrom
547deleteFrom
545 :: ( SOP.SListI row1
548 :: ( SOP.SListI row1
546− , db ~ (commons :=> schemas)
547 , Has sch schemas schema
549 , Has sch schemas schema
548 , Has tab schema ('Table table)
550 , Has tab schema ('Table table)
549 , row0 ~ TableToRow table
551 , row0 ~ TableToRow table
@@ -565,8 +567,7 @@ deleteFrom tab using wh returning = UnsafeManipulation $
565
567
566-- | Delete rows returning `Nil`.
568-- | Delete rows returning `Nil`.
567deleteFrom_
569deleteFrom_
568− :: ( db ~ (commons :=> schemas)
569− , Has sch schemas schema
570+ :: ( Has sch schemas schema
570 , Has tab schema ('Table table)
571 , Has tab schema ('Table table)
571 , row ~ TableToRow table
572 , row ~ TableToRow table
572 , columns ~ TableToColumns table )
573 , columns ~ TableToColumns table )
@@ -575,17 +576,3 @@ deleteFrom_
575 -- ^ condition under which to delete a row
576 -- ^ condition under which to delete a row
576 -> Manipulation commons schemas params '[]
577 -> Manipulation commons schemas params '[]
577deleteFrom_ tab wh = deleteFrom tab NoUsing wh (Returning_ Nil)
578deleteFrom_ tab wh = deleteFrom tab NoUsing wh (Returning_ Nil)
578−
579−-- | This has the behaviour of a cartesian product, taking all
580−-- possible combinations between @left@ and @right@ - exactly like a
581−-- `crossJoin`. Used when no `crossJoin` syntax is required but simply
582−-- a comma separated list of tables. Typical case is the `UsingClause`
583−-- of a `deleteFrom` query.
584−also
585− :: FromClause outer commons schemas params right
586− -- ^ right
587− -> FromClause outer commons schemas params left
588− -- ^ left
589− -> FromClause outer commons schemas params (Join left right)
590−also right left = UnsafeFromClause $
591− renderSQL left <> "," <+> renderSQL right
squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs+53−57
@@ -66,7 +66,7 @@ let
66 }
66 }
67:}
67:}
68
68
69−Now that we have a couple migrations we can chain them together into an `AlignedList`.
69+Now that we have a couple migrations we can chain them together into a `Path`.
70
70
71>>> let migrations = makeUsers :>> makeEmails :>> Done
71>>> let migrations = makeUsers :>> makeEmails :>> Done
72
72
@@ -156,7 +156,6 @@ import Data.Function ((&))
156import Data.List ((\\))
156import Data.List ((\\))
157import Data.Text (Text)
157import Data.Text (Text)
158import Data.Time (UTCTime)
158import Data.Time (UTCTime)
159−import Generics.SOP (K (..))
160import Prelude hiding ((.), id)
159import Prelude hiding ((.), id)
161import System.Environment
160import System.Environment
162import UnliftIO (MonadIO (..))
161import UnliftIO (MonadIO (..))
@@ -165,7 +164,21 @@ import qualified Data.Text.IO as Text (putStrLn)
165import qualified Generics.SOP as SOP
164import qualified Generics.SOP as SOP
166import qualified GHC.Generics as GHC
165import qualified GHC.Generics as GHC
167
166
168−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
169
182
170-- | A `Migration` is a named "isomorphism" over a given category.
183-- | A `Migration` is a named "isomorphism" over a given category.
171-- It should contain an inverse pair of `up` and `down`
184-- It should contain an inverse pair of `up` and `down`
@@ -179,34 +192,34 @@ data Migration p schemas0 schemas1 = Migration
179
192
180{- |
193{- |
181A `Migratory` @p@ is a `Category` for which one can execute or rewind
194A `Migratory` @p@ is a `Category` for which one can execute or rewind
182−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
183SQL `Definition`s and the category of impure `Terminally` `PQ` `IO` actions.
196SQL `Definition`s and the category of impure `Terminally` `PQ` `IO` actions.
184-}
197-}
185class Category p => Migratory p where
198class Category p => Migratory p where
186
199
187 {- |
200 {- |
188− Run an `AlignedList` of `Migration`s.
201+ Run a `Path` of `Migration`s.
189 Create the `MigrationsTable` as @public.schema_migrations@ if it does not already exist.
202 Create the `MigrationsTable` as @public.schema_migrations@ if it does not already exist.
190− In a transaction for each each `Migration`, query to see if the `Migration` has been executed;
203+ In one transaction, for each each `Migration` query to see if the `Migration` has been executed;
191− if not, execute the `Migration` and insert a row in the `MigrationsTable`.
204+ if not, `up` the `Migration` and insert its `name` in the `MigrationsTable`.
192 -}
205 -}
193 migrateUp
206 migrateUp
194− :: AlignedList (Migration p) schemas0 schemas1
207+ :: Path (Migration p) schemas0 schemas1
195 -> PQ schemas0 schemas1 IO ()
208 -> PQ schemas0 schemas1 IO ()
196
209
197 {- |
210 {- |
198− Rewind an `AlignedList` of `Migration`s.
211+ Rewind a `Path` of `Migration`s.
199 Create the `MigrationsTable` as @public.schema_migrations@ if it does not already exist.
212 Create the `MigrationsTable` as @public.schema_migrations@ if it does not already exist.
200− In a transaction for each each `Migration`, query to see if the `Migration` has been executed;
213+ In one transaction, for each each `Migration` query to see if the `Migration` has been executed;
201− if so, rewind the `Migration` and delete its row in the `MigrationsTable`.
214+ if so, `down` the `Migration` and delete its `name` in the `MigrationsTable`.
202 -}
215 -}
203 migrateDown
216 migrateDown
204− :: AlignedList (Migration p) schemas0 schemas1
217+ :: Path (Migration p) schemas0 schemas1
205 -> PQ schemas1 schemas0 IO ()
218 -> PQ schemas1 schemas0 IO ()
206
219
207instance Migratory Definition where
220instance Migratory Definition where
208− migrateUp = migrateUp . alignedMap pureMigration
221+ migrateUp = migrateUp . cmap pureMigration
209− migrateDown = migrateDown . alignedMap pureMigration
222+ migrateDown = migrateDown . cmap pureMigration
210
223
211{- | `Terminally` turns an indexed monad transformer and the monad it transforms
224{- | `Terminally` turns an indexed monad transformer and the monad it transforms
212into a category by restricting the return type to @()@ and permuting the type variables.
225into a category by restricting the return type to @()@ and permuting the type variables.
@@ -238,8 +251,8 @@ terminally = Terminally . void
238-- | A `pureMigration` turns a `Migration` involving only pure SQL
251-- | A `pureMigration` turns a `Migration` involving only pure SQL
239-- `Definition`s into a `Migration` that may be combined with arbitrary `IO`.
252-- `Definition`s into a `Migration` that may be combined with arbitrary `IO`.
240pureMigration
253pureMigration
241− :: Migration Definition schema0 schema1
254+ :: Migration Definition schemas0 schemas1
242− -> Migration (Terminally PQ IO) schema0 schema1
255+ -> Migration (Terminally PQ IO) schemas0 schemas1
243pureMigration migration = Migration
256pureMigration migration = Migration
244 { name = name migration
257 { name = name migration
245 , up = terminally . define $ up migration
258 , up = terminally . define $ up migration
@@ -248,81 +261,64 @@ pureMigration migration = Migration
248
261
249instance Migratory (Terminally PQ IO) where
262instance Migratory (Terminally PQ IO) where
250
263
251− migrateUp migration = unsafePQ $
264+ migrateUp migration = unsafePQ . transactionally_ $ do
252 define createMigrations
265 define createMigrations
253− & pqBind okResult
254− & pqThen (transactionallySchema_ (upMigrations migration))
266+ upMigrations migration
255
267
256 where
268 where
257
269
258 upMigrations
270 upMigrations
259− :: AlignedList (Migration (Terminally PQ IO)) schemas0 schemas1
271+ :: Path (Migration (Terminally PQ IO)) schemas0 schemas1
260 -> PQ MigrationsSchemas MigrationsSchemas IO ()
272 -> PQ MigrationsSchemas MigrationsSchemas IO ()
261 upMigrations = \case
273 upMigrations = \case
262 Done -> return ()
274 Done -> return ()
263− step :>> steps -> upMigration step & pqThen (upMigrations steps)
275+ step :>> steps -> upMigration step >> upMigrations steps
264
276
265 upMigration
277 upMigration
266 :: Migration (Terminally PQ IO) schemas0 schemas1
278 :: Migration (Terminally PQ IO) schemas0 schemas1
267 -> PQ MigrationsSchemas MigrationsSchemas IO ()
279 -> PQ MigrationsSchemas MigrationsSchemas IO ()
268− upMigration step =
280+ upMigration step = do
269− queryExecuted step
281+ executed <- queryExecuted step
270− & pqBind ( \ executed -> unless (executed == 1)
282+ unless (executed == 1) $ do
271− $ unsafePQ (runTerminally (up step))
283+ unsafePQ . runTerminally $ up step
272− & pqThen (manipulateParams insertMigration (Only (name step)))
284+ manipulateParams_ insertMigration (Only (name step))
273− -- insert execution record
274− & pqBind okResult )
275
285
276 queryExecuted
286 queryExecuted
277 :: Migration (Terminally PQ IO) schemas0 schemas1
287 :: Migration (Terminally PQ IO) schemas0 schemas1
278 -> PQ MigrationsSchemas MigrationsSchemas IO Row
288 -> PQ MigrationsSchemas MigrationsSchemas IO Row
279 queryExecuted step = do
289 queryExecuted step = do
280 result <- runQueryParams selectMigration (Only (name step))
290 result <- runQueryParams selectMigration (Only (name step))
281− okResult result
282 ntuples result
291 ntuples result
283
292
284− migrateDown migrations = unsafePQ $
293+ migrateDown migrations = unsafePQ . transactionally_ $ do
285 define createMigrations
294 define createMigrations
286− & pqBind okResult
287− & pqThen (transactionallySchema_ (downMigrations migrations))
295+ downMigrations migrations
288
296
289 where
297 where
290
298
291 downMigrations
299 downMigrations
292− :: AlignedList (Migration (Terminally PQ IO)) schemas0 schemas1
300+ :: Path (Migration (Terminally PQ IO)) schemas0 schemas1
293 -> PQ MigrationsSchemas MigrationsSchemas IO ()
301 -> PQ MigrationsSchemas MigrationsSchemas IO ()
294 downMigrations = \case
302 downMigrations = \case
295 Done -> return ()
303 Done -> return ()
296− step :>> steps -> downMigrations steps & pqThen (downMigration step)
304+ step :>> steps -> downMigrations steps >> downMigration step
297
305
298 downMigration
306 downMigration
299 :: Migration (Terminally PQ IO) schemas0 schemas1
307 :: Migration (Terminally PQ IO) schemas0 schemas1
300 -> PQ MigrationsSchemas MigrationsSchemas IO ()
308 -> PQ MigrationsSchemas MigrationsSchemas IO ()
301− downMigration step =
309+ downMigration step = do
302− queryExecuted step
310+ executed <- queryExecuted step
303− & pqBind ( \ executed -> unless (executed == 0)
311+ unless (executed == 0) $ do
304− $ unsafePQ (runTerminally (down step))
312+ unsafePQ . runTerminally $ down step
305− & pqThen (manipulateParams deleteMigration (Only (name step)))
313+ manipulateParams_ deleteMigration (Only (name step))
306− -- delete execution record
307− & pqBind okResult )
308
314
309 queryExecuted
315 queryExecuted
310 :: Migration (Terminally PQ IO) schemas0 schemas1
316 :: Migration (Terminally PQ IO) schemas0 schemas1
311 -> PQ MigrationsSchemas MigrationsSchemas IO Row
317 -> PQ MigrationsSchemas MigrationsSchemas IO Row
312 queryExecuted step = do
318 queryExecuted step = do
313 result <- runQueryParams selectMigration (Only (name step))
319 result <- runQueryParams selectMigration (Only (name step))
314− okResult result
315 ntuples result
320 ntuples result
316
321
317−okResult :: K Result results -> PQ schema schema IO ()
318−okResult result = do
319− status <- resultStatus result
320− when (not (status `elem` [CommandOk, TuplesOk])) $ do
321− errorMessageMaybe <- resultErrorMessage result
322− case errorMessageMaybe of
323− Nothing -> error "migration: unknown error"
324− Just msg -> error ("migration: " <> show msg)
325−
326unsafePQ :: (Functor m) => PQ db0 db1 m x -> PQ db0' db1' m x
322unsafePQ :: (Functor m) => PQ db0 db1 m x -> PQ db0' db1' m x
327unsafePQ (PQ pq) = PQ $ fmap (SOP.K . SOP.unK) . pq . SOP.K . SOP.unK
323unsafePQ (PQ pq) = PQ $ fmap (SOP.K . SOP.unK) . pq . SOP.K . SOP.unK
328
324
@@ -357,7 +353,7 @@ createMigrations =
357-- the time at which it was inserted.
353-- the time at which it was inserted.
358insertMigration :: Manipulation_ MigrationsSchemas (Only Text) ()
354insertMigration :: Manipulation_ MigrationsSchemas (Only Text) ()
359insertMigration = insertInto_ #schema_migrations
355insertMigration = insertInto_ #schema_migrations
360− (Values_ ((param @1) `as` #name :* defaultAs #executed_at))
356+ (Values_ (Set (param @1) `as` #name :* Default `as` #executed_at))
361
357
362-- | Deletes a `Migration` from the `MigrationsTable`, returning
358-- | Deletes a `Migration` from the `MigrationsTable`, returning
363-- the time at which it was inserted.
359-- the time at which it was inserted.
@@ -367,8 +363,8 @@ deleteMigration = deleteFrom_ #schema_migrations (#name .== param @1)
367-- | Selects a `Migration` from the `MigrationsTable`, returning
363-- | Selects a `Migration` from the `MigrationsTable`, returning
368-- the time at which it was inserted.
364-- the time at which it was inserted.
369selectMigration
365selectMigration
370− :: Query_ MigrationsSchemas (Only Text) (P ("executed_at" ::: UTCTime))
366+ :: Query_ MigrationsSchemas (Only Text) (Only UTCTime)
371−selectMigration = select_ #executed_at
367+selectMigration = select_ (#executed_at `as` #fromOnly)
372 $ from (table (#schema_migrations))
368 $ from (table (#schema_migrations))
373 & where_ (#name .== param @1)
369 & where_ (#name .== param @1)
374
370
@@ -388,7 +384,7 @@ defaultMain
388 :: Migratory p
384 :: Migratory p
389 => ByteString
385 => ByteString
390 -- ^ connection string
386 -- ^ connection string
391− -> AlignedList (Migration p) db0 db1
387+ -> Path (Migration p) db0 db1
392 -- ^ migrations
388 -- ^ migrations
393 -> IO ()
389 -> IO ()
394defaultMain connectTo migrations = do
390defaultMain connectTo migrations = do
@@ -409,12 +405,12 @@ defaultMain connectTo migrations = do
409 migrateStatus :: PQ schema schema IO ()
405 migrateStatus :: PQ schema schema IO ()
410 migrateStatus = unsafePQ $ do
406 migrateStatus = unsafePQ $ do
411 runNames <- getRunMigrationNames
407 runNames <- getRunMigrationNames
412− let names = extractList name migrations
408+ let names = ctoList name migrations
413 unrunNames = names \\ runNames
409 unrunNames = names \\ runNames
414 liftIO $ displayRunned runNames >> displayUnrunned unrunNames
410 liftIO $ displayRunned runNames >> displayUnrunned unrunNames
415
411
416 suppressNotices :: PQ schema schema IO ()
412 suppressNotices :: PQ schema schema IO ()
417− suppressNotices = void . manipulate $
413+ suppressNotices = manipulate_ $
418 UnsafeManipulation "SET client_min_messages TO WARNING;"
414 UnsafeManipulation "SET client_min_messages TO WARNING;"
419
415
420 readCommandFromArgs :: IO (Maybe MigrateCommand)
416 readCommandFromArgs :: IO (Maybe MigrateCommand)
squeal-postgresql/src/Squeal/PostgreSQL/PG.hs+102−92
@@ -1,18 +1,29 @@
1−
1+{-|
2+Module: Squeal.PostgreSQL.PG
3+Description: Embedding of Haskell types into Postgres's type system
4+Copyright: (c) Eitan Chatav, 2010
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+`Squeal.PostgreSQL.PG` provides type families for turning Haskell
9+`Type`s into corresponding Postgres types.
10+-}
2{-# LANGUAGE
11{-# LANGUAGE
3 AllowAmbiguousTypes
12 AllowAmbiguousTypes
13+ , DeriveAnyClass
4 , DeriveFoldable
14 , DeriveFoldable
5 , DeriveFunctor
15 , DeriveFunctor
6 , DeriveGeneric
16 , DeriveGeneric
7 , DeriveTraversable
17 , DeriveTraversable
18+ , DerivingStrategies
8 , DefaultSignatures
19 , DefaultSignatures
9 , FlexibleContexts
20 , FlexibleContexts
10 , FlexibleInstances
21 , FlexibleInstances
11 , FunctionalDependencies
22 , FunctionalDependencies
12 , GADTs
23 , GADTs
13 , LambdaCase
24 , LambdaCase
14− , OverloadedStrings
15 , MultiParamTypeClasses
25 , MultiParamTypeClasses
26+ , OverloadedStrings
16 , ScopedTypeVariables
27 , ScopedTypeVariables
17 , TypeApplications
28 , TypeApplications
18 , TypeFamilies
29 , TypeFamilies
@@ -28,7 +39,6 @@ module Squeal.PostgreSQL.PG
28 , NullPG
39 , NullPG
29 , TuplePG
40 , TuplePG
30 , RowPG
41 , RowPG
31− , Entity
32 -- * Storage newtypes
42 -- * Storage newtypes
33 , Money (..)
43 , Money (..)
34 , Json (..)
44 , Json (..)
@@ -37,13 +47,14 @@ module Squeal.PostgreSQL.PG
37 , Enumerated (..)
47 , Enumerated (..)
38 , VarArray (..)
48 , VarArray (..)
39 , FixArray (..)
49 , FixArray (..)
40− , SOP.P (..)
50+ , LibPQ.Oid (..)
41 -- * Type families
51 -- * Type families
42 , LabelsPG
52 , LabelsPG
43 , DimPG
53 , DimPG
44 , FixPG
54 , FixPG
45 , TupleOf
55 , TupleOf
46 , TupleCodeOf
56 , TupleCodeOf
57+ , RowOf
47 , ConstructorsOf
58 , ConstructorsOf
48 , ConstructorNameOf
59 , ConstructorNameOf
49 , ConstructorNamesOf
60 , ConstructorNamesOf
@@ -55,7 +66,6 @@ import Data.Int (Int16, Int32, Int64)
55import Data.Scientific (Scientific)
66import Data.Scientific (Scientific)
56import Data.Time (Day, DiffTime, LocalTime, TimeOfDay, TimeZone, UTCTime)
67import Data.Time (Day, DiffTime, LocalTime, TimeOfDay, TimeZone, UTCTime)
57import Data.Vector (Vector)
68import Data.Vector (Vector)
58−import Data.Word (Word16, Word32, Word64)
59import Data.UUID.Types (UUID)
69import Data.UUID.Types (UUID)
60import GHC.TypeLits
70import GHC.TypeLits
61import Network.IP.Addr (NetAddr, IP)
71import Network.IP.Addr (NetAddr, IP)
@@ -64,15 +74,19 @@ import qualified Data.ByteString.Lazy as Lazy (ByteString)
64import qualified Data.ByteString as Strict (ByteString)
74import qualified Data.ByteString as Strict (ByteString)
65import qualified Data.Text.Lazy as Lazy (Text)
75import qualified Data.Text.Lazy as Lazy (Text)
66import qualified Data.Text as Strict (Text)
76import qualified Data.Text as Strict (Text)
77+import qualified Database.PostgreSQL.LibPQ as LibPQ
67import qualified GHC.Generics as GHC
78import qualified GHC.Generics as GHC
68import qualified Generics.SOP as SOP
79import qualified Generics.SOP as SOP
69import qualified Generics.SOP.Record as SOP
80import qualified Generics.SOP.Record as SOP
70import qualified Generics.SOP.Type.Metadata as Type
81import qualified Generics.SOP.Type.Metadata as Type
71
82
72import Squeal.PostgreSQL.Alias
83import Squeal.PostgreSQL.Alias
73−import Squeal.PostgreSQL.List
74import Squeal.PostgreSQL.Schema
84import Squeal.PostgreSQL.Schema
75
85
86+-- $setup
87+-- >>> import Squeal.PostgreSQL
88+-- >>> import Data.Text (Text)
89+
76{- | The `PG` type family embeds a subset of Haskell types
90{- | The `PG` type family embeds a subset of Haskell types
77as Postgres types. As an open type family, `PG` is extensible.
91as Postgres types. As an open type family, `PG` is extensible.
78
92
@@ -85,30 +99,51 @@ PG LocalTime :: PGType
85>>> type instance PG MyDouble = 'PGfloat8
99>>> type instance PG MyDouble = 'PGfloat8
86-}
100-}
87type family PG (hask :: Type) :: PGType
101type family PG (hask :: Type) :: PGType
102+-- | `PGbool`
88type instance PG Bool = 'PGbool
103type instance PG Bool = 'PGbool
104+-- | `PGint2`
89type instance PG Int16 = 'PGint2
105type instance PG Int16 = 'PGint2
106+-- | `PGint4`
90type instance PG Int32 = 'PGint4
107type instance PG Int32 = 'PGint4
108+-- | `PGint8`
91type instance PG Int64 = 'PGint8
109type instance PG Int64 = 'PGint8
92−type instance PG Word16 = 'PGint2
110+-- | `PGint2`
93−type instance PG Word32 = 'PGint4
111+type instance PG LibPQ.Oid = 'PGoid
94−type instance PG Word64 = 'PGint8
112+-- | `PGnumeric`
95type instance PG Scientific = 'PGnumeric
113type instance PG Scientific = 'PGnumeric
114+-- | `PGfloat4`
96type instance PG Float = 'PGfloat4
115type instance PG Float = 'PGfloat4
116+-- | `PGfloat8`
97type instance PG Double = 'PGfloat8
117type instance PG Double = 'PGfloat8
118+-- | `PGchar` @1@
98type instance PG Char = 'PGchar 1
119type instance PG Char = 'PGchar 1
120+-- | `PGtext`
99type instance PG Strict.Text = 'PGtext
121type instance PG Strict.Text = 'PGtext
122+-- | `PGtext`
100type instance PG Lazy.Text = 'PGtext
123type instance PG Lazy.Text = 'PGtext
124+-- | `PGtext`
101type instance PG String = 'PGtext
125type instance PG String = 'PGtext
126+-- | `PGbytea`
102type instance PG Strict.ByteString = 'PGbytea
127type instance PG Strict.ByteString = 'PGbytea
128+-- | `PGbytea`
103type instance PG Lazy.ByteString = 'PGbytea
129type instance PG Lazy.ByteString = 'PGbytea
130+-- | `PGtimestamp`
104type instance PG LocalTime = 'PGtimestamp
131type instance PG LocalTime = 'PGtimestamp
132+-- | `PGtimestamptz`
105type instance PG UTCTime = 'PGtimestamptz
133type instance PG UTCTime = 'PGtimestamptz
134+-- | `PGdate`
106type instance PG Day = 'PGdate
135type instance PG Day = 'PGdate
136+-- | `PGtime`
107type instance PG TimeOfDay = 'PGtime
137type instance PG TimeOfDay = 'PGtime
138+-- | `PGtimetz`
108type instance PG (TimeOfDay, TimeZone) = 'PGtimetz
139type instance PG (TimeOfDay, TimeZone) = 'PGtimetz
140+-- | `PGinterval`
109type instance PG DiffTime = 'PGinterval
141type instance PG DiffTime = 'PGinterval
142+-- | `PGuuid`
110type instance PG UUID = 'PGuuid
143type instance PG UUID = 'PGuuid
144+-- | `PGinet`
111type instance PG (NetAddr IP) = 'PGinet
145type instance PG (NetAddr IP) = 'PGinet
146+-- | `PGjson`
112type instance PG Value = 'PGjson
147type instance PG Value = 'PGjson
113
148
114{-| The `LabelsPG` type family calculates the constructors of a
149{-| The `LabelsPG` type family calculates the constructors of a
@@ -129,7 +164,7 @@ type family LabelsPG (hask :: Type) :: [Type.ConstructorName] where
129`RowPG` turns a Haskell `Type` into a `RowType`.
164`RowPG` turns a Haskell `Type` into a `RowType`.
130
165
131`RowPG` may be applied to normal Haskell record types provided they
166`RowPG` may be applied to normal Haskell record types provided they
132−have the `SOP.Generic` and `SOP.HasDatatypeInfo` instances;
167+have `SOP.Generic` and `SOP.HasDatatypeInfo` instances;
133
168
134>>> data Person = Person { name :: Strict.Text, age :: Int32 } deriving GHC.Generic
169>>> data Person = Person { name :: Strict.Text, age :: Int32 } deriving GHC.Generic
135>>> instance SOP.Generic Person
170>>> instance SOP.Generic Person
@@ -137,84 +172,22 @@ have the `SOP.Generic` and `SOP.HasDatatypeInfo` instances;
137>>> :kind! RowPG Person
172>>> :kind! RowPG Person
138RowPG Person :: [(Symbol, NullityType)]
173RowPG Person :: [(Symbol, NullityType)]
139= '["name" ::: 'NotNull 'PGtext, "age" ::: 'NotNull 'PGint4]
174= '["name" ::: 'NotNull 'PGtext, "age" ::: 'NotNull 'PGint4]
140−
141−Or to tuples of `SOP.P` types;
142−
143−>>> :kind! RowPG (SOP.P ("id" ::: Int32), SOP.P ("foreign_id" ::: Int32))
144−RowPG (SOP.P ("id" ::: Int32), SOP.P ("foreign_id" ::: Int32)) :: [(Symbol,
145− NullityType)]
146−= '[ '("id", 'NotNull 'PGint4), "foreign_id" ::: 'NotNull 'PGint4]
147−
148−Or to tuples which mix `SOP.P` types and record types.
149−
150−>>> :kind! RowPG (SOP.P ("id" ::: Int32), Person, SOP.P ("foreign_id" ::: Int32))
151−RowPG (SOP.P ("id" ::: Int32), Person, SOP.P ("foreign_id" ::: Int32)) :: [(Symbol,
152− NullityType)]
153−= '[ '("id", 'NotNull 'PGint4), '("name", 'NotNull 'PGtext),
154− '("age", 'NotNull 'PGint4), "foreign_id" ::: 'NotNull 'PGint4]
155-}
175-}
156type family RowPG (hask :: Type) :: RowType where
176type family RowPG (hask :: Type) :: RowType where
157− RowPG (hask1, hask2) = Join (RowPG hask1) (RowPG hask2)
158− RowPG (hask1, hask2, hask3) =
159− Join (RowPG hask1) (RowPG (hask2, hask3))
160− RowPG (hask1, hask2, hask3, hask4) =
161− Join (RowPG hask1) (RowPG (hask2, hask3, hask4))
162− RowPG (hask1, hask2, hask3, hask4, hask5) =
163− Join (RowPG hask1) (RowPG (hask2, hask3, hask4, hask5))
164− RowPG (SOP.P (col ::: ty)) = '[col ::: NullPG ty]
165 RowPG hask = RowOf (SOP.RecordCodeOf hask)
177 RowPG hask = RowOf (SOP.RecordCodeOf hask)
166
178
179+-- | `RowOf` applies `NullPG` to the fields of a list.
167type family RowOf (record :: [(Symbol, Type)]) :: RowType where
180type family RowOf (record :: [(Symbol, Type)]) :: RowType where
168− 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
169 RowOf (col ::: ty ': record) = col ::: NullPG ty ': RowOf record
189 RowOf (col ::: ty ': record) = col ::: NullPG ty ': RowOf record
170−
190+ RowOf '[] = '[]
171−type family ColumnsOf (record :: [(Symbol, Type)]) :: ColumnsType where
172− ColumnsOf '[] = '[]
173− ColumnsOf (col ::: ty ': record) =
174− col ::: 'NoDef :=> NullPG ty ': ColumnsOf record
175−
176−{- |
177−`Entity` turns a Haskell `Type` into a `ColumnsType`.
178−
179−`Entity` may be applied to normal Haskell record types provided they
180−have the `SOP.Generic` and `SOP.HasDatatypeInfo` instances;
181−
182−>>> data Person = Person { name :: Strict.Text, age :: Int32 } deriving GHC.Generic
183−>>> instance SOP.Generic Person
184−>>> instance SOP.HasDatatypeInfo Person
185−>>> :kind! Entity Person
186−Entity Person :: [(Symbol, (ColumnConstraint, NullityType))]
187−= '["name" ::: ('NoDef :=> 'NotNull 'PGtext),
188− "age" ::: ('NoDef :=> 'NotNull 'PGint4)]
189−
190−Or to tuples of `SOP.P` types;
191−
192−>>> :kind! Entity (SOP.P ("id" ::: Int32), SOP.P ("foreign_id" ::: Int32))
193−Entity (SOP.P ("id" ::: Int32), SOP.P ("foreign_id" ::: Int32)) :: [(Symbol,
194− ColumnType)]
195−= '[ '("id", 'Def :=> 'NotNull 'PGint4),
196− "foreign_id" ::: ('Def :=> 'NotNull 'PGint4)]
197−
198−Or to tuples which mix `SOP.P` types and record types.
199−
200−>>> :kind! Entity (SOP.P ("id" ::: Int32), Person, SOP.P ("foreign_id" ::: Int32))
201−Entity (SOP.P ("id" ::: Int32), Person, SOP.P ("foreign_id" ::: Int32)) :: [(Symbol,
202− ColumnType)]
203−= '[ '("id", 'Def :=> 'NotNull 'PGint4),
204− '("name", 'NoDef :=> 'NotNull 'PGtext),
205− '("age", 'NoDef :=> 'NotNull 'PGint4),
206− "foreign_id" ::: ('Def :=> 'NotNull 'PGint4)]
207−-}
208−type family Entity (hask :: Type) :: ColumnsType where
209− Entity (hask1, hask2) = Join (Entity hask1) (Entity hask2)
210− Entity (hask1, hask2, hask3) =
211− Join (Entity hask1) (Entity (hask2, hask3))
212− Entity (hask1, hask2, hask3, hask4) =
213− Join (Entity hask1) (Entity (hask2, hask3, hask4))
214− Entity (hask1, hask2, hask3, hask4, hask5) =
215− Join (Entity hask1) (Entity (hask2, hask3, hask4, hask5))
216− Entity (SOP.P (col ::: ty)) = '[col ::: 'Def :=> NullPG ty]
217− Entity hask = ColumnsOf (SOP.RecordCodeOf hask)
218
191
219{- | `NullPG` turns a Haskell type into a `NullityType`.
192{- | `NullPG` turns a Haskell type into a `NullityType`.
220
193
@@ -239,10 +212,22 @@ TuplePG (Double, Maybe Char) :: [NullityType]
239type family TuplePG (hask :: Type) :: [NullityType] where
212type family TuplePG (hask :: Type) :: [NullityType] where
240 TuplePG hask = TupleOf (TupleCodeOf hask (SOP.Code hask))
213 TuplePG hask = TupleOf (TupleCodeOf hask (SOP.Code hask))
241
214
215+-- | `TupleOf` turns a list of Haskell `Type`s into a list of `NullityType`s.
242type family TupleOf (tuple :: [Type]) :: [NullityType] where
216type family TupleOf (tuple :: [Type]) :: [NullityType] where
243− 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
244 TupleOf (hask ': tuple) = NullPG hask ': TupleOf tuple
226 TupleOf (hask ': tuple) = NullPG hask ': TupleOf tuple
227+ TupleOf '[] = '[]
245
228
229+-- | `TupleCodeOf` takes the `SOP.Code` of a haskell `Type`
230+-- and if it's a simple product returns it, otherwise giving a `TypeError`.
246type family TupleCodeOf (hask :: Type) (code :: [[Type]]) :: [Type] where
231type family TupleCodeOf (hask :: Type) (code :: [[Type]]) :: [Type] where
247 TupleCodeOf hask '[tuple] = tuple
232 TupleCodeOf hask '[tuple] = tuple
248 TupleCodeOf hask '[] =
233 TupleCodeOf hask '[] =
@@ -283,6 +268,7 @@ type family ConstructorNamesOf (constructors :: [Type.ConstructorInfo])
283 ConstructorNamesOf (constructor ': constructors) =
268 ConstructorNamesOf (constructor ': constructors) =
284 ConstructorNameOf constructor ': ConstructorNamesOf constructors
269 ConstructorNameOf constructor ': ConstructorNamesOf constructors
285
270
271+-- | `DimPG` turns Haskell nested homogeneous tuples into a list of lengths.
286type family DimPG (hask :: Type) :: [Nat] where
272type family DimPG (hask :: Type) :: [Nat] where
287 DimPG (x,x) = 2 ': DimPG x
273 DimPG (x,x) = 2 ': DimPG x
288 DimPG (x,x,x) = 3 ': DimPG x
274 DimPG (x,x,x) = 3 ': DimPG x
@@ -295,6 +281,7 @@ type family DimPG (hask :: Type) :: [Nat] where
295 DimPG (x,x,x,x,x,x,x,x,x,x) = 10 ': DimPG x
281 DimPG (x,x,x,x,x,x,x,x,x,x) = 10 ': DimPG x
296 DimPG x = '[]
282 DimPG x = '[]
297
283
284+-- | `FixPG` extracts `NullPG` of the base type of nested homogeneous tuples.
298type family FixPG (hask :: Type) :: NullityType where
285type family FixPG (hask :: Type) :: NullityType where
299 FixPG (x,x) = FixPG x
286 FixPG (x,x) = FixPG x
300 FixPG (x,x,x) = FixPG x
287 FixPG (x,x,x) = FixPG x
@@ -324,7 +311,7 @@ let
324>>> let input = Only (Money 20020)
311>>> let input = Only (Money 20020)
325
312
326>>> :{
313>>> :{
327−void . withConnection "host=localhost port=5432 dbname=exampledb" $ do
314+withConnection "host=localhost port=5432 dbname=exampledb" $ do
328 result <- runQueryParams roundTrip input
315 result <- runQueryParams roundTrip input
329 Just output <- firstRow result
316 Just output <- firstRow result
330 liftIO . print $ input == output
317 liftIO . print $ input == output
@@ -332,47 +319,70 @@ void . withConnection "host=localhost port=5432 dbname=exampledb" $ do
332True
319True
333-}
320-}
334newtype Money = Money { cents :: Int64 }
321newtype Money = Money { cents :: Int64 }
335− deriving (Eq, Ord, Show, Read, GHC.Generic)
322+ deriving stock (Eq, Ord, Show, Read, GHC.Generic)
323+ deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
324+-- | `PGmoney`
336type instance PG Money = 'PGmoney
325type instance PG Money = 'PGmoney
337
326
338{- | The `Json` newtype is an indication that the Haskell
327{- | The `Json` newtype is an indication that the Haskell
339type it's applied to should be stored as a `PGjson`.
328type it's applied to should be stored as a `PGjson`.
340-}
329-}
341newtype Json hask = Json {getJson :: hask}
330newtype Json hask = Json {getJson :: hask}
342− deriving (Eq, Ord, Show, Read, GHC.Generic)
331+ deriving stock (Eq, Ord, Show, Read, GHC.Generic)
332+ deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
333+-- | `PGjson`
343type instance PG (Json hask) = 'PGjson
334type instance PG (Json hask) = 'PGjson
344
335
345{- | The `Jsonb` newtype is an indication that the Haskell
336{- | The `Jsonb` newtype is an indication that the Haskell
346type it's applied to should be stored as a `PGjsonb`.
337type it's applied to should be stored as a `PGjsonb`.
347-}
338-}
348newtype Jsonb hask = Jsonb {getJsonb :: hask}
339newtype Jsonb hask = Jsonb {getJsonb :: hask}
349− deriving (Eq, Ord, Show, Read, GHC.Generic)
340+ deriving stock (Eq, Ord, Show, Read, GHC.Generic)
341+ deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
342+-- | `PGjsonb`
350type instance PG (Jsonb hask) = 'PGjsonb
343type instance PG (Jsonb hask) = 'PGjsonb
351
344
352{- | The `Composite` newtype is an indication that the Haskell
345{- | The `Composite` newtype is an indication that the Haskell
353type it's applied to should be stored as a `PGcomposite`.
346type it's applied to should be stored as a `PGcomposite`.
354-}
347-}
355newtype Composite record = Composite {getComposite :: record}
348newtype Composite record = Composite {getComposite :: record}
356− deriving (Eq, Ord, Show, Read, GHC.Generic)
349+ deriving stock (Eq, Ord, Show, Read, GHC.Generic)
350+ deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
351+-- | `PGcomposite` @(@`RowPG` @hask)@
357type instance PG (Composite hask) = 'PGcomposite (RowPG hask)
352type instance PG (Composite hask) = 'PGcomposite (RowPG hask)
358
353
359{- | The `Enumerated` newtype is an indication that the Haskell
354{- | The `Enumerated` newtype is an indication that the Haskell
360type it's applied to should be stored as a `PGenum`.
355type it's applied to should be stored as a `PGenum`.
361-}
356-}
362newtype Enumerated enum = Enumerated {getEnumerated :: enum}
357newtype 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)
360+-- | `PGenum` @(@`LabelsPG` @hask)@
364type instance PG (Enumerated hask) = 'PGenum (LabelsPG hask)
361type instance PG (Enumerated hask) = 'PGenum (LabelsPG hask)
365
362
366{- | The `VarArray` newtype is an indication that the Haskell
363{- | The `VarArray` newtype is an indication that the Haskell
367type it's applied to should be stored as a `PGvararray`.
364type it's applied to should be stored as a `PGvararray`.
365+
366+>>> :kind! PG (VarArray (Vector Double))
367+PG (VarArray (Vector Double)) :: PGType
368+= 'PGvararray ('NotNull 'PGfloat8)
368-}
369-}
369newtype VarArray arr = VarArray {getVarArray :: arr}
370newtype VarArray arr = VarArray {getVarArray :: arr}
370− deriving (Eq, Ord, Show, Read, GHC.Generic)
371+ deriving stock (Eq, Ord, Show, Read, GHC.Generic)
372+ deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
373+-- | `PGvararray` @(@`NullPG` @hask)@
371type instance PG (VarArray (Vector hask)) = 'PGvararray (NullPG hask)
374type instance PG (VarArray (Vector hask)) = 'PGvararray (NullPG hask)
375+type instance PG (VarArray [hask]) = 'PGvararray (NullPG hask)
372
376
373{- | The `FixArray` newtype is an indication that the Haskell
377{- | The `FixArray` newtype is an indication that the Haskell
374type it's applied to should be stored as a `PGfixarray`.
378type it's applied to should be stored as a `PGfixarray`.
379+
380+>>> :kind! PG (FixArray ((Double, Double), (Double, Double)))
381+PG (FixArray ((Double, Double), (Double, Double))) :: PGType
382+= 'PGfixarray '[2, 2] ('NotNull 'PGfloat8)
375-}
383-}
376newtype FixArray arr = FixArray {getFixArray :: arr}
384newtype FixArray arr = FixArray {getFixArray :: arr}
377− deriving (Eq, Ord, Show, Read, GHC.Generic)
385+ deriving stock (Eq, Ord, Show, Read, GHC.Generic)
386+ deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
387+-- | `PGfixarray` @(@`DimPG` @hask) (@`FixPG` @hask)@
378−type instance PG (FixArray x) = 'PGfixarray (DimPG x) (FixPG x)
388+type instance PG (FixArray hask) = 'PGfixarray (DimPG hask) (FixPG hask)
squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs+96−40
@@ -64,17 +64,21 @@ module Squeal.PostgreSQL.PQ
64 , resultErrorCode
64 , resultErrorCode
65 -- * Exceptions
65 -- * Exceptions
66 , SquealException (..)
66 , SquealException (..)
67+ , PQState (..)
68+ , okResult
67 , catchSqueal
69 , catchSqueal
68 , handleSqueal
70 , handleSqueal
71+ , trySqueal
69 ) where
72 ) where
70
73
71import Control.Exception (Exception, throw)
74import Control.Exception (Exception, throw)
72import Control.Monad.Except
75import Control.Monad.Except
73import Control.Monad.Morph
76import Control.Monad.Morph
74−import UnliftIO (MonadUnliftIO (..), bracket, catch, handle)
77+import UnliftIO (MonadUnliftIO (..), bracket, catch, handle, try)
75import Data.ByteString (ByteString)
78import Data.ByteString (ByteString)
76import Data.Foldable
79import Data.Foldable
77import Data.Function ((&))
80import Data.Function ((&))
81+import Data.Functor ((<&>))
78import Data.Kind
82import Data.Kind
79import Data.Text (pack, Text)
83import Data.Text (pack, Text)
80import Data.Traversable
84import Data.Traversable
@@ -83,6 +87,7 @@ import PostgreSQL.Binary.Encoding (encodingBytes)
83
87
84import qualified Control.Monad.Fail as Fail
88import qualified Control.Monad.Fail as Fail
85import qualified Database.PostgreSQL.LibPQ as LibPQ
89import qualified Database.PostgreSQL.LibPQ as LibPQ
90+import qualified PostgreSQL.Binary.Encoding as Encoding
86
91
87import Squeal.PostgreSQL.Binary
92import Squeal.PostgreSQL.Binary
88import Squeal.PostgreSQL.Definition
93import Squeal.PostgreSQL.Definition
@@ -243,13 +248,16 @@ class IndexedMonadTransPQ pq where
243 -> x -> pq schemas0 schemas2 m z
248 -> x -> pq schemas0 schemas2 m z
244 pqAndThen g f x = pqBind g (f x)
249 pqAndThen g f x = pqBind g (f x)
245
250
246− -- | Run a `Definition` with `LibPQ.exec`, we expect that libpq obeys the law
251+ -- | Run a `Definition` with `LibPQ.exec`.
247 --
252 --
253+ -- It should be functorial in effect.
254+ --
255+ -- @define id = return ()@
248− -- @define statement1 & pqThen (define statement2) = define (statement1 >>> statement2)@
256+ -- @define (statement1 >>> statement2) = define statement1 & pqThen (define statement2)@
249 define
257 define
250 :: MonadIO io
258 :: MonadIO io
251 => Definition schemas0 schemas1
259 => Definition schemas0 schemas1
252− -> pq schemas0 schemas1 io (K LibPQ.Result '[])
260+ -> pq schemas0 schemas1 io ()
253
261
254instance IndexedMonadTransPQ PQ where
262instance IndexedMonadTransPQ PQ where
255
263
@@ -267,7 +275,7 @@ instance IndexedMonadTransPQ PQ where
267 case resultMaybe of
275 case resultMaybe of
268 Nothing -> throw $ ResultException
276 Nothing -> throw $ ResultException
269 "define: LibPQ.exec returned no results"
277 "define: LibPQ.exec returned no results"
270− Just result -> return $ K (K result)
278+ Just result -> K <$> okResult_ result
271
279
272{- | `MonadPQ` is an @mtl@ style constraint, similar to
280{- | `MonadPQ` is an @mtl@ style constraint, similar to
273`Control.Monad.State.Class.MonadState`, for using `Database.PostgreSQL.LibPQ` to
281`Control.Monad.State.Class.MonadState`, for using `Database.PostgreSQL.LibPQ` to
@@ -276,8 +284,12 @@ instance IndexedMonadTransPQ PQ where
276 with a `ToParams` constraint. It calls `LibPQ.execParams` and
284 with a `ToParams` constraint. It calls `LibPQ.execParams` and
277 doesn't afraid of anything.
285 doesn't afraid of anything.
278
286
287+* `manipulateParams_` is like `manipulateParams` for a returning-free statement.
288+
279* `manipulate` is like `manipulateParams` for a parameter-free statement.
289* `manipulate` is like `manipulateParams` for a parameter-free statement.
280
290
291+* `manipulate_` is like `manipulate` for a returning-free statement.
292+
281* `runQueryParams` is like `manipulateParams` for query statements.
293* `runQueryParams` is like `manipulateParams` for query statements.
282
294
283* `runQuery` is like `runQueryParams` for a parameter-free statement.
295* `runQuery` is like `runQueryParams` for a parameter-free statement.
@@ -291,7 +303,7 @@ instance IndexedMonadTransPQ PQ where
291* `forPrepared` is a flipped `traversePrepared`
303* `forPrepared` is a flipped `traversePrepared`
292
304
293* `traversePrepared_` is like `traversePrepared` but works on `Foldable`
305* `traversePrepared_` is like `traversePrepared` but works on `Foldable`
294− containers and returns unit.
306+ containers for a returning-free statement.
295
307
296* `forPrepared_` is a flipped `traversePrepared_`.
308* `forPrepared_` is a flipped `traversePrepared_`.
297
309
@@ -305,24 +317,34 @@ a default instance.
305-}
317-}
306class Monad pq => MonadPQ schemas pq | pq -> schemas where
318class Monad pq => MonadPQ schemas pq | pq -> schemas where
307 manipulateParams
319 manipulateParams
308− :: ToParams x params
320+ :: (ToParams x params, All OidOfParam params)
309 => Manipulation '[] schemas params ys
321 => Manipulation '[] schemas params ys
310 -- ^ `insertInto`, `update` or `deleteFrom`
322 -- ^ `insertInto`, `update` or `deleteFrom`
311 -> x -> pq (K LibPQ.Result ys)
323 -> x -> pq (K LibPQ.Result ys)
312 default manipulateParams
324 default manipulateParams
313 :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)
325 :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)
314− => ToParams x params
326+ => (ToParams x params, All OidOfParam params)
315 => Manipulation '[] schemas params ys
327 => Manipulation '[] schemas params ys
316 -- ^ `insertInto`, `update` or `deleteFrom`
328 -- ^ `insertInto`, `update` or `deleteFrom`
317 -> x -> pq (K LibPQ.Result ys)
329 -> x -> pq (K LibPQ.Result ys)
318 manipulateParams manipulation params = lift $
330 manipulateParams manipulation params = lift $
319 manipulateParams manipulation params
331 manipulateParams manipulation params
320
332
333+ manipulateParams_
334+ :: (ToParams x params, All OidOfParam params)
335+ => Manipulation '[] schemas params '[]
336+ -- ^ `insertInto`, `update` or `deleteFrom`
337+ -> x -> pq ()
338+ manipulateParams_ q x = void $ manipulateParams q x
339+
321 manipulate :: Manipulation '[] schemas '[] ys -> pq (K LibPQ.Result ys)
340 manipulate :: Manipulation '[] schemas '[] ys -> pq (K LibPQ.Result ys)
322 manipulate statement = manipulateParams statement ()
341 manipulate statement = manipulateParams statement ()
323
342
343+ manipulate_ :: Manipulation '[] schemas '[] '[] -> pq ()
344+ manipulate_ = void . manipulate
345+
324 runQueryParams
346 runQueryParams
325− :: ToParams x params
347+ :: (ToParams x params, All OidOfParam params)
326 => Query '[] '[] schemas params ys
348 => Query '[] '[] schemas params ys
327 -- ^ `select` and friends
349 -- ^ `select` and friends
328 -> x -> pq (K LibPQ.Result ys)
350 -> x -> pq (K LibPQ.Result ys)
@@ -335,19 +357,19 @@ class Monad pq => MonadPQ schemas pq | pq -> schemas where
335 runQuery q = runQueryParams q ()
357 runQuery q = runQueryParams q ()
336
358
337 traversePrepared
359 traversePrepared
338− :: (ToParams x params, Traversable list)
360+ :: (ToParams x params, Traversable list, All OidOfParam params)
339 => Manipulation '[] schemas params ys
361 => Manipulation '[] schemas params ys
340 -- ^ `insertInto`, `update`, or `deleteFrom`, and friends
362 -- ^ `insertInto`, `update`, or `deleteFrom`, and friends
341 -> list x -> pq (list (K LibPQ.Result ys))
363 -> list x -> pq (list (K LibPQ.Result ys))
342 default traversePrepared
364 default traversePrepared
343 :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)
365 :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)
344− => (ToParams x params, Traversable list)
366+ => (ToParams x params, Traversable list, All OidOfParam params)
345 => Manipulation '[] schemas params ys -> list x -> pq (list (K LibPQ.Result ys))
367 => Manipulation '[] schemas params ys -> list x -> pq (list (K LibPQ.Result ys))
346 traversePrepared manipulation params = lift $
368 traversePrepared manipulation params = lift $
347 traversePrepared manipulation params
369 traversePrepared manipulation params
348
370
349 forPrepared
371 forPrepared
350− :: (ToParams x params, Traversable list)
372+ :: (ToParams x params, Traversable list, All OidOfParam params)
351 => list x
373 => list x
352 -> Manipulation '[] schemas params ys
374 -> Manipulation '[] schemas params ys
353 -- ^ `insertInto`, `update` or `deleteFrom`
375 -- ^ `insertInto`, `update` or `deleteFrom`
@@ -355,13 +377,13 @@ class Monad pq => MonadPQ schemas pq | pq -> schemas where
355 forPrepared = flip traversePrepared
377 forPrepared = flip traversePrepared
356
378
357 traversePrepared_
379 traversePrepared_
358− :: (ToParams x params, Foldable list)
380+ :: (ToParams x params, Foldable list, All OidOfParam params)
359 => Manipulation '[] schemas params '[]
381 => Manipulation '[] schemas params '[]
360 -- ^ `insertInto`, `update` or `deleteFrom`
382 -- ^ `insertInto`, `update` or `deleteFrom`
361 -> list x -> pq ()
383 -> list x -> pq ()
362 default traversePrepared_
384 default traversePrepared_
363 :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)
385 :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)
364− => (ToParams x params, Foldable list)
386+ => (ToParams x params, Foldable list, All OidOfParam params)
365 => Manipulation '[] schemas params '[]
387 => Manipulation '[] schemas params '[]
366 -- ^ `insertInto`, `update` or `deleteFrom`
388 -- ^ `insertInto`, `update` or `deleteFrom`
367 -> list x -> pq ()
389 -> list x -> pq ()
@@ -369,7 +391,7 @@ class Monad pq => MonadPQ schemas pq | pq -> schemas where
369 traversePrepared_ manipulation params
391 traversePrepared_ manipulation params
370
392
371 forPrepared_
393 forPrepared_
372− :: (ToParams x params, Foldable list)
394+ :: (ToParams x params, Foldable list, All OidOfParam params)
373 => list x
395 => list x
374 -> Manipulation '[] schemas params '[]
396 -> Manipulation '[] schemas params '[]
375 -- ^ `insertInto`, `update` or `deleteFrom`
397 -- ^ `insertInto`, `update` or `deleteFrom`
@@ -389,54 +411,76 @@ instance (MonadIO io, schemas0 ~ schemas, schemas1 ~ schemas)
389 (UnsafeManipulation q :: Manipulation '[] schemas ps ys) (params :: x) =
411 (UnsafeManipulation q :: Manipulation '[] schemas ps ys) (params :: x) =
390 PQ $ \ (K conn) -> do
412 PQ $ \ (K conn) -> do
391 let
413 let
392− toParam' encoding =
414+ paramSet
415+ :: forall param. OidOfParam param
416+ => K (Maybe Encoding.Encoding) param
417+ -> K (Maybe (LibPQ.Oid, ByteString, LibPQ.Format)) param
418+ paramSet (K maybeEncoding) = K $
419+ maybeEncoding <&> \encoding ->
393− (LibPQ.invalidOid, encodingBytes encoding, LibPQ.Binary)
420+ (oidOfParam @param, encodingBytes encoding, LibPQ.Binary)
421+ params'
422+ = hcollapse
423+ . hcmap (Proxy @OidOfParam) paramSet
394− params' = fmap (fmap toParam') (hcollapse (toParams @x @ps params))
424+ $ toParams @x @ps params
395 q' = q <> ";"
425 q' = q <> ";"
396 resultMaybe <- liftIO $ LibPQ.execParams conn q' params' LibPQ.Binary
426 resultMaybe <- liftIO $ LibPQ.execParams conn q' params' LibPQ.Binary
397 case resultMaybe of
427 case resultMaybe of
398 Nothing -> throw $ ResultException
428 Nothing -> throw $ ResultException
399 "manipulateParams: LibPQ.execParams returned no results"
429 "manipulateParams: LibPQ.execParams returned no results"
400 Just result -> do
430 Just result -> do
401− tryResult result
431+ okResult_ result
402 return $ K (K result)
432 return $ K (K result)
403
433
404 traversePrepared
434 traversePrepared
405 (UnsafeManipulation q :: Manipulation '[] schemas xs ys) (list :: list x) =
435 (UnsafeManipulation q :: Manipulation '[] schemas xs ys) (list :: list x) =
406 PQ $ \ (K conn) -> liftIO $ do
436 PQ $ \ (K conn) -> liftIO $ do
437+ let
407− let temp = "temporary_statement"
438+ temp = "temporary_statement"
439+ paramOid :: forall p. OidOfParam p => K LibPQ.Oid p
440+ paramOid = K (oidOfParam @p)
441+ paramOids :: NP (K LibPQ.Oid) xs
442+ paramOids = hcpure (Proxy @OidOfParam) paramOid
443+ paramOids' :: [LibPQ.Oid]
444+ paramOids' = hcollapse paramOids
408− prepResultMaybe <- LibPQ.prepare conn temp q Nothing
445+ prepResultMaybe <- LibPQ.prepare conn temp q (Just paramOids')
409 case prepResultMaybe of
446 case prepResultMaybe of
410 Nothing -> throw $ ResultException
447 Nothing -> throw $ ResultException
411 "traversePrepared: LibPQ.prepare returned no results"
448 "traversePrepared: LibPQ.prepare returned no results"
412− Just prepResult -> tryResult prepResult
449+ Just prepResult -> okResult_ prepResult
413 results <- for list $ \ params -> do
450 results <- for list $ \ params -> do
414 let
451 let
415− toParam' encoding = (encodingBytes encoding,LibPQ.Binary)
452+ toParam' encoding = (encodingBytes encoding, LibPQ.Binary)
416 params' = fmap (fmap toParam') (hcollapse (toParams @x @xs params))
453 params' = fmap (fmap toParam') (hcollapse (toParams @x @xs params))
417 resultMaybe <- LibPQ.execPrepared conn temp params' LibPQ.Binary
454 resultMaybe <- LibPQ.execPrepared conn temp params' LibPQ.Binary
418 case resultMaybe of
455 case resultMaybe of
419 Nothing -> throw $ ResultException
456 Nothing -> throw $ ResultException
420 "traversePrepared: LibPQ.execParams returned no results"
457 "traversePrepared: LibPQ.execParams returned no results"
421 Just result -> do
458 Just result -> do
422− tryResult result
459+ okResult_ result
423 return $ K result
460 return $ K result
424 deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")
461 deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")
425 case deallocResultMaybe of
462 case deallocResultMaybe of
426 Nothing -> throw $ ResultException
463 Nothing -> throw $ ResultException
427 "traversePrepared: LibPQ.exec DEALLOCATE returned no results"
464 "traversePrepared: LibPQ.exec DEALLOCATE returned no results"
428− Just deallocResult -> tryResult deallocResult
465+ Just deallocResult -> okResult_ deallocResult
429 return (K results)
466 return (K results)
430
467
431 traversePrepared_
468 traversePrepared_
432 (UnsafeManipulation q :: Manipulation '[] schemas xs '[]) (list :: list x) =
469 (UnsafeManipulation q :: Manipulation '[] schemas xs '[]) (list :: list x) =
433 PQ $ \ (K conn) -> liftIO $ do
470 PQ $ \ (K conn) -> liftIO $ do
471+ let
434− let temp = "temporary_statement"
472+ temp = "temporary_statement"
473+ paramOid :: forall p. OidOfParam p => K LibPQ.Oid p
474+ paramOid = K (oidOfParam @p)
475+ paramOids :: NP (K LibPQ.Oid) xs
476+ paramOids = hcpure (Proxy @OidOfParam) paramOid
477+ paramOids' :: [LibPQ.Oid]
478+ paramOids' = hcollapse paramOids
435− prepResultMaybe <- LibPQ.prepare conn temp q Nothing
479+ prepResultMaybe <- LibPQ.prepare conn temp q (Just paramOids')
436 case prepResultMaybe of
480 case prepResultMaybe of
437 Nothing -> throw $ ResultException
481 Nothing -> throw $ ResultException
438 "traversePrepared_: LibPQ.prepare returned no results"
482 "traversePrepared_: LibPQ.prepare returned no results"
439− Just prepResult -> tryResult prepResult
483+ Just prepResult -> okResult_ prepResult
440 for_ list $ \ params -> do
484 for_ list $ \ params -> do
441 let
485 let
442 toParam' encoding = (encodingBytes encoding, LibPQ.Binary)
486 toParam' encoding = (encodingBytes encoding, LibPQ.Binary)
@@ -445,12 +489,12 @@ instance (MonadIO io, schemas0 ~ schemas, schemas1 ~ schemas)
445 case resultMaybe of
489 case resultMaybe of
446 Nothing -> throw $ ResultException
490 Nothing -> throw $ ResultException
447 "traversePrepared_: LibPQ.execParams returned no results"
491 "traversePrepared_: LibPQ.execParams returned no results"
448− Just result -> tryResult result
492+ Just result -> okResult_ result
449 deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")
493 deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")
450 case deallocResultMaybe of
494 case deallocResultMaybe of
451 Nothing -> throw $ ResultException
495 Nothing -> throw $ ResultException
452 "traversePrepared: LibPQ.exec DEALLOCATE returned no results"
496 "traversePrepared: LibPQ.exec DEALLOCATE returned no results"
453− Just deallocResult -> tryResult deallocResult
497+ Just deallocResult -> okResult_ deallocResult
454 return (K ())
498 return (K ())
455
499
456 liftPQ pq = PQ $ \ (K conn) -> do
500 liftPQ pq = PQ $ \ (K conn) -> do
@@ -613,24 +657,24 @@ resultErrorCode
613 -> io (Maybe ByteString)
657 -> io (Maybe ByteString)
614resultErrorCode = liftResult (flip LibPQ.resultErrorField LibPQ.DiagSqlstate)
658resultErrorCode = liftResult (flip LibPQ.resultErrorField LibPQ.DiagSqlstate)
615
659
616−-- | `Exception`s that can be thrown by Squeal.
660+-- | the state of LibPQ
617−data SquealException
661+data PQState = PQState
618− = PQException
619 { sqlExecStatus :: LibPQ.ExecStatus
662 { sqlExecStatus :: LibPQ.ExecStatus
620 , sqlStateCode :: Maybe ByteString
663 , sqlStateCode :: Maybe ByteString
621 -- ^ https://www.postgresql.org/docs/current/static/errcodes-appendix.html
664 -- ^ https://www.postgresql.org/docs/current/static/errcodes-appendix.html
622 , sqlErrorMessage :: Maybe ByteString
665 , sqlErrorMessage :: Maybe ByteString
623− }
666+ } deriving (Eq, Show)
667+
668+-- | `Exception`s that can be thrown by Squeal.
669+data SquealException
670+ = PQException PQState
624 | ResultException Text
671 | ResultException Text
625 | ParseException Text
672 | ParseException Text
626 deriving (Eq, Show)
673 deriving (Eq, Show)
627instance Exception SquealException
674instance Exception SquealException
628
675
629−tryResult
630− :: MonadIO io
631− => LibPQ.Result
676+okResult_ :: MonadIO io => LibPQ.Result -> io ()
632− -> io ()
633−tryResult result = liftIO $ do
677+okResult_ result = liftIO $ do
634 status <- LibPQ.resultStatus result
678 status <- LibPQ.resultStatus result
635 case status of
679 case status of
636 LibPQ.CommandOk -> return ()
680 LibPQ.CommandOk -> return ()
@@ -638,7 +682,12 @@ tryResult result = liftIO $ do
638 _ -> do
682 _ -> do
639 stateCode <- LibPQ.resultErrorField result LibPQ.DiagSqlstate
683 stateCode <- LibPQ.resultErrorField result LibPQ.DiagSqlstate
640 msg <- LibPQ.resultErrorMessage result
684 msg <- LibPQ.resultErrorMessage result
641− throw $ PQException status stateCode msg
685+ throw . PQException $ PQState status stateCode msg
686+
687+-- | Check if a `LibPQ.Result`'s status is either `LibPQ.CommandOk`
688+-- or `LibPQ.TuplesOk` otherwise `throw` a `PQException`.
689+okResult :: MonadIO io => K LibPQ.Result row -> io ()
690+okResult = okResult_ . unK
642
691
643-- | Catch `SquealException`s.
692-- | Catch `SquealException`s.
644catchSqueal
693catchSqueal
@@ -654,3 +703,10 @@ handleSqueal
654 => (SquealException -> io a) -- ^ handler
703 => (SquealException -> io a) -- ^ handler
655 -> io a -> io a
704 -> io a -> io a
656handleSqueal = handle
705handleSqueal = 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 @@
1{-|
1{-|
2−Module: Squeal.PostgreSQL.Definition
2+Module: Squeal.PostgreSQL.Pool
3−Description: Pooled connections
3+Description: Connection pools
4Copyright: (c) Eitan Chatav, 2017
4Copyright: (c) Eitan Chatav, 2017
5Maintainer: eitan@morphism.tech
5Maintainer: eitan@morphism.tech
6Stability: experimental
6Stability: experimental
7
7
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
9-}
31-}
10
32
11{-# LANGUAGE
33{-# LANGUAGE
@@ -23,51 +45,19 @@ A `MonadPQ` for pooled connections.
23
45
24module Squeal.PostgreSQL.Pool
46module Squeal.PostgreSQL.Pool
25 ( -- * Pools
47 ( -- * Pools
26− PoolPQ (..)
48+ Pool
27 , createConnectionPool
49 , createConnectionPool
28− , Pool
50+ , usingConnectionPool
29− , destroyAllResources
51+ , destroyConnectionPool
30 ) where
52 ) where
31
53
32−import Control.Monad.Trans
33import Data.ByteString
54import Data.ByteString
34import Data.Time
55import Data.Time
35−import Generics.SOP (K(..))
56+import Generics.SOP (K(..), unK)
36import UnliftIO (MonadUnliftIO (..))
57import UnliftIO (MonadUnliftIO (..))
37import UnliftIO.Pool (Pool, createPool, destroyAllResources, withResource)
58import UnliftIO.Pool (Pool, createPool, destroyAllResources, withResource)
38
59
39−import qualified Control.Monad.Fail as Fail
40−
41import Squeal.PostgreSQL.PQ
60import 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
71
61
72-- | Create a striped pool of connections.
62-- | Create a striped pool of connections.
73-- 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.
63-- 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
92createConnectionPool conninfo stripes idle maxResrc =
82createConnectionPool conninfo stripes idle maxResrc =
93 createPool (connectdb conninfo) finish stripes idle maxResrc
83 createPool (connectdb conninfo) finish stripes idle maxResrc
94
84
95−-- | `Applicative` instance for `PoolPQ`.
85+{-|
96−instance Monad m => Applicative (PoolPQ schemas m) where
86+Temporarily take a connection from a `Pool`, perform an action with it,
97− pure x = PoolPQ $ \ _ -> pure x
87+and return it to the pool afterwards.
98− PoolPQ f <*> PoolPQ x = PoolPQ $ \ pool -> do
88+
99− f' <- f pool
89+If the pool has an idle connection available, it is used immediately.
100− x' <- x pool
90+Otherwise, if the maximum number of connections has not yet been reached,
101− return $ f' x'
91+a new connection is created and used.
102−
92+If the maximum number of connections has been reached, this function blocks
103−-- | `Monad` instance for `PoolPQ`.
93+until a connection becomes available.
104−instance Monad m => Monad (PoolPQ schemas m) where
94+-}
105− return = pure
95+usingConnectionPool
106− PoolPQ x >>= f = PoolPQ $ \ pool -> do
96+ :: MonadUnliftIO io
107− x' <- x pool
97+ => Pool (K Connection schemas) -- ^ pool
108− runPoolPQ (f x') pool
98+ -> PQ schemas schemas io x -- ^ session
109−
99+ -> io x
110−-- | `Fail.MonadFail` instance for `PoolPQ`.
100+usingConnectionPool pool (PQ session) = unK <$> withResource pool session
111−instance Monad m => Fail.MonadFail (PoolPQ schemas m) where
101+
112− fail = Fail.fail
102+{- |
113−
103+Destroy all connections in all stripes in the pool.
114−-- | `MonadTrans` instance for `PoolPQ`.
104+Note that this will ignore any exceptions in the destroy function.
115−instance MonadTrans (PoolPQ schemas) where
105+
116− lift m = PoolPQ $ \ _pool -> m
106+This function is useful when you detect that all connections
117−
107+in the pool are broken. For example after a database has been
118−-- | `MonadPQ` instance for `PoolPQ`.
108+restarted all connections opened before the restart will be broken.
119−instance MonadUnliftIO io => MonadPQ schemas (PoolPQ schemas io) where
109+In that case it's better to close those connections so that
120− manipulateParams manipulation params = PoolPQ $ \ pool -> do
110+`usingConnectionPool` won't take a broken connection from the pool
121− withResource pool $ \ conn -> do
111+but will open a new connection instead.
122− (K result :: K (K Result ys) schemas) <- flip unPQ conn $
112+
123− manipulateParams manipulation params
113+Another use-case for this function is that when you know you are done
124− return result
114+with the pool you can destroy all idle connections immediately
125− traversePrepared manipulation params = PoolPQ $ \ pool ->
115+instead of waiting on the garbage collector to destroy them,
126− withResource pool $ \ conn -> do
116+thus freeing up those connections sooner.
127− (K result :: K (list (K Result ys)) schemas) <- flip unPQ conn $
117+-}
128− traversePrepared manipulation params
118+destroyConnectionPool
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)
119+ :: MonadUnliftIO io
148− => MonadUnliftIO (PoolPQ schemas m) where
120+ => Pool (K Connection schemas) -- ^ pool
149− withRunInIO
121+ -> io ()
150− :: ((forall a . PoolPQ schemas m a -> IO a) -> IO b)
122+destroyConnectionPool = destroyAllResources
151− -> PoolPQ schemas m b
152− withRunInIO inner = PoolPQ $ \pool ->
153− withRunInIO $ \(run :: (forall x . m x -> IO x)) ->
154− inner (\poolpq -> run $ runPoolPQ poolpq pool)
squeal-postgresql/src/Squeal/PostgreSQL/Query.hs+247−370
@@ -1,7 +1,7 @@
1{-|
1{-|
2Module: Squeal.PostgreSQL.Query
2Module: Squeal.PostgreSQL.Query
3Description: Squeal queries
3Description: Squeal queries
4−Copyright: (c) Eitan Chatav, 2017
4+Copyright: (c) Eitan Chatav, 2019
5Maintainer: eitan@morphism.tech
5Maintainer: eitan@morphism.tech
6Stability: experimental
6Stability: experimental
7
7
@@ -32,13 +32,15 @@ Squeal queries.
32
32
33module Squeal.PostgreSQL.Query
33module Squeal.PostgreSQL.Query
34 ( -- * Queries
34 ( -- * Queries
35+ Query_
35− Query (..)
36+ , Query (..)
36− , Query_
37 -- ** Select
37 -- ** Select
38 , select
38 , select
39 , select_
39 , select_
40 , selectDistinct
40 , selectDistinct
41 , selectDistinct_
41 , selectDistinct_
42+ , selectDistinctOn
43+ , selectDistinctOn_
42 , Selection (..)
44 , Selection (..)
43 -- ** Values
45 -- ** Values
44 , values
46 , values
@@ -53,23 +55,7 @@ module Squeal.PostgreSQL.Query
53 -- ** With
55 -- ** With
54 , With (..)
56 , With (..)
55 , CommonTableExpression (..)
57 , CommonTableExpression (..)
56− -- ** Unnest
58+ , withRecursive
57− , unnest
58− -- ** Json
59− , jsonEach
60− , jsonbEach
61− , jsonEachText
62− , jsonbEachText
63− , jsonObjectKeys
64− , jsonbObjectKeys
65− , jsonPopulateRecord
66− , jsonbPopulateRecord
67− , jsonPopulateRecordSet
68− , jsonbPopulateRecordSet
69− , jsonToRecord
70− , jsonbToRecord
71− , jsonToRecordSet
72− , jsonbToRecordSet
73 -- * Table Expressions
59 -- * Table Expressions
74 , TableExpression (..)
60 , TableExpression (..)
75 , from
61 , from
@@ -93,13 +79,6 @@ module Squeal.PostgreSQL.Query
93 , By (..)
79 , By (..)
94 , GroupByClause (..)
80 , GroupByClause (..)
95 , HavingClause (..)
81 , HavingClause (..)
96− -- * Subquery Expressions
97− , exists
98− , in_
99− , notIn
100− , Operator
101− , subAll
102− , subAny
103 ) where
82 ) where
104
83
105import Control.DeepSeq
84import Control.DeepSeq
@@ -124,10 +103,55 @@ import Squeal.PostgreSQL.Schema
124
103
125-- $setup
104-- $setup
126-- >>> import Squeal.PostgreSQL
105-- >>> 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
127
110
128{- |
111{- |
129−The process of retrieving or the command to retrieve data from a database
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+
130−is called a `Query`. Let's see some examples of queries.
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+:}
131
155
132simple query:
156simple query:
133
157
@@ -135,7 +159,7 @@ simple query:
135>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]
159>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]
136>>> :{
160>>> :{
137let
161let
138− query :: Query '[] '[] (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]
162+ query :: Query_ (Public Schema) () (Row Int32 Int32)
139 query = select Star (from (table #tab))
163 query = select Star (from (table #tab))
140in printSQL query
164in printSQL query
141:}
165:}
@@ -145,21 +169,21 @@ restricted query:
145
169
146>>> :{
170>>> :{
147let
171let
148− query :: Query '[] '[] (Public Schema) '[] '["sum" ::: 'NotNull 'PGint4, "col1" ::: 'NotNull 'PGint4]
172+ query :: Query_ (Public Schema) () (Row Int32 Int32)
149 query =
173 query =
150− select_ ((#col1 + #col2) `as` #sum :* #col1)
174+ select_ ((#col1 + #col2) `as` #col1 :* #col1 `as` #col2)
151 ( from (table #tab)
175 ( from (table #tab)
152 & where_ (#col1 .> #col2)
176 & where_ (#col1 .> #col2)
153 & where_ (#col2 .> 0) )
177 & where_ (#col2 .> 0) )
154in printSQL query
178in printSQL query
155:}
179:}
156−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))
157
181
158subquery:
182subquery:
159
183
160>>> :{
184>>> :{
161let
185let
162− query :: Query '[] '[] (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]
186+ query :: Query_ (Public Schema) () (Row Int32 Int32)
163 query = select Star (from (subquery (select Star (from (table #tab)) `as` #sub)))
187 query = select Star (from (subquery (select Star (from (table #tab)) `as` #sub)))
164in printSQL query
188in printSQL query
165:}
189:}
@@ -169,7 +193,7 @@ limits and offsets:
169
193
170>>> :{
194>>> :{
171let
195let
172− query :: Query '[] '[] (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]
196+ query :: Query_ (Public Schema) () (Row Int32 Int32)
173 query = select Star (from (table #tab) & limit 100 & offset 2 & limit 50 & offset 2)
197 query = select Star (from (table #tab) & limit 100 & offset 2 & limit 50 & offset 2)
174in printSQL query
198in printSQL query
175:}
199:}
@@ -179,7 +203,7 @@ parameterized query:
179
203
180>>> :{
204>>> :{
181let
205let
182− query :: Query '[] '[] (Public Schema) '[ 'NotNull 'PGint4] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]
206+ query :: Query_ (Public Schema) (Only Int32) (Row Int32 Int32)
183 query = select Star (from (table #tab) & where_ (#col1 .> param @1))
207 query = select Star (from (table #tab) & where_ (#col1 .> param @1))
184in printSQL query
208in printSQL query
185:}
209:}
@@ -189,21 +213,21 @@ aggregation query:
189
213
190>>> :{
214>>> :{
191let
215let
192− query :: Query '[] '[] (Public Schema) '[] '["sum" ::: 'NotNull 'PGint4, "col1" ::: 'NotNull 'PGint4 ]
216+ query :: Query_ (Public Schema) () (Row Int64 Int32)
193 query =
217 query =
194− select_ (sum_ (All #col2) `as` #sum :* #col1)
218+ select_ ((fromNull 0 (sum_ (All #col2))) `as` #col1 :* #col1 `as` #col2)
195 ( from (table (#tab `as` #table1))
219 ( from (table (#tab `as` #table1))
196 & groupBy #col1
220 & groupBy #col1
197− & having (#col1 + sum_ (Distinct #col2) .> 1) )
221+ & having (sum_ (Distinct #col2) .> 1) )
198in printSQL query
222in printSQL query
199:}
223:}
200−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)
201
225
202sorted query:
226sorted query:
203
227
204>>> :{
228>>> :{
205let
229let
206− query :: Query '[] '[] (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]
230+ query :: Query_ (Public Schema) () (Row Int32 Int32)
207 query = select Star (from (table #tab) & orderBy [#col1 & Asc])
231 query = select Star (from (table #tab) & orderBy [#col1 & Asc])
208in printSQL query
232in printSQL query
209:}
233:}
@@ -211,14 +235,12 @@ SELECT * FROM "tab" AS "tab" ORDER BY "col1" ASC
211
235
212joins:
236joins:
213
237
214−>>> :set -XFlexibleContexts
215>>> :{
238>>> :{
216type OrdersColumns =
239type OrdersColumns =
217 '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4
240 '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4
218− , "price" ::: 'NoDef :=> 'NotNull 'PGfloat4
241+ , "price" ::: 'NoDef :=> 'NotNull 'PGfloat4
219− , "customer_id" ::: 'NoDef :=> 'NotNull 'PGint4
242+ , "customer_id" ::: 'NoDef :=> 'NotNull 'PGint4
220− , "shipper_id" ::: 'NoDef :=> 'NotNull 'PGint4
243+ , "shipper_id" ::: 'NoDef :=> 'NotNull 'PGint4 ]
221− ]
222:}
244:}
223
245
224>>> :{
246>>> :{
@@ -234,22 +256,27 @@ type OrdersConstraints =
234>>> :{
256>>> :{
235type OrdersSchema =
257type OrdersSchema =
236 '[ "orders" ::: 'Table (OrdersConstraints :=> OrdersColumns)
258 '[ "orders" ::: 'Table (OrdersConstraints :=> OrdersColumns)
237− , "customers" ::: 'Table (CustomersConstraints :=> NamesColumns)
259+ , "customers" ::: 'Table (CustomersConstraints :=> NamesColumns)
238− , "shippers" ::: 'Table (ShippersConstraints :=> 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
239:}
271:}
240
272
241>>> :{
273>>> :{
242let
274let
243− query :: Query '[] '[] (Public OrdersSchema)
275+ query :: Query_ (Public OrdersSchema) () Order
244− '[]
245− '[ "order_price" ::: 'NotNull 'PGfloat4
246− , "customer_name" ::: 'NotNull 'PGtext
247− , "shipper_name" ::: 'NotNull 'PGtext
248− ]
249 query = select_
276 query = select_
250− ( #o ! #price `as` #order_price :*
277+ ( #o ! #price `as` #price :*
251− #c ! #name `as` #customer_name :*
278+ #c ! #name `as` #customerName :*
252− #s ! #name `as` #shipper_name )
279+ #s ! #name `as` #shipperName )
253 ( from (table (#orders `as` #o)
280 ( from (table (#orders `as` #o)
254 & innerJoin (table (#customers `as` #c))
281 & innerJoin (table (#customers `as` #c))
255 (#o ! #customer_id .== #c ! #id)
282 (#o ! #customer_id .== #c ! #id)
@@ -257,14 +284,16 @@ let
257 (#o ! #shipper_id .== #s ! #id)) )
284 (#o ! #shipper_id .== #s ! #id)) )
258in printSQL query
285in printSQL query
259:}
286:}
260−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")
261
288
262self-join:
289self-join:
263
290
264>>> :{
291>>> :{
265let
292let
266− query :: Query '[] '[] (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]
293+ query :: Query_ (Public Schema) () (Row Int32 Int32)
294+ query = select
295+ (#t1 & DotStar)
267− query = select (#t1 & DotStar) (from (table (#tab `as` #t1) & crossJoin (table (#tab `as` #t2))))
296+ (from (table (#tab `as` #t1) & crossJoin (table (#tab `as` #t2))))
268in printSQL query
297in printSQL query
269:}
298:}
270SELECT "t1".* FROM "tab" AS "t1" CROSS JOIN "tab" AS "t2"
299SELECT "t1".* FROM "tab" AS "t1" CROSS JOIN "tab" AS "t2"
@@ -273,17 +302,19 @@ value queries:
273
302
274>>> :{
303>>> :{
275let
304let
276− query :: Query '[] commons schemas '[] '["foo" ::: 'NotNull 'PGint2, "bar" ::: 'NotNull 'PGbool]
305+ query :: Query_ schemas () (Row String Bool)
277− query = values (1 `as` #foo :* true `as` #bar) [2 `as` #foo :* false `as` #bar]
306+ query = values
307+ ("true" `as` #col1 :* true `as` #col2)
308+ ["false" `as` #col1 :* false `as` #col2]
278in printSQL query
309in printSQL query
279:}
310:}
280−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")
281
312
282set operations:
313set operations:
283
314
284>>> :{
315>>> :{
285let
316let
286− query :: Query '[] '[] (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]
317+ query :: Query_ (Public Schema) () (Row Int32 Int32)
287 query = select Star (from (table #tab)) `unionAll` select Star (from (table #tab))
318 query = select Star (from (table #tab)) `unionAll` select Star (from (table #tab))
288in printSQL query
319in printSQL query
289:}
320:}
@@ -293,7 +324,7 @@ with queries:
293
324
294>>> :{
325>>> :{
295let
326let
296− query :: Query '[] '[] (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]
327+ query :: Query_ (Public Schema) () (Row Int32 Int32)
297 query = with (
328 query = with (
298 select Star (from (table #tab)) `as` #cte1 :>>
329 select Star (from (table #tab)) `as` #cte1 :>>
299 select Star (from (common #cte1)) `as` #cte2
330 select Star (from (common #cte1)) `as` #cte2
@@ -306,40 +337,35 @@ window function queries
306
337
307>>> :{
338>>> :{
308let
339let
309− query :: Query '[] '[] (Public Schema) '[] ["col1" ::: 'NotNull 'PGint4, "rank" ::: 'NotNull 'PGint8]
340+ query :: Query_ (Public Schema) () (Row Int32 Int64)
310 query = select
341 query = select
311− (#col1 & Also (rank `as` #rank `Over` (partitionBy #col1 & orderBy [#col2 & Asc])))
342+ (#col1 & Also (rank `as` #col2 `Over` (partitionBy #col1 & orderBy [#col2 & Asc])))
312 (from (table #tab))
343 (from (table #tab))
313in printSQL query
344in printSQL query
314:}
345:}
315−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"
316
347
317correlated subqueries
348correlated subqueries
318
349
319>>> :{
350>>> :{
320let
351let
321− query :: Query '[] '[] (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4]
352+ query :: Query_ (Public Schema) () (Only Int32)
322 query =
353 query =
323− select #col1 (from (table (#tab `as` #t1))
354+ select (#col1 `as` #fromOnly) (from (table (#tab `as` #t1))
324 & where_ (exists (
355 & where_ (exists (
325 select Star (from (table (#tab `as` #t2))
356 select Star (from (table (#tab `as` #t2))
326 & where_ (#t2 ! #col2 .== #t1 ! #col1)))))
357 & where_ (#t2 ! #col2 .== #t1 ! #col1)))))
327in printSQL query
358in printSQL query
328:}
359:}
329−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+
330-}
362-}
331−newtype Query
363+type family Query_
332− (outer :: FromType)
333− (commons :: FromType)
334 (schemas :: SchemasType)
364 (schemas :: SchemasType)
335− (params :: [NullityType])
365+ (parameters :: Type)
336− (row :: RowType)
366+ (row :: Type) where
337− = UnsafeQuery { renderQuery :: ByteString }
367+ Query_ schemas params row =
338− deriving (GHC.Generic,Show,Eq,Ord,NFData)
339−instance RenderSQL (Query outer commons schemas params row) where renderSQL = renderQuery
340−
341−type family Query_ (schemas :: SchemasType) (params :: Type) (row :: Type) where
342− Query_ schemas params row = Query '[] '[] schemas (TuplePG params) (RowPG row)
368+ Query '[] '[] schemas (TuplePG params) (RowPG row)
343
369
344-- | The results of two queries can be combined using the set operation
370-- | The results of two queries can be combined using the set operation
345-- `union`. Duplicate rows are eliminated.
371-- `union`. Duplicate rows are eliminated.
@@ -411,27 +437,40 @@ q1 `exceptAll` q2 = UnsafeQuery $
411SELECT queries
437SELECT queries
412-----------------------------------------}
438-----------------------------------------}
413
439
440+{- | The simplest kinds of `Selection` are `Star` and `DotStar` which
441+emits all columns that a `TableExpression` produces. A select `List`
442+is a list of `Expression`s. A `Selection` could be a list of
443+`WindowFunction`s `Over` `WindowDefinition`. `Additional` `Selection`s can
444+be selected with `Also`.
445+-}
414data Selection outer commons grp schemas params from row where
446data Selection outer commons grp schemas params from row where
415− List
416− :: SListI row
417− => NP (Aliased (Expression outer commons grp schemas params from)) row
418− -> Selection outer commons grp schemas params from row
419 Star
447 Star
420 :: HasUnique tab from row
448 :: HasUnique tab from row
421 => Selection outer commons 'Ungrouped schemas params from row
449 => Selection outer commons 'Ungrouped schemas params from row
450+ -- ^ `HasUnique` table in the `FromClause`
422 DotStar
451 DotStar
423 :: Has tab from row
452 :: Has tab from row
424 => Alias tab
453 => Alias tab
454+ -- ^ `Has` table with `Alias`
425 -> Selection outer commons 'Ungrouped schemas params from row
455 -> Selection outer commons 'Ungrouped schemas params from row
426− Also
456+ List
457+ :: SListI row
427− :: Selection outer commons grp schemas params from right
458+ => NP (Aliased (Expression outer commons grp schemas params from)) row
428− -> Selection outer commons grp schemas params from left
459+ -- ^ `NP` list of `Aliased` `Expression`s
429− -> Selection outer commons grp schemas params from (Join left right)
460+ -> Selection outer commons grp schemas params from row
430 Over
461 Over
431 :: SListI row
462 :: SListI row
432 => NP (Aliased (WindowFunction outer commons grp schemas params from)) row
463 => NP (Aliased (WindowFunction outer commons grp schemas params from)) row
464+ -- ^ `NP` list of `Aliased` `WindowFunction`s
433 -> WindowDefinition outer commons grp schemas params from
465 -> WindowDefinition outer commons grp schemas params from
434 -> Selection outer commons grp schemas params from row
466 -> Selection outer commons grp schemas params from row
467+ Also
468+ :: Selection outer commons grp schemas params from right
469+ -- ^ `Additional` `Selection`
470+ -> Selection outer commons grp schemas params from left
471+ -> Selection outer commons grp schemas params from (Join left right)
472+instance Additional (Selection outer commons grp schemas params from) where
473+ also = Also
435instance (KnownSymbol col, row ~ '[col ::: ty])
474instance (KnownSymbol col, row ~ '[col ::: ty])
436 => Aliasable col
475 => Aliasable col
437 (Expression outer commons grp schemas params from ty)
476 (Expression outer commons grp schemas params from ty)
@@ -491,7 +530,7 @@ instance IsString
491select
530select
492 :: (SListI row, row ~ (x ': xs))
531 :: (SListI row, row ~ (x ': xs))
493 => Selection outer commons grp schemas params from row
532 => Selection outer commons grp schemas params from row
494− -- ^ select list
533+ -- ^ selection
495 -> TableExpression outer commons grp schemas params from
534 -> TableExpression outer commons grp schemas params from
496 -- ^ intermediate virtual table
535 -- ^ intermediate virtual table
497 -> Query outer commons schemas params row
536 -> Query outer commons schemas params row
@@ -500,20 +539,24 @@ select selection tabexpr = UnsafeQuery $
500 <+> renderSQL selection
539 <+> renderSQL selection
501 <+> renderSQL tabexpr
540 <+> renderSQL tabexpr
502
541
542+-- | Like `select` but takes an `NP` list of `Expression`s instead
543+-- of a general `Selection`.
503select_
544select_
504 :: (SListI row, row ~ (x ': xs))
545 :: (SListI row, row ~ (x ': xs))
505 => NP (Aliased (Expression outer commons grp schemas params from)) row
546 => NP (Aliased (Expression outer commons grp schemas params from)) row
547+ -- ^ select list
506 -> TableExpression outer commons grp schemas params from
548 -> TableExpression outer commons grp schemas params from
549+ -- ^ intermediate virtual table
507 -> Query outer commons schemas params row
550 -> Query outer commons schemas params row
508−select_ list = select (List list)
551+select_ = select . List
509
552
510-- | After the select list has been processed, the result table can
553-- | After the select list has been processed, the result table can
511-- be subject to the elimination of duplicate rows using `selectDistinct`.
554-- be subject to the elimination of duplicate rows using `selectDistinct`.
512selectDistinct
555selectDistinct
513 :: (SListI columns, columns ~ (col ': cols))
556 :: (SListI columns, columns ~ (col ': cols))
514− => Selection outer commons 'Ungrouped schemas params from columns
557+ => Selection outer commons grp schemas params from columns
515− -- ^ select list
558+ -- ^ selection
516− -> TableExpression outer commons 'Ungrouped schemas params from
559+ -> TableExpression outer commons grp schemas params from
517 -- ^ intermediate virtual table
560 -- ^ intermediate virtual table
518 -> Query outer commons schemas params columns
561 -> Query outer commons schemas params columns
519selectDistinct selection tabexpr = UnsafeQuery $
562selectDistinct selection tabexpr = UnsafeQuery $
@@ -521,14 +564,65 @@ selectDistinct selection tabexpr = UnsafeQuery $
521 <+> renderSQL selection
564 <+> renderSQL selection
522 <+> renderSQL tabexpr
565 <+> renderSQL tabexpr
523
566
567+-- | Like `selectDistinct` but takes an `NP` list of `Expression`s instead
568+-- of a general `Selection`.
524selectDistinct_
569selectDistinct_
525 :: (SListI columns, columns ~ (col ': cols))
570 :: (SListI columns, columns ~ (col ': cols))
526− => NP (Aliased (Expression outer commons 'Ungrouped schemas params from)) columns
571+ => NP (Aliased (Expression outer commons grp schemas params from)) columns
527 -- ^ select list
572 -- ^ select list
528− -> TableExpression outer commons 'Ungrouped schemas params from
573+ -> TableExpression outer commons grp schemas params from
529 -- ^ intermediate virtual table
574 -- ^ intermediate virtual table
530 -> Query outer commons schemas params columns
575 -> Query outer commons schemas params columns
531−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
532
626
533-- | `values` computes a row value or set of row values
627-- | `values` computes a row value or set of row values
534-- specified by value expressions. It is most commonly used
628-- specified by value expressions. It is most commonly used
@@ -663,7 +757,7 @@ instance RenderSQL (TableExpression outer commons grp schemas params from) where
663from
757from
664 :: FromClause outer commons schemas params from -- ^ table reference
758 :: FromClause outer commons schemas params from -- ^ table reference
665 -> TableExpression outer commons 'Ungrouped schemas params from
759 -> TableExpression outer commons 'Ungrouped schemas params from
666−from tab = TableExpression tab [] NoGroups NoHaving [] [] []
760+from tab = TableExpression tab [] noGroups NoHaving [] [] []
667
761
668-- | A `where_` is an endomorphism of `TableExpression`s which adds a
762-- | A `where_` is an endomorphism of `TableExpression`s which adds a
669-- search condition to the `whereClause`.
763-- search condition to the `whereClause`.
@@ -684,7 +778,7 @@ groupBy
684groupBy bys rels = TableExpression
778groupBy bys rels = TableExpression
685 { fromClause = fromClause rels
779 { fromClause = fromClause rels
686 , whereClause = whereClause rels
780 , whereClause = whereClause rels
687− , groupByClause = Group bys
781+ , groupByClause = group bys
688 , havingClause = Having []
782 , havingClause = Having []
689 , orderByClause = []
783 , orderByClause = []
690 , limitClause = limitClause rels
784 , limitClause = limitClause rels
@@ -719,170 +813,6 @@ offset
719 -> TableExpression outer commons grp schemas params from
813 -> TableExpression outer commons grp schemas params from
720offset off rels = rels {offsetClause = off : offsetClause rels}
814offset off rels = rels {offsetClause = off : offsetClause rels}
721
815
722−{-----------------------------------------
723−JSON stuff
724−-----------------------------------------}
725−
726−unsafeSetOfFunction
727− :: ByteString
728− -> Expression outer commons 'Ungrouped schemas params '[] ty
729− -> FromClause outer commons schemas params from
730−unsafeSetOfFunction fun expr = UnsafeFromClause $
731− fun <> "(" <> renderSQL expr <> ")"
732−
733−-- | Expand an array to a set of rows
734−unnest
735− :: Expression outer commons 'Ungrouped schemas params '[] (nullity ('PGvararray ty))
736− -> FromClause outer commons schemas params '["unnest" ::: '["unnest" ::: ty]]
737−unnest = unsafeSetOfFunction "unnest"
738−
739−-- | Expands the outermost JSON object into a set of key/value pairs.
740−-- >>> import Data.Aeson
741−-- >>> printSQL (select Star (from (jsonEach (literal (Json (object ["a" .= "foo", "b" .= "bar"]))))))
742−-- SELECT * FROM json_each(('{"a":"foo","b":"bar"}' :: json))
743−jsonEach
744− :: Expression outer commons 'Ungrouped schemas params '[] (nullity 'PGjson) -- ^ json object
745− -> FromClause outer commons schemas params
746− '["json_each" ::: '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGjson]]
747−jsonEach = unsafeSetOfFunction "json_each"
748−
749−-- | Expands the outermost binary JSON object into a set of key/value pairs.
750−-- >>> import Data.Aeson
751−-- >>> printSQL (select Star (from (jsonbEach (literal (Jsonb (object ["a" .= "foo", "b" .= "bar"]))))))
752−-- SELECT * FROM jsonb_each(('{"a":"foo","b":"bar"}' :: jsonb))
753−jsonbEach
754− :: Expression outer commons 'Ungrouped schemas params '[] (nullity 'PGjsonb) -- ^ jsonb object
755− -> FromClause outer commons schemas params
756− '["jsonb_each" ::: '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGjson]]
757−jsonbEach = unsafeSetOfFunction "jsonb_each"
758−
759−-- | Expands the outermost JSON object into a set of key/value pairs.-- | Expands the outermost binary JSON object into a set of key/value pairs.
760−-- >>> import Data.Aeson
761−-- >>> printSQL (select Star (from (jsonEachText (literal (Json (object ["a" .= "foo", "b" .= "bar"]))))))
762−-- SELECT * FROM json_each_text(('{"a":"foo","b":"bar"}' :: json))
763−jsonEachText
764− :: Expression outer commons 'Ungrouped schemas params '[] (nullity 'PGjson) -- ^ json object
765− -> FromClause outer commons schemas params
766− '["json_each" ::: '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext]]
767−jsonEachText = unsafeSetOfFunction "json_each_text"
768−
769−-- | Expands the outermost binary JSON object into a set of key/value pairs.
770−-- >>> import Data.Aeson
771−-- >>> printSQL (select Star (from (jsonbEachText (literal (Jsonb (object ["a" .= "foo", "b" .= "bar"]))))))
772−-- SELECT * FROM jsonb_each_text(('{"a":"foo","b":"bar"}' :: jsonb))
773−jsonbEachText
774− :: Expression outer commons 'Ungrouped schemas params '[] (nullity 'PGjsonb) -- ^ jsonb object
775− -> FromClause outer commons schemas params
776− '["jsonb_each" ::: '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext]]
777−jsonbEachText = unsafeSetOfFunction "jsonb_each_text"
778−
779−-- | Returns set of keys in the outermost JSON object.
780−-- >>> import Data.Aeson
781−-- >>> printSQL (jsonObjectKeys (literal (Json (object ["a" .= "foo", "b" .= "bar"]))))
782−-- json_object_keys(('{"a":"foo","b":"bar"}' :: json))
783−jsonObjectKeys
784− :: Expression outer commons 'Ungrouped schemas params '[] (nullity 'PGjson) -- ^ json object
785− -> FromClause outer commons schemas params
786− '["json_object_keys" ::: '["json_object_keys" ::: 'NotNull 'PGtext]]
787−jsonObjectKeys = unsafeSetOfFunction "json_object_keys"
788−
789−-- | Returns set of keys in the outermost JSON object.
790−-- >>> import Data.Aeson
791−-- >>> printSQL (jsonbObjectKeys (literal (Jsonb (object ["a" .= "foo", "b" .= "bar"]))))
792−-- jsonb_object_keys(('{"a":"foo","b":"bar"}' :: jsonb))
793−jsonbObjectKeys
794− :: Expression outer commons 'Ungrouped schemas params '[] (nullity 'PGjsonb) -- ^ jsonb object
795− -> FromClause outer commons schemas params
796− '["jsonb_object_keys" ::: '["jsonb_object_keys" ::: 'NotNull 'PGtext]]
797−jsonbObjectKeys = unsafeSetOfFunction "jsonb_object_keys"
798−
799−unsafePopulateFunction
800− :: KnownSymbol fun
801− => Alias fun
802− -> TypeExpression schemas (nullity ('PGcomposite row))
803− -> Expression outer commons 'Ungrouped schemas params '[] ty
804− -> FromClause outer commons schemas params '[fun ::: row]
805−unsafePopulateFunction fun ty expr = UnsafeFromClause $ renderSQL fun
806− <> parenthesized ("null::" <> renderSQL ty <> ", " <> renderSQL expr)
807−
808−-- | Expands the JSON expression to a row whose columns match the record
809−-- type defined by the given table.
810−jsonPopulateRecord
811− :: TypeExpression schemas (nullity ('PGcomposite row)) -- ^ row type
812− -> Expression outer commons 'Ungrouped schemas params '[] (nullity 'PGjson) -- ^ json object
813− -> FromClause outer commons schemas params '["json_populate_record" ::: row]
814−jsonPopulateRecord = unsafePopulateFunction #json_populate_record
815−
816−-- | Expands the binary JSON expression to a row whose columns match the record
817−-- type defined by the given table.
818−jsonbPopulateRecord
819− :: TypeExpression schemas (nullity ('PGcomposite row)) -- ^ row type
820− -> Expression outer commons 'Ungrouped schemas params '[] (nullity 'PGjsonb) -- ^ jsonb object
821− -> FromClause outer commons schemas params '["jsonb_populate_record" ::: row]
822−jsonbPopulateRecord = unsafePopulateFunction #jsonb_populate_record
823−
824−-- | Expands the outermost array of objects in the given JSON expression to a
825−-- set of rows whose columns match the record type defined by the given table.
826−jsonPopulateRecordSet
827− :: TypeExpression schemas (nullity ('PGcomposite row)) -- ^ row type
828− -> Expression outer commons 'Ungrouped schemas params '[] (nullity 'PGjson) -- ^ json array
829− -> FromClause outer commons schemas params '["json_populate_record_set" ::: row]
830−jsonPopulateRecordSet = unsafePopulateFunction #json_populate_record_set
831−
832−-- | Expands the outermost array of objects in the given binary JSON expression
833−-- to a set of rows whose columns match the record type defined by the given
834−-- table.
835−jsonbPopulateRecordSet
836− :: TypeExpression schemas (nullity ('PGcomposite row)) -- ^ row type
837− -> Expression outer commons 'Ungrouped schemas params '[] (nullity 'PGjsonb) -- ^ jsonb array
838− -> FromClause outer commons schemas params '["jsonb_populate_record_set" ::: row]
839−jsonbPopulateRecordSet = unsafePopulateFunction #jsonb_populate_record_set
840−
841−unsafeRecordFunction
842− :: (SListI record, json `In` PGJsonType)
843− => ByteString
844− -> Expression outer commons 'Ungrouped schemas params '[] (nullity json)
845− -> Aliased (NP (Aliased (TypeExpression schemas))) (tab ::: record)
846− -> FromClause outer commons schemas params '[tab ::: record]
847−unsafeRecordFunction fun expr (types `As` tab) = UnsafeFromClause $
848− fun <> parenthesized (renderSQL expr) <+> "AS" <+> renderSQL tab
849− <> parenthesized (renderCommaSeparated renderTy types)
850− where
851− renderTy :: Aliased (TypeExpression schemas) ty -> ByteString
852− renderTy (ty `As` alias) = renderSQL alias <+> renderSQL ty
853−
854−-- | Builds an arbitrary record from a JSON object.
855−jsonToRecord
856− :: SListI record
857− => Expression outer commons 'Ungrouped schemas params '[] (nullity 'PGjson) -- ^ json object
858− -> Aliased (NP (Aliased (TypeExpression schemas))) (tab ::: record)
859− -> FromClause outer commons schemas params '[tab ::: record]
860−jsonToRecord = unsafeRecordFunction "json_to_record"
861−
862−-- | Builds an arbitrary record from a binary JSON object.
863−jsonbToRecord
864− :: SListI record
865− => Expression outer commons 'Ungrouped schemas params '[] (nullity 'PGjsonb) -- ^ jsonb object
866− -> Aliased (NP (Aliased (TypeExpression schemas))) (tab ::: record)
867− -> FromClause outer commons schemas params '[tab ::: record]
868−jsonbToRecord = unsafeRecordFunction "jsonb_to_record"
869−
870−-- | Builds an arbitrary set of records from a JSON array of objects.
871−jsonToRecordSet
872− :: SListI record
873− => Expression outer commons 'Ungrouped schemas params '[] (nullity 'PGjson) -- ^ json array
874− -> Aliased (NP (Aliased (TypeExpression schemas))) (tab ::: record)
875− -> FromClause outer commons schemas params '[tab ::: record]
876−jsonToRecordSet = unsafeRecordFunction "json_to_record_set"
877−
878−-- | Builds an arbitrary set of records from a binary JSON array of objects.
879−jsonbToRecordSet
880− :: SListI record
881− => Expression outer commons 'Ungrouped schemas params '[] (nullity 'PGjsonb) -- ^ jsonb array
882− -> Aliased (NP (Aliased (TypeExpression schemas))) (tab ::: record)
883− -> FromClause outer commons schemas params '[tab ::: record]
884−jsonbToRecordSet = unsafeRecordFunction "jsonb_to_record_set"
885−
886{-----------------------------------------
816{-----------------------------------------
887FROM clauses
817FROM clauses
888-----------------------------------------}
818-----------------------------------------}
@@ -909,7 +839,7 @@ table (tab `As` alias) = UnsafeFromClause $
909subquery
839subquery
910 :: Aliased (Query outer commons schemas params) query
840 :: Aliased (Query outer commons schemas params) query
911 -> FromClause outer commons schemas params '[query]
841 -> FromClause outer commons schemas params '[query]
912−subquery = UnsafeFromClause . renderAliased (parenthesized . renderQuery)
842+subquery = UnsafeFromClause . renderAliased (parenthesized . renderSQL)
913
843
914-- | `view` derives a table from a `View`.
844-- | `view` derives a table from a `View`.
915view
845view
@@ -927,11 +857,16 @@ common
927common (cte `As` alias) = UnsafeFromClause $
857common (cte `As` alias) = UnsafeFromClause $
928 renderSQL cte <+> "AS" <+> renderSQL alias
858 renderSQL cte <+> "AS" <+> renderSQL alias
929
859
860+instance Additional (FromClause outer commons schemas params) where
861+ also right left = UnsafeFromClause $
862+ renderSQL left <> ", " <> renderSQL right
863+
864+{- |
930−{- | @left & crossJoin right@. For every possible combination of rows from
865+@left & crossJoin right@. For every possible combination of rows from
931− @left@ and @right@ (i.e., a Cartesian product), the joined table will contain
866+@left@ and @right@ (i.e., a Cartesian product), the joined table will contain
932− a row consisting of all columns in @left@ followed by all columns in @right@.
867+a row consisting of all columns in @left@ followed by all columns in @right@.
933− If the tables have @n@ and @m@ rows respectively, the joined table will
868+If the tables have @n@ and @m@ rows respectively, the joined table will
934− have @n * m@ rows.
869+have @n * m@ rows.
935-}
870-}
936crossJoin
871crossJoin
937 :: FromClause outer commons schemas params right
872 :: FromClause outer commons schemas params right
@@ -1057,19 +992,20 @@ instance (Has rel rels cols, Has col cols ty, bys ~ '[ '(rel, col)])
1057-- done on @NoGroups@ while all output `Expression`s must be aggregated
992-- done on @NoGroups@ while all output `Expression`s must be aggregated
1058-- in @Group Nil@. In general, all output `Expression`s in the
993-- in @Group Nil@. In general, all output `Expression`s in the
1059-- complement of @bys@ must be aggregated in @Group bys@.
994-- complement of @bys@ must be aggregated in @Group bys@.
1060−data GroupByClause grp from where
995+newtype GroupByClause grp from = UnsafeGroupByClause
1061− NoGroups :: GroupByClause 'Ungrouped from
996+ { renderGroupByClause :: ByteString }
1062− Group
997+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
1063− :: SListI bys
1064− => NP (By from) bys
1065− -> GroupByClause ('Grouped bys) from
1066−
1067−-- | Renders a `GroupByClause`.
1068instance RenderSQL (GroupByClause grp from) where
998instance RenderSQL (GroupByClause grp from) where
1069− renderSQL = \case
999+ renderSQL = renderGroupByClause
1070− NoGroups -> ""
1000+noGroups :: GroupByClause 'Ungrouped from
1001+noGroups = UnsafeGroupByClause ""
1002+group
1003+ :: SListI bys
1004+ => NP (By from) bys
1005+ -> GroupByClause ('Grouped bys) from
1006+group bys = UnsafeGroupByClause $ case bys of
1071− Group Nil -> ""
1007+ Nil -> ""
1072− Group bys -> " GROUP BY" <+> renderCommaSeparated renderSQL bys
1008+ bys' -> " GROUP BY" <+> renderCommaSeparated renderSQL bys'
1073
1009
1074-- | A `HavingClause` is used to eliminate groups that are not of interest.
1010-- | A `HavingClause` is used to eliminate groups that are not of interest.
1075-- An `Ungrouped` `TableExpression` may only use `NoHaving` while a `Grouped`
1011-- An `Ungrouped` `TableExpression` may only use `NoHaving` while a `Grouped`
@@ -1092,90 +1028,6 @@ instance RenderSQL (HavingClause outer commons grp schemas params from) where
1092 Having conditions ->
1028 Having conditions ->
1093 " HAVING" <+> commaSeparated (renderSQL <$> conditions)
1029 " HAVING" <+> commaSeparated (renderSQL <$> conditions)
1094
1030
1095−{- |
1096−The argument of `exists` is an arbitrary subquery. The subquery is evaluated
1097−to determine whether it returns any rows. If it returns at least one row,
1098−the result of `exists` is `true`; if the subquery returns no rows,
1099−the result of `exists` is `false`.
1100−
1101−The subquery can refer to variables from the surrounding query,
1102−which will act as constants during any one evaluation of the subquery.
1103−
1104−The subquery will generally only be executed long enough to determine whether
1105−at least one row is returned, not all the way to completion.
1106−-}
1107−exists
1108− :: Query (Join outer from) commons schemas params row
1109− -> Condition outer commons grp schemas params from
1110−exists query = UnsafeExpression $ "EXISTS" <+> parenthesized (renderSQL query)
1111−
1112−{- |
1113−The right-hand side is a parenthesized subquery, which must return
1114−exactly one column. The left-hand expression is evaluated and compared to each
1115−row of the subquery result using the given `Operator`,
1116−which must yield a Boolean result. The result of `subAll` is `true`
1117−if all rows yield true (including the case where the subquery returns no rows).
1118−The result is `false` if any `false` result is found.
1119−The result is `null_` if no comparison with a subquery row returns `false`,
1120−and at least one comparison returns `null_`.
1121−
1122−>>> printSQL $ subAll true (.==) (values_ (true `as` #foo))
1123−(TRUE = ALL (SELECT * FROM (VALUES (TRUE)) AS t ("foo")))
1124−-}
1125−subAll
1126− :: Expression outer commons grp schemas params from ty1 -- ^ expression
1127− -> Operator ty1 ty2 ('Null 'PGbool) -- ^ operator
1128− -> Query (Join outer from) commons schemas params '[col ::: ty2] -- ^ subquery
1129− -> Condition outer commons grp schemas params from
1130−subAll expr (?) qry = expr ?
1131− (UnsafeExpression $ "ALL" <+> parenthesized (renderSQL qry))
1132−
1133−{- |
1134−The right-hand side is a parenthesized subquery, which must return exactly one column.
1135−The left-hand expression is evaluated and compared to each row of the subquery result
1136−using the given `Operator`, which must yield a Boolean result. The result of `subAny` is `true`
1137−if any `true` result is obtained. The result is `false` if no true result is found
1138−(including the case where the subquery returns no rows).
1139−
1140−>>> printSQL $ subAll "foo" like (values_ ("foobar" `as` #foo))
1141−(E'foo' LIKE ALL (SELECT * FROM (VALUES (E'foobar')) AS t ("foo")))
1142−-}
1143−subAny
1144− :: Expression outer commons grp schemas params from ty1 -- ^ expression
1145− -> Operator ty1 ty2 ('Null 'PGbool) -- ^ operator
1146− -> Query (Join outer from) commons schemas params '[col ::: ty2] -- ^ subquery
1147− -> Condition outer commons grp schemas params from
1148−subAny expr (?) qry = expr ?
1149− (UnsafeExpression $ "ANY" <+> parenthesized (renderSQL qry))
1150−
1151−{- |
1152−The result is `true` if the left-hand expression's result is equal
1153−to any of the right-hand expressions.
1154−
1155−>>> printSQL $ true `in_` [true, false, null_]
1156−TRUE IN (TRUE, FALSE, NULL)
1157−-}
1158−in_
1159− :: Expression outer commons grp schemas params from ty -- ^ expression
1160− -> [Expression outer commons grp schemas params from ty]
1161− -> Condition outer commons grp schemas params from
1162−expr `in_` exprs = UnsafeExpression $ renderSQL expr <+> "IN"
1163− <+> parenthesized (commaSeparated (renderSQL <$> exprs))
1164−
1165−{- |
1166−The result is `true` if the left-hand expression's result is not equal
1167−to any of the right-hand expressions.
1168−
1169−>>> printSQL $ true `notIn` [false, null_]
1170−TRUE NOT IN (FALSE, NULL)
1171−-}
1172−notIn
1173− :: Expression outer commons grp schemas params from ty -- ^ expression
1174− -> [Expression outer commons grp schemas params from ty]
1175− -> Condition outer commons grp schemas params from
1176−expr `notIn` exprs = UnsafeExpression $ renderSQL expr <+> "NOT IN"
1177− <+> parenthesized (commaSeparated (renderSQL <$> exprs))
1178−
1179-- | A `CommonTableExpression` is an auxiliary statement in a `with` clause.
1031-- | A `CommonTableExpression` is an auxiliary statement in a `with` clause.
1180data CommonTableExpression statement
1032data CommonTableExpression statement
1181 (schemas :: SchemasType)
1033 (schemas :: SchemasType)
@@ -1197,8 +1049,8 @@ instance
1197 , commons1 ~ (cte ::: common ': commons)
1049 , commons1 ~ (cte ::: common ': commons)
1198 ) => Aliasable cte
1050 ) => Aliasable cte
1199 (statement commons schemas params common)
1051 (statement commons schemas params common)
1200− (AlignedList (CommonTableExpression statement schemas params) commons commons1) where
1052+ (Path (CommonTableExpression statement schemas params) commons commons1) where
1201− statement `as` cte = single (statement `as` cte)
1053+ statement `as` cte = csingleton (statement `as` cte)
1202
1054
1203instance (forall c s p r. RenderSQL (statement c s p r)) => RenderSQL
1055instance (forall c s p r. RenderSQL (statement c s p r)) => RenderSQL
1204 (CommonTableExpression statement schemas params commons0 commons1) where
1056 (CommonTableExpression statement schemas params commons0 commons1) where
@@ -1210,7 +1062,7 @@ instance (forall c s p r. RenderSQL (statement c s p r)) => RenderSQL
1210-- defining temporary tables that exist just for one query.
1062-- defining temporary tables that exist just for one query.
1211class With statement where
1063class With statement where
1212 with
1064 with
1213− :: AlignedList (CommonTableExpression statement schemas params) commons0 commons1
1065+ :: Path (CommonTableExpression statement schemas params) commons0 commons1
1214 -- ^ common table expressions
1066 -- ^ common table expressions
1215 -> statement commons1 schemas params row
1067 -> statement commons1 schemas params row
1216 -- ^ larger query
1068 -- ^ larger query
@@ -1218,4 +1070,29 @@ class With statement where
1218instance With (Query outer) where
1070instance With (Query outer) where
1219 with Done query = query
1071 with Done query = query
1220 with ctes query = UnsafeQuery $
1072 with ctes query = UnsafeQuery $
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)
1221− "WITH" <+> renderSQL ctes <+> renderSQL query
1098+ <+> renderSQL query
squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs+164−62
@@ -1,11 +1,11 @@
1{-|
1{-|
2Module: Squeal.PostgreSQL.Schema
2Module: Squeal.PostgreSQL.Schema
3Description: Embedding of PostgreSQL type and alias system
3Description: Embedding of PostgreSQL type and alias system
4−Copyright: (c) Eitan Chatav, 2017
4+Copyright: (c) Eitan Chatav, 2019
5Maintainer: eitan@morphism.tech
5Maintainer: eitan@morphism.tech
6Stability: experimental
6Stability: experimental
7
7
8−This module provides a type-level DSL for kinds of Postgres types,
8+`Squeal.PostgreSQL.Schema` provides a type-level DSL for kinds of Postgres types,
9tables, schema, constraints, aliases, enumerated labels, and groupings.
9tables, schema, constraints, aliases, enumerated labels, and groupings.
10It also defines useful type families to operate on these. Finally,
10It also defines useful type families to operate on these. Finally,
11it defines an embedding of Haskell types into Postgres types.
11it defines an embedding of Haskell types into Postgres types.
@@ -44,6 +44,10 @@ module Squeal.PostgreSQL.Schema
44 , ColumnsType
44 , ColumnsType
45 , TableType
45 , TableType
46 , SchemumType (..)
46 , SchemumType (..)
47+ , IndexType (..)
48+ , FunctionType
49+ , OperatorType (..)
50+ , ReturnsType (..)
47 , SchemaType
51 , SchemaType
48 , SchemasType
52 , SchemasType
49 , Public
53 , Public
@@ -58,15 +62,21 @@ module Squeal.PostgreSQL.Schema
58 , PGlabel (..)
62 , PGlabel (..)
59 -- * Data Definitions
63 -- * Data Definitions
60 , Create
64 , Create
65+ , CreateIfNotExists
66+ , CreateOrReplace
61 , Drop
67 , Drop
68+ , DropSchemum
69+ , DropIfExists
70+ , DropSchemumIfExists
62 , Alter
71 , Alter
72+ , AlterIfExists
63 , Rename
73 , Rename
74+ , RenameIfExists
64 , ConstraintInvolves
75 , ConstraintInvolves
65 , DropIfConstraintsInvolve
76 , DropIfConstraintsInvolve
66 , IsNotElem
77 , IsNotElem
67 , AllUnique
78 , AllUnique
68 -- * Type Classifications
79 -- * Type Classifications
69− , HasOid (..)
70 , PGNum
80 , PGNum
71 , PGIntegral
81 , PGIntegral
72 , PGFloating
82 , PGFloating
@@ -90,17 +100,19 @@ import Control.Category
90import Data.Kind
100import Data.Kind
91import Data.Monoid hiding (All)
101import Data.Monoid hiding (All)
92import Data.Type.Bool
102import Data.Type.Bool
93−import Data.Word (Word32)
94import Generics.SOP
103import Generics.SOP
95import GHC.TypeLits
104import GHC.TypeLits
96import Prelude hiding (id, (.))
105import Prelude hiding (id, (.))
97
106
98import Squeal.PostgreSQL.Alias
107import Squeal.PostgreSQL.Alias
108+import Squeal.PostgreSQL.List
99import Squeal.PostgreSQL.Render
109import Squeal.PostgreSQL.Render
100
110
111+-- $setup
112+-- >>> import Squeal.PostgreSQL
113+
101-- | `PGType` is the promoted datakind of PostgreSQL types.
114-- | `PGType` is the promoted datakind of PostgreSQL types.
102--
115--
103−-- >>> import Squeal.PostgreSQL.Schema
104-- >>> :kind 'PGbool
116-- >>> :kind 'PGbool
105-- 'PGbool :: PGType
117-- 'PGbool :: PGType
106data PGType
118data PGType
@@ -131,37 +143,11 @@ data PGType
131 | PGenum [Symbol] -- ^ enumerated (enum) types are data types that comprise a static, ordered set of values.
143 | PGenum [Symbol] -- ^ enumerated (enum) types are data types that comprise a static, ordered set of values.
132 | 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.
144 | PGcomposite RowType -- ^ a composite type represents the structure of a row or record; it is essentially just a list of field names and their data types.
133 | 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.
145 | PGtsvector -- ^ A tsvector value is a sorted list of distinct lexemes, which are words that have been normalized to merge different variants of the same word.
134− | 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).
135 | UnsafePGType Symbol -- ^ an escape hatch for unsupported PostgreSQL types
149 | UnsafePGType Symbol -- ^ an escape hatch for unsupported PostgreSQL types
136
150
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−
165-- | `NullityType` encodes the potential presence or definite absence of a
151-- | `NullityType` encodes the potential presence or definite absence of a
166-- @NULL@ allowing operations which are sensitive to such to be well typed.
152-- @NULL@ allowing operations which are sensitive to such to be well typed.
167--
153--
@@ -274,9 +260,19 @@ type FromType = [(Symbol,RowType)]
274
260
275-- | `ColumnsToRow` removes column constraints.
261-- | `ColumnsToRow` removes column constraints.
276type family ColumnsToRow (columns :: ColumnsType) :: RowType where
262type family ColumnsToRow (columns :: ColumnsType) :: RowType where
277− ColumnsToRow '[] = '[]
263+ ColumnsToRow (column ::: _ :=> ty ': column1 ::: _ :=> ty1 ': column2 ::: _ :=> ty2 ': column3 ::: _ :=> ty3 ': column4 ::: _ :=> ty4 ': column5 ::: _ :=> ty5 ': columns) =
278− ColumnsToRow (column ::: constraint :=> ty ': columns) =
264+ column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': column3 ::: ty3 ': column4 ::: ty4 ': column5 ::: ty5 ': ColumnsToRow columns
265+ ColumnsToRow (column ::: _ :=> ty ': column1 ::: _ :=> ty1 ': column2 ::: _ :=> ty2 ': column3 ::: _ :=> ty3 ': column4 ::: _ :=> ty4 ': columns) =
266+ column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': column3 ::: ty3 ': column4 ::: ty4 ': ColumnsToRow columns
267+ ColumnsToRow (column ::: _ :=> ty ': column1 ::: _ :=> ty1 ': column2 ::: _ :=> ty2 ': column3 ::: _ :=> ty3 ': columns) =
268+ column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': column3 ::: ty3 ': ColumnsToRow columns
269+ ColumnsToRow (column ::: _ :=> ty ': column1 ::: _ :=> ty1 ': column2 ::: _ :=> ty2 ': columns) =
270+ column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': ColumnsToRow columns
271+ ColumnsToRow (column ::: _ :=> ty ': column1 ::: _ :=> ty1 ': columns) =
272+ column ::: ty ': column1 ::: ty1 ': ColumnsToRow columns
273+ ColumnsToRow (column ::: _ :=> ty ': columns) =
279 column ::: ty ': ColumnsToRow columns
274 column ::: ty ': ColumnsToRow columns
275+ ColumnsToRow '[] = '[]
280
276
281-- | `TableToColumns` removes table constraints.
277-- | `TableToColumns` removes table constraints.
282type family TableToColumns (table :: TableType) :: ColumnsType where
278type family TableToColumns (table :: TableType) :: ColumnsType where
@@ -286,15 +282,6 @@ type family TableToColumns (table :: TableType) :: ColumnsType where
286type family TableToRow (table :: TableType) :: RowType where
282type family TableToRow (table :: TableType) :: RowType where
287 TableToRow tab = ColumnsToRow (TableToColumns tab)
283 TableToRow tab = ColumnsToRow (TableToColumns tab)
288
284
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−
298-- | Numeric Postgres types.
285-- | Numeric Postgres types.
299type PGNum =
286type PGNum =
300 '[ 'PGint2, 'PGint4, 'PGint8, 'PGnumeric, 'PGfloat4, 'PGfloat8]
287 '[ 'PGint2, 'PGint4, 'PGint8, 'PGnumeric, 'PGfloat4, 'PGfloat8]
@@ -318,14 +305,24 @@ instance ty0 ~ ty1 => SamePGType
318
305
319-- | `AllNotNull` is a constraint that proves a `ColumnsType` has no @NULL@s.
306-- | `AllNotNull` is a constraint that proves a `ColumnsType` has no @NULL@s.
320type family AllNotNull (columns :: ColumnsType) :: Constraint where
307type family AllNotNull (columns :: ColumnsType) :: Constraint where
308+ AllNotNull (_ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': columns) = AllNotNull columns
309+ AllNotNull (_ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': columns) = AllNotNull columns
310+ AllNotNull (_ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': columns) = AllNotNull columns
311+ AllNotNull (_ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': columns) = AllNotNull columns
312+ AllNotNull (_ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': columns) = AllNotNull columns
313+ AllNotNull (_ ::: _ :=> 'NotNull _ ': columns) = AllNotNull columns
321 AllNotNull '[] = ()
314 AllNotNull '[] = ()
322− AllNotNull (column ::: def :=> 'NotNull ty ': columns) = AllNotNull columns
323
315
324-- | `NotAllNull` is a constraint that proves a `ColumnsType` has some
316-- | `NotAllNull` is a constraint that proves a `ColumnsType` has some
325-- @NOT NULL@.
317-- @NOT NULL@.
326type family NotAllNull (columns :: ColumnsType) :: Constraint where
318type family NotAllNull (columns :: ColumnsType) :: Constraint where
327− NotAllNull (column ::: def :=> 'NotNull ty ': columns) = ()
319+ NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()
320+ NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()
321+ NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()
322+ NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()
323+ NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()
324+ NotAllNull (_ ::: _ :=> 'NotNull _ ': _) = ()
328− NotAllNull (column ::: def :=> 'Null ty ': columns) = NotAllNull columns
325+ NotAllNull (_ ::: _ :=> 'Null _ ': columns) = NotAllNull columns
329
326
330-- | `NullifyType` is an idempotent that nullifies a `NullityType`.
327-- | `NullifyType` is an idempotent that nullifies a `NullityType`.
331type family NullifyType (ty :: NullityType) :: NullityType where
328type family NullifyType (ty :: NullityType) :: NullityType where
@@ -334,17 +331,37 @@ type family NullifyType (ty :: NullityType) :: NullityType where
334
331
335-- | `NullifyRow` is an idempotent that nullifies a `RowType`.
332-- | `NullifyRow` is an idempotent that nullifies a `RowType`.
336type family NullifyRow (columns :: RowType) :: RowType where
333type 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
338 NullifyRow (column ::: ty ': columns) =
344 NullifyRow (column ::: ty ': columns) =
339 column ::: NullifyType ty ': NullifyRow columns
345 column ::: NullifyType ty ': NullifyRow columns
346+ NullifyRow '[] = '[]
340
347
341-- | `NullifyFrom` is an idempotent that nullifies a `FromType`
348-- | `NullifyFrom` is an idempotent that nullifies a `FromType`
342-- used to nullify the left or right hand side of an outer join
349-- used to nullify the left or right hand side of an outer join
343-- in a `Squeal.PostgreSQL.Query.FromClause`.
350-- in a `Squeal.PostgreSQL.Query.FromClause`.
344type family NullifyFrom (tables :: FromType) :: FromType where
351type 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
346 NullifyFrom (table ::: columns ': tables) =
362 NullifyFrom (table ::: columns ': tables) =
347 table ::: NullifyRow columns ': NullifyFrom tables
363 table ::: NullifyRow columns ': NullifyFrom tables
364+ NullifyFrom '[] = '[]
348
365
349-- | @Create alias x xs@ adds @alias ::: x@ to the end of @xs@ and is used in
366-- | @Create alias x xs@ adds @alias ::: x@ to the end of @xs@ and is used in
350-- `Squeal.PostgreSQL.Definition.createTable` statements and in @ALTER TABLE@
367-- `Squeal.PostgreSQL.Definition.createTable` statements and in @ALTER TABLE@
@@ -354,30 +371,101 @@ type family Create alias x xs where
354 Create alias x (alias ::: y ': xs) = TypeError
371 Create alias x (alias ::: y ': xs) = TypeError
355 ('Text "Create: alias "
372 ('Text "Create: alias "
356 ':<>: 'ShowType alias
373 ':<>: 'ShowType alias
357− ':<>: 'Text "already in use")
374+ ':<>: 'Text "already exists")
358 Create alias y (x ': xs) = x ': Create alias y xs
375 Create alias y (x ': xs) = x ': Create alias y xs
359
376
377+type family CreateIfNotExists alias x xs where
378+ CreateIfNotExists alias x '[] = '[alias ::: x]
379+ CreateIfNotExists alias x (alias ::: y ': xs) = alias ::: y ': xs
380+ CreateIfNotExists alias y (x ': xs) = x ': CreateIfNotExists alias y xs
381+
382+type family CreateOrReplace alias x xs where
383+ CreateOrReplace alias x '[] = '[alias ::: x]
384+ CreateOrReplace alias x (alias ::: x ': xs) = alias ::: x ': xs
385+ CreateOrReplace alias x (alias ::: y ': xs) = TypeError
386+ ('Text "CreateOrReplace: expected type "
387+ ':<>: 'ShowType x
388+ ':<>: 'Text " but alias "
389+ ':<>: 'ShowType alias
390+ ':<>: 'Text " has type "
391+ ':<>: 'ShowType y)
392+ CreateOrReplace alias y (x ': xs) = x ': CreateOrReplace alias y xs
393+
360-- | @Drop alias xs@ removes the type associated with @alias@ in @xs@
394-- | @Drop alias xs@ removes the type associated with @alias@ in @xs@
361-- and is used in `Squeal.PostgreSQL.Definition.dropTable` statements
395-- and is used in `Squeal.PostgreSQL.Definition.dropTable` statements
362-- and in @ALTER TABLE@ `Squeal.PostgreSQL.Definition.dropColumn` statements.
396-- and in @ALTER TABLE@ `Squeal.PostgreSQL.Definition.dropColumn` statements.
363type family Drop alias xs where
397type family Drop alias xs where
398+ Drop alias '[] = TypeError
399+ ('Text "Drop: alias "
400+ ':<>: 'ShowType alias
401+ ':<>: 'Text " does not exist" )
364− Drop alias ((alias ::: x) ': xs) = xs
402+ Drop alias (alias ::: x ': xs) = xs
365 Drop alias (x ': xs) = x ': Drop alias xs
403 Drop alias (x ': xs) = x ': Drop alias xs
366
404
405+type family DropSchemum alias sch xs where
406+ DropSchemum alias sch '[] = TypeError
407+ ('Text "DropSchemum: alias "
408+ ':<>: 'ShowType alias
409+ ':<>: 'Text " does not exist" )
410+ DropSchemum alias sch (alias ::: sch x ': xs) = xs
411+ DropSchemum alias sch0 (alias ::: sch1 x ': xs) = TypeError
412+ ('Text "DropSchemum: expected schemum "
413+ ':<>: 'ShowType sch0
414+ ':<>: 'Text " but alias "
415+ ':<>: 'ShowType alias
416+ ':<>: 'Text " has schemum "
417+ ':<>: 'ShowType sch1)
418+ DropSchemum alias sch (x ': xs) = x ': DropSchemum alias sch xs
419+
420+type family DropIfExists alias xs where
421+ DropIfExists alias '[] = '[]
422+ DropIfExists alias (alias ::: x ': xs) = xs
423+ DropIfExists alias (x ': xs) = x ': DropIfExists alias xs
424+
425+type family DropSchemumIfExists alias sch xs where
426+ DropSchemumIfExists alias sch '[] = '[]
427+ DropSchemumIfExists alias sch (alias ::: sch x ': xs) = xs
428+ DropSchemumIfExists alias sch0 (alias ::: sch1 x ': xs) = TypeError
429+ ('Text "DropSchemumIfExists: expected schemum "
430+ ':<>: 'ShowType sch1
431+ ':<>: 'Text " but alias "
432+ ':<>: 'ShowType alias
433+ ':<>: 'Text " has schemum "
434+ ':<>: 'ShowType sch0)
435+ DropSchemumIfExists alias sch (x ': xs) = x ': DropSchemumIfExists alias sch xs
436+
367-- | @Alter alias x xs@ replaces the type associated with an @alias@ in @xs@
437-- | @Alter alias x xs@ replaces the type associated with an @alias@ in @xs@
368-- with the type @x@ and is used in `Squeal.PostgreSQL.Definition.alterTable`
438-- with the type @x@ and is used in `Squeal.PostgreSQL.Definition.alterTable`
369-- and `Squeal.PostgreSQL.Definition.alterColumn`.
439-- and `Squeal.PostgreSQL.Definition.alterColumn`.
370type family Alter alias x xs where
440type family Alter alias x xs where
441+ Alter alias x '[] = TypeError
442+ ('Text "Alter: alias "
443+ ':<>: 'ShowType alias
444+ ':<>: 'Text " does not exist" )
371 Alter alias x1 (alias ::: x0 ': xs) = alias ::: x1 ': xs
445 Alter alias x1 (alias ::: x0 ': xs) = alias ::: x1 ': xs
372 Alter alias x1 (x0 ': xs) = x0 ': Alter alias x1 xs
446 Alter alias x1 (x0 ': xs) = x0 ': Alter alias x1 xs
373
447
448+type family AlterIfExists alias x xs where
449+ AlterIfExists alias x '[] = '[]
450+ AlterIfExists alias x1 (alias ::: x0 ': xs) = alias ::: x1 ': xs
451+ AlterIfExists alias x1 (x0 ': xs) = x0 ': AlterIfExists alias x1 xs
452+
374-- | @Rename alias0 alias1 xs@ replaces the alias @alias0@ by @alias1@ in @xs@
453-- | @Rename alias0 alias1 xs@ replaces the alias @alias0@ by @alias1@ in @xs@
375-- and is used in `Squeal.PostgreSQL.Definition.alterTableRename` and
454-- and is used in `Squeal.PostgreSQL.Definition.alterTableRename` and
376-- `Squeal.PostgreSQL.Definition.renameColumn`.
455-- `Squeal.PostgreSQL.Definition.renameColumn`.
377type family Rename alias0 alias1 xs where
456type family Rename alias0 alias1 xs where
457+ Rename alias0 alias1 '[] = TypeError
458+ ('Text "Rename: alias "
459+ ':<>: 'ShowType alias0
460+ ':<>: 'Text " does not exist" )
378 Rename alias0 alias1 ((alias0 ::: x0) ': xs) = (alias1 ::: x0) ': xs
461 Rename alias0 alias1 ((alias0 ::: x0) ': xs) = (alias1 ::: x0) ': xs
379 Rename alias0 alias1 (x ': xs) = x ': Rename alias0 alias1 xs
462 Rename alias0 alias1 (x ': xs) = x ': Rename alias0 alias1 xs
380
463
464+type family RenameIfExists alias0 alias1 xs where
465+ RenameIfExists alias x '[] = '[]
466+ RenameIfExists alias0 alias1 ((alias0 ::: x0) ': xs) = (alias1 ::: x0) ': xs
467+ RenameIfExists alias0 alias1 (x ': xs) = x ': RenameIfExists alias0 alias1 xs
468+
381-- | Check if a `TableConstraint` involves a column
469-- | Check if a `TableConstraint` involves a column
382type family ConstraintInvolves column constraint where
470type family ConstraintInvolves column constraint where
383 ConstraintInvolves column ('Check columns) = column `Elem` columns
471 ConstraintInvolves column ('Check columns) = column `Elem` columns
@@ -394,22 +482,35 @@ type family DropIfConstraintsInvolve column constraints where
394 (DropIfConstraintsInvolve column constraints)
482 (DropIfConstraintsInvolve column constraints)
395 (alias ::: constraint ': DropIfConstraintsInvolve column constraints)
483 (alias ::: constraint ': DropIfConstraintsInvolve column constraints)
396
484
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−
407-- | A `SchemumType` is a user-defined type, either a `Table`,
485-- | A `SchemumType` is a user-defined type, either a `Table`,
408-- `View` or `Typedef`.
486-- `View` or `Typedef`.
409data SchemumType
487data SchemumType
410 = Table TableType
488 = Table TableType
411 | View RowType
489 | View RowType
412 | Typedef PGType
490 | 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
413
514
414{- | The schema of a database consists of a list of aliased,
515{- | The schema of a database consists of a list of aliased,
415user-defined `SchemumType`s.
516user-defined `SchemumType`s.
@@ -452,6 +553,7 @@ There are several reasons why one might want to use schemas:
452-}
553-}
453type SchemasType = [(Symbol,SchemaType)]
554type SchemasType = [(Symbol,SchemaType)]
454
555
556+-- | A type family to use for a single schema database.
455type family Public (schema :: SchemaType) :: SchemasType
557type family Public (schema :: SchemaType) :: SchemasType
456 where Public schema = '["public" ::: schema]
558 where Public schema = '["public" ::: schema]
457
559
squeal-postgresql/src/Squeal/PostgreSQL/Transaction.hs+76−44
@@ -1,7 +1,7 @@
1{-|
1{-|
2Module: Squeal.PostgreSQL.Transaction
2Module: Squeal.PostgreSQL.Transaction
3Description: Squeal transaction control language
3Description: Squeal transaction control language
4−Copyright: (c) Eitan Chatav, 2017
4+Copyright: (c) Eitan Chatav, 2019
5Maintainer: eitan@morphism.tech
5Maintainer: eitan@morphism.tech
6Stability: experimental
6Stability: experimental
7
7
@@ -20,11 +20,12 @@ module Squeal.PostgreSQL.Transaction
20 ( -- * Transaction
20 ( -- * Transaction
21 transactionally
21 transactionally
22 , transactionally_
22 , transactionally_
23+ , transactionallyRetry
24+ , ephemerally
25+ , ephemerally_
23 , begin
26 , begin
24 , commit
27 , commit
25 , rollback
28 , rollback
26− , transactionallySchema
27− , transactionallySchema_
28 -- * Transaction Mode
29 -- * Transaction Mode
29 , TransactionMode (..)
30 , TransactionMode (..)
30 , defaultMode
31 , defaultMode
@@ -34,68 +35,99 @@ module Squeal.PostgreSQL.Transaction
34 , DeferrableMode (..)
35 , DeferrableMode (..)
35 ) where
36 ) where
36
37
37−import Generics.SOP
38+import UnliftIO
38−import UnliftIO (MonadUnliftIO, liftIO, mask, onException)
39−
40−import qualified Database.PostgreSQL.LibPQ as LibPQ
41
39
42import Squeal.PostgreSQL.Manipulation
40import Squeal.PostgreSQL.Manipulation
43import Squeal.PostgreSQL.Render
41import Squeal.PostgreSQL.Render
44import Squeal.PostgreSQL.PQ
42import Squeal.PostgreSQL.PQ
45−import Squeal.PostgreSQL.Schema
46
43
47−-- | Run a schema invariant computation `transactionally`.
44+{- | Run a computation `transactionally`;
45+first `begin`,
46+then run the computation,
47+`onException` `rollback` and rethrow the exception,
48+otherwise `commit` and `return` the result.
49+-}
48transactionally
50transactionally
49 :: (MonadUnliftIO tx, MonadPQ schemas tx)
51 :: (MonadUnliftIO tx, MonadPQ schemas tx)
50 => TransactionMode
52 => TransactionMode
51 -> tx x -- ^ run inside a transaction
53 -> tx x -- ^ run inside a transaction
52 -> tx x
54 -> tx x
53transactionally mode tx = mask $ \restore -> do
55transactionally mode tx = mask $ \restore -> do
54− _ <- begin mode
56+ manipulate_ $ begin mode
55− result <- restore tx `onException` rollback
57+ result <- restore tx `onException` (manipulate_ rollback)
56− _ <- commit
58+ manipulate_ commit
57 return result
59 return result
58
60
59−-- | Run a schema invariant computation `transactionally_` in `defaultMode`.
61+-- | Run a computation `transactionally_`, in `defaultMode`.
60transactionally_
62transactionally_
61 :: (MonadUnliftIO tx, MonadPQ schemas tx)
63 :: (MonadUnliftIO tx, MonadPQ schemas tx)
62 => tx x -- ^ run inside a transaction
64 => tx x -- ^ run inside a transaction
63 -> tx x
65 -> tx x
64transactionally_ = transactionally defaultMode
66transactionally_ = transactionally defaultMode
65
67
66−-- | @BEGIN@ a transaction.
68+{- |
67−begin :: MonadPQ schemas tx => TransactionMode -> tx (K Result ('[] :: RowType))
69+`transactionallyRetry` a computation;
68−begin mode = manipulate . UnsafeManipulation $
69− "BEGIN" <+> renderSQL mode <> ";"
70
70
71−-- | @COMMIT@ a schema invariant transaction.
71+* first `begin`,
72−commit :: MonadPQ schemas tx => tx (K Result ('[] :: RowType))
72+* then `try` the computation,
73−commit = manipulate $ UnsafeManipulation "COMMIT;"
73+ - if it raises a serialization failure then `rollback` and restart the transaction,
74+ - if it raises any other exception then `rollback` and rethrow the exception,
75+ - otherwise `commit` and `return` the result.
76+-}
77+transactionallyRetry
78+ :: (MonadUnliftIO tx, MonadPQ schemas tx)
79+ => TransactionMode
80+ -> tx x -- ^ run inside a transaction
81+ -> tx x
82+transactionallyRetry mode tx = mask $ \restore ->
83+ loop . try $ do
84+ x <- restore tx
85+ manipulate_ commit
86+ return x
87+ where
88+ loop attempt = do
89+ manipulate_ $ begin mode
90+ attempt >>= \case
91+ Left (PQException (PQState _ (Just "40001") _)) -> do
92+ manipulate_ rollback
93+ loop attempt
94+ Left err -> do
95+ manipulate_ rollback
96+ throwIO err
97+ Right x -> return x
98+
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
74
112
75−-- | @ROLLBACK@ a schema invariant transaction.
113+{- | Run a computation `ephemerally` in `defaultMode`. -}
114+ephemerally_
76−rollback :: MonadPQ schemas tx => tx (K Result ('[] :: RowType))
115+ :: (MonadUnliftIO tx, MonadPQ schemas tx)
77−rollback = manipulate $ UnsafeManipulation "ROLLBACK;"
116+ => tx x -- ^ run inside an ephemeral transaction
117+ -> tx x
118+ephemerally_ = ephemerally defaultMode
78
119
79−-- | Run a schema changing computation `transactionallySchema`.
120+-- | @BEGIN@ a transaction.
80−transactionallySchema
81− :: MonadUnliftIO io
82− => TransactionMode
121+begin :: TransactionMode -> Manipulation_ schemas () ()
83− -> PQ schemas0 schemas1 io x
84− -> PQ schemas0 schemas1 io x
85−transactionallySchema mode u = PQ $ \ conn -> mask $ \ restore -> do
86− _ <- liftIO . LibPQ.exec (unK conn) $
87− "BEGIN" <+> renderSQL mode <> ";"
122+begin mode = UnsafeManipulation $ "BEGIN" <+> renderSQL mode
88− x <- restore (unPQ u conn)
123+
89− `onException` (liftIO (LibPQ.exec (unK conn) "ROLLBACK"))
124+-- | @COMMIT@ a transaction.
90− _ <- liftIO $ LibPQ.exec (unK conn) "COMMIT"
125+commit :: Manipulation_ schemas () ()
91− return x
126+commit = UnsafeManipulation "COMMIT"
92−
127+
93−-- | Run a schema changing computation `transactionallySchema_` in `defaultMode`.
128+-- | @ROLLBACK@ a transaction.
94−transactionallySchema_
129+rollback :: Manipulation_ schemas () ()
95− :: MonadUnliftIO io
130+rollback = UnsafeManipulation "ROLLBACK"
96− => PQ schemas0 schemas1 io x
97− -> PQ schemas0 schemas1 io x
98−transactionallySchema_ = transactionallySchema defaultMode
99
131
100-- | The available transaction characteristics are the transaction `IsolationLevel`,
132-- | The available transaction characteristics are the transaction `IsolationLevel`,
101-- the transaction `AccessMode` (`ReadWrite` or `ReadOnly`), and the `DeferrableMode`.
133-- the transaction `AccessMode` (`ReadWrite` or `ReadOnly`), and the `DeferrableMode`.
@@ -108,7 +140,7 @@ data TransactionMode = TransactionMode
108-- | `TransactionMode` with a `Serializable` `IsolationLevel`,
140-- | `TransactionMode` with a `Serializable` `IsolationLevel`,
109-- `ReadWrite` `AccessMode` and `NotDeferrable` `DeferrableMode`.
141-- `ReadWrite` `AccessMode` and `NotDeferrable` `DeferrableMode`.
110defaultMode :: TransactionMode
142defaultMode :: TransactionMode
111−defaultMode = TransactionMode Serializable ReadWrite NotDeferrable
143+defaultMode = TransactionMode ReadCommitted ReadWrite NotDeferrable
112
144
113-- | `TransactionMode` with a `Serializable` `IsolationLevel`,
145-- | `TransactionMode` with a `Serializable` `IsolationLevel`,
114-- `ReadOnly` `AccessMode` and `Deferrable` `DeferrableMode`.
146-- `ReadOnly` `AccessMode` and `Deferrable` `DeferrableMode`.
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 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
2packages:
2packages:
3- squeal-postgresql
3- squeal-postgresql
4
4
5extra-deps:
5extra-deps:
6- unliftio-pool-0.2.1.0
6- unliftio-pool-0.2.1.0
7+- github: morphismtech/free-categories
8+ commit: c0e555fbefb5c21619e532264c4dfeac556d0630