git.iko.soy/squeal
on dev help sign in
swap
ddc9847427 ahead, 0 behind
.circleci/config.yml+3−2
since splitsnapshots
unifiedsplit
@@ -2,9 +2,10 @@ version: 2
2jobs:
2jobs:
3 build:
3 build:
4 docker:
4 docker:
5− - image: haskell:8.2.2
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_DB: exampledb
9 POSTGRES_DB: exampledb
9 steps:
10 steps:
10 - checkout
11 - checkout
@@ -13,7 +14,7 @@ jobs:
13 - dependency-cache
14 - dependency-cache
14 - run: apt-get update && apt-get install -y libpq-dev xz-utils make
15 - run: apt-get update && apt-get install -y libpq-dev xz-utils make
15 - run: stack upgrade && stack update
16 - run: stack upgrade && stack update
16− - run: stack build
17+ - run: stack build --fast
17 - run: stack test
18 - run: stack test
18 - run: stack haddock
19 - run: stack haddock
19 - save_cache:
20 - save_cache:
README.md+83−87
@@ -45,7 +45,12 @@ composable and cover a large portion of SQL.
45* connection pools
45* connection pools
46* transactions
46* transactions
47* views
47* views
48−* composite and enumerated types
48+* array, composite and enumerated types
49+* json functions and operations
50+* multischema support
51+* correlated subqueries
52+* window functions
53+* text search
49
54
50## installation
55## installation
51
56
@@ -53,10 +58,16 @@ composable and cover a large portion of SQL.
53
58
54## testing
59## testing
55
60
56−start postgres on localhost port `5432` and create a database named `exampledb`.
61+Start postgres on localhost port `5432` and create a database named `exampledb`.
57
62
58`stack test`
63`stack test`
59
64
65+## contributing
66+
67+We welcome contributors.
68+Please make pull requests on the `dev` branch instead of `master`.
69+The `Issues` page is a good place to communicate.
70+
60## usage
71## usage
61
72
62Let's see an example!
73Let's see an example!
@@ -65,19 +76,17 @@ First, we need some language extensions because Squeal uses modern GHC
65features.
76features.
66
77
67```Haskell
78```Haskell
68−>>> :set -XDataKinds -XDeriveGeneric -XOverloadedLabels
79+>>> :set -XDataKinds -XDeriveGeneric -XOverloadedLabels -XFlexibleContexts
69−>>> :set -XOverloadedStrings -XTypeApplications -XTypeOperators
80+>>> :set -XOverloadedStrings -XTypeApplications -XTypeOperators -XGADTs
70```
81```
71
82
72We'll need some imports.
83We'll need some imports.
73
84
74```Haskell
85```Haskell
75−>>> import Control.Monad (void)
86+>>> import Control.Monad.IO.Class (liftIO)
76−>>> import Control.Monad.Base (liftBase)
77>>> import Data.Int (Int32)
87>>> import Data.Int (Int32)
78>>> import Data.Text (Text)
88>>> import Data.Text (Text)
79>>> import Squeal.PostgreSQL
89>>> import Squeal.PostgreSQL
80−>>> import Squeal.PostgreSQL.Render
81```
90```
82
91
83We'll use generics to easily convert between Haskell and PostgreSQL values.
92We'll use generics to easily convert between Haskell and PostgreSQL values.
@@ -92,27 +101,27 @@ we use `DataKinds` and `TypeOperators`.
92
101
93```Haskell
102```Haskell
94>>> :{
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"] ]
95type Schema =
115type Schema =
96− '[ "users" ::: 'Table (
116+ '[ "users" ::: 'Table (UsersConstraints :=> UsersColumns)
97− '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
98− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
99− , "name" ::: 'NoDef :=> 'NotNull 'PGtext
100− ])
101− , "emails" ::: 'Table (
117+ , "emails" ::: 'Table (EmailsConstraints :=> EmailsColumns) ]
102− '[ "pk_emails" ::: 'PrimaryKey '["id"]
118+type Schemas = Public Schema
103− , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
104− ] :=>
105− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
106− , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
107− , "email" ::: 'NoDef :=> 'Null 'PGtext
108− ])
109− ]
110:}
119:}
111```
120```
112
121
113Notice the use of type operators.
122Notice the use of type operators.
114
123
115−`:::` is used to pair an alias `GHC.TypeLits.Symbol` with a `SchemumType`,
124+`:::` is used to pair an alias `Symbol` with a `SchemumType`,
116a `TableConstraint` or a `ColumnType`. It is intended to connote Haskell's `::`
125a `TableConstraint` or a `ColumnType`. It is intended to connote Haskell's `::`
117operator.
126operator.
118
127
@@ -121,7 +130,7 @@ yielding a `TableType`, or to pair a `ColumnConstraint` with a `NullityType`,
121yielding a `ColumnType`. It is intended to connote Haskell's `=>` operator
130yielding a `ColumnType`. It is intended to connote Haskell's `=>` operator
122
131
123Next, we'll write `Definition`s to set up and tear down the schema. In
132Next, we'll write `Definition`s to set up and tear down the schema. In
124−Squeal, a `Definition` like `createTable`, `alterTable` or `dropTable`
133+Squeal, a `Definition` like `createTable`, `alterTable` or `dropTable`
125has two type parameters, corresponding to the schema
134has two type parameters, corresponding to the schema
126before being run and the schema after. We can compose definitions using `>>>`.
135before being run and the schema after. We can compose definitions using `>>>`.
127Here and in the rest of our commands we make use of overloaded
136Here and in the rest of our commands we make use of overloaded
@@ -130,19 +139,19 @@ labels to refer to named tables and columns in our schema.
130```Haskell
139```Haskell
131>>> :{
140>>> :{
132let
141let
133− setup :: Definition '[] Schema
142+ setup :: Definition (Public '[]) Schemas
134− setup =
143+ setup =
135 createTable #users
144 createTable #users
136− ( serial `As` #id :*
145+ ( serial `as` #id :*
137− (text & notNullable) `As` #name :* Nil )
146+ (text & notNullable) `as` #name )
138− ( primaryKey #id `As` #pk_users :* Nil ) >>>
147+ ( primaryKey #id `as` #pk_users ) >>>
139 createTable #emails
148 createTable #emails
140− ( serial `As` #id :*
149+ ( serial `as` #id :*
141− (int & notNullable) `As` #user_id :*
150+ (int & notNullable) `as` #user_id :*
142− (text & nullable) `As` #email :* Nil )
151+ (text & nullable) `as` #email )
143− ( primaryKey #id `As` #pk_emails :*
152+ ( primaryKey #id `as` #pk_emails :*
144 foreignKey #user_id #users #id
153 foreignKey #user_id #users #id
145− OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil )
154+ OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
146:}
155:}
147```
156```
148
157
@@ -162,7 +171,7 @@ primary and foreign keys, making them somewhat complex. Our `teardown`
162```Haskell
171```Haskell
163>>> :{
172>>> :{
164let
173let
165− teardown :: Definition Schema '[]
174+ teardown :: Definition Schemas (Public '[])
166 teardown = dropTable #emails >>> dropTable #users
175 teardown = dropTable #emails >>> dropTable #users
167:}
176:}
168
177
@@ -171,57 +180,57 @@ DROP TABLE "emails";
171DROP TABLE "users";
180DROP TABLE "users";
172```
181```
173
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+
174−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.
175−A `Manipulation` like `insertRow`, `update` or `deleteFrom`
193+A `Manipulation_` like `insertInto`, `update` or `deleteFrom`
176−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
177−it can take as input, and a list of columns it produces as output. When
195+and an output row. When
178we 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`
179field 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
180value. 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
181need 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
182−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
183−of our inserts.
201+`with` statement.
184
202
185```Haskell
203```Haskell
186>>> :{
204>>> :{
187let
205let
188− insertUser :: Manipulation Schema '[ 'NotNull 'PGtext ] '[ "fromOnly" ::: 'NotNull 'PGint4 ]
206+ insertUser :: Manipulation_ Schemas User ()
189− insertUser = insertRow #users
207+ insertUser = with (u `as` #u) e
208+ where
209+ u = insertInto #users
190− (Default `As` #id :* Set (param @1) `As` #name :* Nil)
210+ (Values_ (Default `as` #id :* Set (param @1) `as` #name))
191− OnConflictDoNothing (Returning (#id `As` #fromOnly :* Nil))
211+ OnConflictDoRaise (Returning_ (#id :* param @2 `as` #email))
192−:}
212+ e = insertInto_ #emails $ Select
193−
213+ (Default `as` #id :* Set (#u ! #id) `as` #user_id :* Set (#u ! #email) `as` #email)
194−>>> :{
214+ (from (common #u))
195−let
196− insertEmail :: Manipulation Schema '[ 'NotNull 'PGint4, 'Null 'PGtext] '[]
197− insertEmail = insertRow #emails
198− ( Default `As` #id :*
199− Set (param @1) `As` #user_id :*
200− Set (param @2) `As` #email :* Nil )
201− OnConflictDoNothing (Returning Nil)
202:}
215:}
203
216
204>>> printSQL insertUser
217>>> printSQL insertUser
205−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"
206−>>> printSQL insertEmail
207−INSERT INTO "emails" ("id", "user_id", "email") VALUES (DEFAULT, ($1 :: int4), ($2 :: text)) ON CONFLICT DO NOTHING
208```
219```
209
220
210−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
211interested in the ids here, just the usernames and email addresses. We
222interested in the ids here, just the usernames and email addresses. We
212−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
213−`Manipulation` with the same kind of type parameters.
224+`Manipulation_` with the same kind of type parameters.
214
225
215```Haskell
226```Haskell
216>>> :{
227>>> :{
217let
228let
218− getUsers :: Query Schema '[]
229+ getUsers :: Query_ Schemas () User
219− '[ "userName" ::: 'NotNull 'PGtext
220− , "userEmail" ::: 'Null 'PGtext ]
221− getUsers = select
230+ getUsers = select_
222− (#u ! #name `As` #userName :* #e ! #email `As` #userEmail :* Nil)
231+ (#u ! #name `as` #userName :* #e ! #email `as` #userEmail)
223− ( from (table (#users `As` #u)
232+ ( from (table (#users `as` #u)
224− & innerJoin (table (#emails `As` #e))
233+ & innerJoin (table (#emails `as` #e))
225 (#u ! #id .== #e ! #user_id)) )
234 (#u ! #id .== #e ! #user_id)) )
226:}
235:}
227
236
@@ -229,25 +238,13 @@ let
229SELECT "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")
230```
239```
231
240
232−Now that we've defined the SQL side of things, we'll need a Haskell type
233−for users. We give the type `Generics.SOP.Generic` and
234−`Generics.SOP.HasDatatypeInfo` instances so that we can decode the rows
235−we receive when we run `getUsers`. Notice that the record fields of the
236−`User` type match the column names of `getUsers`.
237−
238−```Haskell
239−>>> data User = User { userName :: Text, userEmail :: Maybe Text } deriving (Show, GHC.Generic)
240−>>> instance SOP.Generic User
241−>>> instance SOP.HasDatatypeInfo User
242−```
243−
244−Let's also create some users to add to the database.
241+Let's create some users to add to the database.
245
242
246```Haskell
243```Haskell
247>>> :{
244>>> :{
248let
245let
249 users :: [User]
246 users :: [User]
250− users =
247+ users =
251 [ User "Alice" (Just "alice@gmail.com")
248 [ User "Alice" (Just "alice@gmail.com")
252 , User "Bob" Nothing
249 , User "Bob" Nothing
253 , User "Carole" (Just "carole@hotmail.com")
250 , User "Carole" (Just "carole@hotmail.com")
@@ -266,19 +263,18 @@ transformer and when the schema doesn't change we can use `Monad` and
266```Haskell
263```Haskell
267>>> :{
264>>> :{
268let
265let
269− session :: PQ Schema Schema IO ()
266+ session :: PQ Schemas Schemas IO ()
270 session = do
267 session = do
271− idResults <- traversePrepared insertUser (Only . userName <$> users)
272− ids <- traverse (fmap fromOnly . getRow 0) idResults
273− traversePrepared_ insertEmail (zip (ids :: [Int32]) (userEmail <$> users))
268+ _ <- traversePrepared_ insertUser users
274 usersResult <- runQuery getUsers
269 usersResult <- runQuery getUsers
275 usersRows <- getRows usersResult
270 usersRows <- getRows usersResult
276− liftBase $ print (usersRows :: [User])
271+ liftIO $ print (usersRows :: [User])
277in
272in
278− void . withConnection "host=localhost port=5432 dbname=exampledb" $
273+ withConnection "host=localhost port=5432 dbname=exampledb" $
279 define setup
274 define setup
280 & pqThen session
275 & pqThen session
281 & pqThen (define teardown)
276 & pqThen (define teardown)
282:}
277:}
283[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+-}
284```
280```
RELEASE NOTES.md+532−15
@@ -1,9 +1,410 @@
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
5−Version 0.4 of strengthens Squeal's type system, adds
405+Version 0.4 strengthens Squeal's type system, adds
6−support for multidimensional arrays, improves `with` statements,
406+support for multidimensional arrays, improves support
407+for container type, improves `with` statements,
7improves runtime exceptions, accomodates SQL's three-valued logic,
408improves runtime exceptions, accomodates SQL's three-valued logic,
8adds subquery expressions, and adds table and view type expressions.
409adds subquery expressions, and adds table and view type expressions.
9
410
@@ -49,7 +450,7 @@ type family RowPG (hask :: Type) :: RowType
49
450
50Let's look at these one by one.
451Let's look at these one by one.
51
452
52−`PG` was introduced in Squeal 0.3. It's a closed type family that
453+`PG` was introduced in Squeal 0.3. It was a closed type family that
53associates some Haskell types to their obvious corresponding Postgres
454associates some Haskell types to their obvious corresponding Postgres
54types like `PG Double = 'PGfloat8`. It only worked on base types,
455types like `PG Double = 'PGfloat8`. It only worked on base types,
55no arrays or composites. Squeal 0.4 extends it to
456no arrays or composites. Squeal 0.4 extends it to
@@ -73,8 +474,11 @@ into lists of `NullityType`s in the logical way, e.g.
73
474
74```Haskell
475```Haskell
75>>> data Person = Person { name :: Text, age :: Int32 } deriving GHC.Generic
476>>> data Person = Person { name :: Text, age :: Int32 } deriving GHC.Generic
76−>>> instance Generic Person
477+>>> instance SOP.Generic Person
77−>>> instance HasDatatypeInfo Person
478+>>> instance SOP.HasDatatypeInfo Person
479+>>> :kind! TuplePG Person
480+TuplePG Person :: [NullityType]
481+= '['NotNull 'PGtext, 'NotNull 'PGint4]
78>>> :kind! RowPG Person
482>>> :kind! RowPG Person
79RowPG Person :: [(Symbol, NullityType)]
483RowPG Person :: [(Symbol, NullityType)]
80= '["name" ::: 'NotNull 'PGtext, "age" ::: 'NotNull 'PGint4]
484= '["name" ::: 'NotNull 'PGtext, "age" ::: 'NotNull 'PGint4]
@@ -91,9 +495,6 @@ boilerplate signature you can reuse these with the help of `TuplePG` and `RowPG`
91For instance:
495For instance:
92
496
93```Haskell
497```Haskell
94−>>> data Person = Person { name :: Text, age :: Int32 } deriving GHC.Generic
95−>>> instance SOP.Generic Person
96−>>> instance SOP.HasDatatypeInfo Person
97>>> :{
498>>> :{
98let
499let
99 query :: Query '["user" ::: 'View (RowPG Person)] (TuplePG (Only Int32)) (RowPG Person)
500 query :: Query '["user" ::: 'View (RowPG Person)] (TuplePG (Only Int32)) (RowPG Person)
@@ -106,8 +507,8 @@ let
106In addition to being able to encode and decode basic Haskell types
507In addition to being able to encode and decode basic Haskell types
107like `Int16` and `Text`, Squeal 0.4 permits you to encode and decode Haskell types to
508like `Int16` and `Text`, Squeal 0.4 permits you to encode and decode Haskell types to
108Postgres array types. The `Vector` type corresponds to to variable length arrays.
509Postgres array types. The `Vector` type corresponds to to variable length arrays.
109−And thanks to [Mike Ledger](https://github.com/mikeplus64) for the idea,
510+And thanks to an idea from [Mike Ledger](https://github.com/mikeplus64),
110−and homogeneous tuples correspond to fixed length arrays. We can even
511+homogeneous tuples correspond to fixed length arrays. We can even
111create multi-dimensional fixed length arrays. Let's see an example.
512create multi-dimensional fixed length arrays. Let's see an example.
112
513
113```Haskell
514```Haskell
@@ -146,6 +547,120 @@ void . withConnection "host=localhost port=5432 dbname=exampledb" $ do
146True
547True
147```
548```
148
549
550+**Containers**
551+
552+Squeal aims to provide a correspondence between Haskell types and Postgres types.
553+In particular, Haskell ADTs with nullary constructors can correspond to
554+Postgres enum types and Haskell record types can correspond to Postgres
555+composite types. However, it's not always obvious that that's how a user
556+will choose to store values of those types. So Squeal 0.4 introduces newtypes
557+whose purpose is to specify how a user wants to store values of a type.
558+
559+```Haskell
560+newtype Json hask = Json {getJson :: hask}
561+newtype Jsonb hask = Jsonb {getJsonb :: hask}
562+newtype Composite record = Composite {getComposite :: record}
563+newtype Enumerated enum = Enumerated {getEnumerated :: enum}
564+```
565+
566+Let's see an example:
567+
568+```Haskell
569+>>> data Schwarma = Beef | Lamb | Chicken deriving (Eq, Show, GHC.Generic)
570+>>> instance SOP.Generic Schwarma
571+>>> instance SOP.HasDatatypeInfo Schwarma
572+>>>
573+>>> data Person = Person {name :: Text, age :: Int32} deriving (Eq, Show, GHC.Generic)
574+>>> instance SOP.Generic Person
575+>>> instance SOP.HasDatatypeInfo Person
576+>>> instance Aeson.FromJSON Person
577+>>> instance Aeson.ToJSON Person
578+```
579+
580+We can create the equivalent Postgres types directly from their Haskell types.
581+
582+```Haskell
583+>>> :{
584+type Schema =
585+ '[ "schwarma" ::: 'Typedef (PG (Enumerated Schwarma))
586+ , "person" ::: 'Typedef (PG (Composite Person))
587+ ]
588+:}
589+
590+>>> :{
591+let
592+ setup :: Definition '[] Schema
593+ setup =
594+ createTypeEnumFrom @Schwarma #schwarma >>>
595+ createTypeCompositeFrom @Person #person
596+:}
597+```
598+
599+Let's demonstrate how to associate our Haskell types `Schwarma` and `Person`
600+with enumerated, composite or json types in Postgres. First create a Haskell
601+`Row` type using the `Enumerated`, `Composite` and `Json` newtypes as fields.
602+
603+```Haskell
604+>>> :{
605+data Row = Row
606+ { schwarma :: Enumerated Schwarma
607+ , person1 :: Composite Person
608+ , person2 :: Json Person
609+ } deriving (Eq, GHC.Generic)
610+:}
611+
612+>>> instance Generic Row
613+>>> instance HasDatatypeInfo Row
614+>>> :{
615+let
616+ input = Row
617+ (Enumerated Chicken)
618+ (Composite (Person "Faisal" 24))
619+ (Json (Person "Ahmad" 48))
620+:}
621+```
622+
623+Once again, define a round trip query.
624+
625+```Haskell
626+>>> :{
627+let
628+ roundTrip :: Query Schema (TuplePG Row) (RowPG Row)
629+ roundTrip = values_ $
630+ parameter @1 (typedef #schwarma) `as` #schwarma :*
631+ parameter @2 (typedef #person) `as` #person1 :*
632+ parameter @3 json `as` #person2
633+:}
634+```
635+
636+Finally, we can drop our type definitions.
637+
638+```Haskell
639+>>> :{
640+let
641+ teardown :: Definition Schema '[]
642+ teardown = dropType #schwarma >>> dropType #person
643+:}
644+```
645+
646+Now let's run it.
647+
648+```Haskell
649+>>> :{
650+let
651+ session = do
652+ result <- runQueryParams roundTrip input
653+ Just output <- firstRow result
654+ liftBase . print $ input == output
655+in
656+ void . withConnection "host=localhost port=5432 dbname=exampledb" $
657+ define setup
658+ & pqThen session
659+ & pqThen (define teardown)
660+:}
661+True
662+```
663+
149**With**
664**With**
150
665
151Squeal 0.3 supported WITH statements but there's a couple problems with them.
666Squeal 0.3 supported WITH statements but there's a couple problems with them.
@@ -160,9 +675,9 @@ with
160 -> Manipulation schema params results
675 -> Manipulation schema params results
161```
676```
162
677
163−The first problem is that with only works with `Manipulations`.
678+The first problem is that `with` only works with `Manipulations`.
164−It can work on Querys by using queryStatement but it still will
679+It can work on `Query`s by using `queryStatement` but it still will
165−return a Manipulation. We can fix this issue by making it a
680+return a `Manipulation`. We can fix this issue by making `with` a
166method of a type class with instances for both `Query` and `Manipulation`.
681method of a type class with instances for both `Query` and `Manipulation`.
167
682
168The second problem is that all the common table expressions
683The second problem is that all the common table expressions
@@ -213,6 +728,8 @@ in printSQL query
213:}
728:}
214WITH "t2" AS (SELECT * FROM "t1" AS "t1"), "t3" AS (SELECT * FROM "t2" AS "t2") SELECT * FROM "t3" AS "t3"
729WITH "t2" AS (SELECT * FROM "t1" AS "t1"), "t3" AS (SELECT * FROM "t2" AS "t2") SELECT * FROM "t3" AS "t3"
215
730
731+>>> type ProductsTable = '[] :=> '["product" ::: 'NoDef :=> 'NotNull 'PGtext, "date" ::: 'Def :=> 'NotNull 'PGdate]
732+
216>>> :{
733>>> :{
217let
734let
218 manipulation :: Manipulation
735 manipulation :: Manipulation
@@ -233,7 +750,7 @@ In previous versions of Squeal, conditions followed classical two valued logic
233of `true` and `false`.
750of `true` and `false`.
234
751
235```Haskell
752```Haskell
236−-- Squeal 0.2
753+-- Squeal 0.3
237type Condition schema from grouping params =
754type Condition schema from grouping params =
238 Expression schema from grouping params ('NotNull 'PGbool)
755 Expression schema from grouping params ('NotNull 'PGbool)
239```
756```
@@ -245,7 +762,7 @@ of being less confusing evaporated I decided to switch to three valued logic
245of `true`, `false` and `null_`.
762of `true`, `false` and `null_`.
246
763
247```Haskell
764```Haskell
248−-- Squeal 0.3
765+-- Squeal 0.4
249type Condition schema from grouping params =
766type Condition schema from grouping params =
250 Expression schema from grouping params ('Null 'PGbool)
767 Expression schema from grouping params ('Null 'PGbool)
251```
768```
squeal-postgresql/exe/Example.hs+34−37
@@ -11,8 +11,7 @@
11
11
12module Main (main, main2) where
12module Main (main, main2) where
13
13
14−import Control.Monad (void)
14+import Control.Monad.IO.Class (MonadIO (..))
15−import Control.Monad.Base (liftBase, MonadBase)
16import Data.Int (Int16, Int32)
15import Data.Int (Int16, Int32)
17import Data.Monoid ((<>))
16import Data.Monoid ((<>))
18import Data.Text (Text)
17import Data.Text (Text)
@@ -39,10 +38,13 @@ 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
44+type Schemas = Public Schema
45+
44−setup :: Definition '[] Schema
46+setup :: Definition (Public '[]) Schemas
45−setup =
47+setup =
46 createTable #users
48 createTable #users
47 ( serial `as` #id :*
49 ( serial `as` #id :*
48 (text & notNullable) `as` #name :*
50 (text & notNullable) `as` #name :*
@@ -51,60 +53,55 @@ setup =
51 >>>
53 >>>
52 createTable #emails
54 createTable #emails
53 ( serial `as` #id :*
55 ( serial `as` #id :*
54− (int & notNullable) `as` #user_id :*
56+ hask @Int32 `as` #user_id :*
55− (text & nullable) `as` #email )
57+ hask @(Maybe Text) `as` #email )
56 ( primaryKey #id `as` #pk_emails :*
58 ( primaryKey #id `as` #pk_emails :*
57 foreignKey #user_id #users #id
59 foreignKey #user_id #users #id
58 OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
60 OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
61+ >>>
62+ createDomain #positive real (#value .> 0 .&& (#value & isNotNull))
63+
64+teardown :: Definition Schemas (Public '[])
65+teardown = dropType #positive >>> dropTable #emails >>> dropTable #users
66+
67+insertUser :: Manipulation_ Schemas (Text, VarArray (Vector (Maybe Int16))) (Only Int32)
68+insertUser = insertInto #users
69+ (Values_ (Default `as` #id :* Set (param @1) `as` #name :* Set (param @2) `as` #vec))
70+ (OnConflict (OnConstraint #pk_users) DoNothing) (Returning_ (#id `as` #fromOnly))
71+
72+insertEmail :: Manipulation_ Schemas (Int32, Maybe Text) ()
73+insertEmail = insertInto_ #emails
74+ (Values_ (Default `as` #id :* Set (param @1) `as` #user_id :* Set (param @2) `as` #email))
59
75
60−teardown :: Definition Schema '[]
76+getUsers :: Query_ Schemas () User
61−teardown = dropTable #emails >>> dropTable #users
62−
63−insertUser :: Manipulation Schema '[ 'NotNull 'PGtext, 'NotNull ('PGvararray ('Null 'PGint2))]
64− '[ "fromOnly" ::: 'NotNull 'PGint4 ]
65−insertUser = insertRows #users
66− (Default `as` #id :* Set (param @1) `as` #name :* Set (param @2) `as` #vec) []
67− OnConflictDoNothing (Returning (#id `as` #fromOnly))
68−
69−insertEmail :: Manipulation Schema '[ 'NotNull 'PGint4, 'Null 'PGtext] '[]
70−insertEmail = insertRows #emails
71− ( Default `as` #id :*
72− Set (param @1) `as` #user_id :*
73− Set (param @2) `as` #email ) []
74− OnConflictDoNothing (Returning Nil)
75−
76−getUsers :: Query Schema '[]
77− '[ "userName" ::: 'NotNull 'PGtext
78− , "userEmail" ::: 'Null 'PGtext
79− , "userVec" ::: 'NotNull ('PGvararray ('Null 'PGint2))]
80−getUsers = select
77+getUsers = select_
81 (#u ! #name `as` #userName :* #e ! #email `as` #userEmail :* #u ! #vec `as` #userVec)
78 (#u ! #name `as` #userName :* #e ! #email `as` #userEmail :* #u ! #vec `as` #userVec)
82 ( from (table (#users `as` #u)
79 ( from (table (#users `as` #u)
83 & innerJoin (table (#emails `as` #e))
80 & innerJoin (table (#emails `as` #e))
84 (#u ! #id .== #e ! #user_id)) )
81 (#u ! #id .== #e ! #user_id)) )
85
82
86−data User = User { userName :: Text, userEmail :: Maybe Text, userVec :: Vector (Maybe Int16) }
83+data User = User { userName :: Text, userEmail :: Maybe Text, userVec :: VarArray (Vector (Maybe Int16)) }
87 deriving (Show, GHC.Generic)
84 deriving (Show, GHC.Generic)
88instance SOP.Generic User
85instance SOP.Generic User
89instance SOP.HasDatatypeInfo User
86instance SOP.HasDatatypeInfo User
90
87
91users :: [User]
88users :: [User]
92−users =
89+users =
93− [ User "Alice" (Just "alice@gmail.com") [Nothing, Just 1]
90+ [ User "Alice" (Just "alice@gmail.com") (VarArray [Nothing, Just 1])
94− , User "Bob" Nothing [Just 2, Nothing]
91+ , User "Bob" Nothing (VarArray [Just 2, Nothing])
95− , User "Carole" (Just "carole@hotmail.com") [Just 3]
92+ , User "Carole" (Just "carole@hotmail.com") (VarArray [Just 3])
96 ]
93 ]
97
94
98−session :: (MonadBase IO pq, MonadPQ Schema pq) => pq ()
95+session :: (MonadIO pq, MonadPQ Schemas pq) => pq ()
99session = do
96session = do
100− liftBase $ Char8.putStrLn "manipulating"
97+ liftIO $ Char8.putStrLn "manipulating"
101 idResults <- traversePrepared insertUser ([(userName user, userVec user) | user <- users])
98 idResults <- traversePrepared insertUser ([(userName user, userVec user) | user <- users])
102 ids <- traverse (fmap fromOnly . getRow 0) idResults
99 ids <- traverse (fmap fromOnly . getRow 0) idResults
103 traversePrepared_ insertEmail (zip (ids :: [Int32]) (userEmail <$> users))
100 traversePrepared_ insertEmail (zip (ids :: [Int32]) (userEmail <$> users))
104− liftBase $ Char8.putStrLn "querying"
101+ liftIO $ Char8.putStrLn "querying"
105 usersResult <- runQuery getUsers
102 usersResult <- runQuery getUsers
106 usersRows <- getRows usersResult
103 usersRows <- getRows usersResult
107− liftBase $ print (usersRows :: [User])
104+ liftIO $ print (usersRows :: [User])
108
105
109main :: IO ()
106main :: IO ()
110main = do
107main = do
@@ -122,7 +119,7 @@ main = do
122
119
123main2 :: IO ()
120main2 :: IO ()
124main2 =
121main2 =
125− void . withConnection "host=localhost port=5432 dbname=exampledb" $
122+ withConnection "host=localhost port=5432 dbname=exampledb" $
126 define setup
123 define setup
127 & pqThen session
124 & pqThen session
128 & pqThen (define teardown)
125 & pqThen (define teardown)
squeal-postgresql/squeal-postgresql.cabal+59−17
@@ -1,5 +1,5 @@
1name: squeal-postgresql
1name: squeal-postgresql
2−version: 0.4.0.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
@@ -22,12 +22,40 @@ library
22 hs-source-dirs: src
22 hs-source-dirs: src
23 exposed-modules:
23 exposed-modules:
24 Squeal.PostgreSQL
24 Squeal.PostgreSQL
25+ Squeal.PostgreSQL.Alias
25 Squeal.PostgreSQL.Binary
26 Squeal.PostgreSQL.Binary
26 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
27 Squeal.PostgreSQL.Expression
35 Squeal.PostgreSQL.Expression
36+ Squeal.PostgreSQL.Expression.Aggregate
37+ Squeal.PostgreSQL.Expression.Collection
38+ Squeal.PostgreSQL.Expression.Comparison
39+ Squeal.PostgreSQL.Expression.Json
40+ Squeal.PostgreSQL.Expression.Literal
41+ Squeal.PostgreSQL.Expression.Logic
42+ Squeal.PostgreSQL.Expression.Math
43+ Squeal.PostgreSQL.Expression.Null
44+ Squeal.PostgreSQL.Expression.Parameter
45+ Squeal.PostgreSQL.Expression.Range
46+ Squeal.PostgreSQL.Expression.Set
47+ Squeal.PostgreSQL.Expression.Sort
48+ Squeal.PostgreSQL.Expression.Subquery
49+ Squeal.PostgreSQL.Expression.Text
50+ Squeal.PostgreSQL.Expression.TextSearch
51+ Squeal.PostgreSQL.Expression.Time
52+ Squeal.PostgreSQL.Expression.Type
53+ Squeal.PostgreSQL.Expression.Window
54+ Squeal.PostgreSQL.List
28 Squeal.PostgreSQL.Manipulation
55 Squeal.PostgreSQL.Manipulation
29 Squeal.PostgreSQL.Migration
56 Squeal.PostgreSQL.Migration
30 Squeal.PostgreSQL.Pool
57 Squeal.PostgreSQL.Pool
58+ Squeal.PostgreSQL.PG
31 Squeal.PostgreSQL.PQ
59 Squeal.PostgreSQL.PQ
32 Squeal.PostgreSQL.Render
60 Squeal.PostgreSQL.Render
33 Squeal.PostgreSQL.Query
61 Squeal.PostgreSQL.Query
@@ -37,15 +65,14 @@ library
37 ghc-options: -Wall
65 ghc-options: -Wall
38 build-depends:
66 build-depends:
39 aeson >= 1.2.4.0
67 aeson >= 1.2.4.0
40− , base >= 4.10.1.0 && < 5.0
68+ , base >= 4.11.1.0 && < 5.0
41 , binary-parser >= 0.5.5
69 , binary-parser >= 0.5.5
42 , bytestring >= 0.10.8.2
70 , bytestring >= 0.10.8.2
43 , bytestring-strict-builder >= 0.4.5
71 , bytestring-strict-builder >= 0.4.5
44 , deepseq >= 1.4.3.0
72 , deepseq >= 1.4.3.0
73+ , free-categories >= 0.1.0.0
45− , generics-sop >= 0.3.2.0
74+ , generics-sop >= 0.3.2.0 && < 0.5.0.0
46− , lifted-base >= 0.2.3.12
47 , mmorph >= 1.1.1
75 , mmorph >= 1.1.1
48− , monad-control >= 1.0.2.3
49 , mtl >= 2.2.2
76 , mtl >= 2.2.2
50 , network-ip >= 0.3.0.2
77 , network-ip >= 0.3.0.2
51 , postgresql-binary >= 0.12.1
78 , postgresql-binary >= 0.12.1
@@ -56,39 +83,55 @@ library
56 , text >= 1.2.3.0
83 , text >= 1.2.3.0
57 , time >= 1.8.0.2
84 , time >= 1.8.0.2
58 , transformers >= 0.5.2.0
85 , transformers >= 0.5.2.0
59− , transformers-base >= 0.4.4
86+ , unliftio >= 0.2.10
87+ , unliftio-pool >= 0.2.1.0
60 , uuid-types >= 1.0.3
88 , uuid-types >= 1.0.3
61 , vector >= 0.12.0.1
89 , vector >= 0.12.0.1
62
90
63−test-suite squeal-postgresql-doctest
91+test-suite doctest
64 default-language: Haskell2010
92 default-language: Haskell2010
65 type: exitcode-stdio-1.0
93 type: exitcode-stdio-1.0
66 hs-source-dirs: test
94 hs-source-dirs: test
67 ghc-options: -Wall
95 ghc-options: -Wall
68− main-is: DocTest.hs
96+ main-is: Doc.hs
69 build-depends:
97 build-depends:
70 base >= 4.10.0.0
98 base >= 4.10.0.0
71 , doctest >= 0.11.4
99 , doctest >= 0.11.4
100+ , squeal-postgresql
72
101
73−test-suite squeal-postgresql-specs
102+test-suite properties
74 default-language: Haskell2010
103 default-language: Haskell2010
75 type: exitcode-stdio-1.0
104 type: exitcode-stdio-1.0
76− hs-source-dirs: test/Specs
105+ hs-source-dirs: test
77− ghc-options: -Wall -main-is Specs
106+ ghc-options: -Wall
78− main-is: Specs.hs
107+ main-is: Property.hs
79− other-modules: ExceptionHandling
80 build-depends:
108 build-depends:
81 base >= 4.10.0.0
109 base >= 4.10.0.0
82 , 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
83 , generics-sop >= 0.3.1.0
127 , generics-sop >= 0.3.1.0
84 , hspec >= 2.4.8
128 , hspec >= 2.4.8
129+ , mtl >= 2.2.2
85 , squeal-postgresql
130 , squeal-postgresql
86 , text >= 1.2.2.2
131 , text >= 1.2.2.2
87− , transformers >= 0.5.2.0
88− , transformers-base >= 0.4.4
89 , vector >= 0.12.0.1
132 , vector >= 0.12.0.1
90
133
91−executable squeal-postgresql-example
134+executable example
92 default-language: Haskell2010
135 default-language: Haskell2010
93 hs-source-dirs: exe
136 hs-source-dirs: exe
94 ghc-options: -Wall
137 ghc-options: -Wall
@@ -101,5 +144,4 @@ executable squeal-postgresql-example
101 , squeal-postgresql
144 , squeal-postgresql
102 , text >= 1.2.2.2
145 , text >= 1.2.2.2
103 , transformers >= 0.5.2.0
146 , transformers >= 0.5.2.0
104− , transformers-base >= 0.4.4
105 , vector >= 0.12.0.1
147 , vector >= 0.12.0.1
squeal-postgresql/src/Squeal/PostgreSQL.hs+101−95
@@ -1,7 +1,7 @@
1{-|
1{-|
2Module: Squeal.PostgreSQL
2Module: Squeal.PostgreSQL
3−Description: Squeel export module
3+Description: 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
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)
19+>>> import Control.Monad.IO.Class (liftIO)
20−>>> import Control.Monad.Base (liftBase)
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
@@ -32,26 +30,26 @@ The first step is to define the schema of our database. This is where
32we use @DataKinds@ and @TypeOperators@.
30we use @DataKinds@ and @TypeOperators@.
33
31
34>>> :{
32>>> :{
33+type UsersColumns =
34+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
35+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext ]
36+type UsersConstraints = '[ "pk_users" ::: 'PrimaryKey '["id"] ]
37+type EmailsColumns =
38+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
39+ , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
40+ , "email" ::: 'NoDef :=> 'Null 'PGtext ]
41+type EmailsConstraints =
42+ '[ "pk_emails" ::: 'PrimaryKey '["id"]
43+ , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"] ]
35type Schema =
44type Schema =
36− '[ "users" ::: 'Table (
45+ '[ "users" ::: 'Table (UsersConstraints :=> UsersColumns)
37− '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
38− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
39− , "name" ::: 'NoDef :=> 'NotNull 'PGtext
40− ])
41− , "emails" ::: 'Table (
46+ , "emails" ::: 'Table (EmailsConstraints :=> EmailsColumns) ]
42− '[ "pk_emails" ::: 'PrimaryKey '["id"]
47+type Schemas = Public Schema
43− , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
44− ] :=>
45− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
46− , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
47− , "email" ::: 'NoDef :=> 'Null 'PGtext
48− ])
49− ]
50:}
48:}
51
49
52Notice the use of type operators.
50Notice the use of type operators.
53
51
54−`:::` is used to pair an alias `GHC.TypeLits.Symbol` with a `SchemumType`,
52+`:::` is used to pair an alias `GHC.TypeLits.Symbol` with a `SchemasType`, a `SchemumType`,
55a `TableConstraint` or a `ColumnType`. It is intended to connote Haskell's @::@
53a `TableConstraint` or a `ColumnType`. It is intended to connote Haskell's @::@
56operator.
54operator.
57
55
@@ -60,7 +58,7 @@ yielding a `TableType`, or to pair a `ColumnConstraint` with a `NullityType`,
60yielding a `ColumnType`. It is intended to connote Haskell's @=>@ operator
58yielding a `ColumnType`. It is intended to connote Haskell's @=>@ operator
61
59
62Next, we'll write `Definition`s to set up and tear down the schema. In
60Next, we'll write `Definition`s to set up and tear down the schema. In
63−Squeal, a `Definition` like `createTable`, `alterTable` or `dropTable`
61+Squeal, a `Definition` like `createTable`, `alterTable` or `dropTable`
64has two type parameters, corresponding to the schema
62has two type parameters, corresponding to the schema
65before being run and the schema after. We can compose definitions using `>>>`.
63before being run and the schema after. We can compose definitions using `>>>`.
66Here and in the rest of our commands we make use of overloaded
64Here and in the rest of our commands we make use of overloaded
@@ -68,8 +66,8 @@ labels to refer to named tables and columns in our schema.
68
66
69>>> :{
67>>> :{
70let
68let
71− setup :: Definition '[] Schema
69+ setup :: Definition (Public '[]) Schemas
72− setup =
70+ setup =
73 createTable #users
71 createTable #users
74 ( serial `as` #id :*
72 ( serial `as` #id :*
75 (text & notNullable) `as` #name )
73 (text & notNullable) `as` #name )
@@ -89,14 +87,14 @@ We can easily see the generated SQL is unsurprising looking.
89CREATE TABLE "users" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_users" PRIMARY KEY ("id"));
87CREATE TABLE "users" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_users" PRIMARY KEY ("id"));
90CREATE 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);
88CREATE 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);
91
89
92−Notice that @setup@ starts with an empty schema @'[]@ and produces @Schema@.
90+Notice that @setup@ starts with an empty public schema @(Public '[])@ and produces @Schemas@.
93In our `createTable` commands we included `TableConstraint`s to define
91In our `createTable` commands we included `TableConstraint`s to define
94primary and foreign keys, making them somewhat complex. Our @teardown@
92primary and foreign keys, making them somewhat complex. Our @teardown@
95`Definition` is simpler.
93`Definition` is simpler.
96
94
97>>> :{
95>>> :{
98let
96let
99− teardown :: Definition Schema '[]
97+ teardown :: Definition Schemas (Public '[])
100 teardown = dropTable #emails >>> dropTable #users
98 teardown = dropTable #emails >>> dropTable #users
101:}
99:}
102
100
@@ -104,51 +102,49 @@ let
104DROP TABLE "emails";
102DROP TABLE "emails";
105DROP TABLE "users";
103DROP TABLE "users";
106
104
105+We'll need a Haskell type for @User@s. We give the type `Generics.SOP.Generic` and
106+`Generics.SOP.HasDatatypeInfo` instances so that we can encode and decode @User@s.
107+
108+>>> data User = User { userName :: Text, userEmail :: Maybe Text } deriving (Show, GHC.Generic)
109+>>> instance SOP.Generic User
110+>>> instance SOP.HasDatatypeInfo User
111+
107−Next, we'll write `Manipulation`s to insert data into our two tables.
112+Next, we'll write `Manipulation_`s to insert @User@s into our two tables.
108−A `Manipulation` like `insertRow`, `update` or `deleteFrom`
113+A `Manipulation_` like `insertInto`, `update` or `deleteFrom`
109−has three type parameters, the schema it refers to, a list of parameters
114+has three type parameters, the schemas it refers to, input parameters
110−it can take as input, and a list of columns it produces as output. When
115+and an output row. When
111we insert into the users table, we will need a parameter for the @name@
116we insert into the users table, we will need a parameter for the @name@
112field but not for the @id@ field. Since it's serial, we can use a default
117field but not for the @id@ field. Since it's serial, we can use a default
113value. However, since the emails table refers to the users table, we will
118value. However, since the emails table refers to the users table, we will
114need to retrieve the user id that the insert generates and insert it into
119need 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
120+the emails table. We can do this in a single `Manipulation_` by using a
116−of our inserts.
121+`with` statement.
117−
118−>>> :{
119−let
120− insertUser :: Manipulation Schema '[ 'NotNull 'PGtext ] '[ "fromOnly" ::: 'NotNull 'PGint4 ]
121− insertUser = insertRow #users
122− (Default `as` #id :* Set (param @1) `as` #name)
123− OnConflictDoNothing (Returning (#id `as` #fromOnly))
124−:}
125
122
126>>> :{
123>>> :{
127let
124let
128− insertEmail :: Manipulation Schema '[ 'NotNull 'PGint4, 'Null 'PGtext] '[]
125+ insertUser :: Manipulation_ Schemas User ()
129− insertEmail = insertRow #emails
126+ insertUser = with (u `as` #u) e
127+ where
128+ u = insertInto #users
129+ (Values_ (Default `as` #id :* Set (param @1) `as` #name))
130+ OnConflictDoRaise (Returning_ (#id :* param @2 `as` #email))
131+ e = insertInto_ #emails $ Select
130− ( Default `as` #id :*
132+ (Default `as` #id :* Set (#u ! #id) `as` #user_id :* Set (#u ! #email) `as` #email)
131− Set (param @1) `as` #user_id :*
133+ (from (common #u))
132− Set (param @2) `as` #email )
133− OnConflictDoNothing (Returning Nil)
134:}
134:}
135
135
136>>> printSQL insertUser
136>>> printSQL insertUser
137−INSERT INTO "users" ("id", "name") VALUES (DEFAULT, ($1 :: text)) ON CONFLICT DO NOTHING RETURNING "id" AS "fromOnly"
137+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"
138−>>> printSQL insertEmail
139−INSERT INTO "emails" ("id", "user_id", "email") VALUES (DEFAULT, ($1 :: int4), ($2 :: text)) ON CONFLICT DO NOTHING
140
138
141−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
142interested in the ids here, just the usernames and email addresses. We
140interested in the ids here, just the usernames and email addresses. We
143−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
144−`Manipulation` with the same kind of type parameters.
142+`Manipulation_` with the same kind of type parameters.
145
143
146>>> :{
144>>> :{
147let
145let
148− getUsers :: Query Schema '[]
146+ getUsers :: Query_ Schemas () User
149− '[ "userName" ::: 'NotNull 'PGtext
150− , "userEmail" ::: 'Null 'PGtext ]
151− getUsers = select
147+ getUsers = select_
152 (#u ! #name `as` #userName :* #e ! #email `as` #userEmail)
148 (#u ! #name `as` #userName :* #e ! #email `as` #userEmail)
153 ( from (table (#users `as` #u)
149 ( from (table (#users `as` #u)
154 & innerJoin (table (#emails `as` #e))
150 & innerJoin (table (#emails `as` #e))
@@ -158,22 +154,12 @@ let
158>>> printSQL getUsers
154>>> printSQL getUsers
159SELECT "u"."name" AS "userName", "e"."email" AS "userEmail" FROM "users" AS "u" INNER JOIN "emails" AS "e" ON ("u"."id" = "e"."user_id")
155SELECT "u"."name" AS "userName", "e"."email" AS "userEmail" FROM "users" AS "u" INNER JOIN "emails" AS "e" ON ("u"."id" = "e"."user_id")
160
156
161−Now that we've defined the SQL side of things, we'll need a Haskell type
162−for users. We give the type `Generics.SOP.Generic` and
163−`Generics.SOP.HasDatatypeInfo` instances so that we can decode the rows
164−we receive when we run @getUsers@. Notice that the record fields of the
165−@User@ type match the column names of @getUsers@.
166−
167−>>> data User = User { userName :: Text, userEmail :: Maybe Text } deriving (Show, GHC.Generic)
168−>>> instance SOP.Generic User
169−>>> instance SOP.HasDatatypeInfo User
170−
171−Let's also create some users to add to the database.
157+Let's create some users to add to the database.
172
158
173>>> :{
159>>> :{
174let
160let
175 users :: [User]
161 users :: [User]
176− users =
162+ users =
177 [ User "Alice" (Just "alice@gmail.com")
163 [ User "Alice" (Just "alice@gmail.com")
178 , User "Bob" Nothing
164 , User "Bob" Nothing
179 , User "Carole" (Just "carole@hotmail.com")
165 , User "Carole" (Just "carole@hotmail.com")
@@ -190,38 +176,58 @@ transformer and when the schema doesn't change we can use `Monad` and
190
176
191>>> :{
177>>> :{
192let
178let
193− session :: PQ Schema Schema IO ()
179+ session :: PQ Schemas Schemas IO ()
194 session = do
180 session = do
195− idResults <- traversePrepared insertUser (Only . userName <$> users)
196− ids <- traverse (fmap fromOnly . getRow 0) idResults
197− traversePrepared_ insertEmail (zip (ids :: [Int32]) (userEmail <$> users))
181+ _ <- traversePrepared_ insertUser users
198 usersResult <- runQuery getUsers
182 usersResult <- runQuery getUsers
199 usersRows <- getRows usersResult
183 usersRows <- getRows usersResult
200− liftBase $ print (usersRows :: [User])
184+ liftIO $ print (usersRows :: [User])
201in
185in
202− void . withConnection "host=localhost port=5432 dbname=exampledb" $
186+ withConnection "host=localhost port=5432 dbname=exampledb" $
203 define setup
187 define setup
204 & pqThen session
188 & pqThen session
205 & pqThen (define teardown)
189 & pqThen (define teardown)
206:}
190:}
207[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"}]
208-}
192-}
209−module Squeal.PostgreSQL
193+module Squeal.PostgreSQL (module X, RenderSQL(..), printSQL) where
210− ( module Squeal.PostgreSQL.Binary
194+
211− , module Squeal.PostgreSQL.Definition
212− , module Squeal.PostgreSQL.Expression
213− , module Squeal.PostgreSQL.Manipulation
214− , module Squeal.PostgreSQL.PQ
215− , module Squeal.PostgreSQL.Query
216− , module Squeal.PostgreSQL.Schema
217− , module Squeal.PostgreSQL.Transaction
218− ) where
219−
220−import Squeal.PostgreSQL.Binary
195+import Squeal.PostgreSQL.Alias as X
196+import Squeal.PostgreSQL.Binary as X
221−import Squeal.PostgreSQL.Definition
197+import Squeal.PostgreSQL.Definition as X
198+import Squeal.PostgreSQL.Definition.Function as X
199+import Squeal.PostgreSQL.Definition.Index as X
200+import Squeal.PostgreSQL.Definition.Schema as X
201+import Squeal.PostgreSQL.Definition.Table as X
202+import Squeal.PostgreSQL.Definition.Table.Constraint as X
203+import Squeal.PostgreSQL.Definition.Type as X
204+import Squeal.PostgreSQL.Definition.View as X
222−import Squeal.PostgreSQL.Expression
205+import Squeal.PostgreSQL.Expression as X
206+import Squeal.PostgreSQL.Expression.Aggregate as X
207+import Squeal.PostgreSQL.Expression.Collection as X
208+import Squeal.PostgreSQL.Expression.Comparison as X
209+import Squeal.PostgreSQL.Expression.Json as X
210+import Squeal.PostgreSQL.Expression.Literal as X
211+import Squeal.PostgreSQL.Expression.Logic as X
212+import Squeal.PostgreSQL.Expression.Math as X
213+import Squeal.PostgreSQL.Expression.Null as X
214+import Squeal.PostgreSQL.Expression.Parameter as X
215+import Squeal.PostgreSQL.Expression.Range as X
216+import Squeal.PostgreSQL.Expression.Set as X
217+import Squeal.PostgreSQL.Expression.Sort as X
218+import Squeal.PostgreSQL.Expression.Subquery as X
219+import Squeal.PostgreSQL.Expression.Text as X
220+import Squeal.PostgreSQL.Expression.TextSearch as X
221+import Squeal.PostgreSQL.Expression.Time as X
222+import Squeal.PostgreSQL.Expression.Type as X
223+import Squeal.PostgreSQL.Expression.Window as X
224+import Squeal.PostgreSQL.List as X
223−import Squeal.PostgreSQL.Manipulation
225+import Squeal.PostgreSQL.Manipulation as X
226+import Squeal.PostgreSQL.Migration as X
227+import Squeal.PostgreSQL.PG as X
228+import Squeal.PostgreSQL.Pool as X
224−import Squeal.PostgreSQL.PQ
229+import Squeal.PostgreSQL.PQ as X
225−import Squeal.PostgreSQL.Query
230+import Squeal.PostgreSQL.Query as X
231+import Squeal.PostgreSQL.Render (RenderSQL(..), printSQL)
226−import Squeal.PostgreSQL.Schema
232+import Squeal.PostgreSQL.Schema as X
227−import Squeal.PostgreSQL.Transaction
233+import Squeal.PostgreSQL.Transaction as X
squeal-postgresql/src/Squeal/PostgreSQL/Alias.hsnew file+249
@@ -0,0 +1,249 @@
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+
13+{-# LANGUAGE
14+ AllowAmbiguousTypes
15+ , ConstraintKinds
16+ , DeriveAnyClass
17+ , DeriveGeneric
18+ , FlexibleContexts
19+ , FlexibleInstances
20+ , FunctionalDependencies
21+ , GADTs
22+ , LambdaCase
23+ , OverloadedStrings
24+ , QuantifiedConstraints
25+ , RankNTypes
26+ , ScopedTypeVariables
27+ , StandaloneDeriving
28+ , TypeApplications
29+ , TypeFamilyDependencies
30+ , TypeInType
31+ , TypeOperators
32+ , UndecidableInstances
33+ , UndecidableSuperClasses
34+#-}
35+
36+module Squeal.PostgreSQL.Alias
37+ ( (:::)
38+ , Alias (..)
39+ , IsLabel (..)
40+ , Aliased (As)
41+ , Aliasable (as)
42+ , renderAliased
43+ , Has
44+ , HasUnique
45+ , HasAll
46+ , HasIn
47+ , QualifiedAlias (..)
48+ , IsQualified (..)
49+ -- * Grouping
50+ , Grouping (..)
51+ , GroupedBy
52+ ) where
53+
54+import Control.DeepSeq
55+import Data.ByteString (ByteString)
56+import Data.String (fromString)
57+import GHC.OverloadedLabels
58+import GHC.TypeLits
59+
60+import qualified Generics.SOP as SOP
61+import qualified GHC.Generics as GHC
62+
63+import Squeal.PostgreSQL.List
64+import Squeal.PostgreSQL.Render
65+
66+-- $setup
67+-- >>> import Squeal.PostgreSQL
68+
69+-- | The alias operator `:::` is like a promoted version of `As`,
70+-- a type level pair between an alias and some type.
71+type (:::) (alias :: Symbol) ty = '(alias,ty)
72+infixr 6 :::
73+
74+
75+-- | `Grouping` is an auxiliary namespace, created by
76+-- @GROUP BY@ clauses (`Squeal.PostgreSQL.Query.group`), and used
77+-- for typesafe aggregation
78+data Grouping
79+ = Ungrouped -- ^ no aggregation permitted
80+ | Grouped [(Symbol,Symbol)] -- ^ aggregation required for any column which is not grouped
81+
82+{- | A `GroupedBy` constraint indicates that a table qualified column is
83+a member of the auxiliary namespace created by @GROUP BY@ clauses and thus,
84+may be called in an output `Squeal.PostgreSQL.Expression.Expression` without aggregating.
85+-}
86+class (KnownSymbol table, KnownSymbol column)
87+ => GroupedBy table column bys where
88+instance {-# OVERLAPPING #-} (KnownSymbol table, KnownSymbol column)
89+ => GroupedBy table column ('(table,column) ': bys)
90+instance {-# OVERLAPPABLE #-}
91+ ( KnownSymbol table
92+ , KnownSymbol column
93+ , GroupedBy table column bys
94+ ) => GroupedBy table column (tabcol ': bys)
95+
96+-- | `Alias`es are proxies for a type level string or `Symbol`
97+-- and have an `IsLabel` instance so that with @-XOverloadedLabels@
98+--
99+-- >>> :set -XOverloadedLabels
100+-- >>> #foobar :: Alias "foobar"
101+-- Alias
102+data Alias (alias :: Symbol) = Alias
103+ deriving (Eq,GHC.Generic,Ord,Show,NFData)
104+instance alias1 ~ alias2 => IsLabel alias1 (Alias alias2) where
105+ fromLabel = Alias
106+instance aliases ~ '[alias] => IsLabel alias (NP Alias aliases) where
107+ fromLabel = fromLabel SOP.:* Nil
108+-- | >>> printSQL (#jimbob :: Alias "jimbob")
109+-- "jimbob"
110+instance KnownSymbol alias => RenderSQL (Alias alias) where
111+ renderSQL = doubleQuoted . fromString . symbolVal
112+
113+-- >>> printSQL (#jimbob :* #kandi :: NP Alias '["jimbob", "kandi"])
114+-- "jimbob", "kandi"
115+instance SOP.All KnownSymbol aliases => RenderSQL (NP Alias aliases) where
116+ renderSQL
117+ = commaSeparated
118+ . SOP.hcollapse
119+ . SOP.hcmap (SOP.Proxy @KnownSymbol) (SOP.K . renderSQL)
120+
121+-- | The `As` operator is used to name an expression. `As` is like a demoted
122+-- version of `:::`.
123+--
124+-- >>> Just "hello" `As` #hi :: Aliased Maybe ("hi" ::: String)
125+-- As (Just "hello") Alias
126+data Aliased expression aliased where
127+ As
128+ :: KnownSymbol alias
129+ => expression ty
130+ -> Alias alias
131+ -> Aliased expression (alias ::: ty)
132+deriving instance Show (expression ty)
133+ => Show (Aliased expression (alias ::: ty))
134+deriving instance Eq (expression ty)
135+ => Eq (Aliased expression (alias ::: ty))
136+deriving instance Ord (expression ty)
137+ => Ord (Aliased expression (alias ::: ty))
138+instance (alias0 ~ alias1, alias0 ~ alias2, KnownSymbol alias2)
139+ => IsLabel alias0 (Aliased Alias (alias1 ::: alias2)) where
140+ fromLabel = fromLabel @alias2 `As` fromLabel @alias1
141+
142+-- | The `Aliasable` class provides a way to scrap your `Nil`s
143+-- in an `NP` list of `Aliased` expressions.
144+class KnownSymbol alias => Aliasable alias expression aliased
145+ | aliased -> expression
146+ , aliased -> alias
147+ where as :: expression -> Alias alias -> aliased
148+instance (KnownSymbol alias, aliased ~ (alias ::: ty)) => Aliasable alias
149+ (expression ty)
150+ (Aliased expression aliased)
151+ where
152+ as = As
153+instance (KnownSymbol alias, tys ~ '[alias ::: ty]) => Aliasable alias
154+ (expression ty)
155+ (NP (Aliased expression) tys)
156+ where
157+ expression `as` alias = expression `As` alias SOP.:* Nil
158+
159+-- | >>> let renderMaybe = fromString . maybe "Nothing" (const "Just")
160+-- >>> renderAliased renderMaybe (Just (3::Int) `As` #an_int)
161+-- "Just AS \"an_int\""
162+renderAliased
163+ :: (forall ty. expression ty -> ByteString)
164+ -> Aliased expression aliased
165+ -> ByteString
166+renderAliased render (expression `As` alias) =
167+ render expression <> " AS " <> renderSQL alias
168+
169+-- | @HasUnique alias fields field@ is a constraint that proves that
170+-- @fields@ is a singleton of @alias ::: field@.
171+type HasUnique alias fields field = fields ~ '[alias ::: field]
172+
173+-- | @Has alias fields field@ is a constraint that proves that
174+-- @fields@ has a field of @alias ::: field@, inferring @field@
175+-- from @alias@ and @fields@.
176+class KnownSymbol alias =>
177+ Has (alias :: Symbol) (fields :: [(Symbol,kind)]) (field :: kind)
178+ | alias fields -> field where
179+instance {-# OVERLAPPING #-} KnownSymbol alias
180+ => Has alias (alias ::: field ': fields) field
181+instance {-# OVERLAPPABLE #-} (KnownSymbol alias, Has alias fields field)
182+ => Has alias (field' ': fields) field
183+
184+{-| @HasIn fields (alias ::: field)@ is a constraint that proves that
185+@fields@ has a field of @alias ::: field@. It is used in @UPDATE@s to
186+choose which subfields to update.
187+-}
188+class HasIn fields field where
189+instance (Has alias fields field) => HasIn fields (alias ::: field) where
190+
191+-- | `HasAll` extends `Has` to take lists of @aliases@ and @fields@ and infer
192+-- a list of @subfields@.
193+class
194+ ( SOP.All KnownSymbol aliases
195+ ) => HasAll
196+ (aliases :: [Symbol])
197+ (fields :: [(Symbol,kind)])
198+ (subfields :: [(Symbol,kind)])
199+ | aliases fields -> subfields where
200+instance {-# OVERLAPPING #-} HasAll '[] fields '[]
201+instance {-# OVERLAPPABLE #-}
202+ (Has alias fields field, HasAll aliases fields subfields)
203+ => HasAll (alias ': aliases) fields (alias ::: field ': subfields)
204+
205+-- | Analagous to `IsLabel`, the constraint
206+-- `IsQualified` defines `!` for a column alias qualified
207+-- by a table alias.
208+class IsQualified table column expression where
209+ (!) :: Alias table -> Alias column -> expression
210+ infixl 9 !
211+instance IsQualified table column (Alias table, Alias column) where (!) = (,)
212+
213+{-| `QualifiedAlias`es enables multi-schema support by allowing a reference
214+to a `Squeal.PostgreSQL.Schema.Table`, `Squeal.PostgreSQL.Schema.Typedef`
215+or `Squeal.PostgreSQL.Schema.View` to be qualified by their schemas. By default,
216+a qualifier of @public@ is provided.
217+
218+>>> :{
219+let
220+ alias1 :: QualifiedAlias "sch" "tab"
221+ alias1 = #sch ! #tab
222+ alias2 :: QualifiedAlias "public" "vw"
223+ alias2 = #vw
224+in printSQL alias1 >> printSQL alias2
225+:}
226+"sch"."tab"
227+"vw"
228+-}
229+data QualifiedAlias (qualifier :: Symbol) (alias :: Symbol) = QualifiedAlias
230+ deriving (Eq,GHC.Generic,Ord,Show,NFData)
231+instance (q ~ q', a ~ a') => IsQualified q a (QualifiedAlias q' a') where
232+ _!_ = QualifiedAlias
233+instance (q' ~ "public", a ~ a') => IsLabel a (QualifiedAlias q' a') where
234+ fromLabel = QualifiedAlias
235+instance (q0 ~ q1, a0 ~ a1, a1 ~ a2, KnownSymbol a2) =>
236+ IsQualified q0 a0 (Aliased (QualifiedAlias q1) (a1 ::: a2)) where
237+ _!_ = QualifiedAlias `As` Alias
238+instance (q ~ "public", a0 ~ a1, a1 ~ a2, KnownSymbol a2) =>
239+ IsLabel a0 (Aliased (QualifiedAlias q) (a1 ::: a2)) where
240+ fromLabel = QualifiedAlias `As` Alias
241+
242+instance (KnownSymbol q, KnownSymbol a)
243+ => RenderSQL (QualifiedAlias q a) where
244+ renderSQL _ =
245+ let
246+ qualifier = renderSQL (Alias @q)
247+ alias = renderSQL (Alias @a)
248+ in
249+ if qualifier == "\"public\"" then alias else qualifier <> "." <> alias
squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs+314−129
@@ -7,7 +7,7 @@ Stability: experimental
7
7
8This module provides binary encoding and decoding between Haskell and PostgreSQL types.
8This module provides binary encoding and decoding between Haskell and PostgreSQL types.
9
9
10−Instances are governed by the `Generic` and `HasDatatypeInfo` typeclasses, so you absolutely
10+Instances are governed by the `SOP.Generic` and `SOP.HasDatatypeInfo` typeclasses, so you absolutely
11do not need to define your own instances to decode retrieved rows into Haskell values or
11do not need to define your own instances to decode retrieved rows into Haskell values or
12to encode Haskell values into statement parameters.
12to encode Haskell values into statement parameters.
13
13
@@ -16,10 +16,10 @@ Let's see some examples. We'll need some imports
16>>> import Data.Int (Int16)
16>>> import Data.Int (Int16)
17>>> import Data.Text (Text)
17>>> import Data.Text (Text)
18>>> import Control.Monad (void)
18>>> import Control.Monad (void)
19−>>> import Control.Monad.Base (liftBase)
19+>>> import Control.Monad.IO.Class (liftIO)
20>>> import Squeal.PostgreSQL
20>>> import Squeal.PostgreSQL
21
21
22−Define a Haskell datatype `Row` that will serve as both the input and output of a simple
22+Define a Haskell datatype @Row@ that will serve as both the input and output of a simple
23round trip query.
23round trip query.
24
24
25>>> data Row = Row { col1 :: Int16, col2 :: Text, col3 :: Maybe Bool } deriving (Eq, GHC.Generic)
25>>> data Row = Row { col1 :: Int16, col2 :: Text, col3 :: Maybe Bool } deriving (Eq, GHC.Generic)
@@ -27,7 +27,7 @@ round trip query.
27>>> instance HasDatatypeInfo Row
27>>> instance HasDatatypeInfo Row
28>>> :{
28>>> :{
29let
29let
30− roundTrip :: Query '[] (TuplePG Row) (RowPG Row)
30+ roundTrip :: Query_ (Public '[]) Row Row
31 roundTrip = values_ $
31 roundTrip = values_ $
32 parameter @1 int2 `as` #col1 :*
32 parameter @1 int2 `as` #col1 :*
33 parameter @2 text `as` #col2 :*
33 parameter @2 text `as` #col2 :*
@@ -39,15 +39,15 @@ 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− liftBase . print $ input == output
45+ liftIO . print $ input == output
46:}
46:}
47True
47True
48
48
49In addition to being able to encode and decode basic Haskell types
49In addition to being able to encode and decode basic Haskell types
50−like `Int16` and `Text`, Squeal permits you to encode and decode Haskell types to
50+like `Int16` and `Data.Text.Text`, Squeal permits you to encode and decode Haskell types to
51Postgres array, enumerated and composite types and json. Let's see another example,
51Postgres array, enumerated and composite types and json. Let's see another example,
52this time using the `Vector` type which corresponds to variable length arrays
52this time using the `Vector` type which corresponds to variable length arrays
53and homogeneous tuples which correspond to fixed length arrays. We can even
53and homogeneous tuples which correspond to fixed length arrays. We can even
@@ -55,9 +55,9 @@ create multi-dimensional fixed length arrays.
55
55
56>>> :{
56>>> :{
57data Row = Row
57data Row = Row
58− { col1 :: Vector Int16
58+ { col1 :: VarArray (Vector Int16)
59− , col2 :: (Maybe Int16,Maybe Int16)
59+ , col2 :: FixArray (Maybe Int16,Maybe Int16)
60− , col3 :: ((Int16,Int16),(Int16,Int16),(Int16,Int16))
60+ , col3 :: FixArray ((Int16,Int16),(Int16,Int16),(Int16,Int16))
61 } deriving (Eq, GHC.Generic)
61 } deriving (Eq, GHC.Generic)
62:}
62:}
63
63
@@ -68,20 +68,20 @@ Once again, we define a simple round trip query.
68
68
69>>> :{
69>>> :{
70let
70let
71− roundTrip :: Query '[] (TuplePG Row) (RowPG Row)
71+ roundTrip :: Query_ (Public '[]) Row Row
72 roundTrip = values_ $
72 roundTrip = values_ $
73− parameter @1 (int2 & vararray) `as` #col1 :*
73+ parameter @1 (int2 & vararray) `as` #col1 :*
74− parameter @2 (int2 & fixarray @2) `as` #col2 :*
74+ parameter @2 (int2 & fixarray @'[2]) `as` #col2 :*
75− parameter @3 (int2 & fixarray @2 & fixarray @3) `as` #col3
75+ parameter @3 (int2 & fixarray @'[3,2]) `as` #col3
76:}
76:}
77
77
78>>> :set -XOverloadedLists
78>>> :set -XOverloadedLists
79−>>> let input = Row [1,2] (Just 1,Nothing) ((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− liftBase . print $ input == output
84+ liftIO . print $ input == output
85:}
85:}
86True
86True
87
87
@@ -114,15 +114,15 @@ type Schema =
114
114
115>>> :{
115>>> :{
116let
116let
117− setup :: Definition '[] Schema
117+ setup :: Definition (Public '[]) (Public Schema)
118 setup =
118 setup =
119 createTypeEnumFrom @Schwarma #schwarma >>>
119 createTypeEnumFrom @Schwarma #schwarma >>>
120 createTypeCompositeFrom @Person #person
120 createTypeCompositeFrom @Person #person
121:}
121:}
122
122
123−Let's demonstrate how to associate our Haskell types `Schwarma` and `Person`
123+Let's demonstrate how to associate our Haskell types @Schwarma@ and @Person@
124with enumerated, composite or json types in Postgres. First create a Haskell
124with enumerated, composite or json types in Postgres. First create a Haskell
125−`Row` type using the `Enumerated`, `Composite` and `Json` newtypes as fields.
125+@Row@ type using the `Enumerated`, `Composite` and `Json` newtypes as fields.
126
126
127>>> :{
127>>> :{
128data Row = Row
128data Row = Row
@@ -146,7 +146,7 @@ Once again, define a round trip query.
146
146
147>>> :{
147>>> :{
148let
148let
149− roundTrip :: Query Schema (TuplePG Row) (RowPG Row)
149+ roundTrip :: Query_ (Public Schema) Row Row
150 roundTrip = values_ $
150 roundTrip = values_ $
151 parameter @1 (typedef #schwarma) `as` #schwarma :*
151 parameter @1 (typedef #schwarma) `as` #schwarma :*
152 parameter @2 (typedef #person) `as` #person1 :*
152 parameter @2 (typedef #person) `as` #person1 :*
@@ -157,7 +157,7 @@ Finally, we can drop our type definitions.
157
157
158>>> :{
158>>> :{
159let
159let
160− teardown :: Definition Schema '[]
160+ teardown :: Definition (Public Schema) (Public '[])
161 teardown = dropType #schwarma >>> dropType #person
161 teardown = dropType #schwarma >>> dropType #person
162:}
162:}
163
163
@@ -168,9 +168,9 @@ let
168 session = do
168 session = do
169 result <- runQueryParams roundTrip input
169 result <- runQueryParams roundTrip input
170 Just output <- firstRow result
170 Just output <- firstRow result
171− liftBase . 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)
@@ -194,20 +194,31 @@ True
194 , MultiParamTypeClasses
194 , MultiParamTypeClasses
195 , ScopedTypeVariables
195 , ScopedTypeVariables
196 , TypeApplications
196 , TypeApplications
197+ , TypeFamilies
197 , TypeInType
198 , TypeInType
198 , TypeOperators
199 , TypeOperators
199 , UndecidableInstances
200 , UndecidableInstances
201+ , UndecidableSuperClasses
200#-}
202#-}
201
203
202module Squeal.PostgreSQL.Binary
204module Squeal.PostgreSQL.Binary
203 ( -- * Encoding
205 ( -- * Encoding
204 ToParam (..)
206 ToParam (..)
205 , ToParams (..)
207 , ToParams (..)
208+ , ToNullityParam (..)
209+ , ToField (..)
210+ , ToFixArray (..)
206 -- * Decoding
211 -- * Decoding
207 , FromValue (..)
212 , FromValue (..)
208 , FromRow (..)
213 , FromRow (..)
214+ , FromField (..)
215+ , FromFixArray (..)
209 -- * Only
216 -- * Only
210 , Only (..)
217 , Only (..)
218+ -- * Oid
219+ , OidOf (..)
220+ , OidOfParam (..)
221+ , OidOfField (..)
211 ) where
222 ) where
212
223
213import BinaryParser
224import BinaryParser
@@ -216,12 +227,12 @@ import Control.Arrow (left)
216import Control.Monad
227import Control.Monad
217import Data.Int
228import Data.Int
218import Data.Kind
229import Data.Kind
219−import Data.Monoid hiding (All)
220import Data.Scientific
230import Data.Scientific
221import Data.Time
231import Data.Time
222import Data.UUID.Types
232import Data.UUID.Types
223import Data.Vector (Vector)
233import Data.Vector (Vector)
224import Data.Word
234import Data.Word
235+import Foreign.C.Types (CUInt(CUInt))
225import Generics.SOP
236import Generics.SOP
226import Generics.SOP.Record
237import Generics.SOP.Record
227import GHC.TypeLits
238import GHC.TypeLits
@@ -235,10 +246,14 @@ import qualified Data.Text.Lazy as Lazy (Text)
235import qualified Data.Text as Strict (Text)
246import qualified Data.Text as Strict (Text)
236import qualified Data.Text as Strict.Text
247import qualified Data.Text as Strict.Text
237import qualified Data.Vector as Vector
248import qualified Data.Vector as Vector
249+import qualified Database.PostgreSQL.LibPQ as LibPQ
238import qualified GHC.Generics as GHC
250import qualified GHC.Generics as GHC
239import qualified PostgreSQL.Binary.Decoding as Decoding
251import qualified PostgreSQL.Binary.Decoding as Decoding
240import qualified PostgreSQL.Binary.Encoding as Encoding
252import qualified PostgreSQL.Binary.Encoding as Encoding
241
253
254+import Squeal.PostgreSQL.Alias
255+import Squeal.PostgreSQL.List
256+import Squeal.PostgreSQL.PG
242import Squeal.PostgreSQL.Schema
257import Squeal.PostgreSQL.Schema
243
258
244-- | A `ToParam` constraint gives an encoding of a Haskell `Type` into
259-- | A `ToParam` constraint gives an encoding of a Haskell `Type` into
@@ -262,14 +277,13 @@ class ToParam (x :: Type) (pg :: PGType) where
262 toParam :: x -> K Encoding.Encoding pg
277 toParam :: x -> K Encoding.Encoding pg
263instance ToParam Bool 'PGbool where toParam = K . Encoding.bool
278instance ToParam Bool 'PGbool where toParam = K . Encoding.bool
264instance ToParam Int16 'PGint2 where toParam = K . Encoding.int2_int16
279instance ToParam Int16 'PGint2 where toParam = K . Encoding.int2_int16
265−instance ToParam Word16 'PGint2 where toParam = K . Encoding.int2_word16
266instance ToParam Int32 'PGint4 where toParam = K . Encoding.int4_int32
280instance ToParam Int32 'PGint4 where toParam = K . Encoding.int4_int32
267−instance ToParam Word32 'PGint4 where toParam = K . Encoding.int4_word32
268instance ToParam Int64 'PGint8 where toParam = K . Encoding.int8_int64
281instance ToParam Int64 'PGint8 where toParam = K . Encoding.int8_int64
269−instance ToParam Word64 'PGint8 where toParam = K . Encoding.int8_word64
282+instance ToParam Oid 'PGoid where toParam = K . Encoding.int4_word32 . getOid
270instance ToParam Float 'PGfloat4 where toParam = K . Encoding.float4
283instance ToParam Float 'PGfloat4 where toParam = K . Encoding.float4
271instance ToParam Double 'PGfloat8 where toParam = K . Encoding.float8
284instance ToParam Double 'PGfloat8 where toParam = K . Encoding.float8
272instance ToParam Scientific 'PGnumeric where toParam = K . Encoding.numeric
285instance ToParam Scientific 'PGnumeric where toParam = K . Encoding.numeric
286+instance ToParam Money 'PGmoney where toParam = K . Encoding.int8_int64 . cents
273instance ToParam UUID 'PGuuid where toParam = K . Encoding.uuid
287instance ToParam UUID 'PGuuid where toParam = K . Encoding.uuid
274instance ToParam (NetAddr IP) 'PGinet where toParam = K . Encoding.inet
288instance ToParam (NetAddr IP) 'PGinet where toParam = K . Encoding.inet
275instance ToParam Char ('PGchar 1) where toParam = K . Encoding.char_utf8
289instance ToParam Char ('PGchar 1) where toParam = K . Encoding.char_utf8
@@ -298,16 +312,27 @@ instance Aeson.ToJSON x => ToParam (Json x) 'PGjson where
298instance Aeson.ToJSON x => ToParam (Jsonb x) 'PGjsonb where
312instance Aeson.ToJSON x => ToParam (Jsonb x) 'PGjsonb where
299 toParam = K . Encoding.jsonb_bytes
313 toParam = K . Encoding.jsonb_bytes
300 . Lazy.ByteString.toStrict . Aeson.encode . getJsonb
314 . Lazy.ByteString.toStrict . Aeson.encode . getJsonb
301−instance ToArray x ('NotNull ('PGvararray ty))
315+instance (ToNullityParam x ty, ty ~ nullity pg, OidOf pg)
302− => ToParam x ('PGvararray ty) where
316+ => ToParam (VarArray [x]) ('PGvararray ty) where
303− toParam
317+ toParam = K
304− = K . Encoding.array (baseOid @x @('NotNull ('PGvararray ty)))
318+ . Encoding.array_foldable
305− . unK . toArray @x @('NotNull ('PGvararray ty))
319+ (getOid (oidOf @pg)) (unK . toNullityParam @x @ty)
306−instance ToArray x ('NotNull ('PGfixarray n ty))
320+ . getVarArray
321+instance (ToParam x pg, OidOf pg)
322+ => ToParam (VarArray (Vector x)) ('PGvararray ('NotNull pg)) where
323+ toParam = K
324+ . Encoding.array_vector (getOid (oidOf @pg)) (unK . toParam @x @pg)
325+ . getVarArray
326+instance (ToParam x pg, OidOf pg)
327+ => ToParam (VarArray (Vector (Maybe x))) ('PGvararray ('Null pg)) where
328+ toParam = K
329+ . Encoding.nullableArray_vector
330+ (getOid (oidOf @pg)) (unK . toParam @x @pg)
331+ . getVarArray
332+instance (ToFixArray x dims ty, ty ~ nullity pg, OidOf pg)
307− => ToParam x ('PGfixarray n ty) where
333+ => ToParam (FixArray x) ('PGfixarray dims ty) where
308− toParam
334+ toParam = K . Encoding.array (getOid (oidOf @pg))
309− = K . Encoding.array (baseOid @x @('NotNull ('PGfixarray n ty)))
335+ . unK . unK . toFixArray @x @dims @ty . getFixArray
310− . unK . toArray @x @('NotNull ('PGfixarray n ty))
311instance
336instance
312 ( IsEnumType x
337 ( IsEnumType x
313 , HasDatatypeInfo x
338 , HasDatatypeInfo x
@@ -331,7 +356,7 @@ instance
331 ( SListI fields
356 ( SListI fields
332 , IsRecord x xs
357 , IsRecord x xs
333 , AllZip ToField xs fields
358 , AllZip ToField xs fields
334− , All HasAliasedOid fields
359+ , All OidOfField fields
335 ) => ToParam (Composite x) ('PGcomposite fields) where
360 ) => ToParam (Composite x) ('PGcomposite fields) where
336 toParam =
361 toParam =
337 let
362 let
@@ -339,7 +364,7 @@ instance
339 encoders = htrans (Proxy @ToField) toField
364 encoders = htrans (Proxy @ToField) toField
340
365
341 composite
366 composite
342− :: All HasAliasedOid row
367+ :: All OidOfField row
343 => NP (K (Maybe Encoding.Encoding)) row
368 => NP (K (Maybe Encoding.Encoding)) row
344 -> K Encoding.Encoding ('PGcomposite row)
369 -> K Encoding.Encoding ('PGcomposite row)
345 composite fields = K $
370 composite fields = K $
@@ -356,27 +381,142 @@ instance
356 int32BE (fromIntegral (lengthSList (Proxy @xs))) <>
381 int32BE (fromIntegral (lengthSList (Proxy @xs))) <>
357 let
382 let
358 each
383 each
359− :: HasAliasedOid field
384+ :: OidOfField field
360 => K (Maybe Encoding.Encoding) field
385 => K (Maybe Encoding.Encoding) field
361 -> Encoding.Encoding
386 -> Encoding.Encoding
362 each (K field :: K (Maybe Encoding.Encoding) field) =
387 each (K field :: K (Maybe Encoding.Encoding) field) =
363− word32BE (aliasedOid @field)
388+ word32BE (getOid (oidOfField @field))
364 <> case field of
389 <> case field of
365 Nothing -> int64BE (-1)
390 Nothing -> int64BE (-1)
366 Just value ->
391 Just value ->
367 int32BE (fromIntegral (builderLength value))
392 int32BE (fromIntegral (builderLength value))
368 <> value
393 <> value
369 in
394 in
370− hcfoldMap (Proxy @HasAliasedOid) each fields
395+ hcfoldMap (Proxy @OidOfField) each fields
371
396
372 in
397 in
373 composite . encoders . toRecord . getComposite
398 composite . encoders . toRecord . getComposite
374
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.
375−class HasAliasedOid (field :: (Symbol, NullityType)) where
513+class OidOfField (field :: (Symbol, NullityType)) where
376− aliasedOid :: Word32
514+ oidOfField :: Oid
377−instance HasOid ty => HasAliasedOid (alias ::: nullity ty) where
515+instance OidOf ty => OidOfField (alias ::: nullity ty) where
378− aliasedOid = oid @ty
516+ oidOfField = oidOf @ty
379−
517+
518+-- | A `ToNullityParam` constraint gives an encoding of a Haskell `Type` into
519+-- into the binary format of a PostgreSQL `NullityType`.
380class ToNullityParam (x :: Type) (ty :: NullityType) where
520class ToNullityParam (x :: Type) (ty :: NullityType) where
381 toNullityParam :: x -> K (Maybe Encoding.Encoding) ty
521 toNullityParam :: x -> K (Maybe Encoding.Encoding) ty
382instance ToParam x pg => ToNullityParam x ('NotNull pg) where
522instance ToParam x pg => ToNullityParam x ('NotNull pg) where
@@ -384,55 +524,36 @@ instance ToParam x pg => ToNullityParam x ('NotNull pg) where
384instance ToParam x pg => ToNullityParam (Maybe x) ('Null pg) where
524instance ToParam x pg => ToNullityParam (Maybe x) ('Null pg) where
385 toNullityParam = K . fmap (unK . toParam @x @pg)
525 toNullityParam = K . fmap (unK . toParam @x @pg)
386
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.
387class ToField (x :: (Symbol, Type)) (field :: (Symbol, NullityType)) where
531class ToField (x :: (Symbol, Type)) (field :: (Symbol, NullityType)) where
388 toField :: P x -> K (Maybe Encoding.Encoding) field
532 toField :: P x -> K (Maybe Encoding.Encoding) field
389instance ToNullityParam x ty => ToField (alias ::: x) (alias ::: ty) where
533instance ToNullityParam x ty => ToField (alias ::: x) (alias ::: ty) where
390 toField (P x) = K . unK $ toNullityParam @x @ty x
534 toField (P x) = K . unK $ toNullityParam @x @ty x
391
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.
392−class ToArray (x :: Type) (array :: NullityType) where
540+class ToFixArray (x :: Type) (dims :: [Nat]) (array :: NullityType) where
393− toArray :: x -> K Encoding.Array array
541+ toFixArray :: x -> K (K Encoding.Array dims) array
394− baseOid :: Word32
542+instance ToNullityParam x ty => ToFixArray x '[] ty where
395− default baseOid :: HasOid (PGTypeOf array) => Word32
396− baseOid = oid @(PGTypeOf array)
397−instance {-# OVERLAPPABLE #-} (HasOid pg, ToParam x pg)
398− => ToArray x ('NotNull pg) where
399− toArray = K . Encoding.encodingArray . unK . toParam @x @pg
400−instance {-# OVERLAPPABLE #-} (HasOid pg, ToParam x pg)
401− => ToArray (Maybe x) ('Null pg) where
402− toArray = K . maybe Encoding.nullArray
403− (Encoding.encodingArray . unK . toParam @x @pg)
404−instance {-# OVERLAPPING #-} ToArray x array
405− => ToArray (Vector x) ('NotNull ('PGvararray array)) where
406− toArray = K . Encoding.dimensionArray Vector.foldl'
407− (unK . toArray @x @array)
408− baseOid = baseOid @x @array
409−instance {-# OVERLAPPING #-} ToArray x array
410− => ToArray (Maybe (Vector x)) ('Null ('PGvararray array)) where
411− toArray = K . maybe Encoding.nullArray
543+ toFixArray = K . K . maybe Encoding.nullArray Encoding.encodingArray . unK
412− (Encoding.dimensionArray Vector.foldl' (unK . toArray @x @array))
544+ . toNullityParam @x @ty
413− baseOid = baseOid @x @array
414−instance {-# OVERLAPPING #-}
415− ( IsProductType product xs
416− , Length xs ~ n
417− , All ((~) x) xs
418− , ToArray x array )
419− => ToArray product ('NotNull ('PGfixarray n array)) where
420− toArray = K . Encoding.dimensionArray foldlN
421− (unK . toArray @x @array) . unZ . unSOP . from
422− baseOid = baseOid @x @array
423−instance {-# OVERLAPPING #-}
545+instance
424 ( IsProductType product xs
546 ( IsProductType product xs
425− , Length xs ~ n
547+ , Length xs ~ dim
426 , All ((~) x) xs
548 , All ((~) x) xs
427− , ToArray x array )
549+ , ToFixArray x dims ty )
428− => ToArray (Maybe product) ('Null ('PGfixarray n array)) where
550+ => ToFixArray product (dim ': dims) ty where
429− toArray = K . maybe Encoding.nullArray
430− (Encoding.dimensionArray foldlN (unK . toArray @x @array) . unZ . unSOP . from)
551+ toFixArray = K . K . Encoding.dimensionArray foldlN
431− baseOid = baseOid @x @array
552+ (unK . unK . toFixArray @x @dims @ty) . unZ . unSOP . from
432
553
433-- | A `ToParams` constraint generically sequences the encodings of `Type`s
554-- | A `ToParams` constraint generically sequences the encodings of `Type`s
434-- of the fields of a tuple or record to a row of `ColumnType`s. You should
555-- of the fields of a tuple or record to a row of `ColumnType`s. You should
435−-- not define instances of `ToParams`. Instead define `Generic` instances
556+-- not define instances of `ToParams`. Instead define `SOP.Generic` instances
436-- which in turn provide `ToParams` instances.
557-- which in turn provide `ToParams` instances.
437class SListI tys => ToParams (x :: Type) (tys :: [NullityType]) where
558class SListI tys => ToParams (x :: Type) (tys :: [NullityType]) where
438 -- | >>> type Params = '[ 'NotNull 'PGbool, 'Null 'PGint2]
559 -- | >>> type Params = '[ 'NotNull 'PGbool, 'Null 'PGint2]
@@ -461,9 +582,11 @@ instance FromValue 'PGbool Bool where fromValue = Decoding.bool
461instance FromValue 'PGint2 Int16 where fromValue = Decoding.int
582instance FromValue 'PGint2 Int16 where fromValue = Decoding.int
462instance FromValue 'PGint4 Int32 where fromValue = Decoding.int
583instance FromValue 'PGint4 Int32 where fromValue = Decoding.int
463instance FromValue 'PGint8 Int64 where fromValue = Decoding.int
584instance FromValue 'PGint8 Int64 where fromValue = Decoding.int
585+instance FromValue 'PGoid Word32 where fromValue = Decoding.int
464instance FromValue 'PGfloat4 Float where fromValue = Decoding.float4
586instance FromValue 'PGfloat4 Float where fromValue = Decoding.float4
465instance FromValue 'PGfloat8 Double where fromValue = Decoding.float8
587instance FromValue 'PGfloat8 Double where fromValue = Decoding.float8
466instance FromValue 'PGnumeric Scientific where fromValue = Decoding.numeric
588instance FromValue 'PGnumeric Scientific where fromValue = Decoding.numeric
589+instance FromValue 'PGmoney Money where fromValue = Money <$> Decoding.int
467instance FromValue 'PGuuid UUID where fromValue = Decoding.uuid
590instance FromValue 'PGuuid UUID where fromValue = Decoding.uuid
468instance FromValue 'PGinet (NetAddr IP) where fromValue = Decoding.inet
591instance FromValue 'PGinet (NetAddr IP) where fromValue = Decoding.inet
469instance FromValue ('PGchar 1) Char where fromValue = Decoding.char
592instance FromValue ('PGchar 1) Char where fromValue = Decoding.char
@@ -493,12 +616,41 @@ instance Aeson.FromJSON x => FromValue 'PGjson (Json x) where
493instance Aeson.FromJSON x => FromValue 'PGjsonb (Jsonb x) where
616instance Aeson.FromJSON x => FromValue 'PGjsonb (Jsonb x) where
494 fromValue = Jsonb <$>
617 fromValue = Jsonb <$>
495 Decoding.jsonb_bytes (left Strict.Text.pack . Aeson.eitherDecodeStrict)
618 Decoding.jsonb_bytes (left Strict.Text.pack . Aeson.eitherDecodeStrict)
496−instance FromArray ('NotNull ('PGvararray ty)) y
619+instance FromValue pg y
620+ => FromValue ('PGvararray ('NotNull pg)) (VarArray (Vector y)) where
621+ fromValue =
622+ let
623+ rep n x = VarArray <$> Vector.replicateM n x
624+ in
625+ Decoding.array $ Decoding.dimensionArray rep
626+ (fromFixArray @'[] @('NotNull pg))
627+instance FromValue pg y
497− => FromValue ('PGvararray ty) y where
628+ => FromValue ('PGvararray ('Null pg)) (VarArray (Vector (Maybe y))) where
498− fromValue = Decoding.array (fromArray @('NotNull ('PGvararray ty)) @y)
629+ fromValue =
499−instance FromArray ('NotNull ('PGfixarray n ty)) y
630+ let
631+ rep n x = VarArray <$> Vector.replicateM n x
632+ in
633+ Decoding.array $ Decoding.dimensionArray rep
634+ (fromFixArray @'[] @('Null pg))
635+instance FromValue pg y
636+ => FromValue ('PGvararray ('NotNull pg)) (VarArray [y]) where
637+ fromValue =
638+ let
639+ rep n x = VarArray <$> replicateM n x
640+ in
641+ Decoding.array $ Decoding.dimensionArray rep
642+ (fromFixArray @'[] @('NotNull pg))
643+instance FromValue pg y
500− => FromValue ('PGfixarray n ty) y where
644+ => FromValue ('PGvararray ('Null pg)) (VarArray [Maybe y]) where
501− fromValue = Decoding.array (fromArray @('NotNull ('PGfixarray n ty)) @y)
645+ fromValue =
646+ let
647+ rep n x = VarArray <$> replicateM n x
648+ in
649+ Decoding.array $ Decoding.dimensionArray rep
650+ (fromFixArray @'[] @('Null pg))
651+instance FromFixArray dims ty y
652+ => FromValue ('PGfixarray dims ty) (FixArray y) where
653+ fromValue = FixArray <$> Decoding.array (fromFixArray @dims @ty @y)
502instance
654instance
503 ( IsEnumType y
655 ( IsEnumType y
504 , HasDatatypeInfo y
656 , HasDatatypeInfo y
@@ -569,49 +721,32 @@ instance FromValue pg y
569 K (Just bytestring) -> P . Just <$>
721 K (Just bytestring) -> P . Just <$>
570 Decoding.valueParser (fromValue @pg) bytestring
722 Decoding.valueParser (fromValue @pg) bytestring
571
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.
572−class FromArray (ty :: NullityType) (y :: Type) where
728+class FromFixArray (dims :: [Nat]) (ty :: NullityType) (y :: Type) where
573− fromArray :: Decoding.Array y
729+ fromFixArray :: Decoding.Array y
574−instance {-# OVERLAPPABLE #-} FromValue pg y
730+instance FromValue pg y => FromFixArray '[] ('NotNull pg) y where
575− => FromArray ('NotNull pg) y where
576− fromArray = Decoding.valueArray (fromValue @pg @y)
731+ fromFixArray = Decoding.valueArray (fromValue @pg @y)
577−instance {-# OVERLAPPABLE #-} FromValue pg y
732+instance FromValue pg y => FromFixArray '[] ('Null pg) (Maybe y) where
578− => FromArray ('Null pg) (Maybe y) where
579− fromArray = Decoding.nullableValueArray (fromValue @pg @y)
733+ fromFixArray = Decoding.nullableValueArray (fromValue @pg @y)
580−instance {-# OVERLAPPING #-} FromArray array y
734+instance
581− => FromArray ('NotNull ('PGvararray array)) (Vector y) where
582− fromArray =
583− Decoding.dimensionArray Vector.replicateM (fromArray @array @y)
584−instance {-# OVERLAPPING #-} FromArray array y
585− => FromArray ('Null ('PGvararray array)) (Maybe (Vector y)) where
586− fromArray = Just <$>
587− Decoding.dimensionArray Vector.replicateM (fromArray @array @y)
588−instance {-# OVERLAPPING #-}
589− ( FromArray array y
590− , All ((~) y) ys
591− , SListI ys
592− , IsProductType product ys )
735+ ( IsProductType product ys
593− => FromArray ('NotNull ('PGfixarray n array)) product where
736+ , Length ys ~ dim
594− fromArray =
595− let
596− rep _ = fmap (to . SOP . Z) . replicateMN
597− in
598− Decoding.dimensionArray rep (fromArray @array @y)
599−instance {-# OVERLAPPING #-}
600− ( FromArray array y
601 , All ((~) y) ys
737 , All ((~) y) ys
602− , SListI ys
738+ , FromFixArray dims ty y )
603− , IsProductType product ys )
739+ => FromFixArray (dim ': dims) ty product where
604− => FromArray ('Null ('PGfixarray n array)) (Maybe product) where
740+ fromFixArray =
605− fromArray =
606 let
741 let
607 rep _ = fmap (to . SOP . Z) . replicateMN
742 rep _ = fmap (to . SOP . Z) . replicateMN
608 in
743 in
609− Just <$> Decoding.dimensionArray rep (fromArray @array @y)
744+ Decoding.dimensionArray rep (fromFixArray @dims @ty @y)
610
745
611-- | A `FromRow` constraint generically sequences the parsings of the columns
746-- | A `FromRow` constraint generically sequences the parsings of the columns
612-- of a `RowType` into the fields of a record `Type` provided they have
747-- of a `RowType` into the fields of a record `Type` provided they have
613-- the same field names. You should not define instances of `FromRow`.
748-- the same field names. You should not define instances of `FromRow`.
614−-- Instead define `Generic` and `HasDatatypeInfo` instances which in turn
749+-- Instead define `SOP.Generic` and `SOP.HasDatatypeInfo` instances which in turn
615-- provide `FromRow` instances.
750-- provide `FromRow` instances.
616class SListI result => FromRow (result :: RowType) y where
751class SListI result => FromRow (result :: RowType) y where
617 -- | >>> :set -XOverloadedStrings
752 -- | >>> :set -XOverloadedStrings
@@ -634,6 +769,53 @@ instance
634 = fmap fromRecord
769 = fmap fromRecord
635 . hsequence'
770 . hsequence'
636 . htrans (Proxy @FromField) fromField
771 . htrans (Proxy @FromField) fromField
772+------------------------------------------------------
773+-- P records
774+------------------------------------------------------
775+-- instance (FromField (col ::: pg) (col ::: hask))
776+-- => FromRow '[col ::: pg] (P (col ::: hask)) where
777+-- fromRow (pg :* Nil) = (unComp . fromField) pg
778+-- instance
779+-- ( row ~ Join row1 row2
780+-- , FromRow row1 hask1
781+-- , FromRow row2 hask2
782+-- , SListI row
783+-- ) => FromRow row (hask1, hask2) where
784+-- fromRow row = case disjoin @row1 @row2 row of
785+-- (row1, row2) -> (,) <$> fromRow row1 <*> fromRow row2
786+-- instance
787+-- ( row ~ Join row1 row23
788+-- , FromRow row1 hask1
789+-- , FromRow row23 (hask2, hask3)
790+-- , SListI row
791+-- ) => FromRow row (hask1, hask2, hask3) where
792+-- fromRow row = case disjoin @row1 @row23 row of
793+-- (row1, row23) -> do
794+-- hask1 <- fromRow row1
795+-- (hask2, hask3) <- fromRow row23
796+-- return (hask1, hask2, hask3)
797+-- instance
798+-- ( row ~ Join row1 row234
799+-- , FromRow row1 hask1
800+-- , FromRow row234 (hask2, hask3, hask4)
801+-- , SListI row
802+-- ) => FromRow row (hask1, hask2, hask3, hask4) where
803+-- fromRow row = case disjoin @row1 @row234 row of
804+-- (row1, row234) -> do
805+-- hask1 <- fromRow row1
806+-- (hask2, hask3, hask4) <- fromRow row234
807+-- return (hask1, hask2, hask3, hask4)
808+-- instance
809+-- ( row ~ Join row1 row2345
810+-- , FromRow row1 hask1
811+-- , FromRow row2345 (hask2, hask3, hask4, hask5)
812+-- , SListI row
813+-- ) => FromRow row (hask1, hask2, hask3, hask4, hask5) where
814+-- fromRow row = case disjoin @row1 @row2345 row of
815+-- (row1, row2345) -> do
816+-- hask1 <- fromRow row1
817+-- (hask2, hask3, hask4, hask5) <- fromRow row2345
818+-- return (hask1, hask2, hask3, hask4, hask5)
637
819
638-- | `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
639-- `toParams` or decoding a single value with `fromRow`.
821-- `toParams` or decoding a single value with `fromRow`.
@@ -660,4 +842,7 @@ replicateMN
660 :: forall x xs m. (All ((~) x) xs, Monad m, SListI xs)
842 :: forall x xs m. (All ((~) x) xs, Monad m, SListI xs)
661 => m x -> m (NP I xs)
843 => m x -> m (NP I xs)
662replicateMN mx = hsequence' $
844replicateMN mx = hsequence' $
663− 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+23−925
@@ -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,960 +27,56 @@ 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 (UnsafeDefinition, renderDefinition)
35+ Definition (..)
33 , (>>>)
36 , (>>>)
34− -- * Tables
37+ , manipDefinition
35− -- ** Create
36− , createTable
37− , createTableIfNotExists
38− , TableConstraintExpression (..)
39− , check
40− , unique
41− , primaryKey
42− , foreignKey
43− , ForeignKeyed
44− , OnDeleteClause (OnDeleteNoAction, OnDeleteRestrict, OnDeleteCascade)
45− , renderOnDeleteClause
46− , OnUpdateClause (OnUpdateNoAction, OnUpdateRestrict, OnUpdateCascade)
47− , renderOnUpdateClause
48− -- ** Drop
49− , dropTable
50− -- ** Alter
51− , alterTable
52− , alterTableRename
53− , AlterTable (UnsafeAlterTable, renderAlterTable)
54− , addConstraint
55− , dropConstraint
56− , AddColumn (addColumn)
57− , dropColumn
58− , renameColumn
59− , alterColumn
60− , AlterColumn (UnsafeAlterColumn, renderAlterColumn)
61− , setDefault
62− , dropDefault
63− , setNotNull
64− , dropNotNull
65− , alterType
66− -- * Views
67− , createView
68− , dropView
69− -- * Types
70− , createTypeEnum
71− , createTypeEnumFrom
72− , createTypeComposite
73− , createTypeCompositeFrom
74− , dropType
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.Expression
48+import Squeal.PostgreSQL.Manipulation
99−import Squeal.PostgreSQL.Query
100import Squeal.PostgreSQL.Render
49import Squeal.PostgreSQL.Render
101import Squeal.PostgreSQL.Schema
50import Squeal.PostgreSQL.Schema
102
51
52+-- $setup
53+-- >>> import Squeal.PostgreSQL
54+
103{-----------------------------------------
55{-----------------------------------------
104statements
56statements
105-----------------------------------------}
57-----------------------------------------}
106
58
107−-- | A `Definition` is a statement that changes the schema of the
59+-- | A `Definition` is a statement that changes the schemas of the
108-- database, like a `createTable`, `dropTable`, or `alterTable` command.
60-- database, like a `createTable`, `dropTable`, or `alterTable` command.
109-- `Definition`s may be composed using the `>>>` operator.
61-- `Definition`s may be composed using the `>>>` operator.
110newtype Definition
62newtype Definition
111− (schema0 :: SchemaType)
63+ (schemas0 :: SchemasType)
112− (schema1 :: SchemaType)
64+ (schemas1 :: SchemasType)
113 = UnsafeDefinition { renderDefinition :: ByteString }
65 = UnsafeDefinition { renderDefinition :: ByteString }
114 deriving (GHC.Generic,Show,Eq,Ord,NFData)
66 deriving (GHC.Generic,Show,Eq,Ord,NFData)
115
67
116−instance RenderSQL (Definition schema0 schema1) where
68+instance RenderSQL (Definition schemas0 schemas1) where
117 renderSQL = renderDefinition
69 renderSQL = renderDefinition
118
70
119instance Category Definition where
71instance Category Definition where
120 id = UnsafeDefinition ";"
72 id = UnsafeDefinition ";"
121 ddl1 . ddl0 = UnsafeDefinition $
73 ddl1 . ddl0 = UnsafeDefinition $
122− renderDefinition ddl0 <> "\n" <> renderDefinition ddl1
74+ renderSQL ddl0 <> "\n" <> renderSQL ddl1
123−
75+
124−{-----------------------------------------
76+-- | A `Manipulation` without input or output can be run as a statement
125−CREATE statements
77+-- along with other `Definition`s, by embedding it using `manipDefinition`.
126−-----------------------------------------}
78+manipDefinition
127−
79+ :: Manipulation '[] schemas '[] '[]
128−{- | `createTable` adds a table to the schema.
80+ -- ^ no input or output
129−
81+ -> Definition schemas schemas
130−>>> :set -XOverloadedLabels
82+manipDefinition = UnsafeDefinition . (<> ";") . renderSQL
131−>>> :{
132−type Table = '[] :=>
133− '[ "a" ::: 'NoDef :=> 'Null 'PGint4
134− , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]
135−:}
136−
137−>>> :{
138−let
139− setup :: Definition '[] '["tab" ::: 'Table Table]
140− setup = createTable #tab
141− (nullable int `as` #a :* nullable real `as` #b) Nil
142−in printSQL setup
143−:}
144−CREATE TABLE "tab" ("a" int NULL, "b" real NULL);
145−-}
146−createTable
147− :: ( KnownSymbol table
148− , columns ~ (col ': cols)
149− , SOP.SListI columns
150− , SOP.SListI constraints
151− , schema1 ~ Create table ('Table (constraints :=> columns)) schema0 )
152− => Alias table -- ^ the name of the table to add
153− -> NP (Aliased (ColumnTypeExpression schema0)) columns
154− -- ^ the names and datatype of each column
155− -> NP (Aliased (TableConstraintExpression schema1 table)) constraints
156− -- ^ constraints that must hold for the table
157− -> Definition schema0 schema1
158−createTable tab columns constraints = UnsafeDefinition $
159− "CREATE TABLE" <+> renderCreation tab columns constraints
160−
161−{-| `createTableIfNotExists` creates a table if it doesn't exist, but does not add it to the schema.
162−Instead, the schema already has the table so if the table did not yet exist, the schema was wrong.
163−`createTableIfNotExists` fixes this. Interestingly, this property makes it an idempotent in
164−the `Category` of `Definition`s.
165−
166−>>> :set -XOverloadedLabels -XTypeApplications
167−>>> :{
168−type Table = '[] :=>
169− '[ "a" ::: 'NoDef :=> 'Null 'PGint4
170− , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]
171−:}
172−
173−>>> type Schema = '["tab" ::: 'Table Table]
174−
175−>>> :{
176−let
177− setup :: Definition Schema Schema
178− setup = createTableIfNotExists #tab
179− (nullable int `as` #a :* nullable real `as` #b) Nil
180−in printSQL setup
181−:}
182−CREATE TABLE IF NOT EXISTS "tab" ("a" int NULL, "b" real NULL);
183−-}
184−createTableIfNotExists
185− :: ( Has table schema ('Table (constraints :=> columns))
186− , SOP.SListI columns
187− , SOP.SListI constraints )
188− => Alias table -- ^ the name of the table to add
189− -> NP (Aliased (ColumnTypeExpression schema)) columns
190− -- ^ the names and datatype of each column
191− -> NP (Aliased (TableConstraintExpression schema table)) constraints
192− -- ^ constraints that must hold for the table
193− -> Definition schema schema
194−createTableIfNotExists tab columns constraints = UnsafeDefinition $
195− "CREATE TABLE IF NOT EXISTS"
196− <+> renderCreation tab columns constraints
197−
198−-- helper function for `createTable` and `createTableIfNotExists`
199−renderCreation
200− :: ( KnownSymbol table
201− , SOP.SListI columns
202− , SOP.SListI constraints )
203− => Alias table -- ^ the name of the table to add
204− -> NP (Aliased (ColumnTypeExpression schema0)) columns
205− -- ^ the names and datatype of each column
206− -> NP (Aliased (TableConstraintExpression schema1 table)) constraints
207− -- ^ constraints that must hold for the table
208− -> ByteString
209−renderCreation tab columns constraints = renderAlias tab
210− <+> parenthesized
211− ( renderCommaSeparated renderColumnDef columns
212− <> ( case constraints of
213− Nil -> ""
214− _ -> ", " <>
215− renderCommaSeparated renderConstraint constraints ) )
216− <> ";"
217− where
218− renderColumnDef :: Aliased (ColumnTypeExpression schema) x -> ByteString
219− renderColumnDef (ty `As` column) =
220− renderAlias column <+> renderColumnTypeExpression ty
221− renderConstraint
222− :: Aliased (TableConstraintExpression schema columns) constraint
223− -> ByteString
224− renderConstraint (constraint `As` alias) =
225− "CONSTRAINT" <+> renderAlias alias <+> renderTableConstraintExpression constraint
226−
227−-- | Data types are a way to limit the kind of data that can be stored in a
228−-- table. For many applications, however, the constraint they provide is
229−-- too coarse. For example, a column containing a product price should
230−-- probably only accept positive values. But there is no standard data type
231−-- that accepts only positive numbers. Another issue is that you might want
232−-- to constrain column data with respect to other columns or rows.
233−-- For example, in a table containing product information,
234−-- there should be only one row for each product number.
235−-- `TableConstraint`s give you as much control over the data in your tables
236−-- as you wish. If a user attempts to store data in a column that would
237−-- violate a constraint, an error is raised. This applies
238−-- even if the value came from the default value definition.
239−newtype TableConstraintExpression
240− (schema :: SchemaType)
241− (table :: Symbol)
242− (tableConstraint :: TableConstraint)
243− = UnsafeTableConstraintExpression
244− { renderTableConstraintExpression :: ByteString }
245− deriving (GHC.Generic,Show,Eq,Ord,NFData)
246−
247−{-| A `check` constraint is the most generic `TableConstraint` type.
248−It allows you to specify that the value in a certain column must satisfy
249−a Boolean (truth-value) expression.
250−
251−>>> :{
252−type Schema = '[
253− "tab" ::: 'Table ('[ "inequality" ::: 'Check '["a","b"]] :=> '[
254− "a" ::: 'NoDef :=> 'NotNull 'PGint4,
255− "b" ::: 'NoDef :=> 'NotNull 'PGint4
256− ])]
257−:}
258−
259−>>> :{
260−let
261− definition :: Definition '[] Schema
262− definition = createTable #tab
263− ( (int & notNullable) `as` #a :*
264− (int & notNullable) `as` #b )
265− ( check (#a :* #b) (#a .> #b) `as` #inequality )
266−:}
267−
268−>>> printSQL definition
269−CREATE TABLE "tab" ("a" int NOT NULL, "b" int NOT NULL, CONSTRAINT "inequality" CHECK (("a" > "b")));
270−-}
271−check
272− :: ( Has alias schema ('Table table)
273− , HasAll aliases (TableToRow table) subcolumns )
274− => NP Alias aliases
275− -- ^ specify the subcolumns which are getting checked
276− -> (forall tab. Condition schema '[tab ::: subcolumns] 'Ungrouped '[])
277− -- ^ a closed `Condition` on those subcolumns
278− -> TableConstraintExpression schema alias ('Check aliases)
279−check _cols condition = UnsafeTableConstraintExpression $
280− "CHECK" <+> parenthesized (renderExpression condition)
281−
282−{-| A `unique` constraint ensure that the data contained in a column,
283−or a group of columns, is unique among all the rows in the table.
284−
285−>>> :{
286−type Schema = '[
287− "tab" ::: 'Table( '[ "uq_a_b" ::: 'Unique '["a","b"]] :=> '[
288− "a" ::: 'NoDef :=> 'Null 'PGint4,
289− "b" ::: 'NoDef :=> 'Null 'PGint4
290− ])]
291−:}
292−
293−>>> :{
294−let
295− definition :: Definition '[] Schema
296− definition = createTable #tab
297− ( (int & nullable) `as` #a :*
298− (int & nullable) `as` #b )
299− ( unique (#a :* #b) `as` #uq_a_b )
300−:}
301−
302−>>> printSQL definition
303−CREATE TABLE "tab" ("a" int NULL, "b" int NULL, CONSTRAINT "uq_a_b" UNIQUE ("a", "b"));
304−-}
305−unique
306− :: ( Has alias schema ('Table table)
307− , HasAll aliases (TableToRow table) subcolumns )
308− => NP Alias aliases
309− -- ^ specify subcolumns which together are unique for each row
310− -> TableConstraintExpression schema alias ('Unique aliases)
311−unique columns = UnsafeTableConstraintExpression $
312− "UNIQUE" <+> parenthesized (commaSeparated (renderAliases columns))
313−
314−{-| A `primaryKey` constraint indicates that a column, or group of columns,
315−can be used as a unique identifier for rows in the table.
316−This requires that the values be both unique and not null.
317−
318−>>> :{
319−type Schema = '[
320− "tab" ::: 'Table ('[ "pk_id" ::: 'PrimaryKey '["id"]] :=> '[
321− "id" ::: 'Def :=> 'NotNull 'PGint4,
322− "name" ::: 'NoDef :=> 'NotNull 'PGtext
323− ])]
324−:}
325−
326−>>> :{
327−let
328− definition :: Definition '[] Schema
329− definition = createTable #tab
330− ( serial `as` #id :*
331− (text & notNullable) `as` #name )
332− ( primaryKey #id `as` #pk_id )
333−:}
334−
335−>>> printSQL definition
336−CREATE TABLE "tab" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_id" PRIMARY KEY ("id"));
337−-}
338−primaryKey
339− :: ( Has alias schema ('Table table)
340− , HasAll aliases (TableToColumns table) subcolumns
341− , AllNotNull subcolumns )
342− => NP Alias aliases
343− -- ^ specify the subcolumns which together form a primary key.
344− -> TableConstraintExpression schema alias ('PrimaryKey aliases)
345−primaryKey columns = UnsafeTableConstraintExpression $
346− "PRIMARY KEY" <+> parenthesized (commaSeparated (renderAliases columns))
347−
348−{-| A `foreignKey` specifies that the values in a column
349−(or a group of columns) must match the values appearing in some row of
350−another table. We say this maintains the referential integrity
351−between two related tables.
352−
353−>>> :{
354−type Schema =
355− '[ "users" ::: 'Table (
356− '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
357− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
358− , "name" ::: 'NoDef :=> 'NotNull 'PGtext
359− ])
360− , "emails" ::: 'Table (
361− '[ "pk_emails" ::: 'PrimaryKey '["id"]
362− , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
363− ] :=>
364− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
365− , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
366− , "email" ::: 'NoDef :=> 'Null 'PGtext
367− ])
368− ]
369−:}
370−
371−>>> :{
372−let
373− setup :: Definition '[] Schema
374− setup =
375− createTable #users
376− ( serial `as` #id :*
377− (text & notNullable) `as` #name )
378− ( primaryKey #id `as` #pk_users ) >>>
379− createTable #emails
380− ( serial `as` #id :*
381− (int & notNullable) `as` #user_id :*
382− (text & nullable) `as` #email )
383− ( primaryKey #id `as` #pk_emails :*
384− foreignKey #user_id #users #id
385− OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
386−in printSQL setup
387−:}
388−CREATE TABLE "users" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_users" PRIMARY KEY ("id"));
389−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);
390−
391−A `foreignKey` can even be a table self-reference.
392−
393−>>> :{
394−type Schema =
395− '[ "employees" ::: 'Table (
396− '[ "employees_pk" ::: 'PrimaryKey '["id"]
397− , "employees_employer_fk" ::: 'ForeignKey '["employer_id"] "employees" '["id"]
398− ] :=>
399− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
400− , "name" ::: 'NoDef :=> 'NotNull 'PGtext
401− , "employer_id" ::: 'NoDef :=> 'Null 'PGint4
402− ])
403− ]
404−:}
405−
406−>>> :{
407−let
408− setup :: Definition '[] Schema
409− setup =
410− createTable #employees
411− ( serial `as` #id :*
412− (text & notNullable) `as` #name :*
413− (integer & nullable) `as` #employer_id )
414− ( primaryKey #id `as` #employees_pk :*
415− foreignKey #employer_id #employees #id
416− OnDeleteCascade OnUpdateCascade `as` #employees_employer_fk )
417−in printSQL setup
418−:}
419−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);
420−-}
421−foreignKey
422− :: (ForeignKeyed schema child parent
423− table reftable
424− columns refcolumns
425− constraints cols
426− reftys tys )
427− => NP Alias columns
428− -- ^ column or columns in the table
429− -> Alias parent
430− -- ^ reference table
431− -> NP Alias refcolumns
432− -- ^ reference column or columns in the reference table
433− -> OnDeleteClause
434− -- ^ what to do when reference is deleted
435− -> OnUpdateClause
436− -- ^ what to do when reference is updated
437− -> TableConstraintExpression schema child
438− ('ForeignKey columns parent refcolumns)
439−foreignKey keys parent refs ondel onupd = UnsafeTableConstraintExpression $
440− "FOREIGN KEY" <+> parenthesized (commaSeparated (renderAliases keys))
441− <+> "REFERENCES" <+> renderAlias parent
442− <+> parenthesized (commaSeparated (renderAliases refs))
443− <+> renderOnDeleteClause ondel
444− <+> renderOnUpdateClause onupd
445−
446−-- | A constraint synonym between types involved in a foreign key constraint.
447−type ForeignKeyed schema
448− child parent
449− table reftable
450− columns refcolumns
451− constraints cols
452− reftys tys =
453− ( Has child schema ('Table table)
454− , Has parent schema ('Table reftable)
455− , HasAll columns (TableToColumns table) tys
456− , reftable ~ (constraints :=> cols)
457− , HasAll refcolumns cols reftys
458− , SOP.AllZip SamePGType tys reftys
459− , Uniquely refcolumns constraints )
460−
461−-- | `OnDeleteClause` indicates what to do with rows that reference a deleted row.
462−data OnDeleteClause
463− = OnDeleteNoAction
464− -- ^ if any referencing rows still exist when the constraint is checked,
465− -- an error is raised
466− | OnDeleteRestrict -- ^ prevents deletion of a referenced row
467− | OnDeleteCascade
468− -- ^ specifies that when a referenced row is deleted,
469− -- row(s) referencing it should be automatically deleted as well
470− deriving (GHC.Generic,Show,Eq,Ord)
471−instance NFData OnDeleteClause
472−
473−-- | Render `OnDeleteClause`.
474−renderOnDeleteClause :: OnDeleteClause -> ByteString
475−renderOnDeleteClause = \case
476− OnDeleteNoAction -> "ON DELETE NO ACTION"
477− OnDeleteRestrict -> "ON DELETE RESTRICT"
478− OnDeleteCascade -> "ON DELETE CASCADE"
479−
480−-- | Analagous to `OnDeleteClause` there is also `OnUpdateClause` which is invoked
481−-- when a referenced column is changed (updated).
482−data OnUpdateClause
483− = OnUpdateNoAction
484− -- ^ if any referencing rows has not changed when the constraint is checked,
485− -- an error is raised
486− | OnUpdateRestrict -- ^ prevents update of a referenced row
487− | OnUpdateCascade
488− -- ^ the updated values of the referenced column(s) should be copied
489− -- into the referencing row(s)
490− deriving (GHC.Generic,Show,Eq,Ord)
491−instance NFData OnUpdateClause
492−
493−-- | Render `OnUpdateClause`.
494−renderOnUpdateClause :: OnUpdateClause -> ByteString
495−renderOnUpdateClause = \case
496− OnUpdateNoAction -> "ON UPDATE NO ACTION"
497− OnUpdateRestrict -> "ON UPDATE RESTRICT"
498− OnUpdateCascade -> "ON UPDATE CASCADE"
499−
500−{-----------------------------------------
501−DROP statements
502−-----------------------------------------}
503−
504−-- | `dropTable` removes a table from the schema.
505−--
506−-- >>> :{
507−-- let
508−-- definition :: Definition '["muh_table" ::: 'Table t] '[]
509−-- definition = dropTable #muh_table
510−-- :}
511−--
512−-- >>> printSQL definition
513−-- DROP TABLE "muh_table";
514−dropTable
515− :: Has table schema ('Table t)
516− => Alias table -- ^ table to remove
517− -> Definition schema (Drop table schema)
518−dropTable tab = UnsafeDefinition $ "DROP TABLE" <+> renderAlias tab <> ";"
519−
520−{-----------------------------------------
521−ALTER statements
522−-----------------------------------------}
523−
524−-- | `alterTable` changes the definition of a table from the schema.
525−alterTable
526− :: KnownSymbol alias
527− => Alias alias -- ^ table to alter
528− -> AlterTable alias table schema -- ^ alteration to perform
529− -> Definition schema (Alter alias ('Table table) schema)
530−alterTable tab alteration = UnsafeDefinition $
531− "ALTER TABLE"
532− <+> renderAlias tab
533− <+> renderAlterTable alteration
534− <> ";"
535−
536−-- | `alterTableRename` changes the name of a table from the schema.
537−--
538−-- >>> printSQL $ alterTableRename #foo #bar
539−-- ALTER TABLE "foo" RENAME TO "bar";
540−alterTableRename
541− :: (KnownSymbol table0, KnownSymbol table1)
542− => Alias table0 -- ^ table to rename
543− -> Alias table1 -- ^ what to rename it
544− -> Definition schema (Rename table0 table1 schema)
545−alterTableRename table0 table1 = UnsafeDefinition $
546− "ALTER TABLE" <+> renderAlias table0
547− <+> "RENAME TO" <+> renderAlias table1 <> ";"
548−
549−-- | An `AlterTable` describes the alteration to perform on the columns
550−-- of a table.
551−newtype AlterTable
552− (alias :: Symbol)
553− (table :: TableType)
554− (schema :: SchemaType) =
555− UnsafeAlterTable {renderAlterTable :: ByteString}
556− deriving (GHC.Generic,Show,Eq,Ord,NFData)
557−
558−-- | An `addConstraint` adds a table constraint.
559−--
560−-- >>> :{
561−-- let
562−-- definition :: Definition
563−-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]
564−-- '["tab" ::: 'Table ('["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]
565−-- definition = alterTable #tab (addConstraint #positive (check #col (#col .> 0)))
566−-- in printSQL definition
567−-- :}
568−-- ALTER TABLE "tab" ADD CONSTRAINT "positive" CHECK (("col" > 0));
569−addConstraint
570− :: ( KnownSymbol alias
571− , Has tab schema ('Table table0)
572− , table0 ~ (constraints :=> columns)
573− , table1 ~ (Create alias constraint constraints :=> columns) )
574− => Alias alias
575− -> TableConstraintExpression schema tab constraint
576− -- ^ constraint to add
577− -> AlterTable tab table1 schema
578−addConstraint alias constraint = UnsafeAlterTable $
579− "ADD" <+> "CONSTRAINT" <+> renderAlias alias
580− <+> renderTableConstraintExpression constraint
581−
582−-- | A `dropConstraint` drops a table constraint.
583−--
584−-- >>> :{
585−-- let
586−-- definition :: Definition
587−-- '["tab" ::: 'Table ('["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]
588−-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]
589−-- definition = alterTable #tab (dropConstraint #positive)
590−-- in printSQL definition
591−-- :}
592−-- ALTER TABLE "tab" DROP CONSTRAINT "positive";
593−dropConstraint
594− :: ( KnownSymbol constraint
595− , Has tab schema ('Table table0)
596− , table0 ~ (constraints :=> columns)
597− , table1 ~ (Drop constraint constraints :=> columns) )
598− => Alias constraint
599− -- ^ constraint to drop
600− -> AlterTable tab table1 schema
601−dropConstraint constraint = UnsafeAlterTable $
602− "DROP" <+> "CONSTRAINT" <+> renderAlias constraint
603−
604−-- | An `AddColumn` is either @NULL@ or has @DEFAULT@.
605−class AddColumn ty where
606− -- | `addColumn` adds a new column, initially filled with whatever
607− -- default value is given or with @NULL@.
608− --
609− -- >>> :{
610− -- let
611− -- definition :: Definition
612− -- '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]
613− -- '["tab" ::: 'Table ('[] :=>
614− -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
615− -- , "col2" ::: 'Def :=> 'Null 'PGtext ])]
616− -- definition = alterTable #tab (addColumn #col2 (text & nullable & default_ "foo"))
617− -- in printSQL definition
618− -- :}
619− -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL DEFAULT E'foo';
620− --
621− -- >>> :{
622− -- let
623− -- definition :: Definition
624− -- '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]
625− -- '["tab" ::: 'Table ('[] :=>
626− -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
627− -- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]
628− -- definition = alterTable #tab (addColumn #col2 (text & nullable))
629− -- in printSQL definition
630− -- :}
631− -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL;
632− addColumn
633− :: ( KnownSymbol column
634− , Has tab schema ('Table table0)
635− , table0 ~ (constraints :=> columns)
636− , table1 ~ (constraints :=> Create column ty columns) )
637− => Alias column -- ^ column to add
638− -> ColumnTypeExpression schema ty -- ^ type of the new column
639− -> AlterTable tab table1 schema
640− addColumn column ty = UnsafeAlterTable $
641− "ADD COLUMN" <+> renderAlias column <+> renderColumnTypeExpression ty
642−instance {-# OVERLAPPING #-} AddColumn ('Def :=> ty)
643−instance {-# OVERLAPPABLE #-} AddColumn ('NoDef :=> 'Null ty)
644−
645−-- | A `dropColumn` removes a column. Whatever data was in the column
646−-- disappears. Table constraints involving the column are dropped, too.
647−-- However, if the column is referenced by a foreign key constraint of
648−-- another table, PostgreSQL will not silently drop that constraint.
649−--
650−-- >>> :{
651−-- let
652−-- definition :: Definition
653−-- '["tab" ::: 'Table ('[] :=>
654−-- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
655−-- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]
656−-- '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]
657−-- definition = alterTable #tab (dropColumn #col2)
658−-- in printSQL definition
659−-- :}
660−-- ALTER TABLE "tab" DROP COLUMN "col2";
661−dropColumn
662− :: ( KnownSymbol column
663− , Has tab schema ('Table table0)
664− , table0 ~ (constraints :=> columns)
665− , table1 ~ (constraints :=> Drop column columns) )
666− => Alias column -- ^ column to remove
667− -> AlterTable tab table1 schema
668−dropColumn column = UnsafeAlterTable $
669− "DROP COLUMN" <+> renderAlias column
670−
671−-- | A `renameColumn` renames a column.
672−--
673−-- >>> :{
674−-- let
675−-- definition :: Definition
676−-- '["tab" ::: 'Table ('[] :=> '["foo" ::: 'NoDef :=> 'Null 'PGint4])]
677−-- '["tab" ::: 'Table ('[] :=> '["bar" ::: 'NoDef :=> 'Null 'PGint4])]
678−-- definition = alterTable #tab (renameColumn #foo #bar)
679−-- in printSQL definition
680−-- :}
681−-- ALTER TABLE "tab" RENAME COLUMN "foo" TO "bar";
682−renameColumn
683− :: ( KnownSymbol column0
684− , KnownSymbol column1
685− , Has tab schema ('Table table0)
686− , table0 ~ (constraints :=> columns)
687− , table1 ~ (constraints :=> Rename column0 column1 columns) )
688− => Alias column0 -- ^ column to rename
689− -> Alias column1 -- ^ what to rename the column
690− -> AlterTable tab table1 schema
691−renameColumn column0 column1 = UnsafeAlterTable $
692− "RENAME COLUMN" <+> renderAlias column0 <+> "TO" <+> renderAlias column1
693−
694−-- | An `alterColumn` alters a single column.
695−alterColumn
696− :: ( KnownSymbol column
697− , Has tab schema ('Table table0)
698− , table0 ~ (constraints :=> columns)
699− , Has column columns ty0
700− , tables1 ~ (constraints :=> Alter column ty1 columns))
701− => Alias column -- ^ column to alter
702− -> AlterColumn schema ty0 ty1 -- ^ alteration to perform
703− -> AlterTable tab table1 schema
704−alterColumn column alteration = UnsafeAlterTable $
705− "ALTER COLUMN" <+> renderAlias column <+> renderAlterColumn alteration
706−
707−-- | An `AlterColumn` describes the alteration to perform on a single column.
708−newtype AlterColumn (schema :: SchemaType) (ty0 :: ColumnType) (ty1 :: ColumnType) =
709− UnsafeAlterColumn {renderAlterColumn :: ByteString}
710− deriving (GHC.Generic,Show,Eq,Ord,NFData)
711−
712−-- | A `setDefault` sets a new default for a column. Note that this doesn't
713−-- affect any existing rows in the table, it just changes the default for
714−-- future insert and update commands.
715−--
716−-- >>> :{
717−-- let
718−-- definition :: Definition
719−-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]
720−-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]
721−-- definition = alterTable #tab (alterColumn #col (setDefault 5))
722−-- in printSQL definition
723−-- :}
724−-- ALTER TABLE "tab" ALTER COLUMN "col" SET DEFAULT 5;
725−setDefault
726− :: Expression schema '[] 'Ungrouped '[] ty -- ^ default value to set
727− -> AlterColumn schema (constraint :=> ty) ('Def :=> ty)
728−setDefault expression = UnsafeAlterColumn $
729− "SET DEFAULT" <+> renderExpression expression
730−
731−-- | A `dropDefault` removes any default value for a column.
732−--
733−-- >>> :{
734−-- let
735−-- definition :: Definition
736−-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]
737−-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]
738−-- definition = alterTable #tab (alterColumn #col dropDefault)
739−-- in printSQL definition
740−-- :}
741−-- ALTER TABLE "tab" ALTER COLUMN "col" DROP DEFAULT;
742−dropDefault :: AlterColumn schema ('Def :=> ty) ('NoDef :=> ty)
743−dropDefault = UnsafeAlterColumn $ "DROP DEFAULT"
744−
745−-- | A `setNotNull` adds a @NOT NULL@ constraint to a column.
746−-- The constraint will be checked immediately, so the table data must satisfy
747−-- the constraint before it can be added.
748−--
749−-- >>> :{
750−-- let
751−-- definition :: Definition
752−-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]
753−-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]
754−-- definition = alterTable #tab (alterColumn #col setNotNull)
755−-- in printSQL definition
756−-- :}
757−-- ALTER TABLE "tab" ALTER COLUMN "col" SET NOT NULL;
758−setNotNull
759− :: AlterColumn schema (constraint :=> 'Null ty) (constraint :=> 'NotNull ty)
760−setNotNull = UnsafeAlterColumn $ "SET NOT NULL"
761−
762−-- | A `dropNotNull` drops a @NOT NULL@ constraint from a column.
763−--
764−-- >>> :{
765−-- let
766−-- definition :: Definition
767−-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]
768−-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]
769−-- definition = alterTable #tab (alterColumn #col dropNotNull)
770−-- in printSQL definition
771−-- :}
772−-- ALTER TABLE "tab" ALTER COLUMN "col" DROP NOT NULL;
773−dropNotNull
774− :: AlterColumn schema (constraint :=> 'NotNull ty) (constraint :=> 'Null ty)
775−dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL"
776−
777−-- | An `alterType` converts a column to a different data type.
778−-- This will succeed only if each existing entry in the column can be
779−-- converted to the new type by an implicit cast.
780−--
781−-- >>> :{
782−-- let
783−-- definition :: Definition
784−-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]
785−-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGnumeric])]
786−-- definition =
787−-- alterTable #tab (alterColumn #col (alterType (numeric & notNullable)))
788−-- in printSQL definition
789−-- :}
790−-- ALTER TABLE "tab" ALTER COLUMN "col" TYPE numeric NOT NULL;
791−alterType :: ColumnTypeExpression schema ty -> AlterColumn schema ty0 ty
792−alterType ty = UnsafeAlterColumn $ "TYPE" <+> renderColumnTypeExpression ty
793−
794−-- | Create a view.
795−--
796−-- >>> :{
797−-- let
798−-- definition :: Definition
799−-- '[ "abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])]
800−-- '[ "abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])
801−-- , "bc" ::: 'View ('["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4])]
802−-- definition =
803−-- createView #bc (select (#b :* #c) (from (table #abc)))
804−-- in printSQL definition
805−-- :}
806−-- CREATE VIEW "bc" AS SELECT "b" AS "b", "c" AS "c" FROM "abc" AS "abc";
807−createView
808− :: KnownSymbol view
809− => Alias view -- ^ the name of the view to add
810− -> Query schema '[] row
811− -- ^ query
812− -> Definition schema (Create view ('View row) schema)
813−createView alias query = UnsafeDefinition $
814− "CREATE" <+> "VIEW" <+> renderAlias alias <+> "AS"
815− <+> renderQuery query <> ";"
816−
817−-- | Drop a view.
818−--
819−-- >>> :{
820−-- let
821−-- definition :: Definition
822−-- '[ "abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])
823−-- , "bc" ::: 'View ('["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4])]
824−-- '[ "abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])]
825−-- definition = dropView #bc
826−-- in printSQL definition
827−-- :}
828−-- DROP VIEW "bc";
829−dropView
830− :: Has view schema ('View v)
831− => Alias view -- ^ view to remove
832− -> Definition schema (Drop view schema)
833−dropView v = UnsafeDefinition $ "DROP VIEW" <+> renderAlias v <> ";"
834−
835−-- | Enumerated types are created using the `createTypeEnum` command, for example
836−--
837−-- >>> printSQL $ createTypeEnum #mood (label @"sad" :* label @"ok" :* label @"happy")
838−-- CREATE TYPE "mood" AS ENUM ('sad', 'ok', 'happy');
839−createTypeEnum
840− :: (KnownSymbol enum, SOP.All KnownSymbol labels)
841− => Alias enum
842− -- ^ name of the user defined enumerated type
843− -> NP PGlabel labels
844− -- ^ labels of the enumerated type
845− -> Definition schema (Create enum ('Typedef ('PGenum labels)) schema)
846−createTypeEnum enum labels = UnsafeDefinition $
847− "CREATE" <+> "TYPE" <+> renderAlias enum <+> "AS" <+> "ENUM" <+>
848− parenthesized (commaSeparated (renderLabels labels)) <> ";"
849−
850−-- | Enumerated types can also be generated from a Haskell type, for example
851−--
852−-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic
853−-- >>> instance SOP.Generic Schwarma
854−-- >>> instance SOP.HasDatatypeInfo Schwarma
855−-- >>> printSQL $ createTypeEnumFrom @Schwarma #schwarma
856−-- CREATE TYPE "schwarma" AS ENUM ('Beef', 'Lamb', 'Chicken');
857−createTypeEnumFrom
858− :: forall hask enum schema.
859− ( SOP.Generic hask
860− , SOP.All KnownSymbol (LabelsPG hask)
861− , KnownSymbol enum
862− )
863− => Alias enum
864− -- ^ name of the user defined enumerated type
865− -> Definition schema (Create enum ('Typedef (PG (Enumerated hask))) schema)
866−createTypeEnumFrom enum = createTypeEnum enum
867− (SOP.hpure label :: NP PGlabel (LabelsPG hask))
868−
869−{- | `createTypeComposite` creates a composite type. The composite type is
870−specified by a list of attribute names and data types.
871−
872−>>> :{
873−type PGcomplex = 'PGcomposite
874− '[ "real" ::: 'NotNull 'PGfloat8
875− , "imaginary" ::: 'NotNull 'PGfloat8 ]
876−:}
877−
878−>>> :{
879−let
880− setup :: Definition '[] '["complex" ::: 'Typedef PGcomplex]
881− setup = createTypeComposite #complex
882− (float8 `as` #real :* float8 `as` #imaginary)
883−in printSQL setup
884−:}
885−CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);
886−-}
887−createTypeComposite
888− :: (KnownSymbol ty, SOP.SListI fields)
889− => Alias ty
890− -- ^ name of the user defined composite type
891− -> NP (Aliased (TypeExpression schema)) fields
892− -- ^ list of attribute names and data types
893− -> Definition schema (Create ty ('Typedef ('PGcomposite fields)) schema)
894−createTypeComposite ty fields = UnsafeDefinition $
895− "CREATE" <+> "TYPE" <+> renderAlias ty <+> "AS" <+> parenthesized
896− (renderCommaSeparated renderField fields) <> ";"
897− where
898− renderField :: Aliased (TypeExpression schema) x -> ByteString
899− renderField (typ `As` alias) =
900− renderAlias alias <+> renderTypeExpression typ
901−
902−-- | Composite types can also be generated from a Haskell type, for example
903−--
904−-- >>> data Complex = Complex {real :: Double, imaginary :: Double} deriving GHC.Generic
905−-- >>> instance SOP.Generic Complex
906−-- >>> instance SOP.HasDatatypeInfo Complex
907−-- >>> printSQL $ createTypeCompositeFrom @Complex #complex
908−-- CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);
909−createTypeCompositeFrom
910− :: forall hask ty schema.
911− ( SOP.All (FieldTyped schema) (RowPG hask)
912− , KnownSymbol ty )
913− => Alias ty
914− -- ^ name of the user defined composite type
915− -> Definition schema (Create ty ( 'Typedef (PG (Composite hask))) schema)
916−createTypeCompositeFrom ty = createTypeComposite ty
917− (SOP.hcpure (SOP.Proxy :: SOP.Proxy (FieldTyped schema)) fieldtype
918− :: NP (Aliased (TypeExpression schema)) (RowPG hask))
919−
920−class FieldTyped schema ty where
921− fieldtype :: Aliased (TypeExpression schema) ty
922−instance (KnownSymbol alias, PGTyped schema ty)
923− => FieldTyped schema (alias ::: ty) where
924− fieldtype = pgtype `As` Alias
925−
926−-- | Drop a type.
927−--
928−-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic
929−-- >>> instance SOP.Generic Schwarma
930−-- >>> instance SOP.HasDatatypeInfo Schwarma
931−-- >>> printSQL (dropType #schwarma :: Definition '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))] '[])
932−-- DROP TYPE "schwarma";
933−dropType
934− :: Has tydef schema ('Typedef ty)
935− => Alias tydef
936− -- ^ name of the user defined type
937− -> Definition schema (Drop tydef schema)
938−dropType tydef = UnsafeDefinition $ "DROP" <+> "TYPE" <+> renderAlias tydef <> ";"
939−
940−-- | `ColumnTypeExpression`s are used in `createTable` commands.
941−newtype ColumnTypeExpression (schema :: SchemaType) (ty :: ColumnType)
942− = UnsafeColumnTypeExpression { renderColumnTypeExpression :: ByteString }
943− deriving (GHC.Generic,Show,Eq,Ord,NFData)
944−
945−-- | used in `createTable` commands as a column constraint to note that
946−-- @NULL@ may be present in a column
947−nullable
948− :: TypeExpression schema (nullity ty)
949− -> ColumnTypeExpression schema ('NoDef :=> 'Null ty)
950−nullable ty = UnsafeColumnTypeExpression $ renderTypeExpression ty <+> "NULL"
951−
952−-- | used in `createTable` commands as a column constraint to ensure
953−-- @NULL@ is not present in a column
954−notNullable
955− :: TypeExpression schema (nullity ty)
956− -> ColumnTypeExpression schema ('NoDef :=> 'NotNull ty)
957−notNullable ty = UnsafeColumnTypeExpression $ renderTypeExpression ty <+> "NOT NULL"
958−
959−-- | used in `createTable` commands as a column constraint to give a default
960−default_
961− :: Expression schema '[] 'Ungrouped '[] ty
962− -> ColumnTypeExpression schema ('NoDef :=> ty)
963− -> ColumnTypeExpression schema ('Def :=> ty)
964−default_ x ty = UnsafeColumnTypeExpression $
965− renderColumnTypeExpression ty <+> "DEFAULT" <+> renderExpression x
966−
967−-- | not a true type, but merely a notational convenience for creating
968−-- unique identifier columns with type `PGint2`
969−serial2, smallserial
970− :: ColumnTypeExpression schema ('Def :=> 'NotNull 'PGint2)
971−serial2 = UnsafeColumnTypeExpression "serial2"
972−smallserial = UnsafeColumnTypeExpression "smallserial"
973−-- | not a true type, but merely a notational convenience for creating
974−-- unique identifier columns with type `PGint4`
975−serial4, serial
976− :: ColumnTypeExpression schema ('Def :=> 'NotNull 'PGint4)
977−serial4 = UnsafeColumnTypeExpression "serial4"
978−serial = UnsafeColumnTypeExpression "serial"
979−-- | not a true type, but merely a notational convenience for creating
980−-- unique identifier columns with type `PGint8`
981−serial8, bigserial
982− :: ColumnTypeExpression schema ('Def :=> 'NotNull 'PGint8)
983−serial8 = UnsafeColumnTypeExpression "serial8"
984−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+336−1622
@@ -1,14 +1,13 @@
1{-|
1{-|
2−Module: Squeal.PostgreSQL.Query
2+Module: 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
@@ -16,11 +15,13 @@ Squeal expressions are the atoms used to build statements.
16 , FlexibleContexts
15 , FlexibleContexts
17 , FlexibleInstances
16 , FlexibleInstances
18 , FunctionalDependencies
17 , FunctionalDependencies
18+ , GADTs
19 , GeneralizedNewtypeDeriving
19 , GeneralizedNewtypeDeriving
20 , LambdaCase
20 , LambdaCase
21 , MagicHash
21 , MagicHash
22 , OverloadedStrings
22 , OverloadedStrings
23 , ScopedTypeVariables
23 , ScopedTypeVariables
24+ , StandaloneDeriving
24 , TypeApplications
25 , TypeApplications
25 , TypeFamilies
26 , TypeFamilies
26 , TypeInType
27 , TypeInType
@@ -31,543 +32,351 @@ Squeal expressions are the atoms used to build statements.
31
32
32module Squeal.PostgreSQL.Expression
33module Squeal.PostgreSQL.Expression
33 ( -- * Expression
34 ( -- * Expression
34− Expression (UnsafeExpression, renderExpression)
35+ Expression (..)
35− , HasParameter (parameter)
36+ , Expr
36− , param
37+ , type (-->)
37− -- ** Null
38+ , FunctionDB
38− , null_
39− , notNull
40− , coalesce
41− , fromNull
42− , isNull
43− , isNotNull
44− , matchNull
45− , nullIf
46− -- ** Collections
47− , array
48− , index
49− , row
50− , field
51− -- ** Functions
52− , unsafeBinaryOp
53− , unsafeUnaryOp
54 , unsafeFunction
39 , unsafeFunction
55− , unsafeVariadicFunction
40+ , function
56− , atan2_
41+ , unsafeLeftOp
57− , cast
42+ , leftOp
58− , quot_
43+ , unsafeRightOp
59− , rem_
44+ , rightOp
60− , trunc
45+ , Operator
61− , round_
46+ , OperatorDB
62− , ceiling_
47+ , unsafeBinaryOp
63− , greatest
48+ , binaryOp
64− , least
49+ , FunctionVar
65− -- ** Conditions
50+ , unsafeFunctionVar
66− , true
51+ , type (--->)
67− , false
52+ , FunctionNDB
68− , not_
53+ , unsafeFunctionN
69− , (.&&)
54+ , functionN
70− , (.||)
55+ , PGSubset (..)
71− , Condition
56+ , PGIntersect (..)
72− , caseWhenThenElse
73− , ifThenElse
74− , (.==)
75− , (./=)
76− , (.>=)
77− , (.<)
78− , (.<=)
79− , (.>)
80− -- ** Time
81− , currentDate
82− , currentTime
83− , currentTimestamp
84− , localTime
85− , localTimestamp
86− -- ** Text
87− , lower
88− , upper
89− , charLength
90− , like
91− -- ** Json
92− -- *** Json and Jsonb operators
93− , (.->)
94− , (.->>)
95− , (.#>)
96− , (.#>>)
97− -- *** Jsonb operators
98− , (.@>)
99− , (.<@)
100− , (.?)
101− , (.?|)
102− , (.?&)
103− , (.-.)
104− , (#-.)
105− -- *** Functions
106− , jsonLit
107− , jsonbLit
108− , toJson
109− , toJsonb
110− , arrayToJson
111− , rowToJson
112− , jsonBuildArray
113− , jsonbBuildArray
114− , jsonBuildObject
115− , jsonbBuildObject
116− , jsonObject
117− , jsonbObject
118− , jsonZipObject
119− , jsonbZipObject
120− , jsonArrayLength
121− , jsonbArrayLength
122− , jsonExtractPath
123− , jsonbExtractPath
124− , jsonExtractPathAsText
125− , jsonbExtractPathAsText
126− , jsonTypeof
127− , jsonbTypeof
128− , jsonStripNulls
129− , jsonbStripNulls
130− , jsonbSet
131− , jsonbInsert
132− , jsonbPretty
133− -- ** Aggregation
134− , unsafeAggregate, unsafeAggregateDistinct
135− , sum_, sumDistinct
136− , PGAvg (avg, avgDistinct)
137− , bitAnd, bitOr, boolAnd, boolOr
138− , bitAndDistinct, bitOrDistinct, boolAndDistinct, boolOrDistinct
139− , countStar
140− , count, countDistinct
141− , every, everyDistinct
142− , max_, maxDistinct, min_, minDistinct
143− -- * Types
144− , TypeExpression (UnsafeTypeExpression, renderTypeExpression)
145− , PGTyped (pgtype)
146− , typedef
147− , typetable
148− , typeview
149− , bool
150− , int2
151− , smallint
152− , int4
153− , int
154− , integer
155− , int8
156− , bigint
157− , numeric
158− , float4
159− , real
160− , float8
161− , doublePrecision
162− , text
163− , char
164− , character
165− , varchar
166− , characterVarying
167− , bytea
168− , timestamp
169− , timestampWithTimeZone
170− , date
171− , time
172− , timeWithTimeZone
173− , interval
174− , uuid
175− , inet
176− , json
177− , jsonb
178− , vararray
179− , fixarray
180 -- * Re-export
57 -- * Re-export
181 , (&)
58 , (&)
182− , NP ((:*), Nil)
59+ , K (..)
60+ , unK
183 ) where
61 ) where
184
62
185import Control.Category
63import Control.Category
186import Control.DeepSeq
64import Control.DeepSeq
187import Data.ByteString (ByteString)
65import Data.ByteString (ByteString)
188−import Data.ByteString.Lazy (toStrict)
189import Data.Function ((&))
66import Data.Function ((&))
190import Data.Semigroup hiding (All)
67import Data.Semigroup hiding (All)
191−import qualified Data.Aeson as JSON
192−import Data.Ratio
193import Data.String
68import Data.String
194−import Data.Word
195−import Generics.SOP hiding (from)
69+import Generics.SOP hiding (All, from)
196import GHC.OverloadedLabels
70import GHC.OverloadedLabels
197import GHC.TypeLits
71import GHC.TypeLits
72+import Numeric
198import Prelude hiding (id, (.))
73import Prelude hiding (id, (.))
199
74
200import qualified GHC.Generics as GHC
75import qualified GHC.Generics as GHC
201
76
77+import Squeal.PostgreSQL.Alias
78+import Squeal.PostgreSQL.List
202import Squeal.PostgreSQL.Render
79import Squeal.PostgreSQL.Render
203import Squeal.PostgreSQL.Schema
80import Squeal.PostgreSQL.Schema
204
81
82+-- $setup
83+-- >>> import Squeal.PostgreSQL
84+
205{-----------------------------------------
85{-----------------------------------------
206column expressions
86column expressions
207-----------------------------------------}
87-----------------------------------------}
208
88
209{- | `Expression`s are used in a variety of contexts,
89{- | `Expression`s are used in a variety of contexts,
90+such as in the target `Squeal.PostgreSQL.Query.List` of the
210−such as in the target list of the `Squeal.PostgreSQL.Query.select` command,
91+`Squeal.PostgreSQL.Query.select` command,
211as new column values in `Squeal.PostgreSQL.Manipulation.insertRow` or
92as new column values in `Squeal.PostgreSQL.Manipulation.insertRow` or
212`Squeal.PostgreSQL.Manipulation.update`,
93`Squeal.PostgreSQL.Manipulation.update`,
213−or in search `Condition`s in a number of commands.
94+or in search `Squeal.PostgreSQL.Logic.Condition`s in a number of commands.
214
95
215The expression syntax allows the calculation of
96The expression syntax allows the calculation of
216values from primitive expression using arithmetic, logical,
97values from primitive expression using arithmetic, logical,
217and other operations.
98and other operations.
99+
100+The type parameters of `Expression` are
101+
102+* @outer :: @ `FromType`, the @from@ clauses of any outer queries in which
103+ the `Expression` is a correlated subquery expression;
104+* @commons :: @ `FromType`, the `Squeal.PostgreSQL.Query.CommonTableExpression`s
105+ that are in scope for the `Expression`;
106+* @grp :: @ `Grouping`, the `Grouping` of the @from@ clause which may limit
107+ which columns may be referenced by alias;
108+* @schemas :: @ `SchemasType`, the schemas of your database that are in
109+ scope for the `Expression`;
110+* @from :: @ `FromType`, the @from@ clause which the `Expression` may use
111+ to reference columns by alias;
112+* @ty :: @ `NullityType`, the type of the `Expression`.
218-}
113-}
219newtype Expression
114newtype Expression
220− (schema :: SchemaType)
115+ (outer :: FromType)
221− (from :: FromType)
116+ (commons :: FromType)
222− (grouping :: Grouping)
117+ (grp :: Grouping)
118+ (schemas :: SchemasType)
223 (params :: [NullityType])
119 (params :: [NullityType])
120+ (from :: FromType)
224 (ty :: NullityType)
121 (ty :: NullityType)
225 = UnsafeExpression { renderExpression :: ByteString }
122 = UnsafeExpression { renderExpression :: ByteString }
226 deriving (GHC.Generic,Show,Eq,Ord,NFData)
123 deriving (GHC.Generic,Show,Eq,Ord,NFData)
227−
228−instance RenderSQL (Expression schema from grouping params ty) where
124+instance RenderSQL (Expression outer commons grp schemas params from ty) where
229 renderSQL = renderExpression
125 renderSQL = renderExpression
230
126
231−{- | A `HasParameter` constraint is used to indicate a value that is
127+-- | An `Expr` is a closed `Expression`.
232−supplied externally to a SQL statement.
128+-- It is a F@RankNType@ but don't be scared.
233−`Squeal.PostgreSQL.PQ.manipulateParams`,
129+-- Think of it as an expression which sees no
234−`Squeal.PostgreSQL.PQ.queryParams` and
130+-- namespaces, so you can't use parameters
235−`Squeal.PostgreSQL.PQ.traversePrepared` support specifying data values
131+-- or alias references. It can be used as
236−separately from the SQL command string, in which case `param`s are used to
132+-- a simple piece of more complex `Expression`s.
237−refer to the out-of-line data values.
133+type Expr x
134+ = forall outer commons grp schemas params from
135+ . Expression outer commons grp schemas params from x
136+ -- ^ cannot reference aliases
137+
138+-- | A @RankNType@ for binary operators.
139+type Operator x1 x2 y
140+ = forall outer commons grp schemas params from
141+ . Expression outer commons grp schemas params from x1
142+ -- ^ left input
143+ -> Expression outer commons grp schemas params from x2
144+ -- ^ right input
145+ -> Expression outer commons grp schemas params from y
146+ -- ^ output
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+
157+-- | A @RankNType@ for functions with a single argument.
158+-- These could be either function calls or unary operators.
159+-- This is a subtype of the usual Haskell function type `Prelude.->`,
160+-- indeed a subcategory as it is closed under the usual
161+-- `Prelude..` and `Prelude.id`.
162+type (-->) x y
163+ = forall outer commons grp schemas params from
164+ . Expression outer commons grp schemas params from x
165+ -- ^ input
166+ -> Expression outer commons grp schemas params from y
167+ -- ^ output
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+
176+{- | A @RankNType@ for functions with a fixed-length list of heterogeneous arguments.
177+Use the `*:` operator to end your argument lists, like so.
178+
179+>>> printSQL (unsafeFunctionN "fun" (true :* false :* localTime *: true))
180+fun(TRUE, FALSE, LOCALTIME, TRUE)
238-}
181-}
239−class KnownNat n => HasParameter
182+type (--->) xs y
240− (n :: Nat)
183+ = forall outer commons grp schemas params from
241− (schema :: SchemaType)
184+ . NP (Expression outer commons grp schemas params from) xs
242− (params :: [NullityType])
185+ -- ^ inputs
243− (ty :: NullityType)
244− | n params -> ty where
245− -- | `parameter` takes a `Nat` using type application and a `TypeExpression`.
246− --
247− -- >>> let expr = parameter @1 int4 :: Expression sch rels grp '[ 'Null 'PGint4] ('Null 'PGint4)
248− -- >>> printSQL expr
249− -- ($1 :: int4)
250− parameter
251− :: TypeExpression schema ty
252− -> Expression schema from grouping params ty
186+ -> Expression outer commons grp schemas params from y
253− parameter ty = UnsafeExpression $ parenthesized $
187+ -- ^ output
254− "$" <> renderNat @n <+> "::"
188+
255− <+> renderTypeExpression ty
189+type FunctionNDB schemas xs y
256−instance {-# OVERLAPPING #-} HasParameter 1 schema (ty1:tys) ty1
190+ = forall outer commons grp params from
257−instance {-# OVERLAPPABLE #-} (KnownNat n, HasParameter (n-1) schema params ty)
191+ . NP (Expression outer commons grp schemas params from) xs
258− => HasParameter n schema (ty' : params) ty
192+ -- ^ inputs
259−
193+ -> Expression outer commons grp schemas params from y
260−-- | `param` takes a `Nat` using type application and for basic types,
194+ -- ^ output
261−-- infers a `TypeExpression`.
195+
262−--
196+{- | A @RankNType@ for functions with a variable-length list of
263−-- >>> let expr = param @1 :: Expression sch rels grp '[ 'Null 'PGint4] ('Null 'PGint4)
197+homogeneous arguments and at least 1 more argument.
264−-- >>> printSQL expr
198+-}
265−-- ($1 :: int4)
199+type FunctionVar x0 x1 y
266−param
200+ = forall outer commons grp schemas params from
267− :: forall n schema params from grouping ty
201+ . [Expression outer commons grp schemas params from x0]
268− . (PGTyped schema ty, HasParameter n schema params ty)
202+ -- ^ inputs
269− => Expression schema from grouping params ty -- ^ param
203+ -> Expression outer commons grp schemas params from x1
270−param = parameter @n pgtype
204+ -- ^ must have at least 1 input
271−
205+ -> Expression outer commons grp schemas params from y
206+ -- ^ output
207+
208+{- | >>> printSQL (unsafeFunctionVar "greatest" [true, null_] false)
209+greatest(TRUE, NULL, FALSE)
210+-}
211+unsafeFunctionVar :: ByteString -> FunctionVar x0 x1 y
212+unsafeFunctionVar fun xs x = UnsafeExpression $ fun <> parenthesized
213+ (commaSeparated (renderSQL <$> xs) <> ", " <> renderSQL x)
214+
272−instance (HasUnique table from columns, Has column columns ty)
215+instance (HasUnique tab (Join outer from) row, Has col row ty)
273− => IsLabel column (Expression schema from 'Ungrouped params ty) where
216+ => IsLabel col (Expression outer commons 'Ungrouped schemas params from ty) where
274− fromLabel = UnsafeExpression $ renderAlias (Alias @column)
217+ fromLabel = UnsafeExpression $ renderSQL (Alias @col)
275−instance (HasUnique table from columns, Has column columns ty)
218+instance (HasUnique tab (Join outer from) row, Has col row ty, tys ~ '[ty])
276− => IsLabel column
277− (Aliased (Expression schema from 'Ungrouped params) (column ::: ty)) where
219+ => IsLabel col (NP (Expression outer commons 'Ungrouped schemas params from) tys) where
220+ fromLabel = fromLabel @col :* Nil
221+instance (HasUnique tab (Join outer from) row, Has col row ty, column ~ (col ::: ty))
222+ => IsLabel col
223+ (Aliased (Expression outer commons 'Ungrouped schemas params from) column) where
278− fromLabel = fromLabel @column `As` Alias @column
224+ fromLabel = fromLabel @col `As` Alias
279−instance (HasUnique table from columns, Has column columns ty)
225+instance (HasUnique tab (Join outer from) row, Has col row ty, columns ~ '[col ::: ty])
280− => IsLabel column
226+ => IsLabel col
281− (NP (Aliased (Expression schema from 'Ungrouped params)) '[column ::: ty]) where
227+ (NP (Aliased (Expression outer commons 'Ungrouped schemas params from)) columns) where
282− fromLabel = fromLabel @column :* Nil
228+ fromLabel = fromLabel @col :* Nil
283−
229+
284−instance (Has table from columns, Has column columns ty)
230+instance (Has tab (Join outer from) row, Has col row ty)
285− => IsQualified table column (Expression schema from 'Ungrouped params ty) where
231+ => IsQualified tab col (Expression outer commons 'Ungrouped schemas params from ty) where
286− table ! column = UnsafeExpression $
232+ tab ! col = UnsafeExpression $
287− renderAlias table <> "." <> renderAlias column
233+ renderSQL tab <> "." <> renderSQL col
288−instance (Has table from columns, Has column columns ty)
234+instance (Has tab (Join outer from) row, Has col row ty, tys ~ '[ty])
289− => IsQualified table column
235+ => IsQualified tab col (NP (Expression outer commons 'Ungrouped schemas params from) tys) where
290− (Aliased (Expression schema from 'Ungrouped params) (column ::: ty)) where
236+ tab ! col = tab ! col :* Nil
291− table ! column = table ! column `As` column
237+instance (Has tab (Join outer from) row, Has col row ty, column ~ (col ::: ty))
238+ => IsQualified tab col
239+ (Aliased (Expression outer commons 'Ungrouped schemas params from) column) where
240+ tab ! col = tab ! col `As` col
292−instance (Has table from columns, Has column columns ty)
241+instance (Has tab (Join outer from) row, Has col row ty, columns ~ '[col ::: ty])
293− => IsQualified table column
242+ => IsQualified tab col
294− (NP (Aliased (Expression schema from 'Ungrouped params)) '[column ::: ty]) where
243+ (NP (Aliased (Expression outer commons 'Ungrouped schemas params from)) columns) where
295− table ! column = table ! column :* Nil
244+ tab ! col = tab ! col :* Nil
296
245
297instance
246instance
298− ( HasUnique table from columns
247+ ( HasUnique tab (Join outer from) row
299− , Has column columns ty
248+ , Has col row ty
300− , GroupedBy table column bys
249+ , GroupedBy tab col bys
301− ) => IsLabel column
250+ ) => IsLabel col
302− (Expression schema from ('Grouped bys) params ty) where
251+ (Expression outer commons ('Grouped bys) schemas params from ty) where
303− fromLabel = UnsafeExpression $ renderAlias (Alias @column)
252+ fromLabel = UnsafeExpression $ renderSQL (Alias @col)
304instance
253instance
305− ( HasUnique table from columns
254+ ( HasUnique tab (Join outer from) row
306− , Has column columns ty
255+ , Has col row ty
307− , GroupedBy table column bys
256+ , GroupedBy tab col bys
257+ , tys ~ '[ty]
308− ) => IsLabel column
258+ ) => IsLabel col
309− ( Aliased (Expression schema from ('Grouped bys) params)
259+ (NP (Expression outer commons ('Grouped bys) schemas params from) tys) where
310− (column ::: ty) ) where
311− fromLabel = fromLabel @column `As` Alias @column
260+ fromLabel = fromLabel @col :* Nil
312instance
261instance
313− ( HasUnique table from columns
262+ ( HasUnique tab (Join outer from) row
314− , Has column columns ty
263+ , Has col row ty
315− , GroupedBy table column bys
264+ , GroupedBy tab col bys
265+ , column ~ (col ::: ty)
316− ) => IsLabel column
266+ ) => IsLabel col
317− ( NP (Aliased (Expression schema from ('Grouped bys) params))
267+ (Aliased (Expression outer commons ('Grouped bys) schemas params from) column) where
318− '[column ::: ty] ) where
268+ fromLabel = fromLabel @col `As` Alias
269+instance
270+ ( HasUnique tab (Join outer from) row
271+ , Has col row ty
272+ , GroupedBy tab col bys
273+ , columns ~ '[col ::: ty]
274+ ) => IsLabel col
275+ (NP (Aliased (Expression outer commons ('Grouped bys) schemas params from)) columns) where
319− fromLabel = fromLabel @column :* Nil
276+ fromLabel = fromLabel @col :* Nil
320
277
321instance
278instance
322− ( Has table from columns
279+ ( Has tab (Join outer from) row
323− , Has column columns ty
280+ , Has col row ty
324− , GroupedBy table column bys
281+ , GroupedBy tab col bys
325− ) => IsQualified table column
282+ ) => IsQualified tab col
326− (Expression schema from ('Grouped bys) params ty) where
283+ (Expression outer commons ('Grouped bys) schemas params from ty) where
327− table ! column = UnsafeExpression $
284+ tab ! col = UnsafeExpression $
328− renderAlias table <> "." <> renderAlias column
285+ renderSQL tab <> "." <> renderSQL col
329instance
286instance
330− ( Has table from columns
287+ ( Has tab (Join outer from) row
331− , Has column columns ty
288+ , Has col row ty
332− , GroupedBy table column bys
289+ , GroupedBy tab col bys
290+ , tys ~ '[ty]
333− ) => IsQualified table column
291+ ) => IsQualified tab col
334− (Aliased (Expression schema from ('Grouped bys) params)
292+ (NP (Expression outer commons ('Grouped bys) schemas params from) tys) where
335− (column ::: ty)) where
293+ tab ! col = tab ! col :* Nil
336− table ! column = table ! column `As` column
337instance
294instance
338− ( Has table from columns
295+ ( Has tab (Join outer from) row
339− , Has column columns ty
296+ , Has col row ty
340− , GroupedBy table column bys
297+ , GroupedBy tab col bys
298+ , column ~ (col ::: ty)
341− ) => IsQualified table column
299+ ) => IsQualified tab col
300+ (Aliased (Expression outer commons ('Grouped bys) schemas params from) column) where
301+ tab ! col = tab ! col `As` col
302+instance
303+ ( Has tab (Join outer from) row
304+ , Has col row ty
305+ , GroupedBy tab col bys
306+ , columns ~ '[col ::: ty]
307+ ) => IsQualified tab col
342− ( NP (Aliased (Expression schema from ('Grouped bys) params))
308+ (NP (Aliased (Expression outer commons ('Grouped bys) schemas params from)) columns) where
343− '[column ::: ty]) where
309+ tab ! col = tab ! col :* Nil
344− table ! column = table ! column :* Nil
345−
346−-- | analagous to `Nothing`
347−--
348−-- >>> printSQL null_
349−-- NULL
350−null_ :: Expression schema rels grouping params ('Null ty)
351−null_ = UnsafeExpression "NULL"
352−
353−-- | analagous to `Just`
354−--
355−-- >>> printSQL $ notNull true
356−-- TRUE
357−notNull
358− :: Expression schema rels grouping params ('NotNull ty)
359− -> Expression schema rels grouping params ('Null ty)
360−notNull = UnsafeExpression . renderExpression
361−
362−-- | return the leftmost value which is not NULL
363−--
364−-- >>> printSQL $ coalesce [null_, true] false
365−-- COALESCE(NULL, TRUE, FALSE)
366−coalesce
367− :: [Expression schema from grouping params ('Null ty)]
368− -- ^ @NULL@s may be present
369− -> Expression schema from grouping params ('NotNull ty)
370− -- ^ @NULL@ is absent
371− -> Expression schema from grouping params ('NotNull ty)
372−coalesce nullxs notNullx = UnsafeExpression $
373− "COALESCE" <> parenthesized (commaSeparated
374− ((renderExpression <$> nullxs) <> [renderExpression notNullx]))
375−
376−-- | analagous to `Data.Maybe.fromMaybe` using @COALESCE@
377−--
378−-- >>> printSQL $ fromNull true null_
379−-- COALESCE(NULL, TRUE)
380−fromNull
381− :: Expression schema from grouping params ('NotNull ty)
382− -- ^ what to convert @NULL@ to
383− -> Expression schema from grouping params ('Null ty)
384− -> Expression schema from grouping params ('NotNull ty)
385−fromNull notNullx nullx = coalesce [nullx] notNullx
386−
387−-- | >>> printSQL $ null_ & isNull
388−-- NULL IS NULL
389−isNull
390− :: Expression schema from grouping params ('Null ty)
391− -- ^ possibly @NULL@
392− -> Condition schema from grouping params
393−isNull x = UnsafeExpression $ renderExpression x <+> "IS NULL"
394−
395−-- | >>> printSQL $ null_ & isNotNull
396−-- NULL IS NOT NULL
397−isNotNull
398− :: Expression schema from grouping params ('Null ty)
399− -- ^ possibly @NULL@
400− -> Condition schema from grouping params
401−isNotNull x = UnsafeExpression $ renderExpression x <+> "IS NOT NULL"
402−
403−-- | analagous to `maybe` using @IS NULL@
404−--
405−-- >>> printSQL $ matchNull true not_ null_
406−-- CASE WHEN NULL IS NULL THEN TRUE ELSE (NOT NULL) END
407−matchNull
408− :: Expression schema from grouping params (nullty)
409− -- ^ what to convert @NULL@ to
410− -> ( Expression schema from grouping params ('NotNull ty)
411− -> Expression schema from grouping params (nullty) )
412− -- ^ function to perform when @NULL@ is absent
413− -> Expression schema from grouping params ('Null ty)
414− -> Expression schema from grouping params (nullty)
415−matchNull y f x = ifThenElse (isNull x) y
416− (f (UnsafeExpression (renderExpression x)))
417−
418−{-| right inverse to `fromNull`, if its arguments are equal then
419−`nullIf` gives @NULL@.
420−
421−>>> :set -XTypeApplications -XDataKinds
422−>>> let expr = nullIf false (param @1) :: Expression schema rels grp '[ 'NotNull 'PGbool] ('Null 'PGbool)
423−>>> printSQL expr
424−NULL IF (FALSE, ($1 :: bool))
425−-}
426−nullIf
427− :: Expression schema from grouping params ('NotNull ty)
428− -- ^ @NULL@ is absent
429− -> Expression schema from grouping params ('NotNull ty)
430− -- ^ @NULL@ is absent
431− -> Expression schema from grouping params ('Null ty)
432−nullIf x y = UnsafeExpression $ "NULL IF" <+> parenthesized
433− (renderExpression x <> ", " <> renderExpression y)
434−
435−-- | >>> printSQL $ array [null_, false, true]
436−-- ARRAY[NULL, FALSE, TRUE]
437−array
438− :: [Expression schema from grouping params ty]
439− -- ^ array elements
440− -> Expression schema from grouping params (nullity ('PGvararray ty))
441−array xs = UnsafeExpression $
442− "ARRAY[" <> commaSeparated (renderExpression <$> xs) <> "]"
443−
444−-- | >>> printSQL $ array [null_, false, true] & index 2
445−-- (ARRAY[NULL, FALSE, TRUE])[2]
446−index
447− :: Word64 -- ^ index
448− -> Expression schema from grouping params (nullity ('PGvararray ty)) -- ^ array
449− -> Expression schema from grouping params (NullifyType ty)
450−index n expr = UnsafeExpression $
451− parenthesized (renderExpression expr) <> "[" <> fromString (show n) <> "]"
452
310
453instance (KnownSymbol label, label `In` labels) => IsPGlabel label
311instance (KnownSymbol label, label `In` labels) => IsPGlabel label
454− (Expression schema from grouping params (nullity ('PGenum labels))) where
312+ (Expression outer commons grp schemas params from (null ('PGenum labels))) where
455− label = UnsafeExpression $ renderLabel (PGlabel @label)
313+ label = UnsafeExpression $ renderSQL (PGlabel @label)
456−
457−-- | A row constructor is an expression that builds a row value
458−-- (also called a composite value) using values for its member fields.
459−--
460−-- >>> :{
461−-- type Complex = 'PGcomposite
462−-- '[ "real" ::: 'NotNull 'PGfloat8
463−-- , "imaginary" ::: 'NotNull 'PGfloat8 ]
464−-- :}
465−--
466−-- >>> let i = row (0 `as` #real :* 1 `as` #imaginary) :: Expression '[] '[] 'Ungrouped '[] ('NotNull Complex)
467−-- >>> printSQL i
468−-- ROW(0, 1)
469−row
470− :: SListI row
471− => NP (Aliased (Expression schema from grouping params)) row
472− -- ^ zero or more expressions for the row field values
473− -> Expression schema from grouping params (nullity ('PGcomposite row))
474−row exprs = UnsafeExpression $ "ROW" <> parenthesized
475− (renderCommaSeparated (\ (expr `As` _) -> renderExpression expr) exprs)
476−
477−-- | >>> :{
478−-- type Complex = 'PGcomposite
479−-- '[ "real" ::: 'NotNull 'PGfloat8
480−-- , "imaginary" ::: 'NotNull 'PGfloat8 ]
481−-- :}
482−--
483−-- >>> let i = row (0 `as` #real :* 1 `as` #imaginary) :: Expression '["complex" ::: 'Typedef Complex] '[] 'Ungrouped '[] ('NotNull Complex)
484−-- >>> printSQL $ i & field #complex #imaginary
485−-- (ROW(0, 1)::"complex")."imaginary"
486−field
487− :: (Has tydef schema ('Typedef ('PGcomposite row)), Has field row ty)
488− => Alias tydef -- ^ row type
489− -> Alias field -- ^ field name
490− -> Expression schema from grouping params ('NotNull ('PGcomposite row))
491− -> Expression schema from grouping params ty
492−field td fld expr = UnsafeExpression $
493− parenthesized (renderExpression expr <> "::" <> renderAlias td)
494− <> "." <> renderAlias fld
495−
496−instance Semigroup
497− (Expression schema from grouping params (nullity ('PGvararray ty))) where
498− (<>) = unsafeBinaryOp "||"
499−
500−instance Monoid
501− (Expression schema from grouping params (nullity ('PGvararray ty))) where
502− mempty = array []
503− mappend = (<>)
504−
505−-- | >>> let expr = greatest currentTimestamp [param @1] :: Expression sch rels grp '[ 'NotNull 'PGtimestamptz] ('NotNull 'PGtimestamptz)
506−-- >>> printSQL expr
507−-- GREATEST(CURRENT_TIMESTAMP, ($1 :: timestamp with time zone))
508−greatest
509− :: Expression schema from grouping params (nullty)
510− -- ^ needs at least 1 argument
511− -> [Expression schema from grouping params (nullty)]
512− -- ^ or more
513− -> Expression schema from grouping params (nullty)
514−greatest x xs = UnsafeExpression $ "GREATEST("
515− <> commaSeparated (renderExpression <$> (x:xs)) <> ")"
516−
517−-- | >>> printSQL $ least currentTimestamp [null_]
518−-- LEAST(CURRENT_TIMESTAMP, NULL)
519−least
520− :: Expression schema from grouping params (nullty)
521− -- ^ needs at least 1 argument
522− -> [Expression schema from grouping params (nullty)]
523− -- ^ or more
524− -> Expression schema from grouping params (nullty)
525−least x xs = UnsafeExpression $ "LEAST("
526− <> commaSeparated (renderExpression <$> (x:xs)) <> ")"
527
314
528-- | >>> printSQL $ unsafeBinaryOp "OR" true false
315-- | >>> printSQL $ unsafeBinaryOp "OR" true false
529-- (TRUE OR FALSE)
316-- (TRUE OR FALSE)
530−unsafeBinaryOp
317+unsafeBinaryOp :: ByteString -> Operator ty0 ty1 ty2
531− :: ByteString
532− -- ^ operator
533− -> Expression schema from grouping params (ty0)
534− -> Expression schema from grouping params (ty1)
535− -> Expression schema from grouping params (ty2)
536unsafeBinaryOp op x y = UnsafeExpression $ parenthesized $
318unsafeBinaryOp op x y = UnsafeExpression $ parenthesized $
537− renderExpression x <+> op <+> renderExpression y
319+ renderSQL x <+> op <+> renderSQL y
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
538
327
539−-- | >>> printSQL $ unsafeUnaryOp "NOT" true
328+-- | >>> printSQL $ unsafeLeftOp "NOT" true
540-- (NOT TRUE)
329-- (NOT TRUE)
541−unsafeUnaryOp
542− :: ByteString
330+unsafeLeftOp :: ByteString -> x --> y
543− -- ^ operator
331+unsafeLeftOp op x = UnsafeExpression $ parenthesized $ op <+> renderSQL x
544− -> Expression schema from grouping params (ty0)
332+
545− -> Expression schema from grouping params (ty1)
333+leftOp
334+ :: forall op sch schemas schema x y.
335+ ( Has sch schemas schema
336+ , Has op schema ('Operator ('LeftOp x y)) )
337+ => FunctionDB schemas x y
338+leftOp = unsafeLeftOp $ renderSymbol @op
339+
340+-- | >>> printSQL $ true & unsafeRightOp "IS NOT TRUE"
341+-- (TRUE IS NOT TRUE)
342+unsafeRightOp :: ByteString -> x --> y
546−unsafeUnaryOp op x = UnsafeExpression $ parenthesized $
343+unsafeRightOp op x = UnsafeExpression $ parenthesized $ renderSQL x <+> op
547− op <+> renderExpression x
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
548
351
549-- | >>> printSQL $ unsafeFunction "f" true
352-- | >>> printSQL $ unsafeFunction "f" true
550-- f(TRUE)
353-- f(TRUE)
551−unsafeFunction
354+unsafeFunction :: ByteString -> x --> y
552− :: ByteString
553− -- ^ function
554− -> Expression schema from grouping params (xty)
555− -> Expression schema from grouping params (yty)
556unsafeFunction fun x = UnsafeExpression $
355unsafeFunction fun x = UnsafeExpression $
557− fun <> parenthesized (renderExpression x)
356+ fun <> parenthesized (renderSQL x)
558−
357+
559−-- | Helper for defining variadic functions.
358+function
560−unsafeVariadicFunction
359+ :: (Has sch schemas schema, Has fun schema ('Function ('[x] :=> 'Returns y)))
561− :: SListI elems
360+ => QualifiedAlias sch fun
361+ -> FunctionDB schemas x y
362+function = unsafeFunction . renderSQL
363+
364+-- | >>> printSQL $ unsafeFunctionN "f" (currentTime :* localTimestamp :* false *: literal 'a')
365+-- f(CURRENT_TIME, LOCALTIMESTAMP, FALSE, E'a')
562− => ByteString
366+unsafeFunctionN :: SListI xs => ByteString -> xs ---> y
563− -- ^ function
564− -> NP (Expression schema from grouping params) elems
565− -> Expression schema from grouping params ret
566−unsafeVariadicFunction fun x = UnsafeExpression $
367+unsafeFunctionN fun xs = UnsafeExpression $
567− fun <> parenthesized (commaSeparated (hcollapse (hmap (K . renderExpression) x)))
368+ fun <> parenthesized (renderCommaSeparated renderSQL xs)
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
568
377
569instance ty `In` PGNum
378instance ty `In` PGNum
570− => Num (Expression schema from grouping params (nullity ty)) where
379+ => Num (Expression outer commons grp schemas params from (null ty)) where
571 (+) = unsafeBinaryOp "+"
380 (+) = unsafeBinaryOp "+"
572 (-) = unsafeBinaryOp "-"
381 (-) = unsafeBinaryOp "-"
573 (*) = unsafeBinaryOp "*"
382 (*) = unsafeBinaryOp "*"
@@ -579,18 +388,23 @@ instance ty `In` PGNum
579 . show
388 . show
580
389
581instance (ty `In` PGNum, ty `In` PGFloating) => Fractional
390instance (ty `In` PGNum, ty `In` PGFloating) => Fractional
582− (Expression schema from grouping params (nullity ty)) where
391+ (Expression outer commons grp schemas params from (null ty)) where
583 (/) = unsafeBinaryOp "/"
392 (/) = unsafeBinaryOp "/"
584− fromRational x = fromInteger (numerator x) / fromInteger (denominator x)
393+ fromRational
394+ = UnsafeExpression
395+ . fromString
396+ . ($ "")
397+ . showFFloat Nothing
398+ . fromRat @Double
585
399
586instance (ty `In` PGNum, ty `In` PGFloating) => Floating
400instance (ty `In` PGNum, ty `In` PGFloating) => Floating
587− (Expression schema from grouping params (nullity ty)) where
401+ (Expression outer commons grp schemas params from (null ty)) where
588 pi = UnsafeExpression "pi()"
402 pi = UnsafeExpression "pi()"
589 exp = unsafeFunction "exp"
403 exp = unsafeFunction "exp"
590 log = unsafeFunction "ln"
404 log = unsafeFunction "ln"
591 sqrt = unsafeFunction "sqrt"
405 sqrt = unsafeFunction "sqrt"
592 b ** x = UnsafeExpression $
406 b ** x = UnsafeExpression $
593− "power(" <> renderExpression b <> ", " <> renderExpression x <> ")"
407+ "power(" <> renderSQL b <> ", " <> renderSQL x <> ")"
594 logBase b y = log y / log b
408 logBase b y = log y / log b
595 sin = unsafeFunction "sin"
409 sin = unsafeFunction "sin"
596 cos = unsafeFunction "cos"
410 cos = unsafeFunction "cos"
@@ -605,1154 +419,54 @@ instance (ty `In` PGNum, ty `In` PGFloating) => Floating
605 acosh x = log (x + sqrt (x*x - 1))
419 acosh x = log (x + sqrt (x*x - 1))
606 atanh x = log ((1 + x) / (1 - x)) / 2
420 atanh x = log ((1 + x) / (1 - x)) / 2
607
421
608−-- | >>> :{
422+-- | Contained by operators
609−-- let
423+class PGSubset ty where
610−-- expression :: Expression schema from grouping params (nullity 'PGfloat4)
424+ (@>) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
611−-- expression = atan2_ pi 2
425+ (@>) = unsafeBinaryOp "@>"
612−-- in printSQL expression
426+ (<@) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
613−-- :}
427+ (<@) = unsafeBinaryOp "<@"
614−-- atan2(pi(), 2)
428+instance PGSubset 'PGjsonb
615−atan2_
429+instance PGSubset 'PGtsquery
616− :: float `In` PGFloating
430+instance PGSubset ('PGvararray ty)
617− => Expression schema from grouping params (nullity float)
431+instance PGSubset ('PGrange ty)
618− -- ^ numerator
432+
619− -> Expression schema from grouping params (nullity float)
433+class PGIntersect ty where
620− -- ^ denominator
434+ (@&&) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
621− -> Expression schema from grouping params (nullity float)
435+ (@&&) = unsafeBinaryOp "&&"
622−atan2_ y x = UnsafeExpression $
436+instance PGIntersect ('PGvararray ty)
623− "atan2(" <> renderExpression y <> ", " <> renderExpression x <> ")"
437+instance PGIntersect ('PGrange ty)
624−
625−-- When a `cast` is applied to an `Expression` of a known type, it
626−-- represents a run-time type conversion. The cast will succeed only if a
627−-- suitable type conversion operation has been defined.
628−--
629−-- | >>> printSQL $ true & cast int4
630−-- (TRUE :: int4)
631−cast
632− :: TypeExpression schema ty1
633− -- ^ type to cast as
634− -> Expression schema from grouping params ty0
635− -- ^ value to convert
636− -> Expression schema from grouping params ty1
637−cast ty x = UnsafeExpression $ parenthesized $
638− renderExpression x <+> "::" <+> renderTypeExpression ty
639−
640−-- | integer division, truncates the result
641−--
642−-- >>> :{
643−-- let
644−-- expression :: Expression schema from grouping params (nullity 'PGint2)
645−-- expression = 5 `quot_` 2
646−-- in printSQL expression
647−-- :}
648−-- (5 / 2)
649−quot_
650− :: int `In` PGIntegral
651− => Expression schema from grouping params (nullity int)
652− -- ^ numerator
653− -> Expression schema from grouping params (nullity int)
654− -- ^ denominator
655− -> Expression schema from grouping params (nullity int)
656−quot_ = unsafeBinaryOp "/"
657−
658−-- | remainder upon integer division
659−--
660−-- >>> :{
661−-- let
662−-- expression :: Expression schema from grouping params (nullity 'PGint2)
663−-- expression = 5 `rem_` 2
664−-- in printSQL expression
665−-- :}
666−-- (5 % 2)
667−rem_
668− :: int `In` PGIntegral
669− => Expression schema from grouping params (nullity int)
670− -- ^ numerator
671− -> Expression schema from grouping params (nullity int)
672− -- ^ denominator
673− -> Expression schema from grouping params (nullity int)
674−rem_ = unsafeBinaryOp "%"
675−
676−-- | >>> :{
677−-- let
678−-- expression :: Expression schema from grouping params (nullity 'PGfloat4)
679−-- expression = trunc pi
680−-- in printSQL expression
681−-- :}
682−-- trunc(pi())
683−trunc
684− :: frac `In` PGFloating
685− => Expression schema from grouping params (nullity frac)
686− -- ^ fractional number
687− -> Expression schema from grouping params (nullity frac)
688−trunc = unsafeFunction "trunc"
689−
690−-- | >>> :{
691−-- let
692−-- expression :: Expression schema from grouping params (nullity 'PGfloat4)
693−-- expression = round_ pi
694−-- in printSQL expression
695−-- :}
696−-- round(pi())
697−round_
698− :: frac `In` PGFloating
699− => Expression schema from grouping params (nullity frac)
700− -- ^ fractional number
701− -> Expression schema from grouping params (nullity frac)
702−round_ = unsafeFunction "round"
703−
704−-- | >>> :{
705−-- let
706−-- expression :: Expression schema from grouping params (nullity 'PGfloat4)
707−-- expression = ceiling_ pi
708−-- in printSQL expression
709−-- :}
710−-- ceiling(pi())
711−ceiling_
712− :: frac `In` PGFloating
713− => Expression schema from grouping params (nullity frac)
714− -- ^ fractional number
715− -> Expression schema from grouping params (nullity frac)
716−ceiling_ = unsafeFunction "ceiling"
717−
718−-- | A `Condition` is an `Expression`, which can evaluate
719−-- to `true`, `false` or `null_`. This is because SQL uses
720−-- a three valued logic.
721−type Condition schema from grouping params =
722− Expression schema from grouping params ('Null 'PGbool)
723−
724−-- | >>> printSQL true
725−-- TRUE
726−true :: Expression schema from grouping params (nullity 'PGbool)
727−true = UnsafeExpression "TRUE"
728−
729−-- | >>> printSQL false
730−-- FALSE
731−false :: Expression schema from grouping params (nullity 'PGbool)
732−false = UnsafeExpression "FALSE"
733−
734−-- | >>> printSQL $ not_ true
735−-- (NOT TRUE)
736−not_
737− :: Expression schema from grouping params (nullity 'PGbool)
738− -> Expression schema from grouping params (nullity 'PGbool)
739−not_ = unsafeUnaryOp "NOT"
740−
741−-- | >>> printSQL $ true .&& false
742−-- (TRUE AND FALSE)
743−(.&&)
744− :: Expression schema from grouping params (nullity 'PGbool)
745− -> Expression schema from grouping params (nullity 'PGbool)
746− -> Expression schema from grouping params (nullity 'PGbool)
747−infixr 3 .&&
748−(.&&) = unsafeBinaryOp "AND"
749−
750−-- | >>> printSQL $ true .|| false
751−-- (TRUE OR FALSE)
752−(.||)
753− :: Expression schema from grouping params (nullity 'PGbool)
754− -> Expression schema from grouping params (nullity 'PGbool)
755− -> Expression schema from grouping params (nullity 'PGbool)
756−infixr 2 .||
757−(.||) = unsafeBinaryOp "OR"
758−
759−-- | >>> :{
760−-- let
761−-- expression :: Expression schema from grouping params (nullity 'PGint2)
762−-- expression = caseWhenThenElse [(true, 1), (false, 2)] 3
763−-- in printSQL expression
764−-- :}
765−-- CASE WHEN TRUE THEN 1 WHEN FALSE THEN 2 ELSE 3 END
766−caseWhenThenElse
767− :: [ ( Condition schema from grouping params
768− , Expression schema from grouping params ty
769− ) ]
770− -- ^ whens and thens
771− -> Expression schema from grouping params ty
772− -- ^ else
773− -> Expression schema from grouping params ty
774−caseWhenThenElse whenThens else_ = UnsafeExpression $ mconcat
775− [ "CASE"
776− , mconcat
777− [ mconcat
778− [ " WHEN ", renderExpression when_
779− , " THEN ", renderExpression then_
780− ]
781− | (when_,then_) <- whenThens
782− ]
783− , " ELSE ", renderExpression else_
784− , " END"
785− ]
786−
787−-- | >>> :{
788−-- let
789−-- expression :: Expression schema from grouping params (nullity 'PGint2)
790−-- expression = ifThenElse true 1 0
791−-- in printSQL expression
792−-- :}
793−-- CASE WHEN TRUE THEN 1 ELSE 0 END
794−ifThenElse
795− :: Condition schema from grouping params
796− -> Expression schema from grouping params ty -- ^ then
797− -> Expression schema from grouping params ty -- ^ else
798− -> Expression schema from grouping params ty
799−ifThenElse if_ then_ else_ = caseWhenThenElse [(if_,then_)] else_
800−
801−-- | Comparison operations like `.==`, `./=`, `.>`, `.>=`, `.<` and `.<=`
802−-- will produce @NULL@s if one of their arguments is @NULL@.
803−--
804−-- >>> printSQL $ true .== null_
805−-- (TRUE = NULL)
806−(.==)
807− :: Expression schema from grouping params (nullity0 ty) -- ^ lhs
808− -> Expression schema from grouping params (nullity1 ty) -- ^ rhs
809− -> Condition schema from grouping params
810−(.==) = unsafeBinaryOp "="
811−infix 4 .==
812−
813−-- | >>> printSQL $ true ./= null_
814−-- (TRUE <> NULL)
815−(./=)
816− :: Expression schema from grouping params (nullity0 ty) -- ^ lhs
817− -> Expression schema from grouping params (nullity1 ty) -- ^ rhs
818− -> Condition schema from grouping params
819−(./=) = unsafeBinaryOp "<>"
820−infix 4 ./=
821−
822−-- | >>> printSQL $ true .>= null_
823−-- (TRUE >= NULL)
824−(.>=)
825− :: Expression schema from grouping params (nullity0 ty) -- ^ lhs
826− -> Expression schema from grouping params (nullity1 ty) -- ^ rhs
827− -> Condition schema from grouping params
828−(.>=) = unsafeBinaryOp ">="
829−infix 4 .>=
830−
831−-- | >>> printSQL $ true .< null_
832−-- (TRUE < NULL)
833−(.<)
834− :: Expression schema from grouping params (nullity0 ty) -- ^ lhs
835− -> Expression schema from grouping params (nullity1 ty) -- ^ rhs
836− -> Condition schema from grouping params
837−(.<) = unsafeBinaryOp "<"
838−infix 4 .<
839−
840−-- | >>> printSQL $ true .<= null_
841−-- (TRUE <= NULL)
842−(.<=)
843− :: Expression schema from grouping params (nullity0 ty) -- ^ lhs
844− -> Expression schema from grouping params (nullity1 ty) -- ^ rhs
845− -> Condition schema from grouping params
846−(.<=) = unsafeBinaryOp "<="
847−infix 4 .<=
848−
849−-- | >>> printSQL $ true .> null_
850−-- (TRUE > NULL)
851−(.>)
852− :: Expression schema from grouping params (nullity0 ty) -- ^ lhs
853− -> Expression schema from grouping params (nullity1 ty) -- ^ rhs
854− -> Condition schema from grouping params
855−(.>) = unsafeBinaryOp ">"
856−infix 4 .>
857−
858−-- | >>> printSQL currentDate
859−-- CURRENT_DATE
860−currentDate
861− :: Expression schema from grouping params (nullity 'PGdate)
862−currentDate = UnsafeExpression "CURRENT_DATE"
863−
864−-- | >>> printSQL currentTime
865−-- CURRENT_TIME
866−currentTime
867− :: Expression schema from grouping params (nullity 'PGtimetz)
868−currentTime = UnsafeExpression "CURRENT_TIME"
869−
870−-- | >>> printSQL currentTimestamp
871−-- CURRENT_TIMESTAMP
872−currentTimestamp
873− :: Expression schema from grouping params (nullity 'PGtimestamptz)
874−currentTimestamp = UnsafeExpression "CURRENT_TIMESTAMP"
875−
876−-- | >>> printSQL localTime
877−-- LOCALTIME
878−localTime
879− :: Expression schema from grouping params (nullity 'PGtime)
880−localTime = UnsafeExpression "LOCALTIME"
881−
882−-- | >>> printSQL localTimestamp
883−-- LOCALTIMESTAMP
884−localTimestamp
885− :: Expression schema from grouping params (nullity 'PGtimestamp)
886−localTimestamp = UnsafeExpression "LOCALTIMESTAMP"
887−
888−{-----------------------------------------
889−text
890−-----------------------------------------}
891
438
892instance IsString
439instance IsString
893− (Expression schema from grouping params (nullity 'PGtext)) where
440+ (Expression outer commons grp schemas params from (null 'PGtext)) where
894 fromString str = UnsafeExpression $
441 fromString str = UnsafeExpression $
895 "E\'" <> fromString (escape =<< str) <> "\'"
442 "E\'" <> fromString (escape =<< str) <> "\'"
896− where
443+instance IsString
897− escape = \case
444+ (Expression outer commons grp schemas params from (null 'PGtsvector)) where
898− '\NUL' -> "\\0"
445+ fromString str = UnsafeExpression . parenthesized . (<> " :: tsvector") $
899− '\'' -> "''"
446+ "E\'" <> fromString (escape =<< str) <> "\'"
900− '"' -> "\\\""
447+instance IsString
901− '\b' -> "\\b"
448+ (Expression outer commons grp schemas params from (null 'PGtsquery)) where
902− '\n' -> "\\n"
449+ fromString str = UnsafeExpression . parenthesized . (<> " :: tsquery") $
903− '\r' -> "\\r"
450+ "E\'" <> fromString (escape =<< str) <> "\'"
904− '\t' -> "\\t"
905− '\\' -> "\\\\"
906− c -> [c]
907
451
908instance Semigroup
452instance Semigroup
909− (Expression schema from grouping params (nullity 'PGtext)) where
453+ (Expression outer commons grp schemas params from (null ('PGvararray ty))) where
454+ (<>) = unsafeBinaryOp "||"
455+instance Semigroup
456+ (Expression outer commons grp schemas params from (null 'PGjsonb)) where
457+ (<>) = unsafeBinaryOp "||"
458+instance Semigroup
459+ (Expression outer commons grp schemas params from (null 'PGtext)) where
460+ (<>) = unsafeBinaryOp "||"
461+instance Semigroup
462+ (Expression outer commons grp schemas params from (null 'PGtsvector)) where
910 (<>) = unsafeBinaryOp "||"
463 (<>) = unsafeBinaryOp "||"
911
464
912instance Monoid
465instance Monoid
913− (Expression schema from grouping params (nullity 'PGtext)) where
466+ (Expression outer commons grp schemas params from (null 'PGtext)) where
467+ mempty = fromString ""
468+ mappend = (<>)
469+instance Monoid
470+ (Expression outer commons grp schemas params from (null 'PGtsvector)) where
914 mempty = fromString ""
471 mempty = fromString ""
915 mappend = (<>)
472 mappend = (<>)
916−
917−-- | >>> printSQL $ lower "ARRRGGG"
918−-- lower(E'ARRRGGG')
919−lower
920− :: Expression schema from grouping params (nullity 'PGtext)
921− -- ^ string to lower case
922− -> Expression schema from grouping params (nullity 'PGtext)
923−lower = unsafeFunction "lower"
924−
925−-- | >>> printSQL $ upper "eeee"
926−-- upper(E'eeee')
927−upper
928− :: Expression schema from grouping params (nullity 'PGtext)
929− -- ^ string to upper case
930− -> Expression schema from grouping params (nullity 'PGtext)
931−upper = unsafeFunction "upper"
932−
933−-- | >>> printSQL $ charLength "four"
934−-- char_length(E'four')
935−charLength
936− :: Expression schema from grouping params (nullity 'PGtext)
937− -- ^ string to measure
938− -> Expression schema from grouping params (nullity 'PGint4)
939−charLength = unsafeFunction "char_length"
940−
941−-- | The `like` expression returns true if the @string@ matches
942−-- the supplied @pattern@. If @pattern@ does not contain percent signs
943−-- or underscores, then the pattern only represents the string itself;
944−-- in that case `like` acts like the equals operator. An underscore (_)
945−-- in pattern stands for (matches) any single character; a percent sign (%)
946−-- matches any sequence of zero or more characters.
947−--
948−-- >>> printSQL $ "abc" `like` "a%"
949−-- (E'abc' LIKE E'a%')
950−like
951− :: Expression schema from grouping params (nullity 'PGtext)
952− -- ^ string
953− -> Expression schema from grouping params (nullity 'PGtext)
954− -- ^ pattern
955− -> Expression schema from grouping params (nullity 'PGbool)
956−like = unsafeBinaryOp "LIKE"
957−
958−{-----------------------------------------
959− -- json and jsonb support
960−
961−See https://www.postgresql.org/docs/10/static/functions-json.html -- most
962−comments lifted directly from this page.
963−
964−Table 9.44: json and jsonb operators
965−-----------------------------------------}
966−
967−-- | Get JSON value (object field or array element) at a key.
968−(.->)
969− :: (json `In` PGJsonType, key `In` PGJsonKey)
970− => Expression schema from grouping params (nullity json)
971− -> Expression schema from grouping params (nullity key)
972− -> Expression schema from grouping params ('Null json)
973−infixl 8 .->
974−(.->) = unsafeBinaryOp "->"
975−
976−-- | Get JSON value (object field or array element) at a key, as text.
977−(.->>)
978− :: (json `In` PGJsonType, key `In` PGJsonKey)
979− => Expression schema from grouping params (nullity json)
980− -> Expression schema from grouping params (nullity key)
981− -> Expression schema from grouping params ('Null 'PGtext)
982−infixl 8 .->>
983−(.->>) = unsafeBinaryOp "->>"
984−
985−-- | Get JSON value at a specified path.
986−(.#>)
987− :: (json `In` PGJsonType, PGTextArray "(.#>)" path)
988− => Expression schema from grouping params (nullity json)
989− -> Expression schema from grouping params (nullity path)
990− -> Expression schema from grouping params ('Null json)
991−infixl 8 .#>
992−(.#>) = unsafeBinaryOp "#>"
993−
994−-- | Get JSON value at a specified path as text.
995−(.#>>)
996− :: (json `In` PGJsonType, PGTextArray "(.#>>)" path)
997− => Expression schema from grouping params (nullity json)
998− -> Expression schema from grouping params (nullity path)
999− -> Expression schema from grouping params ('Null 'PGtext)
1000−infixl 8 .#>>
1001−(.#>>) = unsafeBinaryOp "#>>"
1002−
1003−-- Additional jsonb operators
1004−
1005−-- | Does the left JSON value contain the right JSON path/value entries at the
1006−-- top level?
1007−(.@>)
1008− :: Expression schema from grouping params (nullity 'PGjsonb)
1009− -> Expression schema from grouping params (nullity 'PGjsonb)
1010− -> Condition schema from grouping params
1011−infixl 9 .@>
1012−(.@>) = unsafeBinaryOp "@>"
1013−
1014−-- | Are the left JSON path/value entries contained at the top level within the
1015−-- right JSON value?
1016−(.<@)
1017− :: Expression schema from grouping params (nullity 'PGjsonb)
1018− -> Expression schema from grouping params (nullity 'PGjsonb)
1019− -> Condition schema from grouping params
1020−infixl 9 .<@
1021−(.<@) = unsafeBinaryOp "<@"
1022−
1023−-- | Does the string exist as a top-level key within the JSON value?
1024−(.?)
1025− :: Expression schema from grouping params (nullity 'PGjsonb)
1026− -> Expression schema from grouping params (nullity 'PGtext)
1027− -> Condition schema from grouping params
1028−infixl 9 .?
1029−(.?) = unsafeBinaryOp "?"
1030−
1031−-- | Do any of these array strings exist as top-level keys?
1032−(.?|)
1033− :: Expression schema from grouping params (nullity 'PGjsonb)
1034− -> Expression schema from grouping params (nullity ('PGvararray ('NotNull 'PGtext)))
1035− -> Condition schema from grouping params
1036−infixl 9 .?|
1037−(.?|) = unsafeBinaryOp "?|"
1038−
1039−-- | Do all of these array strings exist as top-level keys?
1040−(.?&)
1041− :: Expression schema from grouping params (nullity 'PGjsonb)
1042− -> Expression schema from grouping params (nullity ('PGvararray ('NotNull 'PGtext)))
1043− -> Condition schema from grouping params
1044−infixl 9 .?&
1045−(.?&) = unsafeBinaryOp "?&"
1046−
1047−-- | Concatenate two jsonb values into a new jsonb value.
1048−instance
1049− Semigroup (Expression schema from grouping param (nullity 'PGjsonb)) where
1050− (<>) = unsafeBinaryOp "||"
1051−
1052−-- | Delete a key or keys from a JSON object, or remove an array element.
1053−--
1054−-- If the right operand is..
1055−--
1056−-- @ text @: Delete key/value pair or string element from left operand. Key/value pairs
1057−-- are matched based on their key value.
1058−--
1059−-- @ text[] @: Delete multiple key/value pairs or string elements
1060−-- from left operand. Key/value pairs are matched based on their key value.
1061−--
1062−-- @ integer @: Delete the array element with specified index (Negative integers
1063−-- count from the end). Throws an error if top level container is not an array.
1064−(.-.)
1065− :: (key `In` '[ 'PGtext, 'PGvararray ('NotNull 'PGtext), 'PGint4, 'PGint2 ]) -- hlint error without parens here
1066− => Expression schema from grouping params (nullity 'PGjsonb)
1067− -> Expression schema from grouping params (nullity key)
1068− -> Expression schema from grouping params (nullity 'PGjsonb)
1069−infixl 6 .-.
1070−(.-.) = unsafeBinaryOp "-"
1071−
1072−-- | Delete the field or element with specified path (for JSON arrays, negative
1073−-- integers count from the end)
1074−(#-.)
1075− :: PGTextArray "(#-.)" arrayty
1076− => Expression schema from grouping params (nullity 'PGjsonb)
1077− -> Expression schema from grouping params (nullity arrayty)
1078− -> Expression schema from grouping params (nullity 'PGjsonb)
1079−infixl 6 #-.
1080−(#-.) = unsafeBinaryOp "#-"
1081−
1082−{-----------------------------------------
1083−Table 9.45: JSON creation functions
1084−-----------------------------------------}
1085−
1086−-- | Literal binary JSON
1087−jsonbLit
1088− :: JSON.ToJSON x
1089− => x -> Expression schema from grouping params (nullity 'PGjsonb)
1090−jsonbLit = cast jsonb . UnsafeExpression
1091− . singleQuotedUtf8 . toStrict . JSON.encode
1092−
1093−-- | Literal JSON
1094−jsonLit
1095− :: JSON.ToJSON x
1096− => x -> Expression schema from grouping params (nullity 'PGjson)
1097−jsonLit = cast json . UnsafeExpression
1098− . singleQuotedUtf8 . toStrict . JSON.encode
1099−
1100−-- | Returns the value as json. Arrays and composites are converted
1101−-- (recursively) to arrays and objects; otherwise, if there is a cast from the
1102−-- type to json, the cast function will be used to perform the conversion;
1103−-- otherwise, a scalar value is produced. For any scalar type other than a
1104−-- number, a Boolean, or a null value, the text representation will be used, in
1105−-- such a fashion that it is a valid json value.
1106−toJson
1107− :: Expression schema from grouping params (nullity ty)
1108− -> Expression schema from grouping params (nullity 'PGjson)
1109−toJson = unsafeFunction "to_json"
1110−
1111−-- | Returns the value as jsonb. Arrays and composites are converted
1112−-- (recursively) to arrays and objects; otherwise, if there is a cast from the
1113−-- type to json, the cast function will be used to perform the conversion;
1114−-- otherwise, a scalar value is produced. For any scalar type other than a
1115−-- number, a Boolean, or a null value, the text representation will be used, in
1116−-- such a fashion that it is a valid jsonb value.
1117−toJsonb
1118− :: Expression schema from grouping params (nullity ty)
1119− -> Expression schema from grouping params (nullity 'PGjsonb)
1120−toJsonb = unsafeFunction "to_jsonb"
1121−
1122−-- | Returns the array as a JSON array. A PostgreSQL multidimensional array
1123−-- becomes a JSON array of arrays.
1124−arrayToJson
1125− :: PGArray "arrayToJson" arr
1126− => Expression schema from grouping params (nullity arr)
1127− -> Expression schema from grouping params (nullity 'PGjson)
1128−arrayToJson = unsafeFunction "array_to_json"
1129−
1130−-- | Returns the row as a JSON object.
1131−rowToJson
1132− :: Expression schema from grouping params (nullity ('PGcomposite ty))
1133− -> Expression schema from grouping params (nullity 'PGjson)
1134−rowToJson = unsafeFunction "row_to_json"
1135−
1136−-- | Builds a possibly-heterogeneously-typed JSON array out of a variadic
1137−-- argument list.
1138−jsonBuildArray
1139− :: SListI elems
1140− => NP (Expression schema from grouping params) elems
1141− -> Expression schema from grouping params (nullity 'PGjson)
1142−jsonBuildArray = unsafeVariadicFunction "json_build_array"
1143−
1144−-- | Builds a possibly-heterogeneously-typed (binary) JSON array out of a
1145−-- variadic argument list.
1146−jsonbBuildArray
1147− :: SListI elems
1148− => NP (Expression schema from grouping params) elems
1149− -> Expression schema from grouping params (nullity 'PGjsonb)
1150−jsonbBuildArray = unsafeVariadicFunction "jsonb_build_array"
1151−
1152−unsafeRowFunction
1153− :: All Top elems
1154− => NP (Aliased (Expression schema from grouping params)) elems
1155− -> [ByteString]
1156−unsafeRowFunction =
1157− (`appEndo` []) . hcfoldMap (Proxy :: Proxy Top)
1158− (\(col `As` name) -> Endo $ \xs ->
1159− renderAliasString name : renderExpression col : xs)
1160−
1161−-- | Builds a possibly-heterogeneously-typed JSON object out of a variadic
1162−-- argument list. The elements of the argument list must alternate between text
1163−-- and values.
1164−jsonBuildObject
1165− :: All Top elems
1166− => NP (Aliased (Expression schema from grouping params)) elems
1167− -> Expression schema from grouping params (nullity 'PGjson)
1168−jsonBuildObject
1169− = unsafeFunction "json_build_object"
1170− . UnsafeExpression
1171− . commaSeparated
1172− . unsafeRowFunction
1173−
1174−-- | Builds a possibly-heterogeneously-typed (binary) JSON object out of a
1175−-- variadic argument list. The elements of the argument list must alternate
1176−-- between text and values.
1177−jsonbBuildObject
1178− :: All Top elems
1179− => NP (Aliased (Expression schema from grouping params)) elems
1180− -> Expression schema from grouping params (nullity 'PGjsonb)
1181−jsonbBuildObject
1182− = unsafeFunction "jsonb_build_object"
1183− . UnsafeExpression
1184− . commaSeparated
1185− . unsafeRowFunction
1186−
1187−-- | Builds a JSON object out of a text array. The array must have either
1188−-- exactly one dimension with an even number of members, in which case they are
1189−-- taken as alternating key/value pairs, or two dimensions such that each inner
1190−-- array has exactly two elements, which are taken as a key/value pair.
1191−jsonObject
1192− :: PGArrayOf "jsonObject" arr ('NotNull 'PGtext)
1193− => Expression schema from grouping params (nullity arr)
1194− -> Expression schema from grouping params (nullity 'PGjson)
1195−jsonObject = unsafeFunction "json_object"
1196−
1197−-- | Builds a binary JSON object out of a text array. The array must have either
1198−-- exactly one dimension with an even number of members, in which case they are
1199−-- taken as alternating key/value pairs, or two dimensions such that each inner
1200−-- array has exactly two elements, which are taken as a key/value pair.
1201−jsonbObject
1202− :: PGArrayOf "jsonbObject" arr ('NotNull 'PGtext)
1203− => Expression schema from grouping params (nullity arr)
1204− -> Expression schema from grouping params (nullity 'PGjsonb)
1205−jsonbObject = unsafeFunction "jsonb_object"
1206−
1207−-- | This is an alternate form of 'jsonObject' that takes two arrays; one for
1208−-- keys and one for values, that are zipped pairwise to create a JSON object.
1209−jsonZipObject
1210− :: ( PGArrayOf "jsonZipObject" keysArray ('NotNull 'PGtext)
1211− , PGArrayOf "jsonZipObject" valuesArray ('NotNull 'PGtext))
1212− => Expression schema from grouping params (nullity keysArray)
1213− -> Expression schema from grouping params (nullity valuesArray)
1214− -> Expression schema from grouping params (nullity 'PGjson)
1215−jsonZipObject ks vs =
1216− unsafeVariadicFunction "json_object" (ks :* vs :* Nil)
1217−
1218−-- | This is an alternate form of 'jsonObject' that takes two arrays; one for
1219−-- keys and one for values, that are zipped pairwise to create a binary JSON
1220−-- object.
1221−jsonbZipObject
1222− :: ( PGArrayOf "jsonbZipObject" keysArray ('NotNull 'PGtext)
1223− , PGArrayOf "jsonbZipObject" valuesArray ('NotNull 'PGtext))
1224− => Expression schema from grouping params (nullity keysArray)
1225− -> Expression schema from grouping params (nullity valuesArray)
1226− -> Expression schema from grouping params (nullity 'PGjsonb)
1227−jsonbZipObject ks vs =
1228− unsafeVariadicFunction "jsonb_object" (ks :* vs :* Nil)
1229−
1230−{-----------------------------------------
1231−Table 9.46: JSON processing functions
1232−-----------------------------------------}
1233−
1234−-- | Returns the number of elements in the outermost JSON array.
1235−jsonArrayLength
1236− :: Expression schema from grouping params (nullity 'PGjson)
1237− -> Expression schema from grouping params (nullity 'PGint4)
1238−jsonArrayLength = unsafeFunction "json_array_length"
1239−
1240−-- | Returns the number of elements in the outermost binary JSON array.
1241−jsonbArrayLength
1242− :: Expression schema from grouping params (nullity 'PGjsonb)
1243− -> Expression schema from grouping params (nullity 'PGint4)
1244−jsonbArrayLength = unsafeFunction "jsonb_array_length"
1245−
1246−-- | Returns JSON value pointed to by the given path (equivalent to #>
1247−-- operator).
1248−jsonExtractPath
1249− :: SListI elems
1250− => Expression schema from grouping params (nullity 'PGjson)
1251− -> NP (Expression schema from grouping params) elems
1252− -> Expression schema from grouping params (nullity 'PGjsonb)
1253−jsonExtractPath x xs =
1254− unsafeVariadicFunction "json_extract_path" (x :* xs)
1255−
1256−-- | Returns JSON value pointed to by the given path (equivalent to #>
1257−-- operator).
1258−jsonbExtractPath
1259− :: SListI elems
1260− => Expression schema from grouping params (nullity 'PGjsonb)
1261− -> NP (Expression schema from grouping params) elems
1262− -> Expression schema from grouping params (nullity 'PGjsonb)
1263−jsonbExtractPath x xs =
1264− unsafeVariadicFunction "jsonb_extract_path" (x :* xs)
1265−
1266−-- | Returns JSON value pointed to by the given path (equivalent to #>
1267−-- operator), as text.
1268−jsonExtractPathAsText
1269− :: SListI elems
1270− => Expression schema from grouping params (nullity 'PGjson)
1271− -> NP (Expression schema from grouping params) elems
1272− -> Expression schema from grouping params (nullity 'PGjson)
1273−jsonExtractPathAsText x xs =
1274− unsafeVariadicFunction "json_extract_path_text" (x :* xs)
1275−
1276−-- | Returns JSON value pointed to by the given path (equivalent to #>
1277−-- operator), as text.
1278−jsonbExtractPathAsText
1279− :: SListI elems
1280− => Expression schema from grouping params (nullity 'PGjsonb)
1281− -> NP (Expression schema from grouping params) elems
1282− -> Expression schema from grouping params (nullity 'PGjsonb)
1283−jsonbExtractPathAsText x xs =
1284− unsafeVariadicFunction "jsonb_extract_path_text" (x :* xs)
1285−
1286−-- | Returns the type of the outermost JSON value as a text string. Possible
1287−-- types are object, array, string, number, boolean, and null.
1288−jsonTypeof
1289− :: Expression schema from grouping params (nullity 'PGjson)
1290− -> Expression schema from grouping params (nullity 'PGtext)
1291−jsonTypeof = unsafeFunction "json_typeof"
1292−
1293−-- | Returns the type of the outermost binary JSON value as a text string.
1294−-- Possible types are object, array, string, number, boolean, and null.
1295−jsonbTypeof
1296− :: Expression schema from grouping params (nullity 'PGjsonb)
1297− -> Expression schema from grouping params (nullity 'PGtext)
1298−jsonbTypeof = unsafeFunction "jsonb_typeof"
1299−
1300−-- | Returns its argument with all object fields that have null values omitted.
1301−-- Other null values are untouched.
1302−jsonStripNulls
1303− :: Expression schema from grouping params (nullity 'PGjson)
1304− -> Expression schema from grouping params (nullity 'PGjson)
1305−jsonStripNulls = unsafeFunction "json_strip_nulls"
1306−
1307−-- | Returns its argument with all object fields that have null values omitted.
1308−-- Other null values are untouched.
1309−jsonbStripNulls
1310− :: Expression schema from grouping params (nullity 'PGjsonb)
1311− -> Expression schema from grouping params (nullity 'PGjsonb)
1312−jsonbStripNulls = unsafeFunction "jsonb_strip_nulls"
1313−
1314−-- | @ jsonbSet target path new_value create_missing @
1315−--
1316−-- Returns target with the section designated by path replaced by new_value,
1317−-- or with new_value added if create_missing is true ( default is true) and the
1318−-- item designated by path does not exist. As with the path orientated
1319−-- operators, negative integers that appear in path count from the end of JSON
1320−-- arrays.
1321−jsonbSet
1322− :: PGTextArray "jsonbSet" arr
1323− => Expression schema from grouping params (nullity 'PGjsonb)
1324− -> Expression schema from grouping params (nullity arr)
1325− -> Expression schema from grouping params (nullity 'PGjsonb)
1326− -> Maybe (Expression schema from grouping params (nullity 'PGbool))
1327− -> Expression schema from grouping params (nullity 'PGjsonb)
1328−jsonbSet tgt path val createMissing = case createMissing of
1329− Just m -> unsafeVariadicFunction "jsonb_set" (tgt :* path :* val :* m :* Nil)
1330− Nothing -> unsafeVariadicFunction "jsonb_set" (tgt :* path :* val :* Nil)
1331−
1332−-- | @ jsonbInsert target path new_value insert_after @
1333−--
1334−-- Returns target with new_value inserted. If target section designated by
1335−-- path is in a JSONB array, new_value will be inserted before target or after
1336−-- if insert_after is true (default is false). If target section designated by
1337−-- path is in JSONB object, new_value will be inserted only if target does not
1338−-- exist. As with the path orientated operators, negative integers that appear
1339−-- in path count from the end of JSON arrays.
1340−jsonbInsert
1341− :: PGTextArray "jsonbInsert" arr
1342− => Expression schema from grouping params (nullity 'PGjsonb)
1343− -> Expression schema from grouping params (nullity arr)
1344− -> Expression schema from grouping params (nullity 'PGjsonb)
1345− -> Maybe (Expression schema from grouping params (nullity 'PGbool))
1346− -> Expression schema from grouping params (nullity 'PGjsonb)
1347−jsonbInsert tgt path val insertAfter = case insertAfter of
1348− Just i -> unsafeVariadicFunction "jsonb_insert" (tgt :* path :* val :* i :* Nil)
1349− Nothing -> unsafeVariadicFunction "jsonb_insert" (tgt :* path :* val :* Nil)
1350−
1351−-- | Returns its argument as indented JSON text.
1352−jsonbPretty
1353− :: Expression schema from grouping params (nullity 'PGjsonb)
1354− -> Expression schema from grouping params (nullity 'PGtext)
1355−jsonbPretty = unsafeFunction "jsonb_pretty"
1356−
1357−{-----------------------------------------
1358−aggregation
1359−-----------------------------------------}
1360−
1361−-- | escape hatch to define aggregate functions
1362−unsafeAggregate
1363− :: ByteString -- ^ aggregate function
1364− -> Expression schema from 'Ungrouped params (xty)
1365− -> Expression schema from ('Grouped bys) params (yty)
1366−unsafeAggregate fun x = UnsafeExpression $ mconcat
1367− [fun, "(", renderExpression x, ")"]
1368−
1369−-- | escape hatch to define aggregate functions over distinct values
1370−unsafeAggregateDistinct
1371− :: ByteString -- ^ aggregate function
1372− -> Expression schema from 'Ungrouped params (xty)
1373− -> Expression schema from ('Grouped bys) params (yty)
1374−unsafeAggregateDistinct fun x = UnsafeExpression $ mconcat
1375− [fun, "(DISTINCT ", renderExpression x, ")"]
1376−
1377−-- | >>> :{
1378−-- let
1379−-- expression :: Expression schema '[tab ::: '["col" ::: 'Null 'PGnumeric]] ('Grouped bys) params ('Null 'PGnumeric)
1380−-- expression = sum_ #col
1381−-- in printSQL expression
1382−-- :}
1383−-- sum("col")
1384−sum_
1385− :: ty `In` PGNum
1386− => Expression schema from 'Ungrouped params (nullity ty)
1387− -- ^ what to sum
1388− -> Expression schema from ('Grouped bys) params (nullity ty)
1389−sum_ = unsafeAggregate "sum"
1390−
1391−-- | >>> :{
1392−-- let
1393−-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGnumeric]] ('Grouped bys) params (nullity 'PGnumeric)
1394−-- expression = sumDistinct #col
1395−-- in printSQL expression
1396−-- :}
1397−-- sum(DISTINCT "col")
1398−sumDistinct
1399− :: ty `In` PGNum
1400− => Expression schema from 'Ungrouped params (nullity ty)
1401− -- ^ what to sum
1402− -> Expression schema from ('Grouped bys) params (nullity ty)
1403−sumDistinct = unsafeAggregateDistinct "sum"
1404−
1405−-- | A constraint for `PGType`s that you can take averages of and the resulting
1406−-- `PGType`.
1407−class PGAvg ty avg | ty -> avg where
1408− avg, avgDistinct
1409− :: Expression schema from 'Ungrouped params (nullity ty)
1410− -- ^ what to average
1411− -> Expression schema from ('Grouped bys) params (nullity avg)
1412− avg = unsafeAggregate "avg"
1413− avgDistinct = unsafeAggregateDistinct "avg"
1414−instance PGAvg 'PGint2 'PGnumeric
1415−instance PGAvg 'PGint4 'PGnumeric
1416−instance PGAvg 'PGint8 'PGnumeric
1417−instance PGAvg 'PGnumeric 'PGnumeric
1418−instance PGAvg 'PGfloat4 'PGfloat8
1419−instance PGAvg 'PGfloat8 'PGfloat8
1420−instance PGAvg 'PGinterval 'PGinterval
1421−
1422−-- | >>> :{
1423−-- let
1424−-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4)
1425−-- expression = bitAnd #col
1426−-- in printSQL expression
1427−-- :}
1428−-- bit_and("col")
1429−bitAnd
1430− :: int `In` PGIntegral
1431− => Expression schema from 'Ungrouped params (nullity int)
1432− -- ^ what to aggregate
1433− -> Expression schema from ('Grouped bys) params (nullity int)
1434−bitAnd = unsafeAggregate "bit_and"
1435−
1436−-- | >>> :{
1437−-- let
1438−-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4)
1439−-- expression = bitOr #col
1440−-- in printSQL expression
1441−-- :}
1442−-- bit_or("col")
1443−bitOr
1444− :: int `In` PGIntegral
1445− => Expression schema from 'Ungrouped params (nullity int)
1446− -- ^ what to aggregate
1447− -> Expression schema from ('Grouped bys) params (nullity int)
1448−bitOr = unsafeAggregate "bit_or"
1449−
1450−-- | >>> :{
1451−-- let
1452−-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4)
1453−-- expression = bitAndDistinct #col
1454−-- in printSQL expression
1455−-- :}
1456−-- bit_and(DISTINCT "col")
1457−bitAndDistinct
1458− :: int `In` PGIntegral
1459− => Expression schema from 'Ungrouped params (nullity int)
1460− -- ^ what to aggregate
1461− -> Expression schema from ('Grouped bys) params (nullity int)
1462−bitAndDistinct = unsafeAggregateDistinct "bit_and"
1463−
1464−-- | >>> :{
1465−-- let
1466−-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4)
1467−-- expression = bitOrDistinct #col
1468−-- in printSQL expression
1469−-- :}
1470−-- bit_or(DISTINCT "col")
1471−bitOrDistinct
1472− :: int `In` PGIntegral
1473− => Expression schema from 'Ungrouped params (nullity int)
1474− -- ^ what to aggregate
1475− -> Expression schema from ('Grouped bys) params (nullity int)
1476−bitOrDistinct = unsafeAggregateDistinct "bit_or"
1477−
1478−-- | >>> :{
1479−-- let
1480−-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)
1481−-- expression = boolAnd #col
1482−-- in printSQL expression
1483−-- :}
1484−-- bool_and("col")
1485−boolAnd
1486− :: Expression schema from 'Ungrouped params (nullity 'PGbool)
1487− -- ^ what to aggregate
1488− -> Expression schema from ('Grouped bys) params (nullity 'PGbool)
1489−boolAnd = unsafeAggregate "bool_and"
1490−
1491−-- | >>> :{
1492−-- let
1493−-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)
1494−-- expression = boolOr #col
1495−-- in printSQL expression
1496−-- :}
1497−-- bool_or("col")
1498−boolOr
1499− :: Expression schema from 'Ungrouped params (nullity 'PGbool)
1500− -- ^ what to aggregate
1501− -> Expression schema from ('Grouped bys) params (nullity 'PGbool)
1502−boolOr = unsafeAggregate "bool_or"
1503−
1504−-- | >>> :{
1505−-- let
1506−-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)
1507−-- expression = boolAndDistinct #col
1508−-- in printSQL expression
1509−-- :}
1510−-- bool_and(DISTINCT "col")
1511−boolAndDistinct
1512− :: Expression schema from 'Ungrouped params (nullity 'PGbool)
1513− -- ^ what to aggregate
1514− -> Expression schema from ('Grouped bys) params (nullity 'PGbool)
1515−boolAndDistinct = unsafeAggregateDistinct "bool_and"
1516−
1517−-- | >>> :{
1518−-- let
1519−-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)
1520−-- expression = boolOrDistinct #col
1521−-- in printSQL expression
1522−-- :}
1523−-- bool_or(DISTINCT "col")
1524−boolOrDistinct
1525− :: Expression schema from 'Ungrouped params (nullity 'PGbool)
1526− -- ^ what to aggregate
1527− -> Expression schema from ('Grouped bys) params (nullity 'PGbool)
1528−boolOrDistinct = unsafeAggregateDistinct "bool_or"
1529−
1530−-- | A special aggregation that does not require an input
1531−--
1532−-- >>> printSQL countStar
1533−-- count(*)
1534−countStar
1535− :: Expression schema from ('Grouped bys) params ('NotNull 'PGint8)
1536−countStar = UnsafeExpression $ "count(*)"
1537−
1538−-- | >>> :{
1539−-- let
1540−-- expression :: Expression schema '[tab ::: '["col" ::: nullity ty]] (Grouped bys) params ('NotNull 'PGint8)
1541−-- expression = count #col
1542−-- in printSQL expression
1543−-- :}
1544−-- count("col")
1545−count
1546− :: Expression schema from 'Ungrouped params ty
1547− -- ^ what to count
1548− -> Expression schema from ('Grouped bys) params ('NotNull 'PGint8)
1549−count = unsafeAggregate "count"
1550−
1551−-- | >>> :{
1552−-- let
1553−-- expression :: Expression schema '[tab ::: '["col" ::: nullity ty]] (Grouped bys) params ('NotNull 'PGint8)
1554−-- expression = countDistinct #col
1555−-- in printSQL expression
1556−-- :}
1557−-- count(DISTINCT "col")
1558−countDistinct
1559− :: Expression schema from 'Ungrouped params ty
1560− -- ^ what to count
1561− -> Expression schema from ('Grouped bys) params ('NotNull 'PGint8)
1562−countDistinct = unsafeAggregateDistinct "count"
1563−
1564−-- | synonym for `boolAnd`
1565−--
1566−-- >>> :{
1567−-- let
1568−-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)
1569−-- expression = every #col
1570−-- in printSQL expression
1571−-- :}
1572−-- every("col")
1573−every
1574− :: Expression schema from 'Ungrouped params (nullity 'PGbool)
1575− -- ^ what to aggregate
1576− -> Expression schema from ('Grouped bys) params (nullity 'PGbool)
1577−every = unsafeAggregate "every"
1578−
1579−-- | synonym for `boolAndDistinct`
1580−--
1581−-- >>> :{
1582−-- let
1583−-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)
1584−-- expression = everyDistinct #col
1585−-- in printSQL expression
1586−-- :}
1587−-- every(DISTINCT "col")
1588−everyDistinct
1589− :: Expression schema from 'Ungrouped params (nullity 'PGbool)
1590− -- ^ what to aggregate
1591− -> Expression schema from ('Grouped bys) params (nullity 'PGbool)
1592−everyDistinct = unsafeAggregateDistinct "every"
1593−
1594−-- | minimum and maximum aggregation
1595−max_, min_, maxDistinct, minDistinct
1596− :: Expression schema from 'Ungrouped params (nullity ty)
1597− -- ^ what to aggregate
1598− -> Expression schema from ('Grouped bys) params (nullity ty)
1599−max_ = unsafeAggregate "max"
1600−min_ = unsafeAggregate "min"
1601−maxDistinct = unsafeAggregateDistinct "max"
1602−minDistinct = unsafeAggregateDistinct "min"
1603−
1604−{-----------------------------------------
1605−type expressions
1606−-----------------------------------------}
1607−
1608−-- | `TypeExpression`s are used in `cast`s and `createTable` commands.
1609−newtype TypeExpression (schema :: SchemaType) (ty :: NullityType)
1610− = UnsafeTypeExpression { renderTypeExpression :: ByteString }
1611− deriving (GHC.Generic,Show,Eq,Ord,NFData)
1612−
1613−-- | The enum or composite type in a `Typedef` can be expressed by its alias.
1614−typedef
1615− :: Has alias schema ('Typedef ty)
1616− => Alias alias
1617− -> TypeExpression schema (nullity ty)
1618−typedef = UnsafeTypeExpression . renderAlias
1619−
1620−-- | The composite type corresponding to a `Table` definition can be expressed
1621−-- by its alias.
1622−typetable
1623− :: Has alias schema ('Table tab)
1624− => Alias alias
1625− -> TypeExpression schema (nullity ('PGcomposite (TableToRow tab)))
1626−typetable = UnsafeTypeExpression . renderAlias
1627−
1628−-- | The composite type corresponding to a `View` definition can be expressed
1629−-- by its alias.
1630−typeview
1631− :: Has alias schema ('View view)
1632− => Alias alias
1633− -> TypeExpression schema (nullity ('PGcomposite view))
1634−typeview = UnsafeTypeExpression . renderAlias
1635−
1636−-- | logical Boolean (true/false)
1637−bool :: TypeExpression schema (nullity 'PGbool)
1638−bool = UnsafeTypeExpression "bool"
1639−-- | signed two-byte integer
1640−int2, smallint :: TypeExpression schema (nullity 'PGint2)
1641−int2 = UnsafeTypeExpression "int2"
1642−smallint = UnsafeTypeExpression "smallint"
1643−-- | signed four-byte integer
1644−int4, int, integer :: TypeExpression schema (nullity 'PGint4)
1645−int4 = UnsafeTypeExpression "int4"
1646−int = UnsafeTypeExpression "int"
1647−integer = UnsafeTypeExpression "integer"
1648−-- | signed eight-byte integer
1649−int8, bigint :: TypeExpression schema (nullity 'PGint8)
1650−int8 = UnsafeTypeExpression "int8"
1651−bigint = UnsafeTypeExpression "bigint"
1652−-- | arbitrary precision numeric type
1653−numeric :: TypeExpression schema (nullity 'PGnumeric)
1654−numeric = UnsafeTypeExpression "numeric"
1655−-- | single precision floating-point number (4 bytes)
1656−float4, real :: TypeExpression schema (nullity 'PGfloat4)
1657−float4 = UnsafeTypeExpression "float4"
1658−real = UnsafeTypeExpression "real"
1659−-- | double precision floating-point number (8 bytes)
1660−float8, doublePrecision :: TypeExpression schema (nullity 'PGfloat8)
1661−float8 = UnsafeTypeExpression "float8"
1662−doublePrecision = UnsafeTypeExpression "double precision"
1663−-- | variable-length character string
1664−text :: TypeExpression schema (nullity 'PGtext)
1665−text = UnsafeTypeExpression "text"
1666−-- | fixed-length character string
1667−char, character
1668− :: forall n schema nullity. (KnownNat n, 1 <= n)
1669− => TypeExpression schema (nullity ('PGchar n))
1670−char = UnsafeTypeExpression $ "char(" <> renderNat @n <> ")"
1671−character = UnsafeTypeExpression $ "character(" <> renderNat @n <> ")"
1672−-- | variable-length character string
1673−varchar, characterVarying
1674− :: forall n schema nullity. (KnownNat n, 1 <= n)
1675− => TypeExpression schema (nullity ('PGvarchar n))
1676−varchar = UnsafeTypeExpression $ "varchar(" <> renderNat @n <> ")"
1677−characterVarying = UnsafeTypeExpression $
1678− "character varying(" <> renderNat @n <> ")"
1679−-- | binary data ("byte array")
1680−bytea :: TypeExpression schema (nullity 'PGbytea)
1681−bytea = UnsafeTypeExpression "bytea"
1682−-- | date and time (no time zone)
1683−timestamp :: TypeExpression schema (nullity 'PGtimestamp)
1684−timestamp = UnsafeTypeExpression "timestamp"
1685−-- | date and time, including time zone
1686−timestampWithTimeZone :: TypeExpression schema (nullity 'PGtimestamptz)
1687−timestampWithTimeZone = UnsafeTypeExpression "timestamp with time zone"
1688−-- | calendar date (year, month, day)
1689−date :: TypeExpression schema (nullity 'PGdate)
1690−date = UnsafeTypeExpression "date"
1691−-- | time of day (no time zone)
1692−time :: TypeExpression schema (nullity 'PGtime)
1693−time = UnsafeTypeExpression "time"
1694−-- | time of day, including time zone
1695−timeWithTimeZone :: TypeExpression schema (nullity 'PGtimetz)
1696−timeWithTimeZone = UnsafeTypeExpression "time with time zone"
1697−-- | time span
1698−interval :: TypeExpression schema (nullity 'PGinterval)
1699−interval = UnsafeTypeExpression "interval"
1700−-- | universally unique identifier
1701−uuid :: TypeExpression schema (nullity 'PGuuid)
1702−uuid = UnsafeTypeExpression "uuid"
1703−-- | IPv4 or IPv6 host address
1704−inet :: TypeExpression schema (nullity 'PGinet)
1705−inet = UnsafeTypeExpression "inet"
1706−-- | textual JSON data
1707−json :: TypeExpression schema (nullity 'PGjson)
1708−json = UnsafeTypeExpression "json"
1709−-- | binary JSON data, decomposed
1710−jsonb :: TypeExpression schema (nullity 'PGjsonb)
1711−jsonb = UnsafeTypeExpression "jsonb"
1712−-- | variable length array
1713−vararray
1714− :: TypeExpression schema pg
1715− -> TypeExpression schema (nullity ('PGvararray pg))
1716−vararray ty = UnsafeTypeExpression $ renderTypeExpression ty <> "[]"
1717−-- | fixed length array
1718−--
1719−-- >>> renderTypeExpression (fixarray @2 json)
1720−-- "json[2]"
1721−fixarray
1722− :: forall n schema nullity pg. KnownNat n
1723− => TypeExpression schema pg
1724− -> TypeExpression schema (nullity ('PGfixarray n pg))
1725−fixarray ty = UnsafeTypeExpression $
1726− renderTypeExpression ty <> "[" <> renderNat @n <> "]"
1727−
1728−-- | `pgtype` is a demoted version of a `PGType`
1729−class PGTyped schema (ty :: NullityType) where
1730− pgtype :: TypeExpression schema ty
1731−instance PGTyped schema (nullity 'PGbool) where pgtype = bool
1732−instance PGTyped schema (nullity 'PGint2) where pgtype = int2
1733−instance PGTyped schema (nullity 'PGint4) where pgtype = int4
1734−instance PGTyped schema (nullity 'PGint8) where pgtype = int8
1735−instance PGTyped schema (nullity 'PGnumeric) where pgtype = numeric
1736−instance PGTyped schema (nullity 'PGfloat4) where pgtype = float4
1737−instance PGTyped schema (nullity 'PGfloat8) where pgtype = float8
1738−instance PGTyped schema (nullity 'PGtext) where pgtype = text
1739−instance (KnownNat n, 1 <= n)
1740− => PGTyped schema (nullity ('PGchar n)) where pgtype = char @n
1741−instance (KnownNat n, 1 <= n)
1742− => PGTyped schema (nullity ('PGvarchar n)) where pgtype = varchar @n
1743−instance PGTyped schema (nullity 'PGbytea) where pgtype = bytea
1744−instance PGTyped schema (nullity 'PGtimestamp) where pgtype = timestamp
1745−instance PGTyped schema (nullity 'PGtimestamptz) where pgtype = timestampWithTimeZone
1746−instance PGTyped schema (nullity 'PGdate) where pgtype = date
1747−instance PGTyped schema (nullity 'PGtime) where pgtype = time
1748−instance PGTyped schema (nullity 'PGtimetz) where pgtype = timeWithTimeZone
1749−instance PGTyped schema (nullity 'PGinterval) where pgtype = interval
1750−instance PGTyped schema (nullity 'PGuuid) where pgtype = uuid
1751−instance PGTyped schema (nullity 'PGjson) where pgtype = json
1752−instance PGTyped schema (nullity 'PGjsonb) where pgtype = jsonb
1753−instance PGTyped schema ty
1754− => PGTyped schema (nullity ('PGvararray ty)) where
1755− pgtype = vararray (pgtype @schema @ty)
1756−instance (KnownNat n, PGTyped schema ty)
1757− => PGTyped schema (nullity ('PGfixarray n ty)) where
1758− pgtype = fixarray @n (pgtype @schema @ty)
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Aggregate.hsnew file+462
@@ -0,0 +1,462 @@
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+
11+{-# LANGUAGE
12+ DataKinds
13+ , DeriveGeneric
14+ , FlexibleContexts
15+ , FlexibleInstances
16+ , FunctionalDependencies
17+ , LambdaCase
18+ , MultiParamTypeClasses
19+ , OverloadedStrings
20+ , PolyKinds
21+ , TypeFamilies
22+ , TypeOperators
23+ , UndecidableInstances
24+#-}
25+
26+module Squeal.PostgreSQL.Expression.Aggregate
27+ ( Aggregate (..)
28+ , Distinction (..)
29+ , PGSum
30+ , PGAvg
31+ ) where
32+
33+import Control.DeepSeq
34+import Data.ByteString (ByteString)
35+import Data.Kind
36+import GHC.TypeLits
37+
38+import qualified GHC.Generics as GHC
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.Schema
46+
47+-- $setup
48+-- >>> import Squeal.PostgreSQL
49+
50+{- |
51+`Aggregate` functions compute a single result from a set of input values.
52+`Aggregate` functions can be used as `GroupedBy` `Expression`s as well
53+as `Squeal.PostgreSQL.Expression.Window.WindowFunction`s.
54+-}
55+class Aggregate expr1 exprN aggr
56+ | aggr -> expr1, aggr -> exprN where
57+
58+ -- | A special aggregation that does not require an input
59+ --
60+ -- >>> :{
61+ -- let
62+ -- expression :: Expression '[] commons ('Grouped bys) schemas params from ('NotNull 'PGint8)
63+ -- expression = countStar
64+ -- in printSQL expression
65+ -- :}
66+ -- count(*)
67+ countStar :: aggr ('NotNull 'PGint8)
68+
69+ -- | >>> :{
70+ -- let
71+ -- expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: null ty]] ('NotNull 'PGint8)
72+ -- expression = count (All #col)
73+ -- in printSQL expression
74+ -- :}
75+ -- count(ALL "col")
76+ count
77+ :: expr1 ty
78+ -- ^ what to count
79+ -> aggr ('NotNull 'PGint8)
80+
81+ -- | >>> :{
82+ -- let
83+ -- expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: 'Null 'PGnumeric]] ('Null 'PGnumeric)
84+ -- expression = sum_ (Distinct #col)
85+ -- in printSQL expression
86+ -- :}
87+ -- sum(DISTINCT "col")
88+ sum_
89+ :: expr1 (null ty)
90+ -> aggr ('Null (PGSum ty))
91+
92+ -- | input values, including nulls, concatenated into an array
93+ arrayAgg
94+ :: expr1 ty
95+ -> aggr ('Null ('PGvararray ty))
96+
97+ -- | aggregates values as a JSON array
98+ jsonAgg
99+ :: expr1 ty
100+ -> aggr ('Null 'PGjson)
101+
102+ -- | aggregates values as a JSON array
103+ jsonbAgg
104+ :: expr1 ty
105+ -> aggr ('Null 'PGjsonb)
106+
107+ {- |
108+ the bitwise AND of all non-null input values, or null if none
109+
110+ >>> :{
111+ let
112+ expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: null 'PGint4]] ('Null 'PGint4)
113+ expression = bitAnd (Distinct #col)
114+ in printSQL expression
115+ :}
116+ bit_and(DISTINCT "col")
117+ -}
118+ bitAnd
119+ :: int `In` PGIntegral
120+ => expr1 (null int)
121+ -- ^ what to aggregate
122+ -> aggr ('Null int)
123+
124+ {- |
125+ the bitwise OR of all non-null input values, or null if none
126+
127+ >>> :{
128+ let
129+ expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: null 'PGint4]] ('Null 'PGint4)
130+ expression = bitOr (All #col)
131+ in printSQL expression
132+ :}
133+ bit_or(ALL "col")
134+ -}
135+ bitOr
136+ :: int `In` PGIntegral
137+ => expr1 (null int)
138+ -- ^ what to aggregate
139+ -> aggr ('Null int)
140+
141+ {- |
142+ true if all input values are true, otherwise false
143+
144+ >>> :{
145+ let
146+ winFun :: WindowFunction '[] commons 'Ungrouped schemas params '[tab ::: '["col" ::: null 'PGbool]] ('Null 'PGbool)
147+ winFun = boolAnd #col
148+ in printSQL winFun
149+ :}
150+ bool_and("col")
151+ -}
152+ boolAnd
153+ :: expr1 (null 'PGbool)
154+ -- ^ what to aggregate
155+ -> aggr ('Null 'PGbool)
156+
157+ {- |
158+ true if at least one input value is true, otherwise false
159+
160+ >>> :{
161+ let
162+ expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: null 'PGbool]] ('Null 'PGbool)
163+ expression = boolOr (All #col)
164+ in printSQL expression
165+ :}
166+ bool_or(ALL "col")
167+ -}
168+ boolOr
169+ :: expr1 (null 'PGbool)
170+ -- ^ what to aggregate
171+ -> aggr ('Null 'PGbool)
172+
173+ {- |
174+ equivalent to `boolAnd`
175+
176+ >>> :{
177+ let
178+ expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: null 'PGbool]] ('Null 'PGbool)
179+ expression = every (Distinct #col)
180+ in printSQL expression
181+ :}
182+ every(DISTINCT "col")
183+ -}
184+ every
185+ :: expr1 (null 'PGbool)
186+ -- ^ what to aggregate
187+ -> aggr ('Null 'PGbool)
188+
189+ {- |maximum value of expression across all input values-}
190+ max_
191+ :: expr1 (null ty)
192+ -- ^ what to maximize
193+ -> aggr ('Null ty)
194+
195+ -- | minimum value of expression across all input values
196+ min_
197+ :: expr1 (null ty)
198+ -- ^ what to minimize
199+ -> aggr ('Null ty)
200+
201+ -- | the average (arithmetic mean) of all input values
202+ avg
203+ :: expr1 (null ty)
204+ -- ^ what to average
205+ -> aggr ('Null (PGAvg ty))
206+
207+ {- | correlation coefficient
208+
209+ >>> :{
210+ let
211+ expression :: Expression '[] c ('Grouped g) s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)
212+ expression = corr (All (#y *: #x))
213+ in printSQL expression
214+ :}
215+ corr(ALL "y", "x")
216+ -}
217+ corr
218+ :: exprN '[null 'PGfloat8, null 'PGfloat8]
219+ -> aggr ('Null 'PGfloat8)
220+
221+ {- | population covariance
222+
223+ >>> :{
224+ let
225+ expression :: Expression '[] c ('Grouped g) s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)
226+ expression = covarPop (All (#y *: #x))
227+ in printSQL expression
228+ :}
229+ covar_pop(ALL "y", "x")
230+ -}
231+ covarPop
232+ :: exprN '[null 'PGfloat8, null 'PGfloat8]
233+ -> aggr ('Null 'PGfloat8)
234+
235+ {- | sample covariance
236+
237+ >>> :{
238+ let
239+ winFun :: WindowFunction '[] c 'Ungrouped s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)
240+ winFun = covarSamp (#y *: #x)
241+ in printSQL winFun
242+ :}
243+ covar_samp("y", "x")
244+ -}
245+ covarSamp
246+ :: exprN '[null 'PGfloat8, null 'PGfloat8]
247+ -> aggr ('Null 'PGfloat8)
248+
249+ {- | average of the independent variable (sum(X)/N)
250+
251+ >>> :{
252+ let
253+ expression :: Expression '[] c ('Grouped g) s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)
254+ expression = regrAvgX (All (#y *: #x))
255+ in printSQL expression
256+ :}
257+ regr_avgx(ALL "y", "x")
258+ -}
259+ regrAvgX
260+ :: exprN '[null 'PGfloat8, null 'PGfloat8]
261+ -> aggr ('Null 'PGfloat8)
262+
263+ {- | average of the dependent variable (sum(Y)/N)
264+
265+ >>> :{
266+ let
267+ winFun :: WindowFunction '[] c 'Ungrouped s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)
268+ winFun = regrAvgY (#y *: #x)
269+ in printSQL winFun
270+ :}
271+ regr_avgy("y", "x")
272+ -}
273+ regrAvgY
274+ :: exprN '[null 'PGfloat8, null 'PGfloat8]
275+ -> aggr ('Null 'PGfloat8)
276+
277+ {- | number of input rows in which both expressions are nonnull
278+
279+ >>> :{
280+ let
281+ winFun :: WindowFunction '[] c 'Ungrouped s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGint8)
282+ winFun = regrCount (#y *: #x)
283+ in printSQL winFun
284+ :}
285+ regr_count("y", "x")
286+ -}
287+ regrCount
288+ :: exprN '[null 'PGfloat8, null 'PGfloat8]
289+ -> aggr ('Null 'PGint8)
290+
291+ {- | y-intercept of the least-squares-fit linear equation determined by the (X, Y) pairs
292+ >>> :{
293+ let
294+ expression :: Expression '[] c ('Grouped g) s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)
295+ expression = regrIntercept (All (#y *: #x))
296+ in printSQL expression
297+ :}
298+ regr_intercept(ALL "y", "x")
299+ -}
300+ regrIntercept
301+ :: exprN '[null 'PGfloat8, null 'PGfloat8]
302+ -> aggr ('Null 'PGfloat8)
303+
304+ -- | @regr_r2(Y, X)@, square of the correlation coefficient
305+ regrR2
306+ :: exprN '[null 'PGfloat8, null 'PGfloat8]
307+ -> aggr ('Null 'PGfloat8)
308+
309+ -- | @regr_slope(Y, X)@, slope of the least-squares-fit linear equation
310+ -- determined by the (X, Y) pairs
311+ regrSlope
312+ :: exprN '[null 'PGfloat8, null 'PGfloat8]
313+ -> aggr ('Null 'PGfloat8)
314+
315+ -- | @regr_sxx(Y, X)@, sum(X^2) - sum(X)^2/N
316+ -- (“sum of squares” of the independent variable)
317+ regrSxx
318+ :: exprN '[null 'PGfloat8, null 'PGfloat8]
319+ -> aggr ('Null 'PGfloat8)
320+
321+ -- | @regr_sxy(Y, X)@, sum(X*Y) - sum(X) * sum(Y)/N
322+ -- (“sum of products” of independent times dependent variable)
323+ regrSxy
324+ :: exprN '[null 'PGfloat8, null 'PGfloat8]
325+ -> aggr ('Null 'PGfloat8)
326+
327+ -- | @regr_syy(Y, X)@, sum(Y^2) - sum(Y)^2/N
328+ -- (“sum of squares” of the dependent variable)
329+ regrSyy
330+ :: exprN '[null 'PGfloat8, null 'PGfloat8]
331+ -> aggr ('Null 'PGfloat8)
332+
333+ -- | historical alias for `stddevSamp`
334+ stddev
335+ :: expr1 (null ty)
336+ -> aggr ('Null (PGAvg ty))
337+
338+ -- | population standard deviation of the input values
339+ stddevPop
340+ :: expr1 (null ty)
341+ -> aggr ('Null (PGAvg ty))
342+
343+ -- | sample standard deviation of the input values
344+ stddevSamp
345+ :: expr1 (null ty)
346+ -> aggr ('Null (PGAvg ty))
347+
348+ -- | historical alias for `varSamp`
349+ variance
350+ :: expr1 (null ty)
351+ -> aggr ('Null (PGAvg ty))
352+
353+ -- | population variance of the input values
354+ -- (square of the population standard deviation)
355+ varPop
356+ :: expr1 (null ty)
357+ -> aggr ('Null (PGAvg ty))
358+
359+ -- | sample variance of the input values
360+ -- (square of the sample standard deviation)
361+ varSamp
362+ :: expr1 (null ty)
363+ -> aggr ('Null (PGAvg ty))
364+
365+{- |
366+`Distinction`s are used for the input of `Aggregate` `Expression`s.
367+`All` invokes the aggregate once for each input row.
368+`Distinct` invokes the aggregate once for each distinct value of the expression
369+(or distinct set of values, for multiple expressions) found in the input
370+-}
371+data Distinction (expr :: kind -> Type) (ty :: kind)
372+ = All (expr ty)
373+ | Distinct (expr ty)
374+ deriving (GHC.Generic,Show,Eq,Ord)
375+instance NFData (Distinction (Expression outer commons grp schemas params from) ty)
376+instance RenderSQL (Distinction (Expression outer commons grp schemas params from) ty) where
377+ renderSQL = \case
378+ All x -> "ALL" <+> renderSQL x
379+ Distinct x -> "DISTINCT" <+> renderSQL x
380+instance SOP.SListI tys => RenderSQL
381+ (Distinction (NP (Expression outer commons grp schemas params from)) tys) where
382+ renderSQL = \case
383+ All xs -> "ALL" <+> renderCommaSeparated renderSQL xs
384+ Distinct xs -> "DISTINCT" <+> renderCommaSeparated renderSQL xs
385+
386+instance Aggregate
387+ (Distinction (Expression outer commons 'Ungrouped schemas params from))
388+ (Distinction (NP (Expression outer commons 'Ungrouped schemas params from)))
389+ (Expression outer commons ('Grouped bys) schemas params from) where
390+ countStar = UnsafeExpression "count(*)"
391+ count = unsafeAggregate1 "count"
392+ sum_ = unsafeAggregate1 "sum"
393+ arrayAgg = unsafeAggregate1 "array_agg"
394+ jsonAgg = unsafeAggregate1 "json_agg"
395+ jsonbAgg = unsafeAggregate1 "jsonb_agg"
396+ bitAnd = unsafeAggregate1 "bit_and"
397+ bitOr = unsafeAggregate1 "bit_or"
398+ boolAnd = unsafeAggregate1 "bool_and"
399+ boolOr = unsafeAggregate1 "bool_or"
400+ every = unsafeAggregate1 "every"
401+ max_ = unsafeAggregate1 "max"
402+ min_ = unsafeAggregate1 "min"
403+ avg = unsafeAggregate1 "avg"
404+ corr = unsafeAggregateN "corr"
405+ covarPop = unsafeAggregateN "covar_pop"
406+ covarSamp = unsafeAggregateN "covar_samp"
407+ regrAvgX = unsafeAggregateN "regr_avgx"
408+ regrAvgY = unsafeAggregateN "regr_avgy"
409+ regrCount = unsafeAggregateN "regr_count"
410+ regrIntercept = unsafeAggregateN "regr_intercept"
411+ regrR2 = unsafeAggregateN "regr_r2"
412+ regrSlope = unsafeAggregateN "regr_slope"
413+ regrSxx = unsafeAggregateN "regr_sxx"
414+ regrSxy = unsafeAggregateN "regr_sxy"
415+ regrSyy = unsafeAggregateN "regr_syy"
416+ stddev = unsafeAggregate1 "stddev"
417+ stddevPop = unsafeAggregate1 "stddev_pop"
418+ stddevSamp = unsafeAggregate1 "stddev_samp"
419+ variance = unsafeAggregate1 "variance"
420+ varPop = unsafeAggregate1 "var_pop"
421+ varSamp = unsafeAggregate1 "var_samp"
422+
423+-- | escape hatch to define aggregate functions
424+unsafeAggregate1
425+ :: ByteString -- ^ aggregate function
426+ -> Distinction (Expression outer commons 'Ungrouped schemas params from) x
427+ -> Expression outer commons ('Grouped bys) schemas params from y
428+unsafeAggregate1 fun x = UnsafeExpression $ fun <> parenthesized (renderSQL x)
429+
430+unsafeAggregateN
431+ :: SOP.SListI xs
432+ => ByteString -- ^ function
433+ -> Distinction (NP (Expression outer commons 'Ungrouped schemas params from)) xs
434+ -> Expression outer commons ('Grouped bys) schemas params from y
435+unsafeAggregateN fun xs = UnsafeExpression $ fun <> parenthesized (renderSQL xs)
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+
452+-- | A type family that calculates `PGAvg` type of a `PGType`.
453+type family PGAvg ty where
454+ PGAvg 'PGint2 = 'PGnumeric
455+ PGAvg 'PGint4 = 'PGnumeric
456+ PGAvg 'PGint8 = 'PGnumeric
457+ PGAvg 'PGnumeric = 'PGnumeric
458+ PGAvg 'PGfloat4 = 'PGfloat8
459+ PGAvg 'PGfloat8 = 'PGfloat8
460+ PGAvg 'PGinterval = 'PGinterval
461+ PGAvg pg = TypeError
462+ ('Text "Squeal type error: No average for " ':<>: 'ShowType pg)
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Collection.hsnew file+169
@@ -0,0 +1,169 @@
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+
11+{-# LANGUAGE
12+ AllowAmbiguousTypes
13+ , DataKinds
14+ , FlexibleContexts
15+ , FlexibleInstances
16+ , MultiParamTypeClasses
17+ , OverloadedLabels
18+ , OverloadedStrings
19+ , RankNTypes
20+ , ScopedTypeVariables
21+ , TypeApplications
22+ , TypeFamilies
23+ , TypeOperators
24+ , UndecidableInstances
25+#-}
26+
27+module Squeal.PostgreSQL.Expression.Collection
28+ ( array
29+ , array1
30+ , array2
31+ , cardinality
32+ , index
33+ , unnest
34+ , row
35+ , field
36+ ) where
37+
38+import Data.String
39+import Data.Word (Word64)
40+
41+import qualified Generics.SOP as SOP
42+
43+import Squeal.PostgreSQL.Alias
44+import Squeal.PostgreSQL.Expression
45+import Squeal.PostgreSQL.Expression.Set
46+import Squeal.PostgreSQL.List
47+import Squeal.PostgreSQL.Render
48+import Squeal.PostgreSQL.Schema
49+
50+-- $setup
51+-- >>> import Squeal.PostgreSQL
52+
53+-- | >>> printSQL $ array [null_, false, true]
54+-- ARRAY[NULL, FALSE, TRUE]
55+array
56+ :: [Expression outer commons grp schemas params from ty]
57+ -- ^ array elements
58+ -> Expression outer commons grp schemas params from (null ('PGvararray ty))
59+array xs = UnsafeExpression $ "ARRAY" <>
60+ bracketed (commaSeparated (renderSQL <$> xs))
61+
62+{- | construct a 1-dimensional fixed length array
63+
64+>>> printSQL $ array1 (null_ :* false *: true)
65+ARRAY[NULL, FALSE, TRUE]
66+
67+>>> :type array1 (null_ :* false *: true)
68+array1 (null_ :* false *: true)
69+ :: Expression
70+ outer
71+ commons
72+ grp
73+ schemas
74+ params
75+ from
76+ (null ('PGfixarray '[3] ('Null 'PGbool)))
77+-}
78+array1
79+ :: (n ~ Length tys, SOP.All ((~) ty) tys)
80+ => NP (Expression outer commons grp schemas params from) tys
81+ -> Expression outer commons grp schemas params from (null ('PGfixarray '[n] ty))
82+array1 xs = UnsafeExpression $ "ARRAY" <>
83+ bracketed (renderCommaSeparated renderSQL xs)
84+
85+{- | construct a 2-dimensional fixed length array
86+
87+>>> printSQL $ array2 ((null_ :* false *: true) *: (false :* null_ *: true))
88+ARRAY[[NULL, FALSE, TRUE], [FALSE, NULL, TRUE]]
89+
90+>>> :type array2 ((null_ :* false *: true) *: (false :* null_ *: true))
91+array2 ((null_ :* false *: true) *: (false :* null_ *: true))
92+ :: Expression
93+ outer
94+ commons
95+ grp
96+ schemas
97+ params
98+ from
99+ (null ('PGfixarray '[2, 3] ('Null 'PGbool)))
100+-}
101+array2
102+ :: ( SOP.All ((~) tys) tyss
103+ , SOP.All SOP.SListI tyss
104+ , Length tyss ~ n1
105+ , SOP.All ((~) ty) tys
106+ , Length tys ~ n2 )
107+ => NP (NP (Expression outer commons grp schemas params from)) tyss
108+ -> Expression outer commons grp schemas params from (null ('PGfixarray '[n1,n2] ty))
109+array2 xss = UnsafeExpression $ "ARRAY" <>
110+ bracketed (renderCommaSeparatedConstraint @SOP.SListI (bracketed . renderCommaSeparated renderSQL) xss)
111+
112+-- | >>> printSQL $ cardinality (array [null_, false, true])
113+-- cardinality(ARRAY[NULL, FALSE, TRUE])
114+cardinality :: null ('PGvararray ty) --> null 'PGint8
115+cardinality = unsafeFunction "cardinality"
116+
117+-- | >>> printSQL $ array [null_, false, true] & index 2
118+-- (ARRAY[NULL, FALSE, TRUE])[2]
119+index
120+ :: Word64 -- ^ index
121+ -> null ('PGvararray ty) --> NullifyType ty
122+index n expr = UnsafeExpression $
123+ parenthesized (renderSQL expr) <> "[" <> fromString (show n) <> "]"
124+
125+-- | Expand an array to a set of rows
126+unnest :: SetFunction "unnest" (null ('PGvararray ty)) '["unnest" ::: ty]
127+unnest = unsafeSetFunction
128+
129+-- | A row constructor is an expression that builds a row value
130+-- (also called a composite value) using values for its member fields.
131+--
132+-- >>> :{
133+-- type Complex = 'PGcomposite
134+-- '[ "real" ::: 'NotNull 'PGfloat8
135+-- , "imaginary" ::: 'NotNull 'PGfloat8 ]
136+-- :}
137+--
138+-- >>> let i = row (0 `as` #real :* 1 `as` #imaginary) :: Expression outer commons grp schemas params from ('NotNull Complex)
139+-- >>> printSQL i
140+-- ROW(0, 1)
141+row
142+ :: SOP.SListI row
143+ => NP (Aliased (Expression outer commons grp schemas params from)) row
144+ -- ^ zero or more expressions for the row field values
145+ -> Expression outer commons grp schemas params from (null ('PGcomposite row))
146+row exprs = UnsafeExpression $ "ROW" <> parenthesized
147+ (renderCommaSeparated (\ (expr `As` _) -> renderSQL expr) exprs)
148+
149+-- | >>> :{
150+-- type Complex = 'PGcomposite
151+-- '[ "real" ::: 'NotNull 'PGfloat8
152+-- , "imaginary" ::: 'NotNull 'PGfloat8 ]
153+-- type Schema = '["complex" ::: 'Typedef Complex]
154+-- :}
155+--
156+-- >>> let i = row (0 `as` #real :* 1 `as` #imaginary) :: Expression outer '[] grp (Public Schema) from params ('NotNull Complex)
157+-- >>> printSQL $ i & field #complex #imaginary
158+-- (ROW(0, 1)::"complex")."imaginary"
159+field
160+ :: ( Has sch schemas schema
161+ , Has tydef schema ('Typedef ('PGcomposite row))
162+ , Has field row ty)
163+ => QualifiedAlias sch tydef -- ^ row type
164+ -> Alias field -- ^ field name
165+ -> Expression outer commons grp schemas params from ('NotNull ('PGcomposite row))
166+ -> Expression outer commons grp schemas params from ty
167+field td fld expr = UnsafeExpression $
168+ parenthesized (renderSQL expr <> "::" <> renderSQL td)
169+ <> "." <> renderSQL fld
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Comparison.hsnew file+206
@@ -0,0 +1,206 @@
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+
11+{-# LANGUAGE
12+ OverloadedStrings
13+ , RankNTypes
14+ , TypeInType
15+ , TypeOperators
16+#-}
17+
18+module Squeal.PostgreSQL.Expression.Comparison
19+ ( (.==)
20+ , (./=)
21+ , (.>=)
22+ , (.<)
23+ , (.<=)
24+ , (.>)
25+ , greatest
26+ , least
27+ , BetweenExpr
28+ , between
29+ , notBetween
30+ , betweenSymmetric
31+ , notBetweenSymmetric
32+ , isDistinctFrom
33+ , isNotDistinctFrom
34+ , isTrue
35+ , isNotTrue
36+ , isFalse
37+ , isNotFalse
38+ , isUnknown
39+ , isNotUnknown
40+ ) where
41+
42+import Data.ByteString
43+
44+import Squeal.PostgreSQL.Expression
45+import Squeal.PostgreSQL.Expression.Logic
46+import Squeal.PostgreSQL.Render
47+import Squeal.PostgreSQL.Schema
48+
49+-- $setup
50+-- >>> import Squeal.PostgreSQL
51+
52+-- | Comparison operations like `.==`, `./=`, `.>`, `.>=`, `.<` and `.<=`
53+-- will produce @NULL@s if one of their arguments is @NULL@.
54+--
55+-- >>> printSQL $ true .== null_
56+-- (TRUE = NULL)
57+(.==) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
58+(.==) = unsafeBinaryOp "="
59+infix 4 .==
60+
61+-- | >>> printSQL $ true ./= null_
62+-- (TRUE <> NULL)
63+(./=) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
64+(./=) = unsafeBinaryOp "<>"
65+infix 4 ./=
66+
67+-- | >>> printSQL $ true .>= null_
68+-- (TRUE >= NULL)
69+(.>=) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
70+(.>=) = unsafeBinaryOp ">="
71+infix 4 .>=
72+
73+-- | >>> printSQL $ true .< null_
74+-- (TRUE < NULL)
75+(.<) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
76+(.<) = unsafeBinaryOp "<"
77+infix 4 .<
78+
79+-- | >>> printSQL $ true .<= null_
80+-- (TRUE <= NULL)
81+(.<=) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
82+(.<=) = unsafeBinaryOp "<="
83+infix 4 .<=
84+
85+-- | >>> printSQL $ true .> null_
86+-- (TRUE > NULL)
87+(.>) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
88+(.>) = unsafeBinaryOp ">"
89+infix 4 .>
90+
91+-- | >>> let expr = greatest [param @1] currentTimestamp :: Expression outer commons grp schemas '[ 'NotNull 'PGtimestamptz] from ('NotNull 'PGtimestamptz)
92+-- >>> printSQL expr
93+-- GREATEST(($1 :: timestamp with time zone), CURRENT_TIMESTAMP)
94+greatest :: FunctionVar ty ty ty
95+greatest = unsafeFunctionVar "GREATEST"
96+
97+-- | >>> printSQL $ least [null_] currentTimestamp
98+-- LEAST(NULL, CURRENT_TIMESTAMP)
99+least :: FunctionVar ty ty ty
100+least = unsafeFunctionVar "LEAST"
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+
116+{- | >>> printSQL $ true `between` (null_, false)
117+TRUE BETWEEN NULL AND FALSE
118+-}
119+between :: BetweenExpr
120+between = unsafeBetweenExpr "BETWEEN"
121+
122+{- | >>> printSQL $ true `notBetween` (null_, false)
123+TRUE NOT BETWEEN NULL AND FALSE
124+-}
125+notBetween :: BetweenExpr
126+notBetween = unsafeBetweenExpr "NOT BETWEEN"
127+
128+{- | between, after sorting the comparison values
129+
130+>>> printSQL $ true `betweenSymmetric` (null_, false)
131+TRUE BETWEEN SYMMETRIC NULL AND FALSE
132+-}
133+betweenSymmetric :: BetweenExpr
134+betweenSymmetric = unsafeBetweenExpr "BETWEEN SYMMETRIC"
135+
136+{- | not between, after sorting the comparison values
137+
138+>>> printSQL $ true `notBetweenSymmetric` (null_, false)
139+TRUE NOT BETWEEN SYMMETRIC NULL AND FALSE
140+-}
141+notBetweenSymmetric :: BetweenExpr
142+notBetweenSymmetric = unsafeBetweenExpr "NOT BETWEEN SYMMETRIC"
143+
144+{- | not equal, treating null like an ordinary value
145+
146+>>> printSQL $ true `isDistinctFrom` null_
147+(TRUE IS DISTINCT FROM NULL)
148+-}
149+isDistinctFrom :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
150+isDistinctFrom = unsafeBinaryOp "IS DISTINCT FROM"
151+
152+{- | equal, treating null like an ordinary value
153+
154+>>> printSQL $ true `isNotDistinctFrom` null_
155+(TRUE IS NOT DISTINCT FROM NULL)
156+-}
157+isNotDistinctFrom :: Operator (null0 ty) (null1 ty) ('NotNull 'PGbool)
158+isNotDistinctFrom = unsafeBinaryOp "IS NOT DISTINCT FROM"
159+
160+{- | is true
161+
162+>>> printSQL $ true & isTrue
163+(TRUE IS TRUE)
164+-}
165+isTrue :: null0 'PGbool --> null1 'PGbool
166+isTrue = unsafeRightOp "IS TRUE"
167+
168+{- | is false or unknown
169+
170+>>> printSQL $ true & isNotTrue
171+(TRUE IS NOT TRUE)
172+-}
173+isNotTrue :: null0 'PGbool --> null1 'PGbool
174+isNotTrue = unsafeRightOp "IS NOT TRUE"
175+
176+{- | is false
177+
178+>>> printSQL $ true & isFalse
179+(TRUE IS FALSE)
180+-}
181+isFalse :: null0 'PGbool --> null1 'PGbool
182+isFalse = unsafeRightOp "IS FALSE"
183+
184+{- | is true or unknown
185+
186+>>> printSQL $ true & isNotFalse
187+(TRUE IS NOT FALSE)
188+-}
189+isNotFalse :: null0 'PGbool --> null1 'PGbool
190+isNotFalse = unsafeRightOp "IS NOT FALSE"
191+
192+{- | is unknown
193+
194+>>> printSQL $ true & isUnknown
195+(TRUE IS UNKNOWN)
196+-}
197+isUnknown :: null0 'PGbool --> null1 'PGbool
198+isUnknown = unsafeRightOp "IS UNKNOWN"
199+
200+{- | is true or false
201+
202+>>> printSQL $ true & isNotUnknown
203+(TRUE IS NOT UNKNOWN)
204+-}
205+isNotUnknown :: null0 'PGbool --> null1 'PGbool
206+isNotUnknown = unsafeRightOp "IS NOT UNKNOWN"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Json.hsnew file+462
@@ -0,0 +1,462 @@
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+
11+{-# LANGUAGE
12+ DataKinds
13+ , FlexibleContexts
14+ , FlexibleInstances
15+ , GADTs
16+ , OverloadedLabels
17+ , OverloadedStrings
18+ , PolyKinds
19+ , RankNTypes
20+ , ScopedTypeVariables
21+ , TypeApplications
22+ , TypeOperators
23+ , UndecidableInstances
24+ , UndecidableSuperClasses
25+#-}
26+
27+module Squeal.PostgreSQL.Expression.Json
28+ ( -- * Json and Jsonb operators
29+ (.->)
30+ , (.->>)
31+ , (.#>)
32+ , (.#>>)
33+ -- * Jsonb operators
34+ , (.?)
35+ , (.?|)
36+ , (.?&)
37+ , (.-.)
38+ , (#-.)
39+ -- * Json and Jsonb functions
40+ , toJson
41+ , toJsonb
42+ , arrayToJson
43+ , rowToJson
44+ , jsonBuildArray
45+ , jsonbBuildArray
46+ , JsonBuildObject (..)
47+ , jsonObject
48+ , jsonbObject
49+ , jsonZipObject
50+ , jsonbZipObject
51+ , jsonArrayLength
52+ , jsonbArrayLength
53+ , jsonTypeof
54+ , jsonbTypeof
55+ , jsonStripNulls
56+ , jsonbStripNulls
57+ , jsonbSet
58+ , jsonbInsert
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
77+ ) where
78+
79+import Data.ByteString (ByteString)
80+import GHC.TypeLits
81+
82+import Squeal.PostgreSQL.Alias
83+import Squeal.PostgreSQL.Expression
84+import Squeal.PostgreSQL.Expression.Set
85+import Squeal.PostgreSQL.Expression.Type
86+import Squeal.PostgreSQL.List
87+import Squeal.PostgreSQL.Query
88+import Squeal.PostgreSQL.Render
89+import Squeal.PostgreSQL.Schema
90+
91+import qualified Generics.SOP as SOP
92+
93+-- $setup
94+-- >>> import Squeal.PostgreSQL
95+-- >>> import Data.Aeson
96+
97+{-----------------------------------------
98+ -- json and jsonb support
99+
100+See https://www.postgresql.org/docs/10/static/functions-json.html -- most
101+comments lifted directly from this page.
102+
103+Table 9.44: json and jsonb operators
104+-----------------------------------------}
105+
106+-- | Get JSON value (object field or array element) at a key.
107+(.->)
108+ :: (json `In` PGJsonType, key `In` PGJsonKey)
109+ => Operator (null json) (null key) ('Null json)
110+infixl 8 .->
111+(.->) = unsafeBinaryOp "->"
112+
113+-- | Get JSON value (object field or array element) at a key, as text.
114+(.->>)
115+ :: (json `In` PGJsonType, key `In` PGJsonKey)
116+ => Operator (null json) (null key) ('Null 'PGtext)
117+infixl 8 .->>
118+(.->>) = unsafeBinaryOp "->>"
119+
120+-- | Get JSON value at a specified path.
121+(.#>)
122+ :: json `In` PGJsonType
123+ => Operator (null json) (null ('PGvararray ('NotNull 'PGtext))) ('Null json)
124+infixl 8 .#>
125+(.#>) = unsafeBinaryOp "#>"
126+
127+-- | Get JSON value at a specified path as text.
128+(.#>>)
129+ :: json `In` PGJsonType
130+ => Operator (null json) (null ('PGvararray ('NotNull 'PGtext))) ('Null 'PGtext)
131+infixl 8 .#>>
132+(.#>>) = unsafeBinaryOp "#>>"
133+
134+-- Additional jsonb operators
135+
136+-- | Does the string exist as a top-level key within the JSON value?
137+(.?) :: Operator (null 'PGjsonb) (null 'PGtext) ('Null 'PGbool)
138+infixl 9 .?
139+(.?) = unsafeBinaryOp "?"
140+
141+-- | Do any of these array strings exist as top-level keys?
142+(.?|) :: Operator
143+ (null 'PGjsonb)
144+ (null ('PGvararray ('NotNull 'PGtext)))
145+ ('Null 'PGbool)
146+infixl 9 .?|
147+(.?|) = unsafeBinaryOp "?|"
148+
149+-- | Do all of these array strings exist as top-level keys?
150+(.?&) :: Operator
151+ (null 'PGjsonb)
152+ (null ('PGvararray ('NotNull 'PGtext)))
153+ ('Null 'PGbool)
154+infixl 9 .?&
155+(.?&) = unsafeBinaryOp "?&"
156+
157+-- | Delete a key or keys from a JSON object, or remove an array element.
158+--
159+-- If the right operand is
160+--
161+-- @ text @: Delete key / value pair or string element from left operand.
162+-- Key / value pairs are matched based on their key value,
163+--
164+-- @ text[] @: Delete multiple key / value pairs or string elements
165+-- from left operand. Key / value pairs are matched based on their key value,
166+--
167+-- @ integer @: Delete the array element with specified index (Negative integers
168+-- count from the end). Throws an error if top level container is not an array.
169+(.-.)
170+ :: key `In` '[ 'PGtext, 'PGvararray ('NotNull 'PGtext), 'PGint4, 'PGint2 ]
171+ => Operator (null 'PGjsonb) (null key) (null 'PGjsonb)
172+infixl 6 .-.
173+(.-.) = unsafeBinaryOp "-"
174+
175+-- | Delete the field or element with specified path (for JSON arrays, negative
176+-- integers count from the end)
177+(#-.) :: Operator (null 'PGjsonb) (null ('PGvararray ('NotNull 'PGtext))) (null 'PGjsonb)
178+infixl 6 #-.
179+(#-.) = unsafeBinaryOp "#-"
180+
181+{-----------------------------------------
182+Table 9.45: JSON creation functions
183+-----------------------------------------}
184+
185+-- | Returns the value as json. Arrays and composites are converted
186+-- (recursively) to arrays and objects; otherwise, if there is a cast from the
187+-- type to json, the cast function will be used to perform the conversion;
188+-- otherwise, a scalar value is produced. For any scalar type other than a
189+-- number, a Boolean, or a null value, the text representation will be used, in
190+-- such a fashion that it is a valid json value.
191+toJson :: null ty --> null 'PGjson
192+toJson = unsafeFunction "to_json"
193+
194+-- | Returns the value as jsonb. Arrays and composites are converted
195+-- (recursively) to arrays and objects; otherwise, if there is a cast from the
196+-- type to json, the cast function will be used to perform the conversion;
197+-- otherwise, a scalar value is produced. For any scalar type other than a
198+-- number, a Boolean, or a null value, the text representation will be used, in
199+-- such a fashion that it is a valid jsonb value.
200+toJsonb :: null ty --> null 'PGjsonb
201+toJsonb = unsafeFunction "to_jsonb"
202+
203+-- | Returns the array as a JSON array. A PostgreSQL multidimensional array
204+-- becomes a JSON array of arrays.
205+arrayToJson :: null ('PGvararray ty) --> null 'PGjson
206+arrayToJson = unsafeFunction "array_to_json"
207+
208+-- | Returns the row as a JSON object.
209+rowToJson :: null ('PGcomposite ty) --> null 'PGjson
210+rowToJson = unsafeFunction "row_to_json"
211+
212+-- | Builds a possibly-heterogeneously-typed JSON array out of a variadic
213+-- argument list.
214+jsonBuildArray :: SOP.SListI tuple => tuple ---> null 'PGjson
215+jsonBuildArray = unsafeFunctionN "json_build_array"
216+
217+-- | Builds a possibly-heterogeneously-typed (binary) JSON array out of a
218+-- variadic argument list.
219+jsonbBuildArray :: SOP.SListI tuple => tuple ---> null 'PGjsonb
220+jsonbBuildArray = unsafeFunctionN "jsonb_build_array"
221+
222+-- | Builds a possibly-heterogeneously-typed JSON object out of a variadic
223+-- argument list. The elements of the argument list must alternate between text
224+-- and values.
225+class SOP.SListI tys => JsonBuildObject tys where
226+
227+ jsonBuildObject :: tys ---> null 'PGjson
228+ jsonBuildObject = unsafeFunctionN "json_build_object"
229+
230+ jsonbBuildObject :: tys ---> null 'PGjsonb
231+ jsonbBuildObject = unsafeFunctionN "jsonb_build_object"
232+
233+instance JsonBuildObject '[]
234+instance (JsonBuildObject tys, key `In` PGJsonKey)
235+ => JsonBuildObject ('NotNull key ': value ': tys)
236+
237+-- | Builds a JSON object out of a text array.
238+-- The array must have two dimensions
239+-- such that each inner array has exactly two elements,
240+-- which are taken as a key/value pair.
241+jsonObject
242+ :: null ('PGfixarray '[n,2] ('NotNull 'PGtext))
243+ --> null 'PGjson
244+jsonObject = unsafeFunction "json_object"
245+
246+-- | Builds a binary JSON object out of a text array.
247+-- The array must have two dimensions
248+-- such that each inner array has exactly two elements,
249+-- which are taken as a key/value pair.
250+jsonbObject
251+ :: null ('PGfixarray '[n,2] ('NotNull 'PGtext))
252+ --> null 'PGjsonb
253+jsonbObject = unsafeFunction "jsonb_object"
254+
255+-- | This is an alternate form of 'jsonObject' that takes two arrays; one for
256+-- keys and one for values, that are zipped pairwise to create a JSON object.
257+jsonZipObject ::
258+ '[ null ('PGvararray ('NotNull 'PGtext))
259+ , null ('PGvararray ('NotNull 'PGtext)) ]
260+ ---> null 'PGjson
261+jsonZipObject = unsafeFunctionN "json_object"
262+
263+-- | This is an alternate form of 'jsonbObject' that takes two arrays; one for
264+-- keys and one for values, that are zipped pairwise to create a binary JSON
265+-- object.
266+jsonbZipObject ::
267+ '[ null ('PGvararray ('NotNull 'PGtext))
268+ , null ('PGvararray ('NotNull 'PGtext)) ]
269+ ---> null 'PGjsonb
270+jsonbZipObject = unsafeFunctionN "jsonb_object"
271+
272+{-----------------------------------------
273+Table 9.46: JSON processing functions
274+-----------------------------------------}
275+
276+-- | Returns the number of elements in the outermost JSON array.
277+jsonArrayLength :: null 'PGjson --> null 'PGint4
278+jsonArrayLength = unsafeFunction "json_array_length"
279+
280+-- | Returns the number of elements in the outermost binary JSON array.
281+jsonbArrayLength :: null 'PGjsonb --> null 'PGint4
282+jsonbArrayLength = unsafeFunction "jsonb_array_length"
283+
284+-- | Returns the type of the outermost JSON value as a text string. Possible
285+-- types are object, array, string, number, boolean, and null.
286+jsonTypeof :: null 'PGjson --> null 'PGtext
287+jsonTypeof = unsafeFunction "json_typeof"
288+
289+-- | Returns the type of the outermost binary JSON value as a text string.
290+-- Possible types are object, array, string, number, boolean, and null.
291+jsonbTypeof :: null 'PGjsonb --> null 'PGtext
292+jsonbTypeof = unsafeFunction "jsonb_typeof"
293+
294+-- | Returns its argument with all object fields that have null values omitted.
295+-- Other null values are untouched.
296+jsonStripNulls :: null 'PGjson --> null 'PGjson
297+jsonStripNulls = unsafeFunction "json_strip_nulls"
298+
299+-- | Returns its argument with all object fields that have null values omitted.
300+-- Other null values are untouched.
301+jsonbStripNulls :: null 'PGjsonb --> null 'PGjsonb
302+jsonbStripNulls = unsafeFunction "jsonb_strip_nulls"
303+
304+-- | @ jsonbSet target path new_value create_missing @
305+--
306+-- Returns target with the section designated by path replaced by @new_value@,
307+-- or with @new_value@ added if create_missing is
308+-- `Squeal.PostgreSQL.Expression.Logic.true` and the
309+-- item designated by path does not exist. As with the path orientated
310+-- operators, negative integers that appear in path count from the end of JSON
311+-- arrays.
312+jsonbSet ::
313+ '[ null 'PGjsonb, null ('PGvararray ('NotNull 'PGtext))
314+ , null 'PGjsonb, null 'PGbool ] ---> null 'PGjsonb
315+jsonbSet = unsafeFunctionN "jsonbSet"
316+
317+-- | @ jsonbInsert target path new_value insert_after @
318+--
319+-- Returns target with @new_value@ inserted. If target section designated by
320+-- path is in a JSONB array, @new_value@ will be inserted before target or after
321+-- if @insert_after@ is `Squeal.PostgreSQL.Expression.Logic.true`.
322+-- If target section designated by
323+-- path is in JSONB object, @new_value@ will be inserted only if target does not
324+-- exist. As with the path orientated operators, negative integers that appear
325+-- in path count from the end of JSON arrays.
326+jsonbInsert ::
327+ '[ null 'PGjsonb, null ('PGvararray ('NotNull 'PGtext))
328+ , null 'PGjsonb, null 'PGbool ] ---> null 'PGjsonb
329+jsonbInsert = unsafeFunctionN "jsonb_insert"
330+
331+-- | Returns its argument as indented JSON text.
332+jsonbPretty :: null 'PGjsonb --> null 'PGtext
333+jsonbPretty = 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.hsnew file+105
@@ -0,0 +1,105 @@
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+
11+{-# LANGUAGE
12+ DataKinds
13+ , OverloadedStrings
14+ , TypeOperators
15+#-}
16+
17+module Squeal.PostgreSQL.Expression.Logic
18+ ( Condition
19+ , true
20+ , false
21+ , not_
22+ , (.&&)
23+ , (.||)
24+ , caseWhenThenElse
25+ , ifThenElse
26+ ) where
27+
28+import Squeal.PostgreSQL.Expression
29+import Squeal.PostgreSQL.Render
30+import Squeal.PostgreSQL.Schema
31+
32+-- | A `Condition` is an `Expression`, which can evaluate
33+-- to `true`, `false` or `Squeal.PostgreSQL.Null.null_`. This is because SQL uses
34+-- a three valued logic.
35+type Condition outer commons grp schemas params from =
36+ Expression outer commons grp schemas params from ('Null 'PGbool)
37+
38+-- | >>> printSQL true
39+-- TRUE
40+true :: Expr (null 'PGbool)
41+true = UnsafeExpression "TRUE"
42+
43+-- | >>> printSQL false
44+-- FALSE
45+false :: Expr (null 'PGbool)
46+false = UnsafeExpression "FALSE"
47+
48+-- | >>> printSQL $ not_ true
49+-- (NOT TRUE)
50+not_ :: null 'PGbool --> null 'PGbool
51+not_ = unsafeLeftOp "NOT"
52+
53+-- | >>> printSQL $ true .&& false
54+-- (TRUE AND FALSE)
55+(.&&) :: Operator (null 'PGbool) (null 'PGbool) (null 'PGbool)
56+infixr 3 .&&
57+(.&&) = unsafeBinaryOp "AND"
58+
59+-- | >>> printSQL $ true .|| false
60+-- (TRUE OR FALSE)
61+(.||) :: Operator (null 'PGbool) (null 'PGbool) (null 'PGbool)
62+infixr 2 .||
63+(.||) = unsafeBinaryOp "OR"
64+
65+-- | >>> :{
66+-- let
67+-- expression :: Expression outer commons grp schemas params from (null 'PGint2)
68+-- expression = caseWhenThenElse [(true, 1), (false, 2)] 3
69+-- in printSQL expression
70+-- :}
71+-- CASE WHEN TRUE THEN 1 WHEN FALSE THEN 2 ELSE 3 END
72+caseWhenThenElse
73+ :: [ ( Condition outer commons grp schemas params from
74+ , Expression outer commons grp schemas params from ty
75+ ) ]
76+ -- ^ whens and thens
77+ -> Expression outer commons grp schemas params from ty
78+ -- ^ else
79+ -> Expression outer commons grp schemas params from ty
80+caseWhenThenElse whenThens else_ = UnsafeExpression $ mconcat
81+ [ "CASE"
82+ , mconcat
83+ [ mconcat
84+ [ " WHEN ", renderSQL when_
85+ , " THEN ", renderSQL then_
86+ ]
87+ | (when_,then_) <- whenThens
88+ ]
89+ , " ELSE ", renderSQL else_
90+ , " END"
91+ ]
92+
93+-- | >>> :{
94+-- let
95+-- expression :: Expression outer commons grp schemas params from (null 'PGint2)
96+-- expression = ifThenElse true 1 0
97+-- in printSQL expression
98+-- :}
99+-- CASE WHEN TRUE THEN 1 ELSE 0 END
100+ifThenElse
101+ :: Condition outer commons grp schemas params from
102+ -> Expression outer commons grp schemas params from ty -- ^ then
103+ -> Expression outer commons grp schemas params from ty -- ^ else
104+ -> Expression outer commons grp schemas params from ty
105+ifThenElse if_ then_ else_ = caseWhenThenElse [(if_,then_)] else_
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Math.hsnew file+100
@@ -0,0 +1,100 @@
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+
11+{-# LANGUAGE
12+ DataKinds
13+ , OverloadedStrings
14+ , TypeOperators
15+#-}
16+
17+module Squeal.PostgreSQL.Expression.Math
18+ ( atan2_
19+ , quot_
20+ , rem_
21+ , trunc
22+ , round_
23+ , ceiling_
24+ ) where
25+
26+import Squeal.PostgreSQL.Expression
27+import Squeal.PostgreSQL.List
28+import Squeal.PostgreSQL.Schema
29+
30+-- $setup
31+-- >>> import Squeal.PostgreSQL
32+
33+-- | >>> :{
34+-- let
35+-- expression :: Expr (null 'PGfloat4)
36+-- expression = atan2_ (pi *: 2)
37+-- in printSQL expression
38+-- :}
39+-- atan2(pi(), 2)
40+atan2_ :: float `In` PGFloating => '[ null float, null float] ---> null float
41+atan2_ = unsafeFunctionN "atan2"
42+
43+
44+-- | integer division, truncates the result
45+--
46+-- >>> :{
47+-- let
48+-- expression :: Expression outer commons grp schemas params from (null 'PGint2)
49+-- expression = 5 `quot_` 2
50+-- in printSQL expression
51+-- :}
52+-- (5 / 2)
53+quot_
54+ :: int `In` PGIntegral
55+ => Operator (null int) (null int) (null int)
56+quot_ = unsafeBinaryOp "/"
57+
58+-- | remainder upon integer division
59+--
60+-- >>> :{
61+-- let
62+-- expression :: Expression outer commons grp schemas params from (null 'PGint2)
63+-- expression = 5 `rem_` 2
64+-- in printSQL expression
65+-- :}
66+-- (5 % 2)
67+rem_
68+ :: int `In` PGIntegral
69+ => Operator (null int) (null int) (null int)
70+rem_ = unsafeBinaryOp "%"
71+
72+-- | >>> :{
73+-- let
74+-- expression :: Expression outer commons grp schemas params from (null 'PGfloat4)
75+-- expression = trunc pi
76+-- in printSQL expression
77+-- :}
78+-- trunc(pi())
79+trunc :: frac `In` PGFloating => null frac --> null frac
80+trunc = unsafeFunction "trunc"
81+
82+-- | >>> :{
83+-- let
84+-- expression :: Expression outer commons grp schemas params from (null 'PGfloat4)
85+-- expression = round_ pi
86+-- in printSQL expression
87+-- :}
88+-- round(pi())
89+round_ :: frac `In` PGFloating => null frac --> null frac
90+round_ = unsafeFunction "round"
91+
92+-- | >>> :{
93+-- let
94+-- expression :: Expression outer commons grp schemas params from (null 'PGfloat4)
95+-- expression = ceiling_ pi
96+-- in printSQL expression
97+-- :}
98+-- ceiling(pi())
99+ceiling_ :: frac `In` PGFloating => null frac --> null frac
100+ceiling_ = unsafeFunction "ceiling"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Null.hsnew file+104
@@ -0,0 +1,104 @@
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+
11+{-# LANGUAGE
12+ DataKinds
13+ , OverloadedStrings
14+ , TypeOperators
15+#-}
16+
17+module Squeal.PostgreSQL.Expression.Null
18+ ( null_
19+ , notNull
20+ , coalesce
21+ , fromNull
22+ , isNull
23+ , isNotNull
24+ , matchNull
25+ , nullIf
26+ ) where
27+
28+import Squeal.PostgreSQL.Expression
29+import Squeal.PostgreSQL.Expression.Logic
30+import Squeal.PostgreSQL.Render
31+import Squeal.PostgreSQL.Schema
32+
33+-- $setup
34+-- >>> import Squeal.PostgreSQL
35+
36+-- | analagous to `Nothing`
37+--
38+-- >>> printSQL null_
39+-- NULL
40+null_ :: Expr ('Null ty)
41+null_ = UnsafeExpression "NULL"
42+
43+-- | analagous to `Just`
44+--
45+-- >>> printSQL $ notNull true
46+-- TRUE
47+notNull :: 'NotNull ty --> 'Null ty
48+notNull = UnsafeExpression . renderSQL
49+
50+-- | return the leftmost value which is not NULL
51+--
52+-- >>> printSQL $ coalesce [null_, true] false
53+-- COALESCE(NULL, TRUE, FALSE)
54+coalesce :: FunctionVar ('Null ty) ('NotNull ty) ('NotNull ty)
55+coalesce nullxs notNullx = UnsafeExpression $
56+ "COALESCE" <> parenthesized (commaSeparated
57+ ((renderSQL <$> nullxs) <> [renderSQL notNullx]))
58+
59+-- | analagous to `Data.Maybe.fromMaybe` using @COALESCE@
60+--
61+-- >>> printSQL $ fromNull true null_
62+-- COALESCE(NULL, TRUE)
63+fromNull
64+ :: Expression outer commons grp schemas params from ('NotNull ty)
65+ -- ^ what to convert @NULL@ to
66+ -> Expression outer commons grp schemas params from ('Null ty)
67+ -> Expression outer commons grp schemas params from ('NotNull ty)
68+fromNull notNullx nullx = coalesce [nullx] notNullx
69+
70+-- | >>> printSQL $ null_ & isNull
71+-- NULL IS NULL
72+isNull :: 'Null ty --> null 'PGbool
73+isNull x = UnsafeExpression $ renderSQL x <+> "IS NULL"
74+
75+-- | >>> printSQL $ null_ & isNotNull
76+-- NULL IS NOT NULL
77+isNotNull :: 'Null ty --> null 'PGbool
78+isNotNull x = UnsafeExpression $ renderSQL x <+> "IS NOT NULL"
79+
80+-- | analagous to `maybe` using @IS NULL@
81+--
82+-- >>> printSQL $ matchNull true not_ null_
83+-- CASE WHEN NULL IS NULL THEN TRUE ELSE (NOT NULL) END
84+matchNull
85+ :: Expression outer commons grp schemas params from (nullty)
86+ -- ^ what to convert @NULL@ to
87+ -> ( Expression outer commons grp schemas params from ('NotNull ty)
88+ -> Expression outer commons grp schemas params from (nullty) )
89+ -- ^ function to perform when @NULL@ is absent
90+ -> Expression outer commons grp schemas params from ('Null ty)
91+ -> Expression outer commons grp schemas params from (nullty)
92+matchNull y f x = ifThenElse (isNull x) y
93+ (f (UnsafeExpression (renderSQL x)))
94+
95+{-| right inverse to `fromNull`, if its arguments are equal then
96+`nullIf` gives @NULL@.
97+
98+>>> :set -XTypeApplications -XDataKinds
99+>>> let expr = nullIf (false *: param @1) :: Expression outer commons grp schemas '[ 'NotNull 'PGbool] from ('Null 'PGbool)
100+>>> printSQL expr
101+NULLIF(FALSE, ($1 :: bool))
102+-}
103+nullIf :: '[ 'NotNull ty, 'NotNull ty] ---> 'Null ty
104+nullIf = 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.hsnew file+85
@@ -0,0 +1,85 @@
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+
11+{-# LANGUAGE
12+ DataKinds
13+ , GADTs
14+ , LambdaCase
15+ , OverloadedStrings
16+ , StandaloneDeriving
17+#-}
18+
19+module Squeal.PostgreSQL.Expression.Sort
20+ ( SortExpression (..)
21+ , OrderBy (..)
22+ ) where
23+
24+import Squeal.PostgreSQL.Expression
25+import Squeal.PostgreSQL.Render
26+import Squeal.PostgreSQL.Schema
27+
28+-- | `SortExpression`s are used by `orderBy` to optionally sort the results
29+-- of a `Squeal.PostgreSQL.Query.Query`. `Asc` or `Desc`
30+-- set the sort direction of a `NotNull` result
31+-- column to ascending or descending. Ascending order puts smaller values
32+-- first, where "smaller" is defined in terms of the
33+-- `Squeal.PostgreSQL.Expression.Comparison..<` operator. Similarly,
34+-- descending order is determined with the
35+-- `Squeal.PostgreSQL.Expression.Comparison..>` operator. `AscNullsFirst`,
36+-- `AscNullsLast`, `DescNullsFirst` and `DescNullsLast` options are used to
37+-- determine whether nulls appear before or after non-null values in the sort
38+-- ordering of a `Null` result column.
39+data SortExpression outer commons grp schemas params from where
40+ Asc
41+ :: Expression outer commons grp schemas params from ('NotNull ty)
42+ -> SortExpression outer commons grp schemas params from
43+ Desc
44+ :: Expression outer commons grp schemas params from ('NotNull ty)
45+ -> SortExpression outer commons grp schemas params from
46+ AscNullsFirst
47+ :: Expression outer commons grp schemas params from ('Null ty)
48+ -> SortExpression outer commons grp schemas params from
49+ AscNullsLast
50+ :: Expression outer commons grp schemas params from ('Null ty)
51+ -> SortExpression outer commons grp schemas params from
52+ DescNullsFirst
53+ :: Expression outer commons grp schemas params from ('Null ty)
54+ -> SortExpression outer commons grp schemas params from
55+ DescNullsLast
56+ :: Expression outer commons grp schemas params from ('Null ty)
57+ -> SortExpression outer commons grp schemas params from
58+deriving 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"
69+
70+{- |
71+The `orderBy` clause causes the result rows of a `Squeal.PostgreSQL.Query.TableExpression`
72+to be sorted according to the specified `SortExpression`(s).
73+If two rows are equal according to the leftmost expression,
74+they are compared according to the next expression and so on.
75+If they are equal according to all specified expressions,
76+they are returned in an implementation-dependent order.
77+
78+You can also control the order in which rows are processed by window functions
79+using `orderBy` within `Squeal.PostgreSQL.Query.Over`.
80+-}
81+class OrderBy expr where
82+ orderBy
83+ :: [SortExpression outer commons grp schemas params from]
84+ -> expr outer commons grp schemas params from
85+ -> expr outer commons grp schemas params from
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.hsnew file+64
@@ -0,0 +1,64 @@
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+
11+{-# LANGUAGE
12+ DataKinds
13+ , OverloadedStrings
14+ , TypeOperators
15+#-}
16+
17+module Squeal.PostgreSQL.Expression.Text
18+ ( lower
19+ , upper
20+ , charLength
21+ , like
22+ , ilike
23+ ) where
24+
25+import Squeal.PostgreSQL.Expression
26+import Squeal.PostgreSQL.Schema
27+
28+-- $setup
29+-- >>> import Squeal.PostgreSQL
30+
31+-- | >>> printSQL $ lower "ARRRGGG"
32+-- lower(E'ARRRGGG')
33+lower :: null 'PGtext --> null 'PGtext
34+lower = unsafeFunction "lower"
35+
36+-- | >>> printSQL $ upper "eeee"
37+-- upper(E'eeee')
38+upper :: null 'PGtext --> null 'PGtext
39+upper = unsafeFunction "upper"
40+
41+-- | >>> printSQL $ charLength "four"
42+-- char_length(E'four')
43+charLength :: null 'PGtext --> null 'PGint4
44+charLength = unsafeFunction "char_length"
45+
46+-- | The `like` expression returns true if the @string@ matches
47+-- the supplied @pattern@. If @pattern@ does not contain percent signs
48+-- or underscores, then the pattern only represents the string itself;
49+-- in that case `like` acts like the equals operator. An underscore (_)
50+-- in pattern stands for (matches) any single character; a percent sign (%)
51+-- matches any sequence of zero or more characters.
52+--
53+-- >>> printSQL $ "abc" `like` "a%"
54+-- (E'abc' LIKE E'a%')
55+like :: Operator (null 'PGtext) (null 'PGtext) ('Null 'PGbool)
56+like = unsafeBinaryOp "LIKE"
57+
58+-- | The key word ILIKE can be used instead of LIKE to make the
59+-- match case-insensitive according to the active locale.
60+--
61+-- >>> printSQL $ "abc" `ilike` "a%"
62+-- (E'abc' ILIKE E'a%')
63+ilike :: Operator (null 'PGtext) (null 'PGtext) ('Null 'PGbool)
64+ilike = unsafeBinaryOp "ILIKE"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/TextSearch.hsnew file+157
@@ -0,0 +1,157 @@
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+
11+{-# LANGUAGE
12+ DataKinds
13+ , OverloadedStrings
14+ , TypeOperators
15+#-}
16+
17+module Squeal.PostgreSQL.Expression.TextSearch
18+ ( (@@)
19+ , (.&)
20+ , (.|)
21+ , (.!)
22+ , (<->)
23+ , arrayToTSvector
24+ , tsvectorLength
25+ , numnode
26+ , plainToTSquery
27+ , phraseToTSquery
28+ , websearchToTSquery
29+ , queryTree
30+ , toTSquery
31+ , toTSvector
32+ , setWeight
33+ , strip
34+ , jsonToTSvector
35+ , jsonbToTSvector
36+ , tsDelete
37+ , tsFilter
38+ , tsHeadline
39+ ) where
40+
41+import Squeal.PostgreSQL.Expression
42+import Squeal.PostgreSQL.List
43+import Squeal.PostgreSQL.Schema
44+
45+-- | `Squeal.PostgreSQL.Expression.Type.tsvector` matches tsquery ?
46+(@@) :: Operator (null 'PGtsvector) (null 'PGtsquery) ('Null 'PGbool)
47+(@@) = unsafeBinaryOp "@@"
48+
49+-- | AND `Squeal.PostgreSQL.Expression.Type.tsquery`s together
50+(.&) :: Operator (null 'PGtsquery) (null 'PGtsquery) (null 'PGtsquery)
51+(.&) = unsafeBinaryOp "&&"
52+
53+-- | OR `Squeal.PostgreSQL.Expression.Type.tsquery`s together
54+(.|) :: Operator (null 'PGtsquery) (null 'PGtsquery) (null 'PGtsquery)
55+(.|) = unsafeBinaryOp "||"
56+
57+-- | negate a `Squeal.PostgreSQL.Expression.Type.tsquery`
58+(.!) :: null 'PGtsquery --> null 'PGtsquery
59+(.!) = unsafeLeftOp "!!"
60+
61+-- | `Squeal.PostgreSQL.Expression.Type.tsquery` followed by
62+-- `Squeal.PostgreSQL.Expression.Type.tsquery`
63+(<->) :: Operator (null 'PGtsquery) (null 'PGtsquery) (null 'PGtsquery)
64+(<->) = unsafeBinaryOp "<->"
65+
66+-- | convert array of lexemes to `Squeal.PostgreSQL.Expression.Type.tsvector`
67+arrayToTSvector
68+ :: null ('PGvararray ('NotNull 'PGtext))
69+ --> null 'PGtsvector
70+arrayToTSvector = unsafeFunction "array_to_tsvector"
71+
72+-- | number of lexemes in `Squeal.PostgreSQL.Expression.Type.tsvector`
73+tsvectorLength :: null 'PGtsvector --> null 'PGint4
74+tsvectorLength = unsafeFunction "length"
75+
76+-- | number of lexemes plus operators in `Squeal.PostgreSQL.Expression.Type.tsquery`
77+numnode :: null 'PGtsquery --> null 'PGint4
78+numnode = unsafeFunction "numnode"
79+
80+-- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` ignoring punctuation
81+plainToTSquery :: null 'PGtext --> null 'PGtsquery
82+plainToTSquery = unsafeFunction "plainto_tsquery"
83+
84+-- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` that searches for a phrase,
85+-- ignoring punctuation
86+phraseToTSquery :: null 'PGtext --> null 'PGtsquery
87+phraseToTSquery = unsafeFunction "phraseto_tsquery"
88+
89+-- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` from a web search style query
90+websearchToTSquery :: null 'PGtext --> null 'PGtsquery
91+websearchToTSquery = unsafeFunction "websearch_to_tsquery"
92+
93+-- | get indexable part of a `Squeal.PostgreSQL.Expression.Type.tsquery`
94+queryTree :: null 'PGtsquery --> null 'PGtext
95+queryTree = unsafeFunction "query_tree"
96+
97+-- | normalize words and convert to `Squeal.PostgreSQL.Expression.Type.tsquery`
98+toTSquery :: null 'PGtext --> null 'PGtsquery
99+toTSquery = unsafeFunction "to_tsquery"
100+
101+-- | reduce document text to `Squeal.PostgreSQL.Expression.Type.tsvector`
102+toTSvector
103+ :: ty `In` '[ 'PGtext, 'PGjson, 'PGjsonb]
104+ => null ty --> null 'PGtsvector
105+toTSvector = unsafeFunction "to_tsvector"
106+
107+-- | assign weight to each element of `Squeal.PostgreSQL.Expression.Type.tsvector`
108+setWeight :: '[null 'PGtsvector, null ('PGchar 1)] ---> null 'PGtsvector
109+setWeight = unsafeFunctionN "set_weight"
110+
111+-- | remove positions and weights from `Squeal.PostgreSQL.Expression.Type.tsvector`
112+strip :: null 'PGtsvector --> null 'PGtsvector
113+strip = unsafeFunction "strip"
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.
125+jsonToTSvector :: '[null 'PGjson, null 'PGjson] ---> null 'PGtsvector
126+jsonToTSvector = unsafeFunctionN "json_to_tsvector"
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.
138+jsonbToTSvector :: '[null 'PGjsonb, null 'PGjsonb] ---> null 'PGtsvector
139+jsonbToTSvector = unsafeFunctionN "jsonb_to_tsvector"
140+
141+-- | remove given lexeme from `Squeal.PostgreSQL.Expression.Type.tsvector`
142+tsDelete ::
143+ '[null 'PGtsvector, null ('PGvararray ('NotNull 'PGtext))]
144+ ---> null 'PGtsvector
145+tsDelete = unsafeFunctionN "ts_delete"
146+
147+-- | select only elements with given weights from `Squeal.PostgreSQL.Expression.Type.tsvector`
148+tsFilter ::
149+ '[null 'PGtsvector, null ('PGvararray ('NotNull ('PGchar 1)))]
150+ ---> null 'PGtsvector
151+tsFilter = unsafeFunctionN "ts_filter"
152+
153+-- | display a `Squeal.PostgreSQL.Expression.Type.tsquery` match
154+tsHeadline
155+ :: document `In` '[ 'PGtext, 'PGjson, 'PGjsonb]
156+ => '[null document, null 'PGtsquery] ---> null 'PGtext
157+tsHeadline = unsafeFunctionN "ts_headline"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Time.hsnew file+192
@@ -0,0 +1,192 @@
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+
11+{-# LANGUAGE
12+ DataKinds
13+ , DeriveGeneric
14+ , FunctionalDependencies
15+ , LambdaCase
16+ , MultiParamTypeClasses
17+ , OverloadedStrings
18+ , PolyKinds
19+ , RankNTypes
20+ , TypeOperators
21+#-}
22+
23+module Squeal.PostgreSQL.Expression.Time
24+ ( TimeOp (..)
25+ , currentDate
26+ , currentTime
27+ , currentTimestamp
28+ , localTime
29+ , localTimestamp
30+ , now
31+ , makeDate
32+ , makeTime
33+ , makeTimestamp
34+ , makeTimestamptz
35+ , interval_
36+ , TimeUnit (..)
37+ ) where
38+
39+import Data.String
40+
41+import qualified GHC.Generics as GHC
42+import qualified Generics.SOP as SOP
43+
44+import Squeal.PostgreSQL.Expression
45+import Squeal.PostgreSQL.Render
46+import Squeal.PostgreSQL.Schema
47+
48+-- $setup
49+-- >>> import Squeal.PostgreSQL
50+
51+-- | >>> printSQL currentDate
52+-- CURRENT_DATE
53+currentDate :: Expr (null 'PGdate)
54+currentDate = UnsafeExpression "CURRENT_DATE"
55+
56+-- | >>> printSQL currentTime
57+-- CURRENT_TIME
58+currentTime :: Expr (null 'PGtimetz)
59+currentTime = UnsafeExpression "CURRENT_TIME"
60+
61+-- | >>> printSQL currentTimestamp
62+-- CURRENT_TIMESTAMP
63+currentTimestamp :: Expr (null 'PGtimestamptz)
64+currentTimestamp = UnsafeExpression "CURRENT_TIMESTAMP"
65+
66+-- | >>> printSQL localTime
67+-- LOCALTIME
68+localTime :: Expr (null 'PGtime)
69+localTime = UnsafeExpression "LOCALTIME"
70+
71+-- | >>> printSQL localTimestamp
72+-- LOCALTIMESTAMP
73+localTimestamp :: Expr (null 'PGtimestamp)
74+localTimestamp = UnsafeExpression "LOCALTIMESTAMP"
75+
76+-- | Current date and time (equivalent to `currentTimestamp`)
77+--
78+-- >>> printSQL now
79+-- now()
80+now :: Expr (null 'PGtimestamptz)
81+now = UnsafeExpression "now()"
82+
83+{-|
84+Create date from year, month and day fields
85+
86+>>> printSQL (makeDate (1984 :* 7 *: 3))
87+make_date(1984, 7, 3)
88+-}
89+makeDate :: '[ null 'PGint4, null 'PGint4, null 'PGint4 ] ---> null 'PGdate
90+makeDate = unsafeFunctionN "make_date"
91+
92+{-|
93+Create time from hour, minute and seconds fields
94+
95+>>> printSQL (makeTime (8 :* 15 *: 23.5))
96+make_time(8, 15, 23.5)
97+-}
98+makeTime :: '[ null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtime
99+makeTime = unsafeFunctionN "make_time"
100+
101+{-|
102+Create timestamp from year, month, day, hour, minute and seconds fields
103+
104+>>> printSQL (makeTimestamp (2013 :* 7 :* 15 :* 8 :* 15 *: 23.5))
105+make_timestamp(2013, 7, 15, 8, 15, 23.5)
106+-}
107+makeTimestamp ::
108+ '[ null 'PGint4, null 'PGint4, null 'PGint4
109+ , null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtimestamp
110+makeTimestamp = unsafeFunctionN "make_timestamp"
111+
112+{-|
113+Create timestamp with time zone from
114+year, month, day, hour, minute and seconds fields;
115+the current time zone is used
116+
117+>>> printSQL (makeTimestamptz (2013 :* 7 :* 15 :* 8 :* 15 *: 23.5))
118+make_timestamptz(2013, 7, 15, 8, 15, 23.5)
119+-}
120+makeTimestamptz ::
121+ '[ null 'PGint4, null 'PGint4, null 'PGint4
122+ , null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtimestamptz
123+makeTimestamptz = unsafeFunctionN "make_timestamptz"
124+
125+{-|
126+Affine space operations on time types.
127+-}
128+class TimeOp time diff | time -> diff where
129+ {-|
130+ >>> printSQL (makeDate (1984 :* 7 *: 3) !+ 365)
131+ (make_date(1984, 7, 3) + 365)
132+ -}
133+ (!+) :: Operator (null time) (null diff) (null time)
134+ (!+) = unsafeBinaryOp "+"
135+ {-|
136+ >>> printSQL (365 +! makeDate (1984 :* 7 *: 3))
137+ (365 + make_date(1984, 7, 3))
138+ -}
139+ (+!) :: Operator (null diff) (null time) (null time)
140+ (+!) = unsafeBinaryOp "+"
141+ {-|
142+ >>> printSQL (makeDate (1984 :* 7 *: 3) !- 365)
143+ (make_date(1984, 7, 3) - 365)
144+ -}
145+ (!-) :: Operator (null time) (null diff) (null time)
146+ (!-) = unsafeBinaryOp "-"
147+ {-|
148+ >>> printSQL (makeDate (1984 :* 7 *: 3) !-! currentDate)
149+ (make_date(1984, 7, 3) - CURRENT_DATE)
150+ -}
151+ (!-!) :: Operator (null time) (null time) (null diff)
152+ (!-!) = unsafeBinaryOp "-"
153+instance TimeOp 'PGtimestamp 'PGinterval
154+instance TimeOp 'PGtimestamptz 'PGinterval
155+instance TimeOp 'PGtime 'PGinterval
156+instance TimeOp 'PGtimetz 'PGinterval
157+instance TimeOp 'PGinterval 'PGinterval
158+instance TimeOp 'PGdate 'PGint4
159+infixl 6 !+
160+infixl 6 +!
161+infixl 6 !-
162+infixl 6 !-!
163+
164+-- | A `TimeUnit` to use in `interval_` construction.
165+data TimeUnit
166+ = Years | Months | Weeks | Days
167+ | Hours | Minutes | Seconds
168+ | Microseconds | Milliseconds
169+ | Decades | Centuries | Millennia
170+ deriving (Eq, Ord, Show, Read, Enum, GHC.Generic)
171+instance SOP.Generic TimeUnit
172+instance SOP.HasDatatypeInfo TimeUnit
173+instance RenderSQL TimeUnit where
174+ renderSQL = \case
175+ Years -> "years"
176+ Months -> "months"
177+ Weeks -> "weeks"
178+ Days -> "days"
179+ Hours -> "hours"
180+ Minutes -> "minutes"
181+ Seconds -> "seconds"
182+ Microseconds -> "microseconds"
183+ Milliseconds -> "milliseconds"
184+ Decades -> "decades"
185+ Centuries -> "centuries"
186+ Millennia -> "millennia"
187+
188+-- | >>> printSQL $ interval_ 7 Days
189+-- (INTERVAL '7.0 days')
190+interval_ :: Double -> TimeUnit -> Expr (null 'PGinterval)
191+interval_ num unit = UnsafeExpression . parenthesized $ "INTERVAL" <+>
192+ "'" <> fromString (show num) <+> renderSQL unit <> "'"
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.hsnew file+284
@@ -0,0 +1,284 @@
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+
11+{-# LANGUAGE
12+ DataKinds
13+ , DeriveGeneric
14+ , FlexibleContexts
15+ , FlexibleInstances
16+ , GADTs
17+ , GeneralizedNewtypeDeriving
18+ , LambdaCase
19+ , MultiParamTypeClasses
20+ , OverloadedStrings
21+ , RankNTypes
22+ , KindSignatures
23+#-}
24+
25+module Squeal.PostgreSQL.Expression.Window
26+ ( -- * functions
27+ partitionBy
28+ , rank
29+ , rowNumber
30+ , denseRank
31+ , percentRank
32+ , cumeDist
33+ , ntile
34+ , lag
35+ , lead
36+ , firstValue
37+ , lastValue
38+ , nthValue
39+ , unsafeWindowFunction1
40+ , unsafeWindowFunctionN
41+ -- * types
42+ , WindowFunction (..)
43+ , WindowDefinition (..)
44+ , WinFun0
45+ , WinFun1
46+ , WinFunN
47+ ) where
48+
49+import Control.DeepSeq
50+import Data.ByteString
51+
52+import qualified GHC.Generics as GHC
53+import qualified Generics.SOP as SOP
54+
55+import Squeal.PostgreSQL.Alias
56+import Squeal.PostgreSQL.Expression
57+import Squeal.PostgreSQL.Expression.Aggregate
58+import Squeal.PostgreSQL.Expression.Sort
59+import Squeal.PostgreSQL.List
60+import Squeal.PostgreSQL.Render
61+import Squeal.PostgreSQL.Schema
62+
63+instance Aggregate
64+ (Expression outer commons grp schemas params from)
65+ (NP (Expression outer commons grp schemas params from))
66+ (WindowFunction outer commons grp schemas params from) where
67+ countStar = UnsafeWindowFunction "count(*)"
68+ count = unsafeWindowFunction1 "count"
69+ sum_ = unsafeWindowFunction1 "sum"
70+ arrayAgg = unsafeWindowFunction1 "array_agg"
71+ jsonAgg = unsafeWindowFunction1 "json_agg"
72+ jsonbAgg = unsafeWindowFunction1 "jsonb_agg"
73+ bitAnd = unsafeWindowFunction1 "bit_and"
74+ bitOr = unsafeWindowFunction1 "bit_or"
75+ boolAnd = unsafeWindowFunction1 "bool_and"
76+ boolOr = unsafeWindowFunction1 "bool_or"
77+ every = unsafeWindowFunction1 "every"
78+ max_ = unsafeWindowFunction1 "max"
79+ min_ = unsafeWindowFunction1 "min"
80+ avg = unsafeWindowFunction1 "avg"
81+ corr = unsafeWindowFunctionN "corr"
82+ covarPop = unsafeWindowFunctionN "covar_pop"
83+ covarSamp = unsafeWindowFunctionN "covar_samp"
84+ regrAvgX = unsafeWindowFunctionN "regr_avgx"
85+ regrAvgY = unsafeWindowFunctionN "regr_avgy"
86+ regrCount = unsafeWindowFunctionN "regr_count"
87+ regrIntercept = unsafeWindowFunctionN "regr_intercept"
88+ regrR2 = unsafeWindowFunctionN "regr_r2"
89+ regrSlope = unsafeWindowFunctionN "regr_slope"
90+ regrSxx = unsafeWindowFunctionN "regr_sxx"
91+ regrSxy = unsafeWindowFunctionN "regr_sxy"
92+ regrSyy = unsafeWindowFunctionN "regr_syy"
93+ stddev = unsafeWindowFunction1 "stddev"
94+ stddevPop = unsafeWindowFunction1 "stddev_pop"
95+ stddevSamp = unsafeWindowFunction1 "stddev_samp"
96+ variance = unsafeWindowFunction1 "variance"
97+ varPop = unsafeWindowFunction1 "var_pop"
98+ varSamp = unsafeWindowFunction1 "var_samp"
99+
100+-- | A `WindowDefinition` is a set of table rows that are somehow related
101+-- to the current row
102+data WindowDefinition outer commons grp schemas params from where
103+ WindowDefinition
104+ :: SOP.SListI bys
105+ => NP (Expression outer commons grp schemas params from) bys
106+ -- ^ `partitionBy` clause
107+ -> [SortExpression outer commons grp schemas params from]
108+ -- ^ `Squeal.PostgreSQL.Expression.Sort.orderBy` clause
109+ -> WindowDefinition outer commons grp schemas params from
110+
111+instance OrderBy WindowDefinition where
112+ orderBy sortsR (WindowDefinition parts sortsL)
113+ = WindowDefinition parts (sortsL ++ sortsR)
114+
115+instance RenderSQL (WindowDefinition outer commons schemas from grp params) where
116+ renderSQL (WindowDefinition part ord) =
117+ renderPartitionByClause part <> renderOrderByClause ord
118+ where
119+ renderPartitionByClause = \case
120+ Nil -> ""
121+ parts -> "PARTITION" <+> "BY" <+> renderCommaSeparated renderExpression parts
122+ renderOrderByClause = \case
123+ [] -> ""
124+ srts -> " ORDER" <+> "BY"
125+ <+> commaSeparated (renderSQL <$> srts)
126+
127+{- |
128+The `partitionBy` clause within `Squeal.PostgreSQL.Query.Over` divides the rows into groups,
129+or partitions, that share the same values of the `partitionBy` `Expression`(s).
130+For each row, the window function is computed across the rows that fall into
131+the same partition as the current row.
132+-}
133+partitionBy
134+ :: SOP.SListI bys
135+ => NP (Expression outer commons grp schemas params from) bys -- ^ partitions
136+ -> WindowDefinition outer commons grp schemas params from
137+partitionBy bys = WindowDefinition bys []
138+
139+{- |
140+A window function performs a calculation across a set of table rows
141+that are somehow related to the current row. This is comparable to the type
142+of calculation that can be done with an aggregate function.
143+However, window functions do not cause rows to become grouped into a single
144+output row like non-window aggregate calls would.
145+Instead, the rows retain their separate identities.
146+Behind the scenes, the window function is able to access more than
147+just the current row of the query result.
148+-}
149+newtype WindowFunction
150+ (outer :: FromType)
151+ (commons :: FromType)
152+ (grp :: Grouping)
153+ (schemas :: SchemasType)
154+ (params :: [NullityType])
155+ (from :: FromType)
156+ (ty :: NullityType)
157+ = UnsafeWindowFunction { renderWindowFunction :: ByteString }
158+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
159+
160+instance RenderSQL (WindowFunction outer commons grp schemas params from ty) where
161+ renderSQL = renderWindowFunction
162+
163+{- |
164+A @RankNType@ for window functions with no arguments.
165+-}
166+type WinFun0 x
167+ = forall outer commons grp schemas params from
168+ . WindowFunction outer commons grp schemas params from x
169+ -- ^ cannot reference aliases
170+
171+{- |
172+A @RankNType@ for window functions with 1 argument.
173+-}
174+type WinFun1 x y
175+ = forall outer commons grp schemas params from
176+ . Expression outer commons grp schemas params from x
177+ -- ^ input
178+ -> WindowFunction outer commons grp schemas params from y
179+ -- ^ output
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+-}
185+type WinFunN xs y
186+ = forall outer commons grp schemas params from
187+ . NP (Expression outer commons grp schemas params from) xs
188+ -- ^ inputs
189+ -> WindowFunction outer commons grp schemas params from y
190+ -- ^ output
191+
192+-- | escape hatch for defining window functions
193+unsafeWindowFunction1 :: ByteString -> WinFun1 x y
194+unsafeWindowFunction1 fun x
195+ = UnsafeWindowFunction $ fun <> parenthesized (renderSQL x)
196+
197+-- | escape hatch for defining multi-argument window functions
198+unsafeWindowFunctionN :: SOP.SListI xs => ByteString -> WinFunN xs y
199+unsafeWindowFunctionN fun xs = UnsafeWindowFunction $ fun <>
200+ parenthesized (renderCommaSeparated renderSQL xs)
201+
202+{- | rank of the current row with gaps; same as `rowNumber` of its first peer
203+
204+>>> printSQL rank
205+rank()
206+-}
207+rank :: WinFun0 ('NotNull 'PGint8)
208+rank = UnsafeWindowFunction "rank()"
209+
210+{- | number of the current row within its partition, counting from 1
211+
212+>>> printSQL rowNumber
213+row_number()
214+-}
215+rowNumber :: WinFun0 ('NotNull 'PGint8)
216+rowNumber = UnsafeWindowFunction "row_number()"
217+
218+{- | rank of the current row without gaps; this function counts peer groups
219+
220+>>> printSQL denseRank
221+dense_rank()
222+-}
223+denseRank :: WinFun0 ('NotNull 'PGint8)
224+denseRank = UnsafeWindowFunction "dense_rank()"
225+
226+{- | relative rank of the current row: (rank - 1) / (total partition rows - 1)
227+
228+>>> printSQL percentRank
229+percent_rank()
230+-}
231+percentRank :: WinFun0 ('NotNull 'PGfloat8)
232+percentRank = UnsafeWindowFunction "percent_rank()"
233+
234+{- | cumulative distribution: (number of partition rows
235+preceding or peer with current row) / total partition rows
236+
237+>>> printSQL cumeDist
238+cume_dist()
239+-}
240+cumeDist :: WinFun0 ('NotNull 'PGfloat8)
241+cumeDist = UnsafeWindowFunction "cume_dist()"
242+
243+{- | integer ranging from 1 to the argument value,
244+dividing the partition as equally as possible
245+
246+>>> printSQL $ ntile 5
247+ntile(5)
248+-}
249+ntile :: WinFun1 ('NotNull 'PGint4) ('NotNull 'PGint4)
250+ntile = unsafeWindowFunction1 "ntile"
251+
252+{- | returns value evaluated at the row that is offset rows before the current
253+row within the partition; if there is no such row, instead return default
254+(which must be of the same type as value). Both offset and default are
255+evaluated with respect to the current row.
256+-}
257+lag :: WinFunN '[ty, 'NotNull 'PGint4, ty] ty
258+lag = unsafeWindowFunctionN "lag"
259+
260+{- | returns value evaluated at the row that is offset rows after the current
261+row within the partition; if there is no such row, instead return default
262+(which must be of the same type as value). Both offset and default are
263+evaluated with respect to the current row.
264+-}
265+lead :: WinFunN '[ty, 'NotNull 'PGint4, ty] ty
266+lead = unsafeWindowFunctionN "lead"
267+
268+{- | returns value evaluated at the row that is the
269+first row of the window frame
270+-}
271+firstValue :: WinFun1 ty ty
272+firstValue = unsafeWindowFunction1 "first_value"
273+
274+{- | returns value evaluated at the row that is the
275+last row of the window frame
276+-}
277+lastValue :: WinFun1 ty ty
278+lastValue = unsafeWindowFunction1 "last_value"
279+
280+{- | returns value evaluated at the row that is the nth
281+row of the window frame (counting from 1); null if no such row
282+-}
283+nthValue :: WinFunN '[null ty, 'NotNull 'PGint4] ('Null ty)
284+nthValue = unsafeWindowFunctionN "nth_value"
squeal-postgresql/src/Squeal/PostgreSQL/List.hsnew file+112
@@ -0,0 +1,112 @@
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+
13+{-# LANGUAGE
14+ DataKinds
15+ , FlexibleContexts
16+ , GADTs
17+ , LambdaCase
18+ , MultiParamTypeClasses
19+ , OverloadedStrings
20+ , PolyKinds
21+ , QuantifiedConstraints
22+ , RankNTypes
23+ , ScopedTypeVariables
24+ , TypeApplications
25+ , TypeFamilies
26+ , TypeOperators
27+ , UndecidableInstances
28+#-}
29+
30+module Squeal.PostgreSQL.List
31+ ( SOP.NP (..)
32+ , (*:)
33+ , Join
34+ , disjoin
35+ , Additional (..)
36+ , Path (..)
37+ , CFunctor (..)
38+ , CFoldable (..)
39+ , CFree (..)
40+ , Elem
41+ , In
42+ , Length
43+ ) where
44+
45+import Control.Category.Free
46+import Data.Function ((&))
47+import Data.Kind
48+import Data.Type.Bool
49+import GHC.TypeLits
50+
51+import Generics.SOP as SOP
52+
53+-- | `Join` is simply promoted `++` and is used in @JOIN@s in
54+-- `Squeal.PostgreSQL.Query.FromClause`s.
55+type family Join xs ys where
56+ Join '[] ys = ys
57+ Join (x ': xs) ys = x ': Join xs ys
58+
59+-- | `disjoin` is a utility function for splitting an `NP` list into pieces.
60+disjoin
61+ :: forall xs ys expr. SListI xs
62+ => NP expr (Join xs ys)
63+ -> (NP expr xs, NP expr ys)
64+disjoin = case sList @xs of
65+ SNil -> \ys -> (Nil, ys)
66+ SCons -> \(x :* xsys) ->
67+ case disjoin xsys of (xs,ys) -> (x :* xs, ys)
68+
69+-- | The `Additional` class is for appending
70+-- type-level list parameterized constructors such as `NP`,
71+-- `Squeal.PostgreSQL.Query.Selection`, and `Squeal.PostgreSQL.Query.FromClause`.
72+class Additional expr where
73+ also :: expr ys -> expr xs -> expr (Join xs ys)
74+instance Additional (NP expr) where
75+ also ys = \case
76+ Nil -> ys
77+ x :* xs -> x :* (xs & also ys)
78+
79+-- | A useful operator for ending an `NP` list of length at least 2 without `Nil`.
80+(*:) :: f x -> f y -> NP f '[x,y]
81+x *: y = x :* y :* Nil
82+infixl 9 *:
83+
84+-- | @Elem@ is a promoted `Data.List.elem`.
85+type family Elem x xs where
86+ Elem x '[] = 'False
87+ Elem x (x ': _) = 'True
88+ Elem x (_ ': x ': _) = 'True
89+ Elem x (_ ': _ ': x ': _) = 'True
90+ Elem x (_ ': _ ': _ ': x ': _) = 'True
91+ Elem x (_ ': _ ': _ ': _ ': x ': _) = 'True
92+ Elem x (_ ': _ ': _ ': _ ': _ ': x ': _) = 'True
93+ Elem x (_ ': xs) = Elem x xs
94+
95+-- | @In x xs@ is a constraint that proves that @x@ is in @xs@.
96+type family In x xs :: Constraint where
97+ In x xs = If (Elem x xs) (() :: Constraint)
98+ (TypeError ('ShowType x ':<>: 'Text " is not in " ':<>: 'ShowType xs))
99+
100+{- | Calculate the `Length` of a type level list
101+
102+>>> :kind! Length '[Char,String,Bool,Double]
103+Length '[Char,String,Bool,Double] :: Nat
104+= 4
105+-}
106+type family Length (xs :: [k]) :: Nat where
107+ Length (_ ': _ ': _ ': _ ': _ : xs) = 5 + Length xs
108+ Length (_ ': _ ': _ ': _ : xs) = 4 + Length xs
109+ Length (_ ': _ ': _ : xs) = 3 + Length xs
110+ Length (_ ': _ : xs) = 2 + Length xs
111+ Length (_ : xs) = 1 + Length xs
112+ Length '[] = 0
squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs+399−321
@@ -11,82 +11,139 @@ Squeal data manipulation language.
11{-# LANGUAGE
11{-# LANGUAGE
12 DeriveGeneric
12 DeriveGeneric
13 , FlexibleContexts
13 , FlexibleContexts
14+ , FlexibleInstances
14 , GADTs
15 , GADTs
15 , GeneralizedNewtypeDeriving
16 , GeneralizedNewtypeDeriving
16 , LambdaCase
17 , LambdaCase
18+ , MultiParamTypeClasses
17 , OverloadedStrings
19 , OverloadedStrings
20+ , PatternSynonyms
21+ , QuantifiedConstraints
18 , RankNTypes
22 , RankNTypes
23+ , ScopedTypeVariables
24+ , TypeApplications
25+ , TypeFamilies
19 , TypeInType
26 , TypeInType
20 , TypeOperators
27 , TypeOperators
28+ , UndecidableInstances
21#-}
29#-}
22
30
23module Squeal.PostgreSQL.Manipulation
31module Squeal.PostgreSQL.Manipulation
24 ( -- * Manipulation
32 ( -- * Manipulation
33+ Manipulation_
25− Manipulation (UnsafeManipulation, renderManipulation)
34+ , Manipulation (..)
26 , queryStatement
35 , queryStatement
27− , ColumnValue (..)
28− , ReturningClause (ReturningStar, Returning)
29− , ConflictClause (OnConflictDoRaise, OnConflictDoNothing, OnConflictDoUpdate)
30 -- * Insert
36 -- * Insert
31− , insertRows
37+ , insertInto
32− , insertRow
38+ , insertInto_
33− , insertRows_
34− , insertRow_
35− , insertQuery
36− , insertQuery_
37− , renderReturningClause
38− , renderConflictClause
39 -- * Update
39 -- * Update
40 , update
40 , update
41 , update_
41 , update_
42 -- * Delete
42 -- * Delete
43 , deleteFrom
43 , deleteFrom
44 , deleteFrom_
44 , deleteFrom_
45+ -- * Clauses
46+ , Optional (..)
47+ , QueryClause (..)
48+ , pattern Values_
49+ , ReturningClause (..)
50+ , pattern Returning_
51+ , ConflictClause (..)
52+ , ConflictTarget (..)
53+ , ConflictAction (..)
54+ , UsingClause (..)
45 ) where
55 ) where
46
56
47import Control.DeepSeq
57import Control.DeepSeq
48import Data.ByteString hiding (foldr)
58import Data.ByteString hiding (foldr)
49−import Data.Monoid
59+import Data.Kind (Type)
50
60
51import qualified Generics.SOP as SOP
61import qualified Generics.SOP as SOP
52import qualified GHC.Generics as GHC
62import qualified GHC.Generics as GHC
53
63
64+import Squeal.PostgreSQL.Alias
54import Squeal.PostgreSQL.Expression
65import Squeal.PostgreSQL.Expression
66+import Squeal.PostgreSQL.Expression.Logic
67+import Squeal.PostgreSQL.List
68+import Squeal.PostgreSQL.PG
55import Squeal.PostgreSQL.Render
69import Squeal.PostgreSQL.Render
56import Squeal.PostgreSQL.Query
70import Squeal.PostgreSQL.Query
57import Squeal.PostgreSQL.Schema
71import Squeal.PostgreSQL.Schema
58
72
73+-- $setup
74+-- >>> import Squeal.PostgreSQL
75+-- >>> import Data.Int
76+-- >>> import Data.Time
77+
59{- |
78{- |
60A `Manipulation` is a statement which may modify data in the database,
79A `Manipulation` is a statement which may modify data in the database,
61−but does not alter the schema. Examples are inserts, updates and deletes.
80+but does not alter its schemas. Examples are inserts, updates and deletes.
62A `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.
63
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+
64simple insert:
125simple insert:
65
126
127+>>> type Columns = '["col1" ::: 'NoDef :=> 'Null 'PGint4, "col2" ::: 'Def :=> 'NotNull 'PGint4]
128+>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]
66>>> :{
129>>> :{
67let
130let
68− manipulation :: Manipulation
131+ manipulation :: Manipulation_ (Public Schema) () ()
69− '[ "tab" ::: 'Table ('[] :=>
70− '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4
71− , "col2" ::: 'Def :=> 'NotNull 'PGint4 ])] '[] '[]
72 manipulation =
132 manipulation =
73− insertRow_ #tab (Set 2 `as` #col1 :* Default `as` #col2)
133+ insertInto_ #tab (Values_ (Set 2 `as` #col1 :* Default `as` #col2))
74in printSQL manipulation
134in printSQL manipulation
75:}
135:}
76INSERT INTO "tab" ("col1", "col2") VALUES (2, DEFAULT)
136INSERT INTO "tab" ("col1", "col2") VALUES (2, DEFAULT)
77
137
78parameterized insert:
138parameterized insert:
79
139
140+>>> type Columns = '["col1" ::: 'NoDef :=> 'NotNull 'PGint4, "col2" ::: 'NoDef :=> 'NotNull 'PGint4]
141+>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]
80>>> :{
142>>> :{
81let
143let
82− manipulation :: Manipulation
144+ manipulation :: Manipulation_ (Public Schema) (Int32, Int32) ()
83− '[ "tab" ::: 'Table ('[] :=>
84− '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4
85− , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ])]
86− '[ 'NotNull 'PGint4, 'NotNull 'PGint4 ] '[]
87 manipulation =
145 manipulation =
88− insertRow_ #tab
89− (Set (param @1) `as` #col1 :* Set (param @2) `as` #col2)
146+ insertInto_ #tab (Values_ (Set (param @1) `as` #col1 :* Set (param @2) `as` #col2))
90in printSQL manipulation
147in printSQL manipulation
91:}
148:}
92INSERT INTO "tab" ("col1", "col2") VALUES (($1 :: int4), ($2 :: int4))
149INSERT INTO "tab" ("col1", "col2") VALUES (($1 :: int4), ($2 :: int4))
@@ -95,71 +152,48 @@ returning insert:
95
152
96>>> :{
153>>> :{
97let
154let
98− manipulation :: Manipulation
155+ manipulation :: Manipulation_ (Public Schema) () (Only Int32)
99− '[ "tab" ::: 'Table ('[] :=>
100− '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4
101− , "col2" ::: 'Def :=> 'NotNull 'PGint4 ])] '[]
102− '["fromOnly" ::: 'NotNull 'PGint4]
103 manipulation =
156 manipulation =
104− insertRow #tab (Set 2 `as` #col1 :* Default `as` #col2)
157+ insertInto #tab (Values_ (Set 2 `as` #col1 :* Set 3 `as` #col2))
105 OnConflictDoRaise (Returning (#col1 `as` #fromOnly))
158 OnConflictDoRaise (Returning (#col1 `as` #fromOnly))
106in printSQL manipulation
159in printSQL manipulation
107:}
160:}
108−INSERT INTO "tab" ("col1", "col2") VALUES (2, DEFAULT) RETURNING "col1" AS "fromOnly"
161+INSERT INTO "tab" ("col1", "col2") VALUES (2, 3) RETURNING "col1" AS "fromOnly"
109
162
110upsert:
163upsert:
111
164
165+>>> type CustomersColumns = '["name" ::: 'NoDef :=> 'NotNull 'PGtext, "email" ::: 'NoDef :=> 'NotNull 'PGtext]
166+>>> type CustomersConstraints = '["uq" ::: 'Unique '["name"]]
167+>>> type CustomersSchema = '["customers" ::: 'Table (CustomersConstraints :=> CustomersColumns)]
112>>> :{
168>>> :{
113let
169let
114− manipulation :: Manipulation
170+ manipulation :: Manipulation_ (Public CustomersSchema) () ()
115− '[ "tab" ::: 'Table ('[] :=>
116− '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4
117− , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ])]
118− '[] '[ "sum" ::: 'NotNull 'PGint4]
119 manipulation =
171 manipulation =
120− insertRows #tab
172+ insertInto #customers
121− (Set 2 `as` #col1 :* Set 4 `as` #col2)
173+ (Values_ (Set "John Smith" `as` #name :* Set "john@smith.com" `as` #email))
122− [Set 6 `as` #col1 :* Set 8 `as` #col2]
174+ (OnConflict (OnConstraint #uq)
123− (OnConflictDoUpdate
175+ (DoUpdate (Set (#excluded ! #email <> "; " <> #customers ! #email) `as` #email) []))
124− (Set 2 `as` #col1 :* Same `as` #col2)
176+ (Returning_ Nil)
125− [#col1 .== #col2])
126− (Returning $ (#col1 + #col2) `as` #sum)
127in printSQL manipulation
177in printSQL manipulation
128:}
178:}
129−INSERT INTO "tab" ("col1", "col2") VALUES (2, 4), (6, 8) ON CONFLICT DO UPDATE SET "col1" = 2 WHERE ("col1" = "col2") RETURNING ("col1" + "col2") AS "sum"
179+INSERT INTO "customers" ("name", "email") VALUES (E'John Smith', E'john@smith.com') ON CONFLICT ON CONSTRAINT "uq" DO UPDATE SET "email" = ("excluded"."email" || (E'; ' || "customers"."email"))
130
180
131query insert:
181query insert:
132
182
133>>> :{
183>>> :{
134let
184let
135− manipulation :: Manipulation
185+ manipulation :: Manipulation_ (Public Schema) () ()
136− '[ "tab" ::: 'Table ('[] :=>
186+ manipulation = insertInto_ #tab (Subquery (select Star (from (table #tab))))
137− '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4
138− , "col2" ::: 'NoDef :=> 'NotNull 'PGint4
139− ])
140− , "other_tab" ::: 'Table ('[] :=>
141− '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4
142− , "col2" ::: 'NoDef :=> 'NotNull 'PGint4
143− ])
144− ] '[] '[]
145− manipulation =
146− insertQuery_ #tab
147− (selectStar (from (table (#other_tab `as` #t))))
148in printSQL manipulation
187in printSQL manipulation
149:}
188:}
150−INSERT INTO "tab" SELECT * FROM "other_tab" AS "t"
189+INSERT INTO "tab" SELECT * FROM "tab" AS "tab"
151
190
152update:
191update:
153
192
154>>> :{
193>>> :{
155let
194let
156− manipulation :: Manipulation
195+ manipulation :: Manipulation_ (Public Schema) () ()
157− '[ "tab" ::: 'Table ('[] :=>
158− '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4
159− , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ])] '[] '[]
160− manipulation =
161− update_ #tab (Set 2 `as` #col1 :* Same `as` #col2)
196+ manipulation = update_ #tab (Set 2 `as` #col1) (#col1 ./= #col2)
162− (#col1 ./= #col2)
163in printSQL manipulation
197in printSQL manipulation
164:}
198:}
165UPDATE "tab" SET "col1" = 2 WHERE ("col1" <> "col2")
199UPDATE "tab" SET "col1" = 2 WHERE ("col1" <> "col2")
@@ -168,179 +202,178 @@ delete:
168
202
169>>> :{
203>>> :{
170let
204let
171− manipulation :: Manipulation
205+ manipulation :: Manipulation_ (Public Schema) () (Row Int32 Int32)
172− '[ "tab" ::: 'Table ('[] :=>
173− '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4
174− , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ])] '[]
175− '[ "col1" ::: 'NotNull 'PGint4
176− , "col2" ::: 'NotNull 'PGint4 ]
177− manipulation = deleteFrom #tab (#col1 .== #col2) ReturningStar
206+ manipulation = deleteFrom #tab NoUsing (#col1 .== #col2) (Returning Star)
178in printSQL manipulation
207in printSQL manipulation
179:}
208:}
180DELETE FROM "tab" WHERE ("col1" = "col2") RETURNING *
209DELETE FROM "tab" WHERE ("col1" = "col2") RETURNING *
181
210
182−with manipulation:
211+delete and using clause:
183
212
184−>>> type ProductsTable = '[] :=> '["product" ::: 'NoDef :=> 'NotNull 'PGtext, "date" ::: 'Def :=> 'NotNull 'PGdate]
213+>>> :{
214+type Schema3 =
215+ '[ "tab" ::: 'Table ('[] :=> Columns)
216+ , "other_tab" ::: 'Table ('[] :=> Columns)
217+ , "third_tab" ::: 'Table ('[] :=> Columns) ]
218+:}
185
219
186>>> :{
220>>> :{
187let
221let
188− manipulation :: Manipulation
222+ manipulation :: Manipulation_ (Public Schema3) () ()
189− '[ "products" ::: 'Table ProductsTable
223+ manipulation =
190− , "products_deleted" ::: 'Table ProductsTable
224+ deleteFrom #tab (Using (table #other_tab & also (table #third_tab)))
191− ] '[ 'NotNull 'PGdate] '[]
225+ ( (#tab ! #col2 .== #other_tab ! #col2)
226+ .&& (#tab ! #col2 .== #third_tab ! #col2) )
227+ (Returning_ Nil)
228+in printSQL manipulation
229+:}
230+DELETE FROM "tab" USING "other_tab" AS "other_tab", "third_tab" AS "third_tab" WHERE (("tab"."col2" = "other_tab"."col2") AND ("tab"."col2" = "third_tab"."col2"))
231+
232+with manipulation:
233+
234+>>> type ProductsColumns = '["product" ::: 'NoDef :=> 'NotNull 'PGtext, "date" ::: 'Def :=> 'NotNull 'PGdate]
235+>>> type ProductsSchema = '["products" ::: 'Table ('[] :=> ProductsColumns), "products_deleted" ::: 'Table ('[] :=> ProductsColumns)]
236+>>> :{
237+let
238+ manipulation :: Manipulation_ (Public ProductsSchema) (Only Day) ()
192 manipulation = with
239 manipulation = with
193− (deleteFrom #products (#date .< param @1) ReturningStar `as` #deleted_rows)
240+ (deleteFrom #products NoUsing (#date .< param @1) (Returning Star) `as` #del)
194− (insertQuery_ #products_deleted (selectStar (from (view (#deleted_rows `as` #t)))))
241+ (insertInto_ #products_deleted (Subquery (select Star (from (common #del)))))
195in printSQL manipulation
242in printSQL manipulation
196:}
243:}
197−WITH "deleted_rows" AS (DELETE FROM "products" WHERE ("date" < ($1 :: date)) RETURNING *) INSERT INTO "products_deleted" SELECT * FROM "deleted_rows" AS "t"
244+WITH "del" AS (DELETE FROM "products" WHERE ("date" < ($1 :: date)) RETURNING *) INSERT INTO "products_deleted" SELECT * FROM "del" AS "del"
198-}
245-}
199−
246+type family Manipulation_ (schemas :: SchemasType) (params :: Type) (row :: Type) where
200−newtype Manipulation
247+ Manipulation_ schemas params row = Manipulation '[] schemas (TuplePG params) (RowPG row)
201− (schema :: SchemaType)
202− (params :: [NullityType])
203− (columns :: RowType)
204− = UnsafeManipulation { renderManipulation :: ByteString }
205− deriving (GHC.Generic,Show,Eq,Ord,NFData)
206−instance RenderSQL (Manipulation schema params columns) where
207− renderSQL = renderManipulation
208−instance With Manipulation where
209− with Done manip = manip
210− with (cte :>> ctes) manip = UnsafeManipulation $
211− "WITH" <+> renderCommonTableExpressions renderManipulation cte ctes
212− <+> renderManipulation manip
213
248
214-- | Convert a `Query` into a `Manipulation`.
249-- | Convert a `Query` into a `Manipulation`.
215queryStatement
250queryStatement
216− :: Query schema params columns
251+ :: Query '[] commons schemas params columns
252+ -- ^ `Query` to embed as a `Manipulation`
217− -> Manipulation schema params columns
253+ -> Manipulation commons schemas params columns
218−queryStatement q = UnsafeManipulation $ renderQuery q
254+queryStatement q = UnsafeManipulation $ renderSQL q
219
255
220{-----------------------------------------
256{-----------------------------------------
221INSERT statements
257INSERT statements
222-----------------------------------------}
258-----------------------------------------}
223
259
224−-- | Insert multiple rows.
260+{- |
225−--
226−-- When a table is created, it contains no data. The first thing to do
261+When a table is created, it contains no data. The first thing to do
227−-- before a database can be of much use is to insert data. Data is
262+before a database can be of much use is to insert data. Data is
228−-- conceptually inserted one row at a time. Of course you can also insert
263+conceptually inserted one row at a time. Of course you can also insert
229−-- more than one row, but there is no way to insert less than one row.
264+more than one row, but there is no way to insert less than one row.
230−-- Even if you know only some column values, a complete row must be created.
265+Even if you know only some column values, a complete row must be created.
231−insertRows
266+-}
232− :: ( SOP.SListI columns
267+insertInto
233− , SOP.SListI results
268+ :: ( Has sch schemas schema
234− , Has tab schema ('Table table)
235− , row ~ TableToRow table
236− , columns ~ TableToColumns table )
237− => Alias tab -- ^ table to insert into
238− -> NP (Aliased (ColumnValue schema '[] params)) columns -- ^ row to insert
239− -> [NP (Aliased (ColumnValue schema '[] params)) columns] -- ^ more rows to insert
240− -> ConflictClause schema table params
241− -- ^ what to do in case of constraint conflict
242− -> ReturningClause schema params row results -- ^ results to return
243− -> Manipulation schema params results
244−insertRows tab rw rws conflict returning = UnsafeManipulation $
245− "INSERT" <+> "INTO" <+> renderAlias tab
246− <+> parenthesized (renderCommaSeparated renderAliasPart rw)
247− <+> "VALUES"
248− <+> commaSeparated
249− ( parenthesized
250− . renderCommaSeparated renderColumnValuePart <$> rw:rws )
251− <> renderConflictClause conflict
252− <> renderReturningClause returning
253− where
254− renderAliasPart, renderColumnValuePart
255− :: Aliased (ColumnValue schema '[] params) ty -> ByteString
256− renderAliasPart (_ `As` name) = renderAlias name
257− renderColumnValuePart (value `As` _) = case value of
258− Default -> "DEFAULT"
259− Set expression -> renderExpression expression
260−
261−-- | Insert a single row.
262−insertRow
263− :: ( SOP.SListI columns
264− , SOP.SListI results
265− , Has tab schema ('Table table)
266− , row ~ TableToRow table
267− , columns ~ TableToColumns table )
268− => Alias tab -- ^ table to insert into
269− -> NP (Aliased (ColumnValue schema '[] params)) columns -- ^ row to insert
270− -> ConflictClause schema table params
271− -- ^ what to do in case of constraint conflict
272− -> ReturningClause schema params row results -- ^ results to return
273− -> Manipulation schema params results
274−insertRow tab rw = insertRows tab rw []
275−
276−-- | Insert multiple rows returning `Nil` and raising an error on conflicts.
277−insertRows_
278− :: ( SOP.SListI columns
279− , Has tab schema ('Table table)
280− , columns ~ TableToColumns table )
281− => Alias tab -- ^ table to insert into
282− -> NP (Aliased (ColumnValue schema '[] params)) columns -- ^ row to insert
283− -> [NP (Aliased (ColumnValue schema '[] params)) columns] -- ^ more rows to insert
284− -> Manipulation schema params '[]
285−insertRows_ tab rw rws =
286− insertRows tab rw rws OnConflictDoRaise (Returning Nil)
287−
288−-- | Insert a single row returning `Nil` and raising an error on conflicts.
289−insertRow_
290− :: ( SOP.SListI columns
291 , Has tab schema ('Table table)
269 , Has tab schema ('Table table)
292− , columns ~ TableToColumns table )
270+ , columns ~ TableToColumns table
271+ , row0 ~ TableToRow table
272+ , SOP.SListI columns
273+ , SOP.SListI row1 )
274+ => QualifiedAlias sch tab
275+ -- ^ table
276+ -> QueryClause commons schemas params columns
293− => Alias tab -- ^ table to insert into
277+ -- ^ what to insert
294− -> NP (Aliased (ColumnValue schema '[] params)) columns -- ^ row to insert
278+ -> ConflictClause tab commons schemas params table
279+ -- ^ what to do in case of conflict
280+ -> ReturningClause commons schemas params '[tab ::: row0] row1
281+ -- ^ what to return
295− -> Manipulation schema params '[]
282+ -> Manipulation commons schemas params row1
296−insertRow_ tab rw = insertRow tab rw OnConflictDoRaise (Returning Nil)
283+insertInto tab qry conflict ret = UnsafeManipulation $
297−
284+ "INSERT" <+> "INTO" <+> renderSQL tab
298−-- | Insert a `Query`.
285+ <+> renderSQL qry
299−insertQuery
286+ <> renderSQL conflict
300− :: ( SOP.SListI columns
287+ <> renderSQL ret
301− , SOP.SListI results
288+
289+-- | Like `insertInto` but with `OnConflictDoRaise` and `no` `ReturningClause`.
290+insertInto_
291+ :: ( Has sch schemas schema
302 , Has tab schema ('Table table)
292 , Has tab schema ('Table table)
293+ , columns ~ TableToColumns table
303 , row ~ TableToRow table
294 , row ~ TableToRow table
304− , columns ~ TableToColumns table )
295+ , SOP.SListI columns )
296+ => QualifiedAlias sch tab
297+ -- ^ table
298+ -> QueryClause commons schemas params columns
305− => Alias tab -- ^ table to insert into
299+ -- ^ what to insert
306− -> Query schema params (TableToRow table)
300+ -> Manipulation commons schemas params '[]
307− -> ConflictClause schema table params
301+insertInto_ tab qry =
308− -- ^ what to do in case of constraint conflict
302+ insertInto tab qry OnConflictDoRaise (Returning_ Nil)
309− -> ReturningClause schema params row results -- ^ results to return
303+
310− -> Manipulation schema params results
304+-- | A `QueryClause` describes what to `insertInto` a table.
311−insertQuery tab query conflict returning = UnsafeManipulation $
305+data QueryClause commons schemas params columns where
312− "INSERT" <+> "INTO" <+> renderAlias tab
306+ Values
307+ :: SOP.SListI columns
308+ => NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[]))) columns
309+ -- ^ row of values
310+ -> [NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[]))) columns]
311+ -- ^ additional rows of values
312+ -> QueryClause commons schemas params columns
313+ Select
314+ :: SOP.SListI columns
315+ => NP (Aliased (Optional (Expression '[] commons grp schemas params from))) columns
316+ -- ^ row of values
317+ -> TableExpression '[] commons grp schemas params from
318+ -- ^ from a table expression
319+ -> QueryClause commons schemas params columns
320+ Subquery
321+ :: ColumnsToRow columns ~ row
322+ => Query '[] commons schemas params row
323+ -- ^ subquery to insert
324+ -> QueryClause commons schemas params columns
325+
326+instance RenderSQL (QueryClause commons schemas params columns) where
327+ renderSQL = \case
328+ Values row0 rows ->
329+ parenthesized (renderCommaSeparated renderSQLPart row0)
330+ <+> "VALUES"
331+ <+> commaSeparated
332+ ( parenthesized
333+ . renderCommaSeparated renderValuePart <$> row0 : rows )
334+ Select row0 tab ->
335+ parenthesized (renderCommaSeparatedMaybe renderSQLPartMaybe row0)
336+ <+> "SELECT"
337+ <+> renderCommaSeparatedMaybe renderValuePartMaybe row0
338+ <+> renderSQL tab
313− <+> renderQuery query
339+ Subquery qry -> renderQuery qry
314− <> renderConflictClause conflict
340+ where
315− <> renderReturningClause returning
341+ renderSQLPartMaybe, renderValuePartMaybe
316−
342+ :: Aliased (Optional (Expression '[] commons grp schemas params from)) column
317−-- | Insert a `Query` returning `Nil` and raising an error on conflicts.
343+ -> Maybe ByteString
318−insertQuery_
344+ renderSQLPartMaybe = \case
319− :: ( SOP.SListI columns
345+ Default `As` _ -> Nothing
320− , Has tab schema ('Table table)
346+ Set _ `As` name -> Just $ renderSQL name
321− , columns ~ TableToColumns table )
347+ renderValuePartMaybe = \case
322− => Alias tab -- ^ table to insert into
348+ Default `As` _ -> Nothing
323− -> Query schema params (TableToRow table)
349+ Set value `As` _ -> Just $ renderExpression value
324− -> Manipulation schema params '[]
350+ renderSQLPart, renderValuePart
325−insertQuery_ tab query =
351+ :: Aliased (Optional (Expression '[] commons grp schemas params from)) column
326− insertQuery tab query OnConflictDoRaise (Returning Nil)
352+ -> ByteString
327−
353+ renderSQLPart (_ `As` name) = renderSQL name
328−-- | `ColumnValue`s are values to insert or update in a row.
354+ renderValuePart (value `As` _) = renderSQL value
329−-- `Same` updates with the same value.
355+
330−-- `Default` inserts or updates with the @DEFAULT@ value.
356+-- | `Values_` describes a single `NP` list of `Aliased` `Optional` `Expression`s
331−-- `Set` sets a value to be an `Expression`, which can refer to
357+-- whose `ColumnsType` must match the tables'.
332−-- existing value in the row for an update.
358+pattern Values_
333−data ColumnValue
359+ :: SOP.SListI columns
334− (schema :: SchemaType)
360+ => NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[]))) columns
335− (columns :: RowType)
361+ -- ^ row of values
336− (params :: [NullityType])
362+ -> QueryClause commons schemas params columns
337− (ty :: ColumnType)
363+pattern Values_ vals = Values vals []
338− where
364+
339− Same :: ColumnValue schema (column ': columns) params ty
365+-- | `Optional` is either `Default` or a value, parameterized by an appropriate
340− Default :: ColumnValue schema columns params ('Def :=> ty)
366+-- `ColumnConstraint`.
341− Set
367+data Optional expr ty where
342− :: (forall table. Expression schema '[table ::: columns] 'Ungrouped params ty)
368+ -- | Use the `Default` value for a column.
343− -> ColumnValue schema columns params (constraint :=> ty)
369+ Default :: Optional expr ('Def :=> ty)
370+ -- | `Set` a value for a column.
371+ Set :: expr ty -> Optional expr (def :=> ty)
372+
373+instance (forall x. RenderSQL (expr x)) => RenderSQL (Optional expr ty) where
374+ renderSQL = \case
375+ Default -> "DEFAULT"
376+ Set expr -> renderSQL expr
344
377
345-- | A `ReturningClause` computes and return value(s) based
378-- | A `ReturningClause` computes and return value(s) based
346-- on each row actually inserted, updated or deleted. This is primarily
379-- on each row actually inserted, updated or deleted. This is primarily
@@ -348,74 +381,100 @@ data ColumnValue
348-- serial sequence number. However, any expression using the table's columns
381-- serial sequence number. However, any expression using the table's columns
349-- is allowed. Only rows that were successfully inserted or updated or
382-- is allowed. Only rows that were successfully inserted or updated or
350-- deleted will be returned. For example, if a row was locked
383-- deleted will be returned. For example, if a row was locked
351−-- but not updated because an `OnConflictDoUpdate` condition was not satisfied,
384+-- but not updated because an `OnConflict` `DoUpdate` condition was not satisfied,
352−-- the row will not be returned. `ReturningStar` will return all columns
385+-- the row will not be returned. `Returning` `Star` will return all columns
353−-- 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
354-- values are desired.
387-- values are desired.
355−data ReturningClause
388+newtype ReturningClause commons schemas params from row =
356− (schema :: SchemaType)
389+ Returning (Selection '[] commons 'Ungrouped schemas params from row)
357− (params :: [NullityType])
390+
358− (row0 :: RowType)
391+instance RenderSQL (ReturningClause commons schemas params from row) where
359− (row1 :: RowType)
392+ renderSQL = \case
360− where
361− ReturningStar
362− :: ReturningClause schema params row row
363− Returning
393+ Returning (List Nil) -> ""
364− :: NP (Aliased (Expression schema '[table ::: row0] 'Ungrouped params)) row1
394+ Returning selection -> " RETURNING" <+> renderSQL selection
365− -> ReturningClause schema params row0 row1
395+
366−
396+-- | `Returning` a `List`
367−-- | Render a `ReturningClause`.
397+pattern Returning_
368−renderReturningClause
369− :: SOP.SListI results
398+ :: SOP.SListI row
370− => ReturningClause schema params columns results
399+ => NP (Aliased (Expression '[] commons 'Ungrouped schemas params from)) row
371− -> ByteString
400+ -- ^ row of values
372−renderReturningClause = \case
401+ -> ReturningClause commons schemas params from row
373− ReturningStar -> " RETURNING *"
402+pattern Returning_ list = Returning (List list)
374− Returning Nil -> ""
375− Returning results -> " RETURNING"
376− <+> renderCommaSeparated (renderAliasedAs renderExpression) results
377
403
378-- | A `ConflictClause` specifies an action to perform upon a constraint
404-- | A `ConflictClause` specifies an action to perform upon a constraint
379-- violation. `OnConflictDoRaise` will raise an error.
405-- violation. `OnConflictDoRaise` will raise an error.
380−-- `OnConflictDoNothing` simply avoids inserting a row.
406+-- `OnConflict` `DoNothing` simply avoids inserting a row.
381−-- `OnConflictDoUpdate` updates the existing row that conflicts with the row
407+-- `OnConflict` `DoUpdate` updates the existing row that conflicts with the row
382-- proposed for insertion.
408-- proposed for insertion.
383−data ConflictClause
409+data ConflictClause tab commons schemas params table where
384− (schema :: SchemaType)
385− (table :: TableType)
386− (params :: [NullityType]) where
387− OnConflictDoRaise :: ConflictClause schema table params
410+ OnConflictDoRaise :: ConflictClause tab commons schemas params table
388− OnConflictDoNothing :: ConflictClause schema table params
411+ OnConflict
389− OnConflictDoUpdate
412+ :: ConflictTarget constraints
390− :: (row ~ TableToRow table, columns ~ TableToColumns table)
413+ -- ^ conflict target
391− => NP (Aliased (ColumnValue schema row params)) columns
414+ -> ConflictAction tab commons schemas params columns
392− -> [Condition schema '[t ::: row] 'Ungrouped params]
415+ -- ^ conflict action
393− -> ConflictClause schema table params
416+ -> ConflictClause tab commons schemas params (constraints :=> columns)
394
417
395-- | Render a `ConflictClause`.
418-- | Render a `ConflictClause`.
396−renderConflictClause
397− :: SOP.SListI (TableToColumns table)
419+instance SOP.SListI (TableToColumns table)
398− => ConflictClause schema table params
420+ => RenderSQL (ConflictClause tab commons schemas params table) where
421+ renderSQL = \case
422+ OnConflictDoRaise -> ""
423+ OnConflict target action -> " ON CONFLICT"
424+ <+> renderSQL target <+> renderSQL action
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+-}
437+data ConflictAction tab commons schemas params columns where
438+ DoNothing :: ConflictAction tab commons schemas params columns
439+ DoUpdate
440+ :: ( row ~ ColumnsToRow columns
441+ , SOP.SListI columns
442+ , columns ~ (col0 ': cols)
443+ , SOP.All (HasIn columns) subcolumns
444+ , AllUnique subcolumns )
445+ => NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[tab ::: row, "excluded" ::: row]))) subcolumns
446+ -> [Condition '[] commons 'Ungrouped schemas params '[tab ::: row, "excluded" ::: row]]
447+ -- ^ WHERE `Condition`s
448+ -> ConflictAction tab commons schemas params columns
449+
450+instance RenderSQL (ConflictAction tab commons schemas params columns) where
451+ renderSQL = \case
452+ DoNothing -> "DO NOTHING"
453+ DoUpdate updates whs'
454+ -> "DO UPDATE SET"
455+ <+> renderCommaSeparated renderUpdate updates
456+ <> case whs' of
457+ [] -> ""
458+ wh:whs -> " WHERE" <+> renderSQL (foldr (.&&) wh whs)
459+
460+renderUpdate
461+ :: (forall x. RenderSQL (expr x))
462+ => Aliased (Optional expr) ty
399 -> ByteString
463 -> ByteString
400−renderConflictClause = \case
464+renderUpdate (expr `As` col) = renderSQL col <+> "=" <+> renderSQL expr
401− OnConflictDoRaise -> ""
465+
402− OnConflictDoNothing -> " ON CONFLICT DO NOTHING"
466+-- | A `ConflictTarget` specifies the constraint violation that triggers a
403− OnConflictDoUpdate updates whs'
467+-- `ConflictAction`.
404− -> " ON CONFLICT DO UPDATE SET"
468+data ConflictTarget constraints where
405− <+> renderCommaSeparatedMaybe renderUpdate updates
469+ OnConstraint
406− <> case whs' of
470+ :: Has con constraints constraint
407− [] -> ""
471+ => Alias con
408− wh:whs -> " WHERE" <+> renderExpression (foldr (.&&) wh whs)
472+ -> ConflictTarget constraints
409− where
473+
410− renderUpdate
474+-- | Render a `ConflictTarget`
411− :: Aliased (ColumnValue schema columns params) column
475+instance RenderSQL (ConflictTarget constraints) where
412− -> Maybe ByteString
476+ renderSQL (OnConstraint con) =
413− renderUpdate = \case
477+ "ON" <+> "CONSTRAINT" <+> renderSQL con
414− Same `As` _ -> Nothing
415− Default `As` column -> Just $
416− renderAlias column <+> "=" <+> "DEFAULT"
417− Set expression `As` column -> Just $
418− renderAlias column <+> "=" <+> renderExpression expression
419
478
420{-----------------------------------------
479{-----------------------------------------
421UPDATE statements
480UPDATE statements
@@ -425,76 +484,95 @@ UPDATE statements
425-- in all rows that satisfy the condition.
484-- in all rows that satisfy the condition.
426update
485update
427 :: ( SOP.SListI columns
486 :: ( SOP.SListI columns
428− , SOP.SListI results
487+ , SOP.SListI row1
488+ , Has sch schemas schema
429 , Has tab schema ('Table table)
489 , Has tab schema ('Table table)
430− , row ~ TableToRow table
490+ , row0 ~ TableToRow table
431− , columns ~ TableToColumns table )
491+ , columns ~ TableToColumns table
492+ , SOP.All (HasIn columns) subcolumns
493+ , AllUnique subcolumns )
432− => Alias tab -- ^ table to update
494+ => QualifiedAlias sch tab -- ^ table to update
433− -> NP (Aliased (ColumnValue schema row params)) columns
495+ -> NP (Aliased (Optional (Expression '[] '[] 'Ungrouped schemas params '[tab ::: row0]))) subcolumns
434 -- ^ modified values to replace old values
496 -- ^ modified values to replace old values
435− -> (forall t. Condition schema '[t ::: row] 'Ungrouped params)
497+ -> Condition '[] commons 'Ungrouped schemas params '[tab ::: row0]
436 -- ^ condition under which to perform update on a row
498 -- ^ condition under which to perform update on a row
437− -> ReturningClause schema params row results -- ^ results to return
499+ -> ReturningClause commons schemas params '[tab ::: row0] row1 -- ^ results to return
438− -> Manipulation schema params results
500+ -> Manipulation commons schemas params row1
439update tab columns wh returning = UnsafeManipulation $
501update tab columns wh returning = UnsafeManipulation $
440 "UPDATE"
502 "UPDATE"
441− <+> renderAlias tab
503+ <+> renderSQL tab
442 <+> "SET"
504 <+> "SET"
443− <+> renderCommaSeparatedMaybe renderUpdate columns
505+ <+> renderCommaSeparated renderUpdate columns
444− <+> "WHERE" <+> renderExpression wh
506+ <+> "WHERE" <+> renderSQL wh
445− <> renderReturningClause returning
507+ <> renderSQL returning
446− where
447− renderUpdate
448− :: Aliased (ColumnValue schema columns params) column
449− -> Maybe ByteString
450− renderUpdate = \case
451− Same `As` _ -> Nothing
452− Default `As` column -> Just $
453− renderAlias column <+> "=" <+> "DEFAULT"
454− Set expression `As` column -> Just $
455− renderAlias column <+> "=" <+> renderExpression expression
456
508
457-- | Update a row returning `Nil`.
509-- | Update a row returning `Nil`.
458update_
510update_
459 :: ( SOP.SListI columns
511 :: ( SOP.SListI columns
512+ , Has sch schemas schema
460 , Has tab schema ('Table table)
513 , Has tab schema ('Table table)
461 , row ~ TableToRow table
514 , row ~ TableToRow table
462− , columns ~ TableToColumns table )
515+ , columns ~ TableToColumns table
516+ , SOP.All (HasIn columns) subcolumns
517+ , AllUnique subcolumns )
463− => Alias tab -- ^ table to update
518+ => QualifiedAlias sch tab -- ^ table to update
464− -> NP (Aliased (ColumnValue schema row params)) columns
519+ -> NP (Aliased (Optional (Expression '[] '[] 'Ungrouped schemas params '[tab ::: row]))) subcolumns
465 -- ^ modified values to replace old values
520 -- ^ modified values to replace old values
466− -> (forall t. Condition schema '[t ::: row] 'Ungrouped params)
521+ -> Condition '[] commons 'Ungrouped schemas params '[tab ::: row]
467 -- ^ condition under which to perform update on a row
522 -- ^ condition under which to perform update on a row
468− -> Manipulation schema params '[]
523+ -> Manipulation commons schemas params '[]
469−update_ tab columns wh = update tab columns wh (Returning Nil)
524+update_ tab columns wh = update tab columns wh (Returning_ Nil)
470
525
471{-----------------------------------------
526{-----------------------------------------
472DELETE statements
527DELETE statements
473-----------------------------------------}
528-----------------------------------------}
474
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.
539+data UsingClause commons schemas params from where
540+ NoUsing :: UsingClause commons schemas params '[]
541+ Using
542+ :: FromClause '[] commons schemas params from
543+ -- ^ what to use
544+ -> UsingClause commons schemas params from
545+
475−-- | Delete rows of a table.
546+-- | Delete rows from a table.
476deleteFrom
547deleteFrom
477− :: ( SOP.SListI results
548+ :: ( SOP.SListI row1
549+ , Has sch schemas schema
478 , Has tab schema ('Table table)
550 , Has tab schema ('Table table)
479− , row ~ TableToRow table
551+ , row0 ~ TableToRow table
480 , columns ~ TableToColumns table )
552 , columns ~ TableToColumns table )
481− => Alias tab -- ^ table to delete from
553+ => QualifiedAlias sch tab -- ^ table to delete from
554+ -> UsingClause commons schemas params from
482− -> Condition schema '[tab ::: row] 'Ungrouped params
555+ -> Condition '[] commons 'Ungrouped schemas params (tab ::: row0 ': from)
483 -- ^ condition under which to delete a row
556 -- ^ condition under which to delete a row
484− -> ReturningClause schema params row results -- ^ results to return
557+ -> ReturningClause commons schemas params '[tab ::: row0] row1 -- ^ results to return
485− -> Manipulation schema params results
558+ -> Manipulation commons schemas params row1
486−deleteFrom tab wh returning = UnsafeManipulation $
559+deleteFrom tab using wh returning = UnsafeManipulation $
487− "DELETE FROM" <+> renderAlias tab
560+ "DELETE FROM"
488− <+> "WHERE" <+> renderExpression wh
561+ <+> renderSQL tab
489− <> renderReturningClause returning
562+ <> case using of
563+ NoUsing -> ""
564+ Using tables -> " USING" <+> renderSQL tables
565+ <+> "WHERE" <+> renderSQL wh
566+ <> renderSQL returning
490
567
491-- | Delete rows returning `Nil`.
568-- | Delete rows returning `Nil`.
492deleteFrom_
569deleteFrom_
570+ :: ( Has sch schemas schema
493− :: ( Has tab schema ('Table table)
571+ , Has tab schema ('Table table)
494 , row ~ TableToRow table
572 , row ~ TableToRow table
495 , columns ~ TableToColumns table )
573 , columns ~ TableToColumns table )
496− => Alias tab -- ^ table to delete from
574+ => QualifiedAlias sch tab -- ^ table to delete from
497− -> (forall t. Condition schema '[t ::: row] 'Ungrouped params)
575+ -> Condition '[] commons 'Ungrouped schemas params '[tab ::: row]
498 -- ^ condition under which to delete a row
576 -- ^ condition under which to delete a row
499− -> Manipulation schema params '[]
577+ -> Manipulation commons schemas params '[]
500−deleteFrom_ tab wh = deleteFrom tab wh (Returning Nil)
578+deleteFrom_ tab wh = deleteFrom tab NoUsing wh (Returning_ Nil)
squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs+339−187
@@ -8,8 +8,13 @@ Stability: experimental
8This module defines a `Migration` type to safely
8This module defines a `Migration` type to safely
9change the schema of your database over time. Let's see an example!
9change the schema of your database over time. Let's see an example!
10
10
11+First turn on some extensions.
12+
11>>> :set -XDataKinds -XOverloadedLabels
13>>> :set -XDataKinds -XOverloadedLabels
12>>> :set -XOverloadedStrings -XFlexibleContexts -XTypeOperators
14>>> :set -XOverloadedStrings -XFlexibleContexts -XTypeOperators
15+
16+Next, let's define our `TableType`s.
17+
13>>> :{
18>>> :{
14type UsersTable =
19type UsersTable =
15 '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
20 '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
@@ -20,7 +25,7 @@ type UsersTable =
20
25
21>>> :{
26>>> :{
22type EmailsTable =
27type EmailsTable =
23− '[ "pk_emails" ::: 'PrimaryKey '["id"]
28+ '[ "pk_emails" ::: 'PrimaryKey '["id"]
24 , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
29 , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
25 ] :=>
30 ] :=>
26 '[ "id" ::: 'Def :=> 'NotNull 'PGint4
31 '[ "id" ::: 'Def :=> 'NotNull 'PGint4
@@ -29,228 +34,293 @@ type EmailsTable =
29 ]
34 ]
30:}
35:}
31
36
37+Now we can define some `Migration`s to make our tables.
38+
32>>> :{
39>>> :{
33let
40let
34− makeUsers :: Migration IO '[] '["users" ::: 'Table UsersTable]
41+ makeUsers :: Migration Definition (Public '[]) '["public" ::: '["users" ::: 'Table UsersTable]]
35 makeUsers = Migration
42 makeUsers = Migration
36 { name = "make users table"
43 { name = "make users table"
37− , up = void . define $
38− createTable #users
44+ , up = createTable #users
39 ( serial `as` #id :*
45 ( serial `as` #id :*
40− (text & notNullable) `as` #name )
46+ notNullable text `as` #name )
41 ( primaryKey #id `as` #pk_users )
47 ( primaryKey #id `as` #pk_users )
42− , down = void . define $ dropTable #users
48+ , down = dropTable #users
43 }
49 }
44:}
50:}
45
51
46>>> :{
52>>> :{
47let
53let
48− makeEmails :: Migration IO '["users" ::: 'Table UsersTable]
54+ makeEmails :: Migration Definition '["public" ::: '["users" ::: 'Table UsersTable]]
49− '["users" ::: 'Table UsersTable, "emails" ::: 'Table EmailsTable]
55+ '["public" ::: '["users" ::: 'Table UsersTable, "emails" ::: 'Table EmailsTable]]
50 makeEmails = Migration
56 makeEmails = Migration
51 { name = "make emails table"
57 { name = "make emails table"
52− , up = void . define $
53− createTable #emails
58+ , up = createTable #emails
54 ( serial `as` #id :*
59 ( serial `as` #id :*
55− (int & notNullable) `as` #user_id :*
60+ notNullable int `as` #user_id :*
56− (text & nullable) `as` #email )
61+ nullable text `as` #email )
57 ( primaryKey #id `as` #pk_emails :*
62 ( primaryKey #id `as` #pk_emails :*
58 foreignKey #user_id #users #id
63 foreignKey #user_id #users #id
59 OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
64 OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
60− , down = void . define $ dropTable #emails
65+ , down = dropTable #emails
61 }
66 }
62:}
67:}
63
68
64−Now that we have a couple migrations we can chain them together.
69+Now that we have a couple migrations we can chain them together into a `Path`.
65
70
66>>> let migrations = makeUsers :>> makeEmails :>> Done
71>>> let migrations = makeUsers :>> makeEmails :>> Done
67
72
68−>>> :{
73+Now run the migrations.
69−let
70− numMigrations
71− :: Has "schema_migrations" schema ('Table MigrationsTable)
72− => PQ schema schema IO ()
73− numMigrations = do
74− result <- runQuery (selectStar (from (table (#schema_migrations `as` #m))))
75− num <- ntuples result
76− liftBase $ print num
77−:}
78
74
75+>>> import Control.Monad.IO.Class
79>>> :{
76>>> :{
80withConnection "host=localhost port=5432 dbname=exampledb" $
77withConnection "host=localhost port=5432 dbname=exampledb" $
81 manipulate (UnsafeManipulation "SET client_min_messages TO WARNING;")
78 manipulate (UnsafeManipulation "SET client_min_messages TO WARNING;")
82 -- suppress notices
79 -- suppress notices
80+ & pqThen (liftIO (putStrLn "Migrate"))
83 & pqThen (migrateUp migrations)
81 & pqThen (migrateUp migrations)
84− & pqThen numMigrations
82+ & pqThen (liftIO (putStrLn "Rollback"))
85 & pqThen (migrateDown migrations)
83 & pqThen (migrateDown migrations)
86− & pqThen numMigrations
87:}
84:}
88−Row 2
85+Migrate
89−Row 0
86+Rollback
87+
88+We can also create a simple executable using `defaultMain`.
89+
90+>>> let main = defaultMain "host=localhost port=5432 dbname=exampledb" migrations
91+
92+>>> withArgs [] main
93+Invalid command: "". Use:
94+migrate to run all available migrations
95+rollback to rollback all available migrations
96+status to display migrations run and migrations left to run
97+
98+>>> withArgs ["status"] main
99+Migrations already run:
100+ None
101+Migrations left to run:
102+ - make users table
103+ - make emails table
104+
105+>>> withArgs ["migrate"] main
106+Migrations already run:
107+ - make users table
108+ - make emails table
109+Migrations left to run:
110+ None
111+
112+>>> withArgs ["rollback"] main
113+Migrations already run:
114+ None
115+Migrations left to run:
116+ - make users table
117+ - make emails table
118+
119+In addition to enabling `Migration`s using pure SQL `Definition`s for
120+the `up` and `down` instructions, you can also perform impure `IO` actions
121+by using a `Migration`s over the `Terminally` `PQ` `IO` category.
90-}
122-}
91
123
92{-# LANGUAGE
124{-# LANGUAGE
93 DataKinds
125 DataKinds
126+ , DeriveGeneric
127+ , FlexibleContexts
128+ , FlexibleInstances
94 , GADTs
129 , GADTs
95 , LambdaCase
130 , LambdaCase
96− , PolyKinds
97 , OverloadedLabels
131 , OverloadedLabels
132+ , OverloadedStrings
133+ , PolyKinds
134+ , QuantifiedConstraints
135+ , RankNTypes
98 , TypeApplications
136 , TypeApplications
99− , FlexibleContexts
100 , TypeOperators
137 , TypeOperators
101#-}
138#-}
102
139
103module Squeal.PostgreSQL.Migration
140module Squeal.PostgreSQL.Migration
104 ( -- * Migration
141 ( -- * Migration
105 Migration (..)
142 Migration (..)
106− , migrateUp
143+ , Migratory (..)
107− , migrateDown
144+ , Terminally (..)
108− -- * Migration table
145+ , terminally
146+ , pureMigration
109 , MigrationsTable
147 , MigrationsTable
110− , createMigrations
148+ , defaultMain
111− , insertMigration
112− , deleteMigration
113− , selectMigration
114 ) where
149 ) where
115
150
151+import Control.Category
116import Control.Monad
152import Control.Monad
117−import Control.Monad.Base
153+import Data.ByteString (ByteString)
118−import Control.Monad.Trans.Control
119−import Data.Monoid
154+import Data.Foldable (traverse_)
120−import Generics.SOP (K(..))
121import Data.Function ((&))
155import Data.Function ((&))
156+import Data.List ((\\))
122import Data.Text (Text)
157import Data.Text (Text)
158+import Data.Time (UTCTime)
159+import Prelude hiding ((.), id)
160+import System.Environment
161+import UnliftIO (MonadIO (..))
162+
163+import qualified Data.Text.IO as Text (putStrLn)
164+import qualified Generics.SOP as SOP
165+import qualified GHC.Generics as GHC
123
166
124−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
125
182
183+-- | A `Migration` is a named "isomorphism" over a given category.
126−-- | A `Migration` should contain an inverse pair of
184+-- It should contain an inverse pair of `up` and `down`
127−-- `up` and `down` instructions and a unique `name`.
185+-- instructions and a unique `name`.
128−data Migration io schema0 schema1 = Migration
186+data Migration p schemas0 schemas1 = Migration
129 { name :: Text -- ^ The `name` of a `Migration`.
187 { name :: Text -- ^ The `name` of a `Migration`.
130 -- Each `name` in a `Migration` should be unique.
188 -- Each `name` in a `Migration` should be unique.
131− , up :: PQ schema0 schema1 io () -- ^ The `up` instruction of a `Migration`.
189+ , up :: p schemas0 schemas1 -- ^ The `up` instruction of a `Migration`.
132− , down :: PQ schema1 schema0 io () -- ^ The `down` instruction of a `Migration`.
190+ , down :: p schemas1 schemas0 -- ^ The `down` instruction of a `Migration`.
191+ } deriving (GHC.Generic)
192+
193+{- |
194+A `Migratory` @p@ is a `Category` for which one can execute or rewind
195+a `Path` of `Migration`s over @p@. This includes the category of pure
196+SQL `Definition`s and the category of impure `Terminally` `PQ` `IO` actions.
197+-}
198+class Category p => Migratory p where
199+
200+ {- |
201+ Run a `Path` of `Migration`s.
202+ Create the `MigrationsTable` as @public.schema_migrations@ if it does not already exist.
203+ In one transaction, for each each `Migration` query to see if the `Migration` has been executed;
204+ if not, `up` the `Migration` and insert its `name` in the `MigrationsTable`.
205+ -}
206+ migrateUp
207+ :: Path (Migration p) schemas0 schemas1
208+ -> PQ schemas0 schemas1 IO ()
209+
210+ {- |
211+ Rewind a `Path` of `Migration`s.
212+ Create the `MigrationsTable` as @public.schema_migrations@ if it does not already exist.
213+ In one transaction, for each each `Migration` query to see if the `Migration` has been executed;
214+ if so, `down` the `Migration` and delete its `name` in the `MigrationsTable`.
215+ -}
216+ migrateDown
217+ :: Path (Migration p) schemas0 schemas1
218+ -> PQ schemas1 schemas0 IO ()
219+
220+instance Migratory Definition where
221+ migrateUp = migrateUp . cmap pureMigration
222+ migrateDown = migrateDown . cmap pureMigration
223+
224+{- | `Terminally` turns an indexed monad transformer and the monad it transforms
225+into a category by restricting the return type to @()@ and permuting the type variables.
226+This is similar to how applying a monad to @()@ yields a monoid.
227+Since a `Terminally` action has a trivial return value, the only reason
228+to run one is for the side effects, in particular database and other IO effects.
229+-}
230+newtype Terminally trans monad x0 x1 = Terminally
231+ { runTerminally :: trans x0 x1 monad () }
232+ deriving GHC.Generic
233+
234+instance
235+ ( IndexedMonadTransPQ trans
236+ , Monad monad
237+ , forall x0 x1. x0 ~ x1 => Monad (trans x0 x1 monad) )
238+ => Category (Terminally trans monad) where
239+ id = Terminally (return ())
240+ Terminally g . Terminally f = Terminally $ pqThen g f
241+
242+-- | `terminally` ignores the output of a computation, returning @()@ and
243+-- wrapping it up into a `Terminally`. You can lift an action in the base monad
244+-- by using @terminally . lift@.
245+terminally
246+ :: Functor (trans x0 x1 monad)
247+ => trans x0 x1 monad ignore
248+ -> Terminally trans monad x0 x1
249+terminally = Terminally . void
250+
251+-- | A `pureMigration` turns a `Migration` involving only pure SQL
252+-- `Definition`s into a `Migration` that may be combined with arbitrary `IO`.
253+pureMigration
254+ :: Migration Definition schemas0 schemas1
255+ -> Migration (Terminally PQ IO) schemas0 schemas1
256+pureMigration migration = Migration
257+ { name = name migration
258+ , up = terminally . define $ up migration
259+ , down = terminally . define $ down migration
133 }
260 }
134
261
135−-- | Run `Migration`s by creating the `MigrationsTable`
262+instance Migratory (Terminally PQ IO) where
136−-- if it does not exist and then in a transaction, for each each `Migration`
137−-- query to see if the `Migration` is executed. If not, then
138−-- execute the `Migration` and insert its row in the `MigrationsTable`.
139−migrateUp
140− :: MonadBaseControl IO io
141− => AlignedList (Migration io) schema0 schema1 -- ^ migrations to run
142− -> PQ
143− ("schema_migrations" ::: 'Table MigrationsTable ': schema0)
144− ("schema_migrations" ::: 'Table MigrationsTable ': schema1)
145− io ()
146−migrateUp migration =
147− define createMigrations
148− & pqBind okResult
149− & pqThen (transactionallySchema_ (upMigrations migration))
150− where
151
263
152− upMigrations
264+ migrateUp migration = unsafePQ . transactionally_ $ do
153− :: MonadBaseControl IO io
265+ define createMigrations
154− => AlignedList (Migration io) schema0 schema1
266+ upMigrations migration
155− -> PQ
267+
156− ("schema_migrations" ::: 'Table MigrationsTable ': schema0)
268+ where
157− ("schema_migrations" ::: 'Table MigrationsTable ': schema1)
269+
158− io ()
270+ upMigrations
271+ :: Path (Migration (Terminally PQ IO)) schemas0 schemas1
272+ -> PQ MigrationsSchemas MigrationsSchemas IO ()
159− upMigrations = \case
273+ upMigrations = \case
160− Done -> return ()
274+ Done -> return ()
161− step :>> steps -> upMigration step & pqThen (upMigrations steps)
275+ step :>> steps -> upMigration step >> upMigrations steps
162−
276+
163− upMigration
277+ upMigration
164− :: MonadBase IO io
278+ :: Migration (Terminally PQ IO) schemas0 schemas1
165− => Migration io schema0 schema1 -> PQ
279+ -> PQ MigrationsSchemas MigrationsSchemas IO ()
166− ("schema_migrations" ::: 'Table MigrationsTable ': schema0)
167− ("schema_migrations" ::: 'Table MigrationsTable ': schema1)
168− io ()
169− upMigration step =
280+ upMigration step = do
170− queryExecuted step
281+ executed <- queryExecuted step
171− & pqBind (\ executed ->
282+ unless (executed == 1) $ do
172− if executed == 1 -- up step has already been executed
283+ unsafePQ . runTerminally $ up step
173− then PQ (\ _ -> return (K ())) -- unsafely switch schemas
174− else
175− pqEmbed (up step) -- safely switch schemas
176− & pqThen (manipulateParams insertMigration (Only (name step)))
284+ manipulateParams_ insertMigration (Only (name step))
177− -- insert execution record
285+
178− & pqBind okResult)
179−
180− queryExecuted
286+ queryExecuted
181− :: MonadBase IO io
287+ :: Migration (Terminally PQ IO) schemas0 schemas1
182− => Migration io schema0 schema1 -> PQ
288+ -> PQ MigrationsSchemas MigrationsSchemas IO Row
183− ("schema_migrations" ::: 'Table MigrationsTable ': schema0)
184− ("schema_migrations" ::: 'Table MigrationsTable ': schema0)
185− io Row
186− queryExecuted step = do
289+ queryExecuted step = do
187− result <- runQueryParams selectMigration (Only (name step))
290+ result <- runQueryParams selectMigration (Only (name step))
188− okResult result
189− ntuples result
291+ ntuples result
190−
292+
191−-- | Rewind `Migration`s by creating the `MigrationsTable`
293+ migrateDown migrations = unsafePQ . transactionally_ $ do
192−-- if it does not exist and then in a transaction, for each each `Migration`
193−-- query to see if the `Migration` is executed. If it is, then
194−-- rewind the `Migration` and delete its row in the `MigrationsTable`.
195−migrateDown
196− :: MonadBaseControl IO io
197− => AlignedList (Migration io) schema0 schema1 -- ^ migrations to rewind
198− -> PQ
199− ("schema_migrations" ::: 'Table MigrationsTable ': schema1)
200− ("schema_migrations" ::: 'Table MigrationsTable ': schema0)
201− io ()
202−migrateDown migrations =
203− define createMigrations
294+ define createMigrations
204− & pqBind okResult
205− & pqThen (transactionallySchema_ (downMigrations migrations))
295+ downMigrations migrations
296+
206− where
297+ where
207
298
208− downMigrations
299+ downMigrations
209− :: MonadBaseControl IO io
300+ :: Path (Migration (Terminally PQ IO)) schemas0 schemas1
210− => AlignedList (Migration io) schema0 schema1 -> PQ
301+ -> PQ MigrationsSchemas MigrationsSchemas IO ()
211− ("schema_migrations" ::: 'Table MigrationsTable ': schema1)
212− ("schema_migrations" ::: 'Table MigrationsTable ': schema0)
213− io ()
214− downMigrations = \case
302+ downMigrations = \case
215− Done -> return ()
303+ Done -> return ()
216− step :>> steps -> downMigrations steps & pqThen (downMigration step)
304+ step :>> steps -> downMigrations steps >> downMigration step
217−
305+
218− downMigration
306+ downMigration
219− :: MonadBase IO io
307+ :: Migration (Terminally PQ IO) schemas0 schemas1
220− => Migration io schema0 schema1 -> PQ
308+ -> PQ MigrationsSchemas MigrationsSchemas IO ()
221− ("schema_migrations" ::: 'Table MigrationsTable ': schema1)
222− ("schema_migrations" ::: 'Table MigrationsTable ': schema0)
223− io ()
224− downMigration step =
309+ downMigration step = do
225− queryExecuted step
310+ executed <- queryExecuted step
226− & pqBind (\ executed ->
311+ unless (executed == 0) $ do
227− if executed == 0 -- up step has not been executed
312+ unsafePQ . runTerminally $ down step
228− then PQ (\ _ -> return (K ())) -- unsafely switch schemas
229− else
230− pqEmbed (down step) -- safely switch schemas
231− & pqThen (manipulateParams deleteMigration (Only (name step)))
313+ manipulateParams_ deleteMigration (Only (name step))
232− -- delete execution record
314+
233− & pqBind okResult)
234−
235− queryExecuted
315+ queryExecuted
236− :: MonadBase IO io
316+ :: Migration (Terminally PQ IO) schemas0 schemas1
237− => Migration io schema0 schema1 -> PQ
317+ -> PQ MigrationsSchemas MigrationsSchemas IO Row
238− ("schema_migrations" ::: 'Table MigrationsTable ': schema1)
239− ("schema_migrations" ::: 'Table MigrationsTable ': schema1)
240− io Row
241− queryExecuted step = do
318+ queryExecuted step = do
242− result <- runQueryParams selectMigration (Only (name step))
319+ result <- runQueryParams selectMigration (Only (name step))
243− okResult result
244− ntuples result
320+ ntuples result
245−
321+
246−okResult :: MonadBase IO io => K Result results -> PQ schema schema io ()
322+unsafePQ :: (Functor m) => PQ db0 db1 m x -> PQ db0' db1' m x
247−okResult result = do
323+unsafePQ (PQ pq) = PQ $ fmap (SOP.K . SOP.unK) . pq . SOP.K . SOP.unK
248− status <- resultStatus result
249− when (not (status `elem` [CommandOk, TuplesOk])) $ do
250− errorMessageMaybe <- resultErrorMessage result
251− case errorMessageMaybe of
252− Nothing -> error "migrateDown: unknown error"
253− Just msg -> error ("migrationDown: " <> show msg)
254
324
255-- | The `TableType` for a Squeal migration.
325-- | The `TableType` for a Squeal migration.
256type MigrationsTable =
326type MigrationsTable =
@@ -259,10 +329,19 @@ type MigrationsTable =
259 , "executed_at" ::: 'Def :=> 'NotNull 'PGtimestamptz
329 , "executed_at" ::: 'Def :=> 'NotNull 'PGtimestamptz
260 ]
330 ]
261
331
332+data MigrationRow =
333+ MigrationRow { migrationName :: Text
334+ , migrationTime :: UTCTime }
335+ deriving (GHC.Generic, Show)
336+
337+instance SOP.Generic MigrationRow
338+instance SOP.HasDatatypeInfo MigrationRow
339+
340+type MigrationsSchema = '["schema_migrations" ::: 'Table MigrationsTable]
341+type MigrationsSchemas = Public MigrationsSchema
342+
262-- | Creates a `MigrationsTable` if it does not already exist.
343-- | Creates a `MigrationsTable` if it does not already exist.
263−createMigrations
344+createMigrations :: Definition MigrationsSchemas MigrationsSchemas
264− :: Has "schema_migrations" schema ('Table MigrationsTable)
265− => Definition schema schema
266createMigrations =
345createMigrations =
267 createTableIfNotExists #schema_migrations
346 createTableIfNotExists #schema_migrations
268 ( (text & notNullable) `as` #name :*
347 ( (text & notNullable) `as` #name :*
@@ -270,27 +349,100 @@ createMigrations =
270 `as` #executed_at )
349 `as` #executed_at )
271 ( unique #name `as` #migrations_unique_name )
350 ( unique #name `as` #migrations_unique_name )
272
351
273−-- | Inserts a `Migration` into the `MigrationsTable`
352+-- | Inserts a `Migration` into the `MigrationsTable`, returning
274−insertMigration
353+-- the time at which it was inserted.
275− :: Has "schema_migrations" schema ('Table MigrationsTable)
354+insertMigration :: Manipulation_ MigrationsSchemas (Only Text) ()
276− => Manipulation schema '[ 'NotNull 'PGtext] '[]
277−insertMigration = insertRow_ #schema_migrations
355+insertMigration = insertInto_ #schema_migrations
278− ( Set (param @1) `as` #name :*
279− Default `as` #executed_at )
356+ (Values_ (Set (param @1) `as` #name :* Default `as` #executed_at))
280−
357+
281−-- | Deletes a `Migration` from the `MigrationsTable`
358+-- | Deletes a `Migration` from the `MigrationsTable`, returning
359+-- the time at which it was inserted.
282−deleteMigration
360+deleteMigration :: Manipulation_ MigrationsSchemas (Only Text) ()
283− :: Has "schema_migrations" schema ('Table MigrationsTable)
284− => Manipulation schema '[ 'NotNull 'PGtext ] '[]
285deleteMigration = deleteFrom_ #schema_migrations (#name .== param @1)
361deleteMigration = deleteFrom_ #schema_migrations (#name .== param @1)
286
362
287-- | Selects a `Migration` from the `MigrationsTable`, returning
363-- | Selects a `Migration` from the `MigrationsTable`, returning
288−-- the time at which it was executed.
364+-- the time at which it was inserted.
289selectMigration
365selectMigration
290− :: Has "schema_migrations" schema ('Table MigrationsTable)
366+ :: Query_ MigrationsSchemas (Only Text) (Only UTCTime)
291− => Query schema '[ 'NotNull 'PGtext ]
292− '[ "executed_at" ::: 'NotNull 'PGtimestamptz ]
293−selectMigration = select
367+selectMigration = select_ (#executed_at `as` #fromOnly)
294− (#executed_at `as` #executed_at)
295− ( from (table (#schema_migrations `as` #m))
368+ $ from (table (#schema_migrations))
296− & where_ (#name .== param @1))
369+ & where_ (#name .== param @1)
370+
371+selectMigrations :: Query_ MigrationsSchemas () MigrationRow
372+selectMigrations = select_
373+ (#name `as` #migrationName :* #executed_at `as` #migrationTime)
374+ (from (table #schema_migrations))
375+
376+data MigrateCommand
377+ = MigrateStatus
378+ | MigrateUp
379+ | MigrateDown deriving (GHC.Generic, Show)
380+
381+{- | `defaultMain` creates a simple executable
382+from a connection string and a list of `Migration`s. -}
383+defaultMain
384+ :: Migratory p
385+ => ByteString
386+ -- ^ connection string
387+ -> Path (Migration p) db0 db1
388+ -- ^ migrations
389+ -> IO ()
390+defaultMain connectTo migrations = do
391+ command <- readCommandFromArgs
392+ maybe (pure ()) performCommand command
393+
394+ where
395+
396+ performCommand :: MigrateCommand -> IO ()
397+ performCommand = \case
398+ MigrateStatus -> withConnection connectTo $
399+ suppressNotices >> migrateStatus
400+ MigrateUp -> withConnection connectTo $
401+ suppressNotices & pqThen (migrateUp migrations) & pqThen migrateStatus
402+ MigrateDown -> withConnection connectTo $
403+ suppressNotices & pqThen (migrateDown migrations) & pqThen migrateStatus
404+
405+ migrateStatus :: PQ schema schema IO ()
406+ migrateStatus = unsafePQ $ do
407+ runNames <- getRunMigrationNames
408+ let names = ctoList name migrations
409+ unrunNames = names \\ runNames
410+ liftIO $ displayRunned runNames >> displayUnrunned unrunNames
411+
412+ suppressNotices :: PQ schema schema IO ()
413+ suppressNotices = manipulate_ $
414+ UnsafeManipulation "SET client_min_messages TO WARNING;"
415+
416+ readCommandFromArgs :: IO (Maybe MigrateCommand)
417+ readCommandFromArgs = getArgs >>= \case
418+ ["migrate"] -> pure . Just $ MigrateUp
419+ ["rollback"] -> pure . Just $ MigrateDown
420+ ["status"] -> pure . Just $ MigrateStatus
421+ args -> displayUsage args >> pure Nothing
422+
423+ displayUsage :: [String] -> IO ()
424+ displayUsage args = do
425+ putStrLn $ "Invalid command: \"" <> unwords args <> "\". Use:"
426+ putStrLn "migrate to run all available migrations"
427+ putStrLn "rollback to rollback all available migrations"
428+ putStrLn "status to display migrations run and migrations left to run"
429+
430+ getRunMigrationNames :: (MonadIO m) => PQ db0 db0 m [Text]
431+ getRunMigrationNames =
432+ fmap migrationName <$> (unsafePQ (define createMigrations & pqThen (runQuery selectMigrations)) >>= getRows)
433+
434+ displayListOfNames :: [Text] -> IO ()
435+ displayListOfNames [] = Text.putStrLn " None"
436+ displayListOfNames xs =
437+ let singleName n = Text.putStrLn $ " - " <> n
438+ in traverse_ singleName xs
439+
440+ displayUnrunned :: [Text] -> IO ()
441+ displayUnrunned unrunned =
442+ Text.putStrLn "Migrations left to run:"
443+ >> displayListOfNames unrunned
444+
445+ displayRunned :: [Text] -> IO ()
446+ displayRunned runned =
447+ Text.putStrLn "Migrations already run:"
448+ >> displayListOfNames runned
squeal-postgresql/src/Squeal/PostgreSQL/PG.hsnew file+388
@@ -0,0 +1,388 @@
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+-}
11+{-# LANGUAGE
12+ AllowAmbiguousTypes
13+ , DeriveAnyClass
14+ , DeriveFoldable
15+ , DeriveFunctor
16+ , DeriveGeneric
17+ , DeriveTraversable
18+ , DerivingStrategies
19+ , DefaultSignatures
20+ , FlexibleContexts
21+ , FlexibleInstances
22+ , FunctionalDependencies
23+ , GADTs
24+ , LambdaCase
25+ , MultiParamTypeClasses
26+ , OverloadedStrings
27+ , ScopedTypeVariables
28+ , TypeApplications
29+ , TypeFamilies
30+ , TypeInType
31+ , TypeOperators
32+ , UndecidableInstances
33+ , UndecidableSuperClasses
34+#-}
35+
36+module Squeal.PostgreSQL.PG
37+ ( -- * PG embeddings
38+ PG
39+ , NullPG
40+ , TuplePG
41+ , RowPG
42+ -- * Storage newtypes
43+ , Money (..)
44+ , Json (..)
45+ , Jsonb (..)
46+ , Composite (..)
47+ , Enumerated (..)
48+ , VarArray (..)
49+ , FixArray (..)
50+ , LibPQ.Oid (..)
51+ -- * Type families
52+ , LabelsPG
53+ , DimPG
54+ , FixPG
55+ , TupleOf
56+ , TupleCodeOf
57+ , RowOf
58+ , ConstructorsOf
59+ , ConstructorNameOf
60+ , ConstructorNamesOf
61+ ) where
62+
63+import Data.Aeson (Value)
64+import Data.Kind (Type)
65+import Data.Int (Int16, Int32, Int64)
66+import Data.Scientific (Scientific)
67+import Data.Time (Day, DiffTime, LocalTime, TimeOfDay, TimeZone, UTCTime)
68+import Data.Vector (Vector)
69+import Data.UUID.Types (UUID)
70+import GHC.TypeLits
71+import Network.IP.Addr (NetAddr, IP)
72+
73+import qualified Data.ByteString.Lazy as Lazy (ByteString)
74+import qualified Data.ByteString as Strict (ByteString)
75+import qualified Data.Text.Lazy as Lazy (Text)
76+import qualified Data.Text as Strict (Text)
77+import qualified Database.PostgreSQL.LibPQ as LibPQ
78+import qualified GHC.Generics as GHC
79+import qualified Generics.SOP as SOP
80+import qualified Generics.SOP.Record as SOP
81+import qualified Generics.SOP.Type.Metadata as Type
82+
83+import Squeal.PostgreSQL.Alias
84+import Squeal.PostgreSQL.Schema
85+
86+-- $setup
87+-- >>> import Squeal.PostgreSQL
88+-- >>> import Data.Text (Text)
89+
90+{- | The `PG` type family embeds a subset of Haskell types
91+as Postgres types. As an open type family, `PG` is extensible.
92+
93+>>> :kind! PG LocalTime
94+PG LocalTime :: PGType
95+= 'PGtimestamp
96+
97+>>> newtype MyDouble = My Double
98+>>> :set -XTypeFamilies
99+>>> type instance PG MyDouble = 'PGfloat8
100+-}
101+type family PG (hask :: Type) :: PGType
102+-- | `PGbool`
103+type instance PG Bool = 'PGbool
104+-- | `PGint2`
105+type instance PG Int16 = 'PGint2
106+-- | `PGint4`
107+type instance PG Int32 = 'PGint4
108+-- | `PGint8`
109+type instance PG Int64 = 'PGint8
110+-- | `PGint2`
111+type instance PG LibPQ.Oid = 'PGoid
112+-- | `PGnumeric`
113+type instance PG Scientific = 'PGnumeric
114+-- | `PGfloat4`
115+type instance PG Float = 'PGfloat4
116+-- | `PGfloat8`
117+type instance PG Double = 'PGfloat8
118+-- | `PGchar` @1@
119+type instance PG Char = 'PGchar 1
120+-- | `PGtext`
121+type instance PG Strict.Text = 'PGtext
122+-- | `PGtext`
123+type instance PG Lazy.Text = 'PGtext
124+-- | `PGtext`
125+type instance PG String = 'PGtext
126+-- | `PGbytea`
127+type instance PG Strict.ByteString = 'PGbytea
128+-- | `PGbytea`
129+type instance PG Lazy.ByteString = 'PGbytea
130+-- | `PGtimestamp`
131+type instance PG LocalTime = 'PGtimestamp
132+-- | `PGtimestamptz`
133+type instance PG UTCTime = 'PGtimestamptz
134+-- | `PGdate`
135+type instance PG Day = 'PGdate
136+-- | `PGtime`
137+type instance PG TimeOfDay = 'PGtime
138+-- | `PGtimetz`
139+type instance PG (TimeOfDay, TimeZone) = 'PGtimetz
140+-- | `PGinterval`
141+type instance PG DiffTime = 'PGinterval
142+-- | `PGuuid`
143+type instance PG UUID = 'PGuuid
144+-- | `PGinet`
145+type instance PG (NetAddr IP) = 'PGinet
146+-- | `PGjson`
147+type instance PG Value = 'PGjson
148+
149+{-| The `LabelsPG` type family calculates the constructors of a
150+Haskell enum type.
151+
152+>>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic
153+>>> instance SOP.Generic Schwarma
154+>>> instance SOP.HasDatatypeInfo Schwarma
155+>>> :kind! LabelsPG Schwarma
156+LabelsPG Schwarma :: [Type.ConstructorName]
157+= '["Beef", "Lamb", "Chicken"]
158+-}
159+type family LabelsPG (hask :: Type) :: [Type.ConstructorName] where
160+ LabelsPG hask =
161+ ConstructorNamesOf (ConstructorsOf (SOP.DatatypeInfoOf hask))
162+
163+{- |
164+`RowPG` turns a Haskell `Type` into a `RowType`.
165+
166+`RowPG` may be applied to normal Haskell record types provided they
167+have `SOP.Generic` and `SOP.HasDatatypeInfo` instances;
168+
169+>>> data Person = Person { name :: Strict.Text, age :: Int32 } deriving GHC.Generic
170+>>> instance SOP.Generic Person
171+>>> instance SOP.HasDatatypeInfo Person
172+>>> :kind! RowPG Person
173+RowPG Person :: [(Symbol, NullityType)]
174+= '["name" ::: 'NotNull 'PGtext, "age" ::: 'NotNull 'PGint4]
175+-}
176+type family RowPG (hask :: Type) :: RowType where
177+ RowPG hask = RowOf (SOP.RecordCodeOf hask)
178+
179+-- | `RowOf` applies `NullPG` to the fields of a list.
180+type family RowOf (record :: [(Symbol, Type)]) :: RowType where
181+ RowOf (col ::: ty ': col1 ::: ty1 ': col2 ::: ty2 ': col3 ::: ty3 ': col4 ::: ty4 ': record) =
182+ col ::: NullPG ty ': col1 ::: NullPG ty1 ': col2 ::: NullPG ty2 ': col3 ::: NullPG ty3 ': col4 ::: NullPG ty4 ': RowOf record
183+ RowOf (col ::: ty ': col1 ::: ty1 ': col2 ::: ty2 ': col3 ::: ty3 ': record) =
184+ col ::: NullPG ty ': col1 ::: NullPG ty1 ': col2 ::: NullPG ty2 ': col3 ::: NullPG ty3 ': RowOf record
185+ RowOf (col ::: ty ': col1 ::: ty1 ': col2 ::: ty2 ': record) =
186+ col ::: NullPG ty ': col1 ::: NullPG ty1 ': col2 ::: NullPG ty2 ': RowOf record
187+ RowOf (col ::: ty ': col1 ::: ty1 ': record) =
188+ col ::: NullPG ty ': col1::: NullPG ty1 ': RowOf record
189+ RowOf (col ::: ty ': record) = col ::: NullPG ty ': RowOf record
190+ RowOf '[] = '[]
191+
192+{- | `NullPG` turns a Haskell type into a `NullityType`.
193+
194+>>> :kind! NullPG Double
195+NullPG Double :: NullityType
196+= 'NotNull 'PGfloat8
197+>>> :kind! NullPG (Maybe Double)
198+NullPG (Maybe Double) :: NullityType
199+= 'Null 'PGfloat8
200+-}
201+type family NullPG (hask :: Type) :: NullityType where
202+ NullPG (Maybe hask) = 'Null (PG hask)
203+ NullPG hask = 'NotNull (PG hask)
204+
205+{- | `TuplePG` turns a Haskell tuple type (including record types) into
206+the corresponding list of `NullityType`s.
207+
208+>>> :kind! TuplePG (Double, Maybe Char)
209+TuplePG (Double, Maybe Char) :: [NullityType]
210+= '[ 'NotNull 'PGfloat8, 'Null ('PGchar 1)]
211+-}
212+type family TuplePG (hask :: Type) :: [NullityType] where
213+ TuplePG hask = TupleOf (TupleCodeOf hask (SOP.Code hask))
214+
215+-- | `TupleOf` turns a list of Haskell `Type`s into a list of `NullityType`s.
216+type family TupleOf (tuple :: [Type]) :: [NullityType] where
217+ TupleOf (hask ': hask1 ': hask2 ': hask3 ': hask4 ': hask5 ': tuple) =
218+ NullPG hask ': NullPG hask1 ': NullPG hask2 ': NullPG hask3 ': NullPG hask4 ': NullPG hask5 ': TupleOf tuple
219+ TupleOf (hask ': hask1 ': hask2 ': hask3 ': hask4 ': tuple) =
220+ NullPG hask ': NullPG hask1 ': NullPG hask2 ': NullPG hask3 ': NullPG hask4 ': TupleOf tuple
221+ TupleOf (hask ': hask1 ': hask2 ': hask3 ': tuple) =
222+ NullPG hask ': NullPG hask1 ': NullPG hask2 ': NullPG hask3 ': TupleOf tuple
223+ TupleOf (hask ': hask1 ': hask2 ': tuple) =
224+ NullPG hask ': NullPG hask1 ': NullPG hask2 ': TupleOf tuple
225+ TupleOf (hask ': hask1 ': tuple) = NullPG hask ': NullPG hask1 ': TupleOf tuple
226+ TupleOf (hask ': tuple) = NullPG hask ': TupleOf tuple
227+ TupleOf '[] = '[]
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`.
231+type family TupleCodeOf (hask :: Type) (code :: [[Type]]) :: [Type] where
232+ TupleCodeOf hask '[tuple] = tuple
233+ TupleCodeOf hask '[] =
234+ TypeError
235+ ( 'Text "The type `" ':<>: 'ShowType hask ':<>: 'Text "' is not a tuple type."
236+ ':$$: 'Text "It is a void type with no constructors."
237+ )
238+ TupleCodeOf hask (_ ': _ ': _) =
239+ TypeError
240+ ( 'Text "The type `" ':<>: 'ShowType hask ':<>: 'Text "' is not a tuple type."
241+ ':$$: 'Text "It is a sum type with more than one constructor."
242+ )
243+
244+-- | Calculates constructors of a datatype.
245+type family ConstructorsOf (datatype :: Type.DatatypeInfo)
246+ :: [Type.ConstructorInfo] where
247+ ConstructorsOf ('Type.ADT _module _datatype constructors) =
248+ constructors
249+ ConstructorsOf ('Type.Newtype _module _datatype constructor) =
250+ '[constructor]
251+
252+-- | Calculates the name of a nullary constructor, otherwise
253+-- generates a type error.
254+type family ConstructorNameOf (constructor :: Type.ConstructorInfo)
255+ :: Type.ConstructorName where
256+ ConstructorNameOf ('Type.Constructor name) = name
257+ ConstructorNameOf ('Type.Infix name _assoc _fix) = TypeError
258+ ('Text "ConstructorNameOf error: non-nullary constructor "
259+ ':<>: 'Text name)
260+ ConstructorNameOf ('Type.Record name _fields) = TypeError
261+ ('Text "ConstructorNameOf error: non-nullary constructor "
262+ ':<>: 'Text name)
263+
264+-- | Calculate the names of nullary constructors.
265+type family ConstructorNamesOf (constructors :: [Type.ConstructorInfo])
266+ :: [Type.ConstructorName] where
267+ ConstructorNamesOf '[] = '[]
268+ ConstructorNamesOf (constructor ': constructors) =
269+ ConstructorNameOf constructor ': ConstructorNamesOf constructors
270+
271+-- | `DimPG` turns Haskell nested homogeneous tuples into a list of lengths.
272+type family DimPG (hask :: Type) :: [Nat] where
273+ DimPG (x,x) = 2 ': DimPG x
274+ DimPG (x,x,x) = 3 ': DimPG x
275+ DimPG (x,x,x,x) = 4 ': DimPG x
276+ DimPG (x,x,x,x,x) = 5 ': DimPG x
277+ DimPG (x,x,x,x,x,x) = 6 ': DimPG x
278+ DimPG (x,x,x,x,x,x,x) = 7 ': DimPG x
279+ DimPG (x,x,x,x,x,x,x,x) = 8 ': DimPG x
280+ DimPG (x,x,x,x,x,x,x,x,x) = 9 ': DimPG x
281+ DimPG (x,x,x,x,x,x,x,x,x,x) = 10 ': DimPG x
282+ DimPG x = '[]
283+
284+-- | `FixPG` extracts `NullPG` of the base type of nested homogeneous tuples.
285+type family FixPG (hask :: Type) :: NullityType where
286+ FixPG (x,x) = FixPG x
287+ FixPG (x,x,x) = FixPG x
288+ FixPG (x,x,x,x) = FixPG x
289+ FixPG (x,x,x,x,x) = FixPG x
290+ FixPG (x,x,x,x,x,x) = FixPG x
291+ FixPG (x,x,x,x,x,x,x) = FixPG x
292+ FixPG (x,x,x,x,x,x,x,x) = FixPG x
293+ FixPG (x,x,x,x,x,x,x,x,x) = FixPG x
294+ FixPG (x,x,x,x,x,x,x,x,x,x) = FixPG x
295+ FixPG (x,x,x,x,x,x,x,x,x,x,x) = FixPG x
296+ FixPG x = NullPG x
297+
298+{- | The `Money` newtype stores a monetary value in terms
299+of the number of cents, i.e. @$2,000.20@ would be expressed as
300+@Money { cents = 200020 }@.
301+
302+>>> import Control.Monad (void)
303+>>> import Control.Monad.IO.Class (liftIO)
304+>>> import Squeal.PostgreSQL
305+>>> :{
306+let
307+ roundTrip :: Query_ (Public '[]) (Only Money) (Only Money)
308+ roundTrip = values_ $ parameter @1 money `as` #fromOnly
309+:}
310+
311+>>> let input = Only (Money 20020)
312+
313+>>> :{
314+withConnection "host=localhost port=5432 dbname=exampledb" $ do
315+ result <- runQueryParams roundTrip input
316+ Just output <- firstRow result
317+ liftIO . print $ input == output
318+:}
319+True
320+-}
321+newtype Money = Money { cents :: Int64 }
322+ deriving stock (Eq, Ord, Show, Read, GHC.Generic)
323+ deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
324+-- | `PGmoney`
325+type instance PG Money = 'PGmoney
326+
327+{- | The `Json` newtype is an indication that the Haskell
328+type it's applied to should be stored as a `PGjson`.
329+-}
330+newtype Json hask = Json {getJson :: hask}
331+ deriving stock (Eq, Ord, Show, Read, GHC.Generic)
332+ deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
333+-- | `PGjson`
334+type instance PG (Json hask) = 'PGjson
335+
336+{- | The `Jsonb` newtype is an indication that the Haskell
337+type it's applied to should be stored as a `PGjsonb`.
338+-}
339+newtype Jsonb hask = Jsonb {getJsonb :: hask}
340+ deriving stock (Eq, Ord, Show, Read, GHC.Generic)
341+ deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
342+-- | `PGjsonb`
343+type instance PG (Jsonb hask) = 'PGjsonb
344+
345+{- | The `Composite` newtype is an indication that the Haskell
346+type it's applied to should be stored as a `PGcomposite`.
347+-}
348+newtype Composite record = Composite {getComposite :: record}
349+ deriving stock (Eq, Ord, Show, Read, GHC.Generic)
350+ deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
351+-- | `PGcomposite` @(@`RowPG` @hask)@
352+type instance PG (Composite hask) = 'PGcomposite (RowPG hask)
353+
354+{- | The `Enumerated` newtype is an indication that the Haskell
355+type it's applied to should be stored as a `PGenum`.
356+-}
357+newtype Enumerated enum = Enumerated {getEnumerated :: enum}
358+ deriving stock (Eq, Ord, Show, Read, GHC.Generic)
359+ deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
360+-- | `PGenum` @(@`LabelsPG` @hask)@
361+type instance PG (Enumerated hask) = 'PGenum (LabelsPG hask)
362+
363+{- | The `VarArray` newtype is an indication that the Haskell
364+type 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)
369+-}
370+newtype VarArray arr = VarArray {getVarArray :: arr}
371+ deriving stock (Eq, Ord, Show, Read, GHC.Generic)
372+ deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
373+-- | `PGvararray` @(@`NullPG` @hask)@
374+type instance PG (VarArray (Vector hask)) = 'PGvararray (NullPG hask)
375+type instance PG (VarArray [hask]) = 'PGvararray (NullPG hask)
376+
377+{- | The `FixArray` newtype is an indication that the Haskell
378+type 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)
383+-}
384+newtype FixArray arr = FixArray {getFixArray :: arr}
385+ deriving stock (Eq, Ord, Show, Read, GHC.Generic)
386+ deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
387+-- | `PGfixarray` @(@`DimPG` @hask) (@`FixPG` @hask)@
388+type instance PG (FixArray hask) = 'PGfixarray (DimPG hask) (FixPG hask)
squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs+233−192
@@ -6,12 +6,12 @@ Maintainer: eitan@morphism.tech
6Stability: experimental
6Stability: experimental
7
7
8This module is where Squeal commands actually get executed by
8This module is where Squeal commands actually get executed by
9−`LibPQ`. It containts two typeclasses, `IndexedMonadTransPQ` for executing
9+`Database.PostgreSQL.LibPQ`. It containts two typeclasses, `IndexedMonadTransPQ` for executing
10a `Definition` and `MonadPQ` for executing a `Manipulation` or `Query`,
10a `Definition` and `MonadPQ` for executing a `Manipulation` or `Query`,
11and a `PQ` type with instances for them.
11and a `PQ` type with instances for them.
12
12
13Using Squeal in your application will come down to defining
13Using Squeal in your application will come down to defining
14−the @schema@ of your database and including @PQ schema schema@ in your
14+the @schemas@ of your database and including @PQ schemas schemas@ in your
15application's monad transformer stack, giving it an instance of `MonadPQ`.
15application's monad transformer stack, giving it an instance of `MonadPQ`.
16
16
17This module also provides functions for retrieving rows from the `LibPQ.Result`
17This module also provides functions for retrieving rows from the `LibPQ.Result`
@@ -24,6 +24,7 @@ of executing Squeal commands.
24 , FunctionalDependencies
24 , FunctionalDependencies
25 , FlexibleContexts
25 , FlexibleContexts
26 , FlexibleInstances
26 , FlexibleInstances
27+ , InstanceSigs
27 , OverloadedStrings
28 , OverloadedStrings
28 , RankNTypes
29 , RankNTypes
29 , ScopedTypeVariables
30 , ScopedTypeVariables
@@ -48,8 +49,6 @@ module Squeal.PostgreSQL.PQ
48 , evalPQ
49 , evalPQ
49 , IndexedMonadTransPQ (..)
50 , IndexedMonadTransPQ (..)
50 , MonadPQ (..)
51 , MonadPQ (..)
51− , PQRun
52− , pqliftWith
53 -- * Results
52 -- * Results
54 , LibPQ.Result
53 , LibPQ.Result
55 , LibPQ.Row
54 , LibPQ.Row
@@ -65,26 +64,30 @@ module Squeal.PostgreSQL.PQ
65 , resultErrorCode
64 , resultErrorCode
66 -- * Exceptions
65 -- * Exceptions
67 , SquealException (..)
66 , SquealException (..)
67+ , PQState (..)
68+ , okResult
68 , catchSqueal
69 , catchSqueal
69 , handleSqueal
70 , handleSqueal
71+ , trySqueal
70 ) where
72 ) where
71
73
72−import Control.Exception.Lifted
74+import Control.Exception (Exception, throw)
73−import Control.Monad.Base
74import Control.Monad.Except
75import Control.Monad.Except
75import Control.Monad.Morph
76import Control.Monad.Morph
76−import Control.Monad.Trans.Control
77+import UnliftIO (MonadUnliftIO (..), bracket, catch, handle, try)
77import Data.ByteString (ByteString)
78import Data.ByteString (ByteString)
78import Data.Foldable
79import Data.Foldable
79import Data.Function ((&))
80import Data.Function ((&))
81+import Data.Functor ((<&>))
80import Data.Kind
82import Data.Kind
81−import Data.Monoid
82import Data.Text (pack, Text)
83import Data.Text (pack, Text)
83import Data.Traversable
84import Data.Traversable
84import Generics.SOP
85import Generics.SOP
85import PostgreSQL.Binary.Encoding (encodingBytes)
86import PostgreSQL.Binary.Encoding (encodingBytes)
86
87
88+import qualified Control.Monad.Fail as Fail
87import qualified Database.PostgreSQL.LibPQ as LibPQ
89import qualified Database.PostgreSQL.LibPQ as LibPQ
90+import qualified PostgreSQL.Binary.Encoding as Encoding
88
91
89import Squeal.PostgreSQL.Binary
92import Squeal.PostgreSQL.Binary
90import Squeal.PostgreSQL.Definition
93import Squeal.PostgreSQL.Definition
@@ -97,7 +100,6 @@ import Control.Monad.Trans.Identity
97import Control.Monad.Trans.Reader
100import Control.Monad.Trans.Reader
98import Control.Monad.Trans.Maybe
101import Control.Monad.Trans.Maybe
99import Control.Monad.Trans.Cont
102import Control.Monad.Trans.Cont
100−import Control.Monad.Trans.List
101
103
102import qualified Control.Monad.Trans.State.Lazy as Lazy
104import qualified Control.Monad.Trans.State.Lazy as Lazy
103import qualified Control.Monad.Trans.State.Strict as Strict
105import qualified Control.Monad.Trans.State.Strict as Strict
@@ -106,6 +108,9 @@ import qualified Control.Monad.Trans.Writer.Strict as Strict
106import qualified Control.Monad.Trans.RWS.Lazy as Lazy
108import qualified Control.Monad.Trans.RWS.Lazy as Lazy
107import qualified Control.Monad.Trans.RWS.Strict as Strict
109import qualified Control.Monad.Trans.RWS.Strict as Strict
108
110
111+-- $setup
112+-- >>> import Squeal.PostgreSQL
113+
109{- | Makes a new connection to the database server.
114{- | Makes a new connection to the database server.
110
115
111This function opens a new database connection using the parameters taken
116This function opens a new database connection using the parameters taken
@@ -132,22 +137,22 @@ Note that, for now, squeal doesn't offer any protection from connecting
132with the wrong schema!
137with the wrong schema!
133-}
138-}
134connectdb
139connectdb
135− :: forall schema io
140+ :: forall schemas io
136− . MonadBase IO io
141+ . MonadIO io
137 => ByteString -- ^ conninfo
142 => ByteString -- ^ conninfo
138− -> io (K LibPQ.Connection schema)
143+ -> io (K LibPQ.Connection schemas)
139−connectdb = fmap K . liftBase . LibPQ.connectdb
144+connectdb = fmap K . liftIO . LibPQ.connectdb
140
145
141-- | Closes the connection to the server.
146-- | Closes the connection to the server.
142−finish :: MonadBase IO io => K LibPQ.Connection schema -> io ()
147+finish :: MonadIO io => K LibPQ.Connection schemas -> io ()
143−finish = liftBase . LibPQ.finish . unK
148+finish = liftIO . LibPQ.finish . unK
144
149
145-- | Do `connectdb` and `finish` before and after a computation.
150-- | Do `connectdb` and `finish` before and after a computation.
146withConnection
151withConnection
147− :: forall schema0 schema1 io x
152+ :: forall schemas0 schemas1 io x
148− . MonadBaseControl IO io
153+ . MonadUnliftIO io
149 => ByteString
154 => ByteString
150− -> PQ schema0 schema1 io x
155+ -> PQ schemas0 schemas1 io x
151 -> io x
156 -> io x
152withConnection connString action = do
157withConnection connString action = do
153 K x <- bracket (connectdb connString) finish (unPQ action)
158 K x <- bracket (connectdb connString) finish (unPQ action)
@@ -155,47 +160,47 @@ withConnection connString action = do
155
160
156-- | Safely `lowerConnection` to a smaller schema.
161-- | Safely `lowerConnection` to a smaller schema.
157lowerConnection
162lowerConnection
158− :: K LibPQ.Connection (table ': schema)
163+ :: K LibPQ.Connection (schema ': schemas)
159− -> K LibPQ.Connection schema
164+ -> K LibPQ.Connection schemas
160lowerConnection (K conn) = K conn
165lowerConnection (K conn) = K conn
161
166
162-- | We keep track of the schema via an Atkey indexed state monad transformer,
167-- | We keep track of the schema via an Atkey indexed state monad transformer,
163-- `PQ`.
168-- `PQ`.
164newtype PQ
169newtype PQ
165− (schema0 :: SchemaType)
170+ (schemas0 :: SchemasType)
166− (schema1 :: SchemaType)
171+ (schemas1 :: SchemasType)
167 (m :: Type -> Type)
172 (m :: Type -> Type)
168 (x :: Type) =
173 (x :: Type) =
169− PQ { unPQ :: K LibPQ.Connection schema0 -> m (K x schema1) }
174+ PQ { unPQ :: K LibPQ.Connection schemas0 -> m (K x schemas1) }
170
175
171−instance Monad m => Functor (PQ schema0 schema1 m) where
176+instance Monad m => Functor (PQ schemas0 schemas1 m) where
172 fmap f (PQ pq) = PQ $ \ conn -> do
177 fmap f (PQ pq) = PQ $ \ conn -> do
173 K x <- pq conn
178 K x <- pq conn
174 return $ K (f x)
179 return $ K (f x)
175
180
176−-- | Run a `PQ` and keep the result and the `Connection`.
181+-- | Run a `PQ` and keep the result and the `LibPQ.Connection`.
177runPQ
182runPQ
178 :: Functor m
183 :: Functor m
179− => PQ schema0 schema1 m x
184+ => PQ schemas0 schemas1 m x
180− -> K LibPQ.Connection schema0
185+ -> K LibPQ.Connection schemas0
181− -> m (x, K LibPQ.Connection schema1)
186+ -> m (x, K LibPQ.Connection schemas1)
182runPQ (PQ pq) conn = (\ x -> (unK x, K (unK conn))) <$> pq conn
187runPQ (PQ pq) conn = (\ x -> (unK x, K (unK conn))) <$> pq conn
183 -- K x <- pq conn
188 -- K x <- pq conn
184 -- return (x, K (unK conn))
189 -- return (x, K (unK conn))
185
190
186−-- | Execute a `PQ` and discard the result but keep the `Connection`.
191+-- | Execute a `PQ` and discard the result but keep the `LibPQ.Connection`.
187execPQ
192execPQ
188 :: Functor m
193 :: Functor m
189− => PQ schema0 schema1 m x
194+ => PQ schemas0 schemas1 m x
190− -> K LibPQ.Connection schema0
195+ -> K LibPQ.Connection schemas0
191− -> m (K LibPQ.Connection schema1)
196+ -> m (K LibPQ.Connection schemas1)
192execPQ (PQ pq) conn = mapKK (\ _ -> unK conn) <$> pq conn
197execPQ (PQ pq) conn = mapKK (\ _ -> unK conn) <$> pq conn
193
198
194−-- | Evaluate a `PQ` and discard the `Connection` but keep the result.
199+-- | Evaluate a `PQ` and discard the `LibPQ.Connection` but keep the result.
195evalPQ
200evalPQ
196 :: Functor m
201 :: Functor m
197− => PQ schema0 schema1 m x
202+ => PQ schemas0 schemas1 m x
198− -> K LibPQ.Connection schema0
203+ -> K LibPQ.Connection schemas0
199 -> m x
204 -> m x
200evalPQ (PQ pq) conn = unK <$> pq conn
205evalPQ (PQ pq) conn = unK <$> pq conn
201
206
@@ -203,60 +208,56 @@ evalPQ (PQ pq) conn = unK <$> pq conn
203-- [enriched category](https://ncatlab.org/nlab/show/enriched+category).
208-- [enriched category](https://ncatlab.org/nlab/show/enriched+category).
204-- An indexed monad transformer transforms a `Monad` into an indexed monad.
209-- An indexed monad transformer transforms a `Monad` into an indexed monad.
205-- And, `IndexedMonadTransPQ` is a class for indexed monad transformers that
210-- And, `IndexedMonadTransPQ` is a class for indexed monad transformers that
206−-- support running `Definition`s using `define` and embedding a computation
211+-- support running `Definition`s using `define`.
207−-- in a larger schema using `pqEmbed`.
208class IndexedMonadTransPQ pq where
212class IndexedMonadTransPQ pq where
209
213
210 -- | indexed analog of `<*>`
214 -- | indexed analog of `<*>`
211 pqAp
215 pqAp
212 :: Monad m
216 :: Monad m
213− => pq schema0 schema1 m (x -> y)
217+ => pq schemas0 schemas1 m (x -> y)
214− -> pq schema1 schema2 m x
218+ -> pq schemas1 schemas2 m x
215− -> pq schema0 schema2 m y
219+ -> pq schemas0 schemas2 m y
216
220
217 -- | indexed analog of `join`
221 -- | indexed analog of `join`
218 pqJoin
222 pqJoin
219 :: Monad m
223 :: Monad m
220− => pq schema0 schema1 m (pq schema1 schema2 m y)
224+ => pq schemas0 schemas1 m (pq schemas1 schemas2 m y)
221− -> pq schema0 schema2 m y
225+ -> pq schemas0 schemas2 m y
222 pqJoin pq = pq & pqBind id
226 pqJoin pq = pq & pqBind id
223
227
224 -- | indexed analog of `=<<`
228 -- | indexed analog of `=<<`
225 pqBind
229 pqBind
226 :: Monad m
230 :: Monad m
227− => (x -> pq schema1 schema2 m y)
231+ => (x -> pq schemas1 schemas2 m y)
228− -> pq schema0 schema1 m x
232+ -> pq schemas0 schemas1 m x
229− -> pq schema0 schema2 m y
233+ -> pq schemas0 schemas2 m y
230
234
231 -- | indexed analog of flipped `>>`
235 -- | indexed analog of flipped `>>`
232 pqThen
236 pqThen
233 :: Monad m
237 :: Monad m
234− => pq schema1 schema2 m y
238+ => pq schemas1 schemas2 m y
235− -> pq schema0 schema1 m x
239+ -> pq schemas0 schemas1 m x
236− -> pq schema0 schema2 m y
240+ -> pq schemas0 schemas2 m y
237 pqThen pq2 pq1 = pq1 & pqBind (\ _ -> pq2)
241 pqThen pq2 pq1 = pq1 & pqBind (\ _ -> pq2)
238
242
239 -- | indexed analog of `<=<`
243 -- | indexed analog of `<=<`
240 pqAndThen
244 pqAndThen
241 :: Monad m
245 :: Monad m
242− => (y -> pq schema1 schema2 m z)
246+ => (y -> pq schemas1 schemas2 m z)
243− -> (x -> pq schema0 schema1 m y)
247+ -> (x -> pq schemas0 schemas1 m y)
244− -> x -> pq schema0 schema2 m z
248+ -> x -> pq schemas0 schemas2 m z
245 pqAndThen g f x = pqBind g (f x)
249 pqAndThen g f x = pqBind g (f x)
246
250
247− -- | Safely embed a computation in a larger schema.
248− pqEmbed
249− :: Monad m
250− => pq schema0 schema1 m x
251− -> pq (table ': schema0) (table : schema1) m x
252−
253− -- | Run a `Definition` with `LibPQ.exec`, we expect that libpq obeys the law
251+ -- | Run a `Definition` with `LibPQ.exec`.
254 --
252 --
253+ -- It should be functorial in effect.
254+ --
255+ -- @define id = return ()@
255− -- @define statement1 & pqThen (define statement2) = define (statement1 >>> statement2)@
256+ -- @define (statement1 >>> statement2) = define statement1 & pqThen (define statement2)@
256 define
257 define
257− :: MonadBase IO io
258+ :: MonadIO io
258− => Definition schema0 schema1
259+ => Definition schemas0 schemas1
259− -> pq schema0 schema1 io (K LibPQ.Result '[])
260+ -> pq schemas0 schemas1 io ()
260
261
261instance IndexedMonadTransPQ PQ where
262instance IndexedMonadTransPQ PQ where
262
263
@@ -269,26 +270,26 @@ instance IndexedMonadTransPQ PQ where
269 K x' <- x conn
270 K x' <- x conn
270 unPQ (f x') (K (unK conn))
271 unPQ (f x') (K (unK conn))
271
272
272− pqEmbed (PQ pq) = PQ $ \ (K conn) -> do
273− K x <- pq (K conn)
274− return $ K x
275−
276 define (UnsafeDefinition q) = PQ $ \ (K conn) -> do
273 define (UnsafeDefinition q) = PQ $ \ (K conn) -> do
277− resultMaybe <- liftBase $ LibPQ.exec conn q
274+ resultMaybe <- liftIO $ LibPQ.exec conn q
278 case resultMaybe of
275 case resultMaybe of
279 Nothing -> throw $ ResultException
276 Nothing -> throw $ ResultException
280 "define: LibPQ.exec returned no results"
277 "define: LibPQ.exec returned no results"
281− Just result -> return $ K (K result)
278+ Just result -> K <$> okResult_ result
282
279
283−{- | `MonadPQ` is an `mtl` style constraint, similar to
280+{- | `MonadPQ` is an @mtl@ style constraint, similar to
284−`Control.Monad.State.Class.MonadState`, for using `LibPQ` to
281+`Control.Monad.State.Class.MonadState`, for using `Database.PostgreSQL.LibPQ` to
285
282
286* `manipulateParams` runs a `Manipulation` with params from a type
283* `manipulateParams` runs a `Manipulation` with params from a type
287 with a `ToParams` constraint. It calls `LibPQ.execParams` and
284 with a `ToParams` constraint. It calls `LibPQ.execParams` and
288 doesn't afraid of anything.
285 doesn't afraid of anything.
289
286
287+* `manipulateParams_` is like `manipulateParams` for a returning-free statement.
288+
290* `manipulate` is like `manipulateParams` for a parameter-free statement.
289* `manipulate` is like `manipulateParams` for a parameter-free statement.
291
290
291+* `manipulate_` is like `manipulate` for a returning-free statement.
292+
292* `runQueryParams` is like `manipulateParams` for query statements.
293* `runQueryParams` is like `manipulateParams` for query statements.
293
294
294* `runQuery` is like `runQueryParams` for a parameter-free statement.
295* `runQuery` is like `runQueryParams` for a parameter-free statement.
@@ -302,11 +303,11 @@ instance IndexedMonadTransPQ PQ where
302* `forPrepared` is a flipped `traversePrepared`
303* `forPrepared` is a flipped `traversePrepared`
303
304
304* `traversePrepared_` is like `traversePrepared` but works on `Foldable`
305* `traversePrepared_` is like `traversePrepared` but works on `Foldable`
305− containers and returns unit.
306+ containers for a returning-free statement.
306
307
307* `forPrepared_` is a flipped `traversePrepared_`.
308* `forPrepared_` is a flipped `traversePrepared_`.
308
309
309−* `liftPQ` lets you lift actions from `LibPQ` that require a connection
310+* `liftPQ` lets you lift actions from `Database.PostgreSQL.LibPQ` that require a connection
310 into your monad.
311 into your monad.
311
312
312To define an instance, you can minimally define only `manipulateParams`,
313To define an instance, you can minimally define only `manipulateParams`,
@@ -314,140 +315,172 @@ To define an instance, you can minimally define only `manipulateParams`,
314a default instance.
315a default instance.
315
316
316-}
317-}
317−class Monad pq => MonadPQ schema pq | pq -> schema where
318+class Monad pq => MonadPQ schemas pq | pq -> schemas where
318 manipulateParams
319 manipulateParams
319− :: ToParams x params
320+ :: (ToParams x params, All OidOfParam params)
320− => Manipulation schema params ys
321+ => Manipulation '[] schemas params ys
321− -- ^ `insertRows`, `update` or `deleteFrom`
322+ -- ^ `insertInto`, `update` or `deleteFrom`
322 -> x -> pq (K LibPQ.Result ys)
323 -> x -> pq (K LibPQ.Result ys)
323 default manipulateParams
324 default manipulateParams
324− :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)
325+ :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)
325− => ToParams x params
326+ => (ToParams x params, All OidOfParam params)
326− => Manipulation schema params ys
327+ => Manipulation '[] schemas params ys
327− -- ^ `insertRows`, `update` or `deleteFrom`
328+ -- ^ `insertInto`, `update` or `deleteFrom`
328 -> x -> pq (K LibPQ.Result ys)
329 -> x -> pq (K LibPQ.Result ys)
329 manipulateParams manipulation params = lift $
330 manipulateParams manipulation params = lift $
330 manipulateParams manipulation params
331 manipulateParams manipulation params
331
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+
332− manipulate :: Manipulation schema '[] ys -> pq (K LibPQ.Result ys)
340+ manipulate :: Manipulation '[] schemas '[] ys -> pq (K LibPQ.Result ys)
333 manipulate statement = manipulateParams statement ()
341 manipulate statement = manipulateParams statement ()
334
342
343+ manipulate_ :: Manipulation '[] schemas '[] '[] -> pq ()
344+ manipulate_ = void . manipulate
345+
335 runQueryParams
346 runQueryParams
336− :: ToParams x params
347+ :: (ToParams x params, All OidOfParam params)
337− => Query schema params ys
348+ => Query '[] '[] schemas params ys
338 -- ^ `select` and friends
349 -- ^ `select` and friends
339 -> x -> pq (K LibPQ.Result ys)
350 -> x -> pq (K LibPQ.Result ys)
340 runQueryParams = manipulateParams . queryStatement
351 runQueryParams = manipulateParams . queryStatement
341
352
342 runQuery
353 runQuery
343− :: Query schema '[] ys
354+ :: Query '[] '[] schemas '[] ys
344 -- ^ `select` and friends
355 -- ^ `select` and friends
345 -> pq (K LibPQ.Result ys)
356 -> pq (K LibPQ.Result ys)
346 runQuery q = runQueryParams q ()
357 runQuery q = runQueryParams q ()
347
358
348 traversePrepared
359 traversePrepared
349− :: (ToParams x params, Traversable list)
360+ :: (ToParams x params, Traversable list, All OidOfParam params)
350− => Manipulation schema params ys
361+ => Manipulation '[] schemas params ys
351− -- ^ `insertRows`, `update`, or `deleteFrom`, and friends
362+ -- ^ `insertInto`, `update`, or `deleteFrom`, and friends
352 -> list x -> pq (list (K LibPQ.Result ys))
363 -> list x -> pq (list (K LibPQ.Result ys))
353 default traversePrepared
364 default traversePrepared
354− :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)
365+ :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)
355− => (ToParams x params, Traversable list)
366+ => (ToParams x params, Traversable list, All OidOfParam params)
356− => Manipulation schema params ys -> list x -> pq (list (K LibPQ.Result ys))
367+ => Manipulation '[] schemas params ys -> list x -> pq (list (K LibPQ.Result ys))
357 traversePrepared manipulation params = lift $
368 traversePrepared manipulation params = lift $
358 traversePrepared manipulation params
369 traversePrepared manipulation params
359
370
360 forPrepared
371 forPrepared
361− :: (ToParams x params, Traversable list)
372+ :: (ToParams x params, Traversable list, All OidOfParam params)
362 => list x
373 => list x
363− -> Manipulation schema params ys
374+ -> Manipulation '[] schemas params ys
364− -- ^ `insertRows`, `update` or `deleteFrom`
375+ -- ^ `insertInto`, `update` or `deleteFrom`
365 -> pq (list (K LibPQ.Result ys))
376 -> pq (list (K LibPQ.Result ys))
366 forPrepared = flip traversePrepared
377 forPrepared = flip traversePrepared
367
378
368 traversePrepared_
379 traversePrepared_
369− :: (ToParams x params, Foldable list)
380+ :: (ToParams x params, Foldable list, All OidOfParam params)
370− => Manipulation schema params '[]
381+ => Manipulation '[] schemas params '[]
371− -- ^ `insertRows`, `update` or `deleteFrom`
382+ -- ^ `insertInto`, `update` or `deleteFrom`
372 -> list x -> pq ()
383 -> list x -> pq ()
373 default traversePrepared_
384 default traversePrepared_
374− :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)
385+ :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)
375− => (ToParams x params, Foldable list)
386+ => (ToParams x params, Foldable list, All OidOfParam params)
376− => Manipulation schema params '[]
387+ => Manipulation '[] schemas params '[]
377− -- ^ `insertRows`, `update` or `deleteFrom`
388+ -- ^ `insertInto`, `update` or `deleteFrom`
378 -> list x -> pq ()
389 -> list x -> pq ()
379 traversePrepared_ manipulation params = lift $
390 traversePrepared_ manipulation params = lift $
380 traversePrepared_ manipulation params
391 traversePrepared_ manipulation params
381
392
382 forPrepared_
393 forPrepared_
383− :: (ToParams x params, Foldable list)
394+ :: (ToParams x params, Foldable list, All OidOfParam params)
384 => list x
395 => list x
385− -> Manipulation schema params '[]
396+ -> Manipulation '[] schemas params '[]
386− -- ^ `insertRows`, `update` or `deleteFrom`
397+ -- ^ `insertInto`, `update` or `deleteFrom`
387 -> pq ()
398 -> pq ()
388 forPrepared_ = flip traversePrepared_
399 forPrepared_ = flip traversePrepared_
389
400
390 liftPQ :: (LibPQ.Connection -> IO a) -> pq a
401 liftPQ :: (LibPQ.Connection -> IO a) -> pq a
391 default liftPQ
402 default liftPQ
392− :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)
403+ :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)
393 => (LibPQ.Connection -> IO a) -> pq a
404 => (LibPQ.Connection -> IO a) -> pq a
394 liftPQ = lift . liftPQ
405 liftPQ = lift . liftPQ
395
406
396−instance (MonadBase IO io, schema0 ~ schema, schema1 ~ schema)
407+instance (MonadIO io, schemas0 ~ schemas, schemas1 ~ schemas)
397− => MonadPQ schema (PQ schema0 schema1 io) where
408+ => MonadPQ schemas (PQ schemas0 schemas1 io) where
398
409
399 manipulateParams
410 manipulateParams
400− (UnsafeManipulation q :: Manipulation schema ps ys) (params :: x) =
411+ (UnsafeManipulation q :: Manipulation '[] schemas ps ys) (params :: x) =
401 PQ $ \ (K conn) -> do
412 PQ $ \ (K conn) -> do
402 let
413 let
403− 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 ->
404− (LibPQ.invalidOid, encodingBytes encoding, LibPQ.Binary)
420+ (oidOfParam @param, encodingBytes encoding, LibPQ.Binary)
421+ params'
422+ = hcollapse
423+ . hcmap (Proxy @OidOfParam) paramSet
405− params' = fmap (fmap toParam') (hcollapse (toParams @x @ps params))
424+ $ toParams @x @ps params
406 q' = q <> ";"
425 q' = q <> ";"
407− resultMaybe <- liftBase $ LibPQ.execParams conn q' params' LibPQ.Binary
426+ resultMaybe <- liftIO $ LibPQ.execParams conn q' params' LibPQ.Binary
408 case resultMaybe of
427 case resultMaybe of
409 Nothing -> throw $ ResultException
428 Nothing -> throw $ ResultException
410 "manipulateParams: LibPQ.execParams returned no results"
429 "manipulateParams: LibPQ.execParams returned no results"
411 Just result -> do
430 Just result -> do
412− tryResult result
431+ okResult_ result
413 return $ K (K result)
432 return $ K (K result)
414
433
415 traversePrepared
434 traversePrepared
416− (UnsafeManipulation q :: Manipulation schema xs ys) (list :: list x) =
435+ (UnsafeManipulation q :: Manipulation '[] schemas xs ys) (list :: list x) =
417− PQ $ \ (K conn) -> liftBase $ do
436+ PQ $ \ (K conn) -> liftIO $ do
437+ let
418− 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
419− prepResultMaybe <- LibPQ.prepare conn temp q Nothing
445+ prepResultMaybe <- LibPQ.prepare conn temp q (Just paramOids')
420 case prepResultMaybe of
446 case prepResultMaybe of
421 Nothing -> throw $ ResultException
447 Nothing -> throw $ ResultException
422 "traversePrepared: LibPQ.prepare returned no results"
448 "traversePrepared: LibPQ.prepare returned no results"
423− Just prepResult -> tryResult prepResult
449+ Just prepResult -> okResult_ prepResult
424 results <- for list $ \ params -> do
450 results <- for list $ \ params -> do
425 let
451 let
426− toParam' encoding = (encodingBytes encoding,LibPQ.Binary)
452+ toParam' encoding = (encodingBytes encoding, LibPQ.Binary)
427 params' = fmap (fmap toParam') (hcollapse (toParams @x @xs params))
453 params' = fmap (fmap toParam') (hcollapse (toParams @x @xs params))
428 resultMaybe <- LibPQ.execPrepared conn temp params' LibPQ.Binary
454 resultMaybe <- LibPQ.execPrepared conn temp params' LibPQ.Binary
429 case resultMaybe of
455 case resultMaybe of
430 Nothing -> throw $ ResultException
456 Nothing -> throw $ ResultException
431 "traversePrepared: LibPQ.execParams returned no results"
457 "traversePrepared: LibPQ.execParams returned no results"
432 Just result -> do
458 Just result -> do
433− tryResult result
459+ okResult_ result
434 return $ K result
460 return $ K result
435 deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")
461 deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")
436 case deallocResultMaybe of
462 case deallocResultMaybe of
437 Nothing -> throw $ ResultException
463 Nothing -> throw $ ResultException
438 "traversePrepared: LibPQ.exec DEALLOCATE returned no results"
464 "traversePrepared: LibPQ.exec DEALLOCATE returned no results"
439− Just deallocResult -> tryResult deallocResult
465+ Just deallocResult -> okResult_ deallocResult
440 return (K results)
466 return (K results)
441
467
442 traversePrepared_
468 traversePrepared_
443− (UnsafeManipulation q :: Manipulation schema xs '[]) (list :: list x) =
469+ (UnsafeManipulation q :: Manipulation '[] schemas xs '[]) (list :: list x) =
444− PQ $ \ (K conn) -> liftBase $ do
470+ PQ $ \ (K conn) -> liftIO $ do
471+ let
445− 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
446− prepResultMaybe <- LibPQ.prepare conn temp q Nothing
479+ prepResultMaybe <- LibPQ.prepare conn temp q (Just paramOids')
447 case prepResultMaybe of
480 case prepResultMaybe of
448 Nothing -> throw $ ResultException
481 Nothing -> throw $ ResultException
449 "traversePrepared_: LibPQ.prepare returned no results"
482 "traversePrepared_: LibPQ.prepare returned no results"
450− Just prepResult -> tryResult prepResult
483+ Just prepResult -> okResult_ prepResult
451 for_ list $ \ params -> do
484 for_ list $ \ params -> do
452 let
485 let
453 toParam' encoding = (encodingBytes encoding, LibPQ.Binary)
486 toParam' encoding = (encodingBytes encoding, LibPQ.Binary)
@@ -456,83 +489,79 @@ instance (MonadBase IO io, schema0 ~ schema, schema1 ~ schema)
456 case resultMaybe of
489 case resultMaybe of
457 Nothing -> throw $ ResultException
490 Nothing -> throw $ ResultException
458 "traversePrepared_: LibPQ.execParams returned no results"
491 "traversePrepared_: LibPQ.execParams returned no results"
459− Just result -> tryResult result
492+ Just result -> okResult_ result
460 deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")
493 deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")
461 case deallocResultMaybe of
494 case deallocResultMaybe of
462 Nothing -> throw $ ResultException
495 Nothing -> throw $ ResultException
463 "traversePrepared: LibPQ.exec DEALLOCATE returned no results"
496 "traversePrepared: LibPQ.exec DEALLOCATE returned no results"
464− Just deallocResult -> tryResult deallocResult
497+ Just deallocResult -> okResult_ deallocResult
465 return (K ())
498 return (K ())
466
499
467 liftPQ pq = PQ $ \ (K conn) -> do
500 liftPQ pq = PQ $ \ (K conn) -> do
468− y <- liftBase $ pq conn
501+ y <- liftIO $ pq conn
469 return (K y)
502 return (K y)
470
503
471−instance MonadPQ schema m => MonadPQ schema (IdentityT m)
504+instance MonadPQ schemas m => MonadPQ schemas (IdentityT m)
472−instance MonadPQ schema m => MonadPQ schema (ReaderT r m)
505+instance MonadPQ schemas m => MonadPQ schemas (ReaderT r m)
473−instance MonadPQ schema m => MonadPQ schema (Strict.StateT s m)
506+instance MonadPQ schemas m => MonadPQ schemas (Strict.StateT s m)
474−instance MonadPQ schema m => MonadPQ schema (Lazy.StateT s m)
507+instance MonadPQ schemas m => MonadPQ schemas (Lazy.StateT s m)
475−instance (Monoid w, MonadPQ schema m) => MonadPQ schema (Strict.WriterT w m)
508+instance (Monoid w, MonadPQ schemas m) => MonadPQ schemas (Strict.WriterT w m)
476−instance (Monoid w, MonadPQ schema m) => MonadPQ schema (Lazy.WriterT w m)
509+instance (Monoid w, MonadPQ schemas m) => MonadPQ schemas (Lazy.WriterT w m)
477−instance MonadPQ schema m => MonadPQ schema (MaybeT m)
510+instance MonadPQ schemas m => MonadPQ schemas (MaybeT m)
478−instance MonadPQ schema m => MonadPQ schema (ExceptT e m)
511+instance MonadPQ schemas m => MonadPQ schemas (ExceptT e m)
479−instance (Monoid w, MonadPQ schema m) => MonadPQ schema (Strict.RWST r w s m)
512+instance (Monoid w, MonadPQ schemas m) => MonadPQ schemas (Strict.RWST r w s m)
480−instance (Monoid w, MonadPQ schema m) => MonadPQ schema (Lazy.RWST r w s m)
513+instance (Monoid w, MonadPQ schemas m) => MonadPQ schemas (Lazy.RWST r w s m)
481−instance MonadPQ schema m => MonadPQ schema (ContT r m)
514+instance MonadPQ schemas m => MonadPQ schemas (ContT r m)
482−instance MonadPQ schema m => MonadPQ schema (ListT m)
515+
483−
484−instance (Monad m, schema0 ~ schema1)
516+instance (Monad m, schemas0 ~ schemas1)
485− => Applicative (PQ schema0 schema1 m) where
517+ => Applicative (PQ schemas0 schemas1 m) where
486 pure x = PQ $ \ _conn -> pure (K x)
518 pure x = PQ $ \ _conn -> pure (K x)
487 (<*>) = pqAp
519 (<*>) = pqAp
488
520
489−instance (Monad m, schema0 ~ schema1)
521+instance (Monad m, schemas0 ~ schemas1)
490− => Monad (PQ schema0 schema1 m) where
522+ => Monad (PQ schemas0 schemas1 m) where
491 return = pure
523 return = pure
492 (>>=) = flip pqBind
524 (>>=) = flip pqBind
493
525
494−instance schema0 ~ schema1 => MFunctor (PQ schema0 schema1) where
526+instance (Monad m, schemas0 ~ schemas1)
527+ => Fail.MonadFail (PQ schemas0 schemas1 m) where
528+ fail = Fail.fail
529+
530+instance schemas0 ~ schemas1 => MFunctor (PQ schemas0 schemas1) where
495 hoist f (PQ pq) = PQ (f . pq)
531 hoist f (PQ pq) = PQ (f . pq)
496
532
497−instance schema0 ~ schema1 => MonadTrans (PQ schema0 schema1) where
533+instance schemas0 ~ schemas1 => MonadTrans (PQ schemas0 schemas1) where
498 lift m = PQ $ \ _conn -> do
534 lift m = PQ $ \ _conn -> do
499 x <- m
535 x <- m
500 return (K x)
536 return (K x)
501
537
502−instance schema0 ~ schema1 => MMonad (PQ schema0 schema1) where
538+instance schemas0 ~ schemas1 => MMonad (PQ schemas0 schemas1) where
503 embed f (PQ pq) = PQ $ \ conn -> do
539 embed f (PQ pq) = PQ $ \ conn -> do
504 evalPQ (f (pq conn)) conn
540 evalPQ (f (pq conn)) conn
505
541
506−instance (MonadBase b m, schema0 ~ schema1)
542+instance (MonadIO m, schema0 ~ schema1)
507− => MonadBase b (PQ schema0 schema1 m) where
543+ => MonadIO (PQ schema0 schema1 m) where
508− liftBase = lift . liftBase
544+ liftIO = lift . liftIO
509−
510−-- | A snapshot of the state of a `PQ` computation.
511−type PQRun schema =
512− forall m x. Monad m => PQ schema schema m x -> m (K x schema)
513−
514−-- | Helper function in defining `MonadBaseControl` instance for `PQ`.
515−pqliftWith :: Functor m => (PQRun schema -> m a) -> PQ schema schema m a
516−pqliftWith f = PQ $ \ conn ->
517− fmap K (f $ \ pq -> unPQ pq conn)
518
545
519−instance (MonadBaseControl b m, schema0 ~ schema1)
546+instance (MonadUnliftIO m, schemas0 ~ schemas1)
520− => MonadBaseControl b (PQ schema0 schema1 m) where
547+ => MonadUnliftIO (PQ schemas0 schemas1 m) where
521− type StM (PQ schema0 schema1 m) x = StM m (K x schema0)
548+ withRunInIO
522− liftBaseWith f =
549+ :: ((forall a . PQ schemas0 schema1 m a -> IO a) -> IO b)
523− pqliftWith $ \ run -> liftBaseWith $ \ runInBase -> f $ runInBase . run
550+ -> PQ schemas0 schema1 m b
524− restoreM = PQ . const . restoreM
551+ withRunInIO inner = PQ $ \conn ->
552+ withRunInIO $ \(run :: (forall x . m x -> IO x)) ->
553+ K <$> inner (\pq -> run $ unK <$> unPQ pq conn)
525
554
526-- | Get a row corresponding to a given row number from a `LibPQ.Result`,
555-- | Get a row corresponding to a given row number from a `LibPQ.Result`,
527-- throwing an exception if the row number is out of bounds.
556-- throwing an exception if the row number is out of bounds.
528getRow
557getRow
529− :: (FromRow columns y, MonadBase IO io)
558+ :: (FromRow columns y, MonadIO io)
530 => LibPQ.Row
559 => LibPQ.Row
531 -- ^ row number
560 -- ^ row number
532 -> K LibPQ.Result columns
561 -> K LibPQ.Result columns
533 -- ^ result
562 -- ^ result
534 -> io y
563 -> io y
535−getRow r (K result :: K LibPQ.Result columns) = liftBase $ do
564+getRow r (K result :: K LibPQ.Result columns) = liftIO $ do
536 numRows <- LibPQ.ntuples result
565 numRows <- LibPQ.ntuples result
537 when (numRows < r) $ throw $ ResultException $
566 when (numRows < r) $ throw $ ResultException $
538 "getRow: expected at least " <> pack (show r) <> "rows but only saw "
567 "getRow: expected at least " <> pack (show r) <> "rows but only saw "
@@ -550,13 +579,13 @@ getRow r (K result :: K LibPQ.Result columns) = liftBase $ do
550-- and a `LibPQ.Result` and given a row number if it's too large returns `Nothing`,
579-- and a `LibPQ.Result` and given a row number if it's too large returns `Nothing`,
551-- otherwise returning the row along with the next row number.
580-- otherwise returning the row along with the next row number.
552nextRow
581nextRow
553− :: (FromRow columns y, MonadBase IO io)
582+ :: (FromRow columns y, MonadIO io)
554 => LibPQ.Row -- ^ total number of rows
583 => LibPQ.Row -- ^ total number of rows
555 -> K LibPQ.Result columns -- ^ result
584 -> K LibPQ.Result columns -- ^ result
556 -> LibPQ.Row -- ^ row number
585 -> LibPQ.Row -- ^ row number
557 -> io (Maybe (LibPQ.Row,y))
586 -> io (Maybe (LibPQ.Row,y))
558nextRow total (K result :: K LibPQ.Result columns) r
587nextRow total (K result :: K LibPQ.Result columns) r
559− = liftBase $ if r >= total then return Nothing else do
588+ = liftIO $ if r >= total then return Nothing else do
560 let len = fromIntegral (lengthSList (Proxy @columns))
589 let len = fromIntegral (lengthSList (Proxy @columns))
561 row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]
590 row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]
562 case fromList row' of
591 case fromList row' of
@@ -567,10 +596,10 @@ nextRow total (K result :: K LibPQ.Result columns) r
567
596
568-- | Get all rows from a `LibPQ.Result`.
597-- | Get all rows from a `LibPQ.Result`.
569getRows
598getRows
570− :: (FromRow columns y, MonadBase IO io)
599+ :: (FromRow columns y, MonadIO io)
571 => K LibPQ.Result columns -- ^ result
600 => K LibPQ.Result columns -- ^ result
572 -> io [y]
601 -> io [y]
573−getRows (K result :: K LibPQ.Result columns) = liftBase $ do
602+getRows (K result :: K LibPQ.Result columns) = liftIO $ do
574 let len = fromIntegral (lengthSList (Proxy @columns))
603 let len = fromIntegral (lengthSList (Proxy @columns))
575 numRows <- LibPQ.ntuples result
604 numRows <- LibPQ.ntuples result
576 for [0 .. numRows - 1] $ \ r -> do
605 for [0 .. numRows - 1] $ \ r -> do
@@ -583,10 +612,10 @@ getRows (K result :: K LibPQ.Result columns) = liftBase $ do
583
612
584-- | Get the first row if possible from a `LibPQ.Result`.
613-- | Get the first row if possible from a `LibPQ.Result`.
585firstRow
614firstRow
586− :: (FromRow columns y, MonadBase IO io)
615+ :: (FromRow columns y, MonadIO io)
587 => K LibPQ.Result columns -- ^ result
616 => K LibPQ.Result columns -- ^ result
588 -> io (Maybe y)
617 -> io (Maybe y)
589−firstRow (K result :: K LibPQ.Result columns) = liftBase $ do
618+firstRow (K result :: K LibPQ.Result columns) = liftIO $ do
590 numRows <- LibPQ.ntuples result
619 numRows <- LibPQ.ntuples result
591 if numRows <= 0 then return Nothing else do
620 if numRows <= 0 then return Nothing else do
592 let len = fromIntegral (lengthSList (Proxy @columns))
621 let len = fromIntegral (lengthSList (Proxy @columns))
@@ -599,23 +628,23 @@ firstRow (K result :: K LibPQ.Result columns) = liftBase $ do
599
628
600-- | Lifts actions on results from @LibPQ@.
629-- | Lifts actions on results from @LibPQ@.
601liftResult
630liftResult
602− :: MonadBase IO io
631+ :: MonadIO io
603 => (LibPQ.Result -> IO x)
632 => (LibPQ.Result -> IO x)
604 -> K LibPQ.Result results -> io x
633 -> K LibPQ.Result results -> io x
605−liftResult f (K result) = liftBase $ f result
634+liftResult f (K result) = liftIO $ f result
606
635
607-- | Returns the number of rows (tuples) in the query result.
636-- | Returns the number of rows (tuples) in the query result.
608−ntuples :: MonadBase IO io => K LibPQ.Result columns -> io LibPQ.Row
637+ntuples :: MonadIO io => K LibPQ.Result columns -> io LibPQ.Row
609ntuples = liftResult LibPQ.ntuples
638ntuples = liftResult LibPQ.ntuples
610
639
611-- | Returns the result status of the command.
640-- | Returns the result status of the command.
612−resultStatus :: MonadBase IO io => K LibPQ.Result results -> io LibPQ.ExecStatus
641+resultStatus :: MonadIO io => K LibPQ.Result results -> io LibPQ.ExecStatus
613resultStatus = liftResult LibPQ.resultStatus
642resultStatus = liftResult LibPQ.resultStatus
614
643
615-- | Returns the error message most recently generated by an operation
644-- | Returns the error message most recently generated by an operation
616-- on the connection.
645-- on the connection.
617resultErrorMessage
646resultErrorMessage
618− :: MonadBase IO io => K LibPQ.Result results -> io (Maybe ByteString)
647+ :: MonadIO io => K LibPQ.Result results -> io (Maybe ByteString)
619resultErrorMessage = liftResult LibPQ.resultErrorMessage
648resultErrorMessage = liftResult LibPQ.resultErrorMessage
620
649
621-- | Returns the error code most recently generated by an operation
650-- | Returns the error code most recently generated by an operation
@@ -623,29 +652,29 @@ resultErrorMessage = liftResult LibPQ.resultErrorMessage
623--
652--
624-- https://www.postgresql.org/docs/current/static/errcodes-appendix.html
653-- https://www.postgresql.org/docs/current/static/errcodes-appendix.html
625resultErrorCode
654resultErrorCode
626− :: MonadBase IO io
655+ :: MonadIO io
627 => K LibPQ.Result results
656 => K LibPQ.Result results
628 -> io (Maybe ByteString)
657 -> io (Maybe ByteString)
629resultErrorCode = liftResult (flip LibPQ.resultErrorField LibPQ.DiagSqlstate)
658resultErrorCode = liftResult (flip LibPQ.resultErrorField LibPQ.DiagSqlstate)
630
659
631−-- | `Exception`s that can be thrown by Squeal.
660+-- | the state of LibPQ
632−data SquealException
661+data PQState = PQState
633− = PQException
634 { sqlExecStatus :: LibPQ.ExecStatus
662 { sqlExecStatus :: LibPQ.ExecStatus
635 , sqlStateCode :: Maybe ByteString
663 , sqlStateCode :: Maybe ByteString
636 -- ^ https://www.postgresql.org/docs/current/static/errcodes-appendix.html
664 -- ^ https://www.postgresql.org/docs/current/static/errcodes-appendix.html
637 , sqlErrorMessage :: Maybe ByteString
665 , sqlErrorMessage :: Maybe ByteString
638− }
666+ } deriving (Eq, Show)
667+
668+-- | `Exception`s that can be thrown by Squeal.
669+data SquealException
670+ = PQException PQState
639 | ResultException Text
671 | ResultException Text
640 | ParseException Text
672 | ParseException Text
641 deriving (Eq, Show)
673 deriving (Eq, Show)
642instance Exception SquealException
674instance Exception SquealException
643
675
644−tryResult
645− :: MonadBase IO io
646− => LibPQ.Result
676+okResult_ :: MonadIO io => LibPQ.Result -> io ()
647− -> io ()
677+okResult_ result = liftIO $ do
648−tryResult result = liftBase $ do
649 status <- LibPQ.resultStatus result
678 status <- LibPQ.resultStatus result
650 case status of
679 case status of
651 LibPQ.CommandOk -> return ()
680 LibPQ.CommandOk -> return ()
@@ -653,11 +682,16 @@ tryResult result = liftBase $ do
653 _ -> do
682 _ -> do
654 stateCode <- LibPQ.resultErrorField result LibPQ.DiagSqlstate
683 stateCode <- LibPQ.resultErrorField result LibPQ.DiagSqlstate
655 msg <- LibPQ.resultErrorMessage result
684 msg <- LibPQ.resultErrorMessage result
656− 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
657
691
658-- | Catch `SquealException`s.
692-- | Catch `SquealException`s.
659catchSqueal
693catchSqueal
660− :: MonadBaseControl IO io
694+ :: MonadUnliftIO io
661 => io a
695 => io a
662 -> (SquealException -> io a) -- ^ handler
696 -> (SquealException -> io a) -- ^ handler
663 -> io a
697 -> io a
@@ -665,7 +699,14 @@ catchSqueal = catch
665
699
666-- | Handle `SquealException`s.
700-- | Handle `SquealException`s.
667handleSqueal
701handleSqueal
668− :: MonadBaseControl IO io
702+ :: MonadUnliftIO io
669 => (SquealException -> io a) -- ^ handler
703 => (SquealException -> io a) -- ^ handler
670 -> io a -> io a
704 -> io a -> io a
671handleSqueal = 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+73−104
@@ -1,17 +1,40 @@
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
12 DeriveFunctor
34 DeriveFunctor
13 , FlexibleContexts
35 , FlexibleContexts
14 , FlexibleInstances
36 , FlexibleInstances
37+ , InstanceSigs
15 , MultiParamTypeClasses
38 , MultiParamTypeClasses
16 , RankNTypes
39 , RankNTypes
17 , ScopedTypeVariables
40 , ScopedTypeVariables
@@ -22,55 +45,24 @@ A `MonadPQ` for pooled connections.
22
45
23module Squeal.PostgreSQL.Pool
46module Squeal.PostgreSQL.Pool
24 ( -- * Pools
47 ( -- * Pools
25− PoolPQ (..)
48+ Pool
26 , createConnectionPool
49 , createConnectionPool
27− , Pool
50+ , usingConnectionPool
28− , destroyAllResources
51+ , destroyConnectionPool
29− , PoolPQRun
30− , poolpqliftWith
31 ) where
52 ) where
32
53
33−import Control.Monad.Base
34−import Control.Monad.Trans
35−import Control.Monad.Trans.Control
36import Data.ByteString
54import Data.ByteString
37−import Data.Pool
38import Data.Time
55import Data.Time
39−import Generics.SOP (K(..))
56+import Generics.SOP (K(..), unK)
57+import UnliftIO (MonadUnliftIO (..))
58+import UnliftIO.Pool (Pool, createPool, destroyAllResources, withResource)
40
59
41import Squeal.PostgreSQL.PQ
60import Squeal.PostgreSQL.PQ
42−import Squeal.PostgreSQL.Schema
43−
44−{- | `PoolPQ` @schema@ should be a drop-in replacement for `PQ` @schema schema@.
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−> type Schema = '[ "tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint2])]
51−>
52−> someQuery :: Manipulation Schema '[ 'NotNull 'PGint2] '[]
53−> someQuery = insertRow #tab
54−> (Set (param @1) `As` #col :* Nil)
55−> OnConflictDoNothing (Returning Nil)
56−>
57−> insertOne :: (MonadBaseControl IO m, MonadPQ Schema m) => m ()
58−> insertOne = void $ manipulateParams someQuery . Only $ (1 :: Int16)
59−>
60−> insertOneInPool :: ByteString -> IO ()
61−> insertOneInPool connectionString = do
62−> pool <- createConnectionPool connectionString 1 0.5 10
63−> liftIO $ runPoolPQ (insertOne) pool
64−
65−-}
66−newtype PoolPQ (schema :: SchemaType) m x =
67− PoolPQ { runPoolPQ :: Pool (K Connection schema) -> m x }
68− deriving Functor
69
61
70-- | Create a striped pool of connections.
62-- | Create a striped pool of connections.
71-- 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.
72createConnectionPool
64createConnectionPool
73− :: MonadBase IO io
65+ :: MonadUnliftIO io
74 => ByteString
66 => ByteString
75 -- ^ The passed string can be empty to use all default parameters, or it can
67 -- ^ The passed string can be empty to use all default parameters, or it can
76 -- contain one or more parameter settings separated by whitespace.
68 -- contain one or more parameter settings separated by whitespace.
@@ -86,68 +78,45 @@ createConnectionPool
86 -> Int
78 -> Int
87 -- ^ Maximum number of connections to keep open per stripe. The smallest acceptable value is 1.
79 -- ^ Maximum number of connections to keep open per stripe. The smallest acceptable value is 1.
88 -- Requests for connections will block if this limit is reached on a single stripe, even if other stripes have idle connections available.
80 -- Requests for connections will block if this limit is reached on a single stripe, even if other stripes have idle connections available.
89− -> io (Pool (K Connection schema))
81+ -> io (Pool (K Connection schemas))
90−createConnectionPool conninfo stripes idle maxResrc = liftBase $
82+createConnectionPool conninfo stripes idle maxResrc =
91 createPool (connectdb conninfo) finish stripes idle maxResrc
83 createPool (connectdb conninfo) finish stripes idle maxResrc
92
84
93−-- | `Applicative` instance for `PoolPQ`.
85+{-|
94−instance Monad m => Applicative (PoolPQ schema m) where
86+Temporarily take a connection from a `Pool`, perform an action with it,
95− pure x = PoolPQ $ \ _ -> pure x
87+and return it to the pool afterwards.
96− PoolPQ f <*> PoolPQ x = PoolPQ $ \ pool -> do
88+
97− f' <- f pool
89+If the pool has an idle connection available, it is used immediately.
98− x' <- x pool
90+Otherwise, if the maximum number of connections has not yet been reached,
99− return $ f' x'
91+a new connection is created and used.
100−
92+If the maximum number of connections has been reached, this function blocks
101−-- | `Monad` instance for `PoolPQ`.
93+until a connection becomes available.
102−instance Monad m => Monad (PoolPQ schema m) where
94+-}
103− return = pure
95+usingConnectionPool
104− PoolPQ x >>= f = PoolPQ $ \ pool -> do
96+ :: MonadUnliftIO io
105− x' <- x pool
97+ => Pool (K Connection schemas) -- ^ pool
106− runPoolPQ (f x') pool
98+ -> PQ schemas schemas io x -- ^ session
107−
99+ -> io x
108−-- | `MonadTrans` instance for `PoolPQ`.
109−instance MonadTrans (PoolPQ schema) where
110− lift m = PoolPQ $ \ _pool -> m
111−
112−-- | `MonadBase` instance for `PoolPQ`.
113−instance MonadBase b m => MonadBase b (PoolPQ schema m) where
114− liftBase = lift . liftBase
115−
116−-- | `MonadPQ` instance for `PoolPQ`.
117−instance MonadBaseControl IO io => MonadPQ schema (PoolPQ schema io) where
118− manipulateParams manipulation params = PoolPQ $ \ pool -> do
119− withResource pool $ \ conn -> do
100+usingConnectionPool pool (PQ session) = unK <$> withResource pool session
120− (K result :: K (K Result ys) schema) <- flip unPQ conn $
101+
121− manipulateParams manipulation params
102+{- |
122− return result
103+Destroy all connections in all stripes in the pool.
123− traversePrepared manipulation params = PoolPQ $ \ pool ->
104+Note that this will ignore any exceptions in the destroy function.
124− withResource pool $ \ conn -> do
105+
125− (K result :: K (list (K Result ys)) schema) <- flip unPQ conn $
106+This function is useful when you detect that all connections
126− traversePrepared manipulation params
107+in the pool are broken. For example after a database has been
127− return result
108+restarted all connections opened before the restart will be broken.
128− traversePrepared_ manipulation params = PoolPQ $ \ pool -> do
109+In that case it's better to close those connections so that
129− withResource pool $ \ conn -> do
110+`usingConnectionPool` won't take a broken connection from the pool
130− (_ :: K () schema) <- flip unPQ conn $
111+but will open a new connection instead.
131− traversePrepared_ manipulation params
112+
132− return ()
113+Another use-case for this function is that when you know you are done
133− liftPQ m = PoolPQ $ \ pool ->
114+with the pool you can destroy all idle connections immediately
134− withResource pool $ \ conn -> do
115+instead of waiting on the garbage collector to destroy them,
135− (K result :: K result schema) <- flip unPQ conn $
116+thus freeing up those connections sooner.
136− liftPQ m
117+-}
137− return result
118+destroyConnectionPool
138−
119+ :: MonadUnliftIO io
139−-- | A snapshot of the state of a `PoolPQ` computation.
120+ => Pool (K Connection schemas) -- ^ pool
140−type PoolPQRun schema =
121+ -> io ()
141− forall m x. Monad m => PoolPQ schema m x -> m x
122+destroyConnectionPool = destroyAllResources
142−
143−-- | Helper function in defining `MonadBaseControl` instance for `PoolPQ`.
144−poolpqliftWith :: Functor m => (PoolPQRun schema -> m a) -> PoolPQ schema m a
145−poolpqliftWith f = PoolPQ $ \ pool ->
146− (f $ \ pq -> runPoolPQ pq pool)
147−
148−-- | `MonadBaseControl` instance for `PoolPQ`.
149−instance MonadBaseControl b m => MonadBaseControl b (PoolPQ schema m) where
150− type StM (PoolPQ schema m) x = StM m x
151− liftBaseWith f =
152− poolpqliftWith $ \ run -> liftBaseWith $ \ runInBase -> f $ runInBase . run
153− restoreM = PoolPQ . const . restoreM
squeal-postgresql/src/Squeal/PostgreSQL/Query.hs+598−916
@@ -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
@@ -17,8 +17,12 @@ Squeal queries.
17 , GeneralizedNewtypeDeriving
17 , GeneralizedNewtypeDeriving
18 , LambdaCase
18 , LambdaCase
19 , MultiParamTypeClasses
19 , MultiParamTypeClasses
20+ , OverloadedLabels
20 , OverloadedStrings
21 , OverloadedStrings
22+ , QuantifiedConstraints
23+ , ScopedTypeVariables
21 , StandaloneDeriving
24 , StandaloneDeriving
25+ , TypeApplications
22 , TypeFamilies
26 , TypeFamilies
23 , TypeInType
27 , TypeInType
24 , TypeOperators
28 , TypeOperators
@@ -28,14 +32,16 @@ Squeal queries.
28
32
29module Squeal.PostgreSQL.Query
33module Squeal.PostgreSQL.Query
30 ( -- * Queries
34 ( -- * Queries
31− Query (UnsafeQuery, renderQuery)
35+ Query_
36+ , Query (..)
32 -- ** Select
37 -- ** Select
33 , select
38 , select
39+ , select_
34 , selectDistinct
40 , selectDistinct
35− , selectStar
41+ , selectDistinct_
36− , selectDistinctStar
42+ , selectDistinctOn
37− , selectDotStar
43+ , selectDistinctOn_
38− , selectDistinctDotStar
44+ , Selection (..)
39 -- ** Values
45 -- ** Values
40 , values
46 , values
41 , values_
47 , values_
@@ -47,33 +53,15 @@ module Squeal.PostgreSQL.Query
47 , except
53 , except
48 , exceptAll
54 , exceptAll
49 -- ** With
55 -- ** With
50− , With (with)
56+ , With (..)
51 , CommonTableExpression (..)
57 , CommonTableExpression (..)
52− , renderCommonTableExpression
58+ , withRecursive
53− , renderCommonTableExpressions
54− -- ** Json
55− , jsonEach
56− , jsonbEach
57− , jsonEachAsText
58− , jsonbEachAsText
59− , jsonObjectKeys
60− , jsonbObjectKeys
61− , jsonPopulateRecord
62− , jsonbPopulateRecord
63− , jsonPopulateRecordSet
64− , jsonbPopulateRecordSet
65− , jsonToRecord
66− , jsonbToRecord
67− , jsonToRecordSet
68− , jsonbToRecordSet
69 -- * Table Expressions
59 -- * Table Expressions
70 , TableExpression (..)
60 , TableExpression (..)
71− , renderTableExpression
72 , from
61 , from
73 , where_
62 , where_
74 , groupBy
63 , groupBy
75 , having
64 , having
76− , orderBy
77 , limit
65 , limit
78 , offset
66 , offset
79 -- * From Clauses
67 -- * From Clauses
@@ -81,53 +69,21 @@ module Squeal.PostgreSQL.Query
81 , table
69 , table
82 , subquery
70 , subquery
83 , view
71 , view
72+ , common
84 , crossJoin
73 , crossJoin
85 , innerJoin
74 , innerJoin
86 , leftOuterJoin
75 , leftOuterJoin
87 , rightOuterJoin
76 , rightOuterJoin
88 , fullOuterJoin
77 , fullOuterJoin
89 -- * Grouping
78 -- * Grouping
90− , By (By1, By2)
79+ , By (..)
91− , renderBy
92− , GroupByClause (NoGroups, Group)
80+ , GroupByClause (..)
93− , renderGroupByClause
94− , HavingClause (NoHaving, Having)
81+ , HavingClause (..)
95− , renderHavingClause
96− -- * Sorting
97− , SortExpression (..)
98− , renderSortExpression
99− -- * Subquery Expressions
100− , in_
101− , rowIn
102− , eqAll
103− , rowEqAll
104− , eqAny
105− , rowEqAny
106− , neqAll
107− , rowNeqAll
108− , neqAny
109− , rowNeqAny
110− , allLt
111− , rowLtAll
112− , ltAny
113− , rowLtAny
114− , lteAll
115− , rowLteAll
116− , lteAny
117− , rowLteAny
118− , gtAll
119− , rowGtAll
120− , gtAny
121− , rowGtAny
122− , gteAll
123− , rowGteAll
124− , gteAny
125− , rowGteAny
126 ) where
82 ) where
127
83
128import Control.DeepSeq
84import Control.DeepSeq
129import Data.ByteString (ByteString)
85import Data.ByteString (ByteString)
130−import Data.Monoid hiding (All)
86+import Data.Kind (Type)
131import Data.String
87import Data.String
132import Data.Word
88import Data.Word
133import Generics.SOP hiding (from)
89import Generics.SOP hiding (from)
@@ -135,23 +91,76 @@ import GHC.TypeLits
135
91
136import qualified GHC.Generics as GHC
92import qualified GHC.Generics as GHC
137
93
94+import Squeal.PostgreSQL.Alias
138import Squeal.PostgreSQL.Expression
95import Squeal.PostgreSQL.Expression
96+import Squeal.PostgreSQL.Expression.Logic
97+import Squeal.PostgreSQL.Expression.Sort
98+import Squeal.PostgreSQL.Expression.Window
99+import Squeal.PostgreSQL.List
100+import Squeal.PostgreSQL.PG
139import Squeal.PostgreSQL.Render
101import Squeal.PostgreSQL.Render
140import Squeal.PostgreSQL.Schema
102import Squeal.PostgreSQL.Schema
141
103
104+-- $setup
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
110+
142{- |
111{- |
143−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+
144−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+:}
145
155
146simple query:
156simple query:
147
157
158+>>> type Columns = '["col1" ::: 'NoDef :=> 'NotNull 'PGint4, "col2" ::: 'NoDef :=> 'NotNull 'PGint4]
159+>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]
148>>> :{
160>>> :{
149let
161let
150− query :: Query
162+ query :: Query_ (Public Schema) () (Row Int32 Int32)
151− '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]
152− '[]
153− '["col" ::: 'Null 'PGint4]
154− query = selectStar (from (table #tab))
163+ query = select Star (from (table #tab))
155in printSQL query
164in printSQL query
156:}
165:}
157SELECT * FROM "tab" AS "tab"
166SELECT * FROM "tab" AS "tab"
@@ -160,34 +169,22 @@ restricted query:
160
169
161>>> :{
170>>> :{
162let
171let
163− query :: Query
172+ query :: Query_ (Public Schema) () (Row Int32 Int32)
164− '[ "tab" ::: 'Table ('[] :=>
165− '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4
166− , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ])]
167− '[]
168− '[ "sum" ::: 'NotNull 'PGint4
169− , "col1" ::: 'NotNull 'PGint4 ]
170 query =
173 query =
171− select
172− ((#col1 + #col2) `as` #sum :* #col1)
174+ select_ ((#col1 + #col2) `as` #col1 :* #col1 `as` #col2)
173 ( from (table #tab)
175 ( from (table #tab)
174 & where_ (#col1 .> #col2)
176 & where_ (#col1 .> #col2)
175 & where_ (#col2 .> 0) )
177 & where_ (#col2 .> 0) )
176in printSQL query
178in printSQL query
177:}
179:}
178−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))
179
181
180subquery:
182subquery:
181
183
182>>> :{
184>>> :{
183let
185let
184− query :: Query
186+ query :: Query_ (Public Schema) () (Row Int32 Int32)
185− '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]
186− '[]
187− '["col" ::: 'Null 'PGint4]
188− query =
189− selectStar
190− (from (subquery (selectStar (from (table #tab)) `as` #sub)))
187+ query = select Star (from (subquery (select Star (from (table #tab)) `as` #sub)))
191in printSQL query
188in printSQL query
192:}
189:}
193SELECT * FROM (SELECT * FROM "tab" AS "tab") AS "sub"
190SELECT * FROM (SELECT * FROM "tab" AS "tab") AS "sub"
@@ -196,12 +193,8 @@ limits and offsets:
196
193
197>>> :{
194>>> :{
198let
195let
199− query :: Query
196+ query :: Query_ (Public Schema) () (Row Int32 Int32)
200− '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]
201− '[]
202− '["col" ::: 'Null 'PGint4]
203− query = selectStar
204− (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)
205in printSQL query
198in printSQL query
206:}
199:}
207SELECT * FROM "tab" AS "tab" LIMIT 50 OFFSET 4
200SELECT * FROM "tab" AS "tab" LIMIT 50 OFFSET 4
@@ -210,85 +203,80 @@ parameterized query:
210
203
211>>> :{
204>>> :{
212let
205let
213− query :: Query
206+ query :: Query_ (Public Schema) (Only Int32) (Row Int32 Int32)
214− '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGfloat8])]
215− '[ 'NotNull 'PGfloat8]
216− '["col" ::: 'NotNull 'PGfloat8]
217− query = selectStar
218− (from (table #tab) & where_ (#col .> param @1))
207+ query = select Star (from (table #tab) & where_ (#col1 .> param @1))
219in printSQL query
208in printSQL query
220:}
209:}
221−SELECT * FROM "tab" AS "tab" WHERE ("col" > ($1 :: float8))
210+SELECT * FROM "tab" AS "tab" WHERE ("col1" > ($1 :: int4))
222
211
223aggregation query:
212aggregation query:
224
213
225>>> :{
214>>> :{
226let
215let
227− query :: Query
216+ query :: Query_ (Public Schema) () (Row Int64 Int32)
228− '[ "tab" ::: 'Table ('[] :=>
229− '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4
230− , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ])]
231− '[]
232− '[ "sum" ::: 'NotNull 'PGint4
233− , "col1" ::: 'NotNull 'PGint4 ]
234 query =
217 query =
235− select (sum_ #col2 `as` #sum :* #col1)
218+ select_ ((fromNull 0 (sum_ (All #col2))) `as` #col1 :* #col1 `as` #col2)
236 ( from (table (#tab `as` #table1))
219 ( from (table (#tab `as` #table1))
237 & groupBy #col1
220 & groupBy #col1
238− & having (#col1 + sum_ #col2 .> 1) )
221+ & having (sum_ (Distinct #col2) .> 1) )
239in printSQL query
222in printSQL query
240:}
223:}
241−SELECT sum("col2") AS "sum", "col1" AS "col1" FROM "tab" AS "table1" GROUP BY "col1" HAVING (("col1" + sum("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)
242
225
243sorted query:
226sorted query:
244
227
245>>> :{
228>>> :{
246let
229let
247− query :: Query
230+ query :: Query_ (Public Schema) () (Row Int32 Int32)
248− '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]
249− '[]
250− '["col" ::: 'Null 'PGint4]
251− query = selectStar
252− (from (table #tab) & orderBy [#col & AscNullsFirst])
231+ query = select Star (from (table #tab) & orderBy [#col1 & Asc])
253in printSQL query
232in printSQL query
254:}
233:}
255−SELECT * FROM "tab" AS "tab" ORDER BY "col" ASC NULLS FIRST
234+SELECT * FROM "tab" AS "tab" ORDER BY "col1" ASC
256
235
257joins:
236joins:
258
237
259−>>> :set -XFlexibleContexts
238+>>> :{
239+type OrdersColumns =
240+ '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4
241+ , "price" ::: 'NoDef :=> 'NotNull 'PGfloat4
242+ , "customer_id" ::: 'NoDef :=> 'NotNull 'PGint4
243+ , "shipper_id" ::: 'NoDef :=> 'NotNull 'PGint4 ]
244+:}
245+
246+>>> :{
247+type OrdersConstraints =
248+ '["pk_orders" ::: PrimaryKey '["id"]
249+ ,"fk_customers" ::: ForeignKey '["customer_id"] "customers" '["id"]
250+ ,"fk_shippers" ::: ForeignKey '["shipper_id"] "shippers" '["id"] ]
251+:}
252+
253+>>> type NamesColumns = '["id" ::: 'NoDef :=> 'NotNull 'PGint4, "name" ::: 'NoDef :=> 'NotNull 'PGtext]
254+>>> type CustomersConstraints = '["pk_customers" ::: PrimaryKey '["id"]]
255+>>> type ShippersConstraints = '["pk_shippers" ::: PrimaryKey '["id"]]
256+>>> :{
257+type OrdersSchema =
258+ '[ "orders" ::: 'Table (OrdersConstraints :=> OrdersColumns)
259+ , "customers" ::: 'Table (CustomersConstraints :=> NamesColumns)
260+ , "shippers" ::: 'Table (ShippersConstraints :=> NamesColumns) ]
261+:}
262+
263+>>> :{
264+data Order = Order
265+ { price :: Float
266+ , customerName :: Text
267+ , shipperName :: Text
268+ } deriving GHC.Generic
269+instance SOP.Generic Order
270+instance SOP.HasDatatypeInfo Order
271+:}
272+
260>>> :{
273>>> :{
261let
274let
262− query :: Query
275+ query :: Query_ (Public OrdersSchema) () Order
263− '[ "orders" ::: 'Table (
264− '["pk_orders" ::: PrimaryKey '["id"]
265− ,"fk_customers" ::: ForeignKey '["customer_id"] "customers" '["id"]
266− ,"fk_shippers" ::: ForeignKey '["shipper_id"] "shippers" '["id"]] :=>
267− '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4
268− , "price" ::: 'NoDef :=> 'NotNull 'PGfloat4
269− , "customer_id" ::: 'NoDef :=> 'NotNull 'PGint4
270− , "shipper_id" ::: 'NoDef :=> 'NotNull 'PGint4
271− ])
272− , "customers" ::: 'Table (
273− '["pk_customers" ::: PrimaryKey '["id"]] :=>
274− '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4
275− , "name" ::: 'NoDef :=> 'NotNull 'PGtext
276− ])
277− , "shippers" ::: 'Table (
278− '["pk_shippers" ::: PrimaryKey '["id"]] :=>
279− '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4
280− , "name" ::: 'NoDef :=> 'NotNull 'PGtext
281− ])
282− ]
283− '[]
284− '[ "order_price" ::: 'NotNull 'PGfloat4
285− , "customer_name" ::: 'NotNull 'PGtext
286− , "shipper_name" ::: 'NotNull 'PGtext
287− ]
288− query = select
276+ query = select_
289− ( #o ! #price `as` #order_price :*
277+ ( #o ! #price `as` #price :*
290− #c ! #name `as` #customer_name :*
278+ #c ! #name `as` #customerName :*
291− #s ! #name `as` #shipper_name )
279+ #s ! #name `as` #shipperName )
292 ( from (table (#orders `as` #o)
280 ( from (table (#orders `as` #o)
293 & innerJoin (table (#customers `as` #c))
281 & innerJoin (table (#customers `as` #c))
294 (#o ! #customer_id .== #c ! #id)
282 (#o ! #customer_id .== #c ! #id)
@@ -296,17 +284,15 @@ let
296 (#o ! #shipper_id .== #s ! #id)) )
284 (#o ! #shipper_id .== #s ! #id)) )
297in printSQL query
285in printSQL query
298:}
286:}
299−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")
300
288
301self-join:
289self-join:
302
290
303>>> :{
291>>> :{
304let
292let
305− query :: Query
293+ query :: Query_ (Public Schema) () (Row Int32 Int32)
306− '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]
294+ query = select
307− '[]
295+ (#t1 & DotStar)
308− '["col" ::: 'Null 'PGint4]
309− query = selectDotStar #t1
310 (from (table (#tab `as` #t1) & crossJoin (table (#tab `as` #t2))))
296 (from (table (#tab `as` #t1) & crossJoin (table (#tab `as` #t2))))
311in printSQL query
297in printSQL query
312:}
298:}
@@ -316,24 +302,20 @@ value queries:
316
302
317>>> :{
303>>> :{
318let
304let
319− query :: Query '[] '[] '["foo" ::: 'NotNull 'PGint2, "bar" ::: 'NotNull 'PGbool]
305+ query :: Query_ schemas () (Row String Bool)
320− 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]
321in printSQL query
309in printSQL query
322:}
310:}
323−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")
324
312
325set operations:
313set operations:
326
314
327>>> :{
315>>> :{
328let
316let
329− query :: Query
317+ query :: Query_ (Public Schema) () (Row Int32 Int32)
330− '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]
318+ query = select Star (from (table #tab)) `unionAll` select Star (from (table #tab))
331− '[]
332− '["col" ::: 'Null 'PGint4]
333− query =
334− selectStar (from (table #tab))
335− `unionAll`
336− selectStar (from (table #tab))
337in printSQL query
319in printSQL query
338:}
320:}
339(SELECT * FROM "tab" AS "tab") UNION ALL (SELECT * FROM "tab" AS "tab")
321(SELECT * FROM "tab" AS "tab") UNION ALL (SELECT * FROM "tab" AS "tab")
@@ -342,173 +324,305 @@ with queries:
342
324
343>>> :{
325>>> :{
344let
326let
345− query :: Query
327+ query :: Query_ (Public Schema) () (Row Int32 Int32)
346− '[ "t1" ::: 'View
347− '[ "c1" ::: 'NotNull 'PGtext
348− , "c2" ::: 'NotNull 'PGtext] ]
349− '[]
350− '[ "c1" ::: 'NotNull 'PGtext
351− , "c2" ::: 'NotNull 'PGtext ]
352 query = with (
328 query = with (
353− selectStar (from (view #t1)) `as` #t2 :>>
329+ select Star (from (table #tab)) `as` #cte1 :>>
354− selectStar (from (view #t2)) `as` #t3
330+ select Star (from (common #cte1)) `as` #cte2
355− ) (selectStar (from (view #t3)))
331+ ) (select Star (from (common #cte2)))
332+in printSQL query
333+:}
334+WITH "cte1" AS (SELECT * FROM "tab" AS "tab"), "cte2" AS (SELECT * FROM "cte1" AS "cte1") SELECT * FROM "cte2" AS "cte2"
335+
336+window function queries
337+
338+>>> :{
339+let
340+ query :: Query_ (Public Schema) () (Row Int32 Int64)
341+ query = select
342+ (#col1 & Also (rank `as` #col2 `Over` (partitionBy #col1 & orderBy [#col2 & Asc])))
343+ (from (table #tab))
344+in printSQL query
345+:}
346+SELECT "col1" AS "col1", rank() OVER (PARTITION BY "col1" ORDER BY "col2" ASC) AS "col2" FROM "tab" AS "tab"
347+
348+correlated subqueries
349+
350+>>> :{
351+let
352+ query :: Query_ (Public Schema) () (Only Int32)
353+ query =
354+ select (#col1 `as` #fromOnly) (from (table (#tab `as` #t1))
355+ & where_ (exists (
356+ select Star (from (table (#tab `as` #t2))
357+ & where_ (#t2 ! #col2 .== #t1 ! #col1)))))
356in printSQL query
358in printSQL query
357:}
359:}
358−WITH "t2" AS (SELECT * FROM "t1" AS "t1"), "t3" AS (SELECT * FROM "t2" AS "t2") SELECT * FROM "t3" AS "t3"
360+SELECT "col1" AS "fromOnly" FROM "tab" AS "t1" WHERE EXISTS (SELECT * FROM "tab" AS "t2" WHERE ("t2"."col2" = "t1"."col1"))
361+
359-}
362-}
360−newtype Query
363+type family Query_
361− (schema :: SchemaType)
364+ (schemas :: SchemasType)
362− (params :: [NullityType])
365+ (parameters :: Type)
363− (columns :: RowType)
366+ (row :: Type) where
364− = UnsafeQuery { renderQuery :: ByteString }
367+ Query_ schemas params row =
365− deriving (GHC.Generic,Show,Eq,Ord,NFData)
368+ Query '[] '[] schemas (TuplePG params) (RowPG row)
366−instance RenderSQL (Query schema params columns) where renderSQL = renderQuery
367
369
368-- | 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
369-- `union`. Duplicate rows are eliminated.
371-- `union`. Duplicate rows are eliminated.
370union
372union
371− :: Query schema params columns
373+ :: Query outer commons schemas params columns
372− -> Query schema params columns
374+ -> Query outer commons schemas params columns
373− -> Query schema params columns
375+ -> Query outer commons schemas params columns
374q1 `union` q2 = UnsafeQuery $
376q1 `union` q2 = UnsafeQuery $
375− parenthesized (renderQuery q1)
377+ parenthesized (renderSQL q1)
376 <+> "UNION"
378 <+> "UNION"
377− <+> parenthesized (renderQuery q2)
379+ <+> parenthesized (renderSQL q2)
378
380
379-- | The results of two queries can be combined using the set operation
381-- | The results of two queries can be combined using the set operation
380-- `unionAll`, the disjoint union. Duplicate rows are retained.
382-- `unionAll`, the disjoint union. Duplicate rows are retained.
381unionAll
383unionAll
382− :: Query schema params columns
384+ :: Query outer commons schemas params columns
383− -> Query schema params columns
385+ -> Query outer commons schemas params columns
384− -> Query schema params columns
386+ -> Query outer commons schemas params columns
385q1 `unionAll` q2 = UnsafeQuery $
387q1 `unionAll` q2 = UnsafeQuery $
386− parenthesized (renderQuery q1)
388+ parenthesized (renderSQL q1)
387 <+> "UNION" <+> "ALL"
389 <+> "UNION" <+> "ALL"
388− <+> parenthesized (renderQuery q2)
390+ <+> parenthesized (renderSQL q2)
389
391
390-- | The results of two queries can be combined using the set operation
392-- | The results of two queries can be combined using the set operation
391-- `intersect`, the intersection. Duplicate rows are eliminated.
393-- `intersect`, the intersection. Duplicate rows are eliminated.
392intersect
394intersect
393− :: Query schema params columns
395+ :: Query outer commons schemas params columns
394− -> Query schema params columns
396+ -> Query outer commons schemas params columns
395− -> Query schema params columns
397+ -> Query outer commons schemas params columns
396q1 `intersect` q2 = UnsafeQuery $
398q1 `intersect` q2 = UnsafeQuery $
397− parenthesized (renderQuery q1)
399+ parenthesized (renderSQL q1)
398 <+> "INTERSECT"
400 <+> "INTERSECT"
399− <+> parenthesized (renderQuery q2)
401+ <+> parenthesized (renderSQL q2)
400
402
401-- | The results of two queries can be combined using the set operation
403-- | The results of two queries can be combined using the set operation
402-- `intersectAll`, the intersection. Duplicate rows are retained.
404-- `intersectAll`, the intersection. Duplicate rows are retained.
403intersectAll
405intersectAll
404− :: Query schema params columns
406+ :: Query outer commons schemas params columns
405− -> Query schema params columns
407+ -> Query outer commons schemas params columns
406− -> Query schema params columns
408+ -> Query outer commons schemas params columns
407q1 `intersectAll` q2 = UnsafeQuery $
409q1 `intersectAll` q2 = UnsafeQuery $
408− parenthesized (renderQuery q1)
410+ parenthesized (renderSQL q1)
409 <+> "INTERSECT" <+> "ALL"
411 <+> "INTERSECT" <+> "ALL"
410− <+> parenthesized (renderQuery q2)
412+ <+> parenthesized (renderSQL q2)
411
413
412-- | The results of two queries can be combined using the set operation
414-- | The results of two queries can be combined using the set operation
413-- `except`, the set difference. Duplicate rows are eliminated.
415-- `except`, the set difference. Duplicate rows are eliminated.
414except
416except
415− :: Query schema params columns
417+ :: Query outer commons schemas params columns
416− -> Query schema params columns
418+ -> Query outer commons schemas params columns
417− -> Query schema params columns
419+ -> Query outer commons schemas params columns
418q1 `except` q2 = UnsafeQuery $
420q1 `except` q2 = UnsafeQuery $
419− parenthesized (renderQuery q1)
421+ parenthesized (renderSQL q1)
420 <+> "EXCEPT"
422 <+> "EXCEPT"
421− <+> parenthesized (renderQuery q2)
423+ <+> parenthesized (renderSQL q2)
422
424
423-- | The results of two queries can be combined using the set operation
425-- | The results of two queries can be combined using the set operation
424-- `exceptAll`, the set difference. Duplicate rows are retained.
426-- `exceptAll`, the set difference. Duplicate rows are retained.
425exceptAll
427exceptAll
426− :: Query schema params columns
428+ :: Query outer commons schemas params columns
427− -> Query schema params columns
429+ -> Query outer commons schemas params columns
428− -> Query schema params columns
430+ -> Query outer commons schemas params columns
429q1 `exceptAll` q2 = UnsafeQuery $
431q1 `exceptAll` q2 = UnsafeQuery $
430− parenthesized (renderQuery q1)
432+ parenthesized (renderSQL q1)
431 <+> "EXCEPT" <+> "ALL"
433 <+> "EXCEPT" <+> "ALL"
432− <+> parenthesized (renderQuery q2)
434+ <+> parenthesized (renderSQL q2)
433
435
434{-----------------------------------------
436{-----------------------------------------
435SELECT queries
437SELECT queries
436-----------------------------------------}
438-----------------------------------------}
437
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+-}
446+data Selection outer commons grp schemas params from row where
447+ Star
448+ :: HasUnique tab from row
449+ => Selection outer commons 'Ungrouped schemas params from row
450+ -- ^ `HasUnique` table in the `FromClause`
451+ DotStar
452+ :: Has tab from row
453+ => Alias tab
454+ -- ^ `Has` table with `Alias`
455+ -> Selection outer commons 'Ungrouped schemas params from row
456+ List
457+ :: SListI row
458+ => NP (Aliased (Expression outer commons grp schemas params from)) row
459+ -- ^ `NP` list of `Aliased` `Expression`s
460+ -> Selection outer commons grp schemas params from row
461+ Over
462+ :: SListI row
463+ => NP (Aliased (WindowFunction outer commons grp schemas params from)) row
464+ -- ^ `NP` list of `Aliased` `WindowFunction`s
465+ -> WindowDefinition outer commons grp schemas params from
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
474+instance (KnownSymbol col, row ~ '[col ::: ty])
475+ => Aliasable col
476+ (Expression outer commons grp schemas params from ty)
477+ (Selection outer commons grp schemas params from row) where
478+ expr `as` col = List (expr `as` col)
479+instance (Has tab (Join outer from) row0, Has col row0 ty, row1 ~ '[col ::: ty])
480+ => IsQualified tab col
481+ (Selection outer commons 'Ungrouped schemas params from row1) where
482+ tab ! col = tab ! col `as` col
483+instance
484+ ( Has tab (Join outer from) row0
485+ , Has col row0 ty
486+ , row1 ~ '[col ::: ty]
487+ , GroupedBy tab col bys )
488+ => IsQualified tab col
489+ (Selection outer commons ('Grouped bys) schemas params from row1) where
490+ tab ! col = tab ! col `as` col
491+instance (HasUnique tab (Join outer from) row0, Has col row0 ty, row1 ~ '[col ::: ty])
492+ => IsLabel col
493+ (Selection outer commons 'Ungrouped schemas params from row1) where
494+ fromLabel = fromLabel @col `as` Alias
495+instance
496+ ( HasUnique tab (Join outer from) row0
497+ , Has col row0 ty
498+ , row1 ~ '[col ::: ty]
499+ , GroupedBy tab col bys )
500+ => IsLabel col
501+ (Selection outer commons ('Grouped bys) schemas params from row1) where
502+ fromLabel = fromLabel @col `as` Alias
503+
504+instance RenderSQL (Selection outer commons grp schemas params from row) where
505+ renderSQL = \case
506+ List list -> renderCommaSeparated (renderAliased renderSQL) list
507+ Star -> "*"
508+ DotStar tab -> renderSQL tab <> ".*"
509+ Also right left -> renderSQL left <> ", " <> renderSQL right
510+ Over winFns winDef ->
511+ let
512+ renderOver
513+ :: Aliased (WindowFunction outer commons grp schemas params from) field
514+ -> ByteString
515+ renderOver (winFn `As` col) = renderSQL winFn
516+ <+> "OVER" <+> parenthesized (renderSQL winDef)
517+ <+> "AS" <+> renderSQL col
518+ in
519+ renderCommaSeparated renderOver winFns
520+
521+instance IsString
522+ (Selection outer commons grp schemas params from '["fromOnly" ::: 'NotNull 'PGtext]) where
523+ fromString str = fromString str `as` Alias
524+
438-- | the `TableExpression` in the `select` command constructs an intermediate
525-- | the `TableExpression` in the `select` command constructs an intermediate
439-- virtual table by possibly combining tables, views, eliminating rows,
526-- virtual table by possibly combining tables, views, eliminating rows,
440-- grouping, etc. This table is finally passed on to processing by
527-- grouping, etc. This table is finally passed on to processing by
441−-- the select list. The select list determines which columns of
528+-- the select list. The `Selection` determines which columns of
442-- the intermediate table are actually output.
529-- the intermediate table are actually output.
443select
530select
444− :: SListI columns
531+ :: (SListI row, row ~ (x ': xs))
445− => NP (Aliased (Expression schema from grouping params)) (column ': columns)
532+ => Selection outer commons grp schemas params from row
446− -- ^ select list
533+ -- ^ selection
447− -> TableExpression schema params from grouping
534+ -> TableExpression outer commons grp schemas params from
448 -- ^ intermediate virtual table
535 -- ^ intermediate virtual table
449− -> Query schema params (column ': columns)
536+ -> Query outer commons schemas params row
450−select list rels = UnsafeQuery $
537+select selection tabexpr = UnsafeQuery $
451 "SELECT"
538 "SELECT"
452− <+> renderCommaSeparated (renderAliasedAs renderExpression) list
539+ <+> renderSQL selection
453− <+> renderTableExpression rels
540+ <+> renderSQL tabexpr
541+
542+-- | Like `select` but takes an `NP` list of `Expression`s instead
543+-- of a general `Selection`.
544+select_
545+ :: (SListI row, row ~ (x ': xs))
546+ => NP (Aliased (Expression outer commons grp schemas params from)) row
547+ -- ^ select list
548+ -> TableExpression outer commons grp schemas params from
549+ -- ^ intermediate virtual table
550+ -> Query outer commons schemas params row
551+select_ = select . List
454
552
455-- | After the select list has been processed, the result table can
553-- | After the select list has been processed, the result table can
456-- be subject to the elimination of duplicate rows using `selectDistinct`.
554-- be subject to the elimination of duplicate rows using `selectDistinct`.
457selectDistinct
555selectDistinct
458− :: SListI columns
556+ :: (SListI columns, columns ~ (col ': cols))
459− => NP (Aliased (Expression schema from 'Ungrouped params)) (column ': columns)
557+ => Selection outer commons grp schemas params from columns
460− -- ^ select list
558+ -- ^ selection
461− -> TableExpression schema params from 'Ungrouped
559+ -> TableExpression outer commons grp schemas params from
462 -- ^ intermediate virtual table
560 -- ^ intermediate virtual table
463− -> Query schema params (column ': columns)
561+ -> Query outer commons schemas params columns
464−selectDistinct list rels = UnsafeQuery $
562+selectDistinct selection tabexpr = UnsafeQuery $
465 "SELECT DISTINCT"
563 "SELECT DISTINCT"
466− <+> renderCommaSeparated (renderAliasedAs renderExpression) list
564+ <+> renderSQL selection
467− <+> renderTableExpression rels
565+ <+> renderSQL tabexpr
468−
566+
469−-- | The simplest kind of query is `selectStar` which emits all columns
567+-- | Like `selectDistinct` but takes an `NP` list of `Expression`s instead
470−-- that the table expression produces.
568+-- of a general `Selection`.
471−selectStar
569+selectDistinct_
472− :: HasUnique table from columns
570+ :: (SListI columns, columns ~ (col ': cols))
473− => TableExpression schema params from 'Ungrouped
571+ => NP (Aliased (Expression outer commons grp schemas params from)) columns
474− -- ^ intermediate virtual table
572+ -- ^ select list
475− -> Query schema params columns
573+ -> TableExpression outer commons grp schemas params from
476−selectStar rels = UnsafeQuery $ "SELECT" <+> "*" <+> renderTableExpression rels
477−
478−-- | A `selectDistinctStar` emits all columns that the table expression
479−-- produces and eliminates duplicate rows.
480−selectDistinctStar
481− :: HasUnique table from columns
482− => TableExpression schema params from 'Ungrouped
483 -- ^ intermediate virtual table
574 -- ^ intermediate virtual table
484− -> Query schema params columns
575+ -> Query outer commons schemas params columns
485−selectDistinctStar rels = UnsafeQuery $
576+selectDistinct_ = selectDistinct . List
486− "SELECT DISTINCT" <+> "*" <+> renderTableExpression rels
577+
487−
578+{-|
488−-- | When working with multiple tables, it can also be useful to ask
579+`selectDistinctOn` keeps only the first row of each set of rows where
489−-- for all the columns of a particular table, using `selectDotStar`.
580+the given expressions evaluate to equal. The DISTINCT ON expressions are
490−selectDotStar
581+interpreted using the same rules as for ORDER BY. ORDER BY is used to
491− :: Has table from columns
582+ensure that the desired row appears first.
492− => Alias table
583+
493− -- ^ particular virtual subtable
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
494− -> TableExpression schema params from 'Ungrouped
597+ -> TableExpression outer commons grp schemas params from
495 -- ^ intermediate virtual table
598 -- ^ intermediate virtual table
496− -> Query schema params columns
599+ -> Query outer commons schemas params columns
497−selectDotStar rel tab = UnsafeQuery $
600+selectDistinctOn distincts selection tab = UnsafeQuery $
498− "SELECT" <+> renderAlias rel <> ".*" <+> renderTableExpression tab
601+ "SELECT DISTINCT ON"
499−
602+ <+> parenthesized (commaSeparated (renderDistinctOn <$> distincts))
500−-- | A `selectDistinctDotStar` asks for all the columns of a particular table,
603+ <+> renderSQL selection
501−-- and eliminates duplicate rows.
604+ <+> renderSQL (tab {orderByClause = distincts <> orderByClause tab})
502−selectDistinctDotStar
605+ where
503− :: Has table from columns
606+ renderDistinctOn = \case
504− => Alias table
607+ Asc expression -> renderSQL expression
505− -- ^ particular virtual table
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
506− -> TableExpression schema params from 'Ungrouped
622+ -> TableExpression outer commons grp schemas params from
507 -- ^ intermediate virtual table
623 -- ^ intermediate virtual table
508− -> Query schema params columns
624+ -> Query outer commons schemas params columns
509−selectDistinctDotStar rel tab = UnsafeQuery $
625+selectDistinctOn_ distincts = selectDistinctOn distincts . List
510− "SELECT DISTINCT" <+> renderAlias rel <> ".*"
511− <+> renderTableExpression tab
512
626
513-- | `values` computes a row value or set of row values
627-- | `values` computes a row value or set of row values
514-- specified by value expressions. It is most commonly used
628-- specified by value expressions. It is most commonly used
@@ -516,16 +630,16 @@ selectDistinctDotStar rel tab = UnsafeQuery $
516-- but it can be used on its own.
630-- but it can be used on its own.
517--
631--
518-- >>> type Row = '["a" ::: 'NotNull 'PGint4, "b" ::: 'NotNull 'PGtext]
632-- >>> type Row = '["a" ::: 'NotNull 'PGint4, "b" ::: 'NotNull 'PGtext]
519−-- >>> let query = values (1 `as` #a :* "one" `as` #b) [] :: Query '[] '[] Row
633+-- >>> let query = values (1 `as` #a :* "one" `as` #b) [] :: Query outer commons schemas '[] Row
520-- >>> printSQL query
634-- >>> printSQL query
521-- SELECT * FROM (VALUES (1, E'one')) AS t ("a", "b")
635-- SELECT * FROM (VALUES (1, E'one')) AS t ("a", "b")
522values
636values
523 :: SListI cols
637 :: SListI cols
524− => NP (Aliased (Expression schema '[] 'Ungrouped params)) cols
638+ => NP (Aliased (Expression outer commons 'Ungrouped schemas params '[] )) cols
525− -> [NP (Aliased (Expression schema '[] 'Ungrouped params)) cols]
639+ -> [NP (Aliased (Expression outer commons 'Ungrouped schemas params '[] )) cols]
526 -- ^ When more than one row is specified, all the rows must
640 -- ^ When more than one row is specified, all the rows must
527 -- must have the same number of elements
641 -- must have the same number of elements
528− -> Query schema params cols
642+ -> Query outer commons schemas params cols
529values rw rws = UnsafeQuery $ "SELECT * FROM"
643values rw rws = UnsafeQuery $ "SELECT * FROM"
530 <+> parenthesized (
644 <+> parenthesized (
531 "VALUES"
645 "VALUES"
@@ -536,17 +650,17 @@ values rw rws = UnsafeQuery $ "SELECT * FROM"
536 <+> parenthesized (renderCommaSeparated renderAliasPart rw)
650 <+> parenthesized (renderCommaSeparated renderAliasPart rw)
537 where
651 where
538 renderAliasPart, renderValuePart
652 renderAliasPart, renderValuePart
539− :: Aliased (Expression schema '[] 'Ungrouped params) ty -> ByteString
653+ :: Aliased (Expression outer commons 'Ungrouped schemas params '[] ) ty -> ByteString
540− renderAliasPart (_ `As` name) = renderAlias name
654+ renderAliasPart (_ `As` name) = renderSQL name
541− renderValuePart (value `As` _) = renderExpression value
655+ renderValuePart (value `As` _) = renderSQL value
542
656
543-- | `values_` computes a row value or set of row values
657-- | `values_` computes a row value or set of row values
544-- specified by value expressions.
658-- specified by value expressions.
545values_
659values_
546 :: SListI cols
660 :: SListI cols
547− => NP (Aliased (Expression schema '[] 'Ungrouped params)) cols
661+ => NP (Aliased (Expression outer commons 'Ungrouped schemas params '[] )) cols
548 -- ^ one row of values
662 -- ^ one row of values
549− -> Query schema params cols
663+ -> Query outer commons schemas params cols
550values_ rw = values rw []
664values_ rw = values rw []
551
665
552{-----------------------------------------
666{-----------------------------------------
@@ -560,15 +674,17 @@ Table Expressions
560-- to a table on disk, a so-called base table, but more complex expressions
674-- to a table on disk, a so-called base table, but more complex expressions
561-- can be used to modify or combine base tables in various ways.
675-- can be used to modify or combine base tables in various ways.
562data TableExpression
676data TableExpression
563− (schema :: SchemaType)
677+ (outer :: FromType)
678+ (commons :: FromType)
679+ (grp :: Grouping)
680+ (schemas :: SchemasType)
564 (params :: [NullityType])
681 (params :: [NullityType])
565 (from :: FromType)
682 (from :: FromType)
566− (grouping :: Grouping)
567 = TableExpression
683 = TableExpression
568− { fromClause :: FromClause schema params from
684+ { fromClause :: FromClause outer commons schemas params from
569 -- ^ A table reference that can be a table name, or a derived table such
685 -- ^ A table reference that can be a table name, or a derived table such
570 -- as a subquery, a @JOIN@ construct, or complex combinations of these.
686 -- as a subquery, a @JOIN@ construct, or complex combinations of these.
571− , whereClause :: [Condition schema from 'Ungrouped params]
687+ , whereClause :: [Condition outer commons 'Ungrouped schemas params from]
572 -- ^ optional search coditions, combined with `.&&`. After the processing
688 -- ^ optional search coditions, combined with `.&&`. After the processing
573 -- of the `fromClause` is done, each row of the derived virtual table
689 -- of the `fromClause` is done, each row of the derived virtual table
574 -- is checked against the search condition. If the result of the
690 -- is checked against the search condition. If the result of the
@@ -577,20 +693,20 @@ data TableExpression
577 -- at least one column of the table generated in the `fromClause`;
693 -- at least one column of the table generated in the `fromClause`;
578 -- this is not required, but otherwise the WHERE clause will
694 -- this is not required, but otherwise the WHERE clause will
579 -- be fairly useless.
695 -- be fairly useless.
580− , groupByClause :: GroupByClause from grouping
696+ , groupByClause :: GroupByClause grp from
581 -- ^ The `groupByClause` is used to group together those rows in a table
697 -- ^ The `groupByClause` is used to group together those rows in a table
582 -- that have the same values in all the columns listed. The order in which
698 -- that have the same values in all the columns listed. The order in which
583 -- the columns are listed does not matter. The effect is to combine each
699 -- the columns are listed does not matter. The effect is to combine each
584 -- set of rows having common values into one group row that represents all
700 -- set of rows having common values into one group row that represents all
585 -- rows in the group. This is done to eliminate redundancy in the output
701 -- rows in the group. This is done to eliminate redundancy in the output
586 -- and/or compute aggregates that apply to these groups.
702 -- and/or compute aggregates that apply to these groups.
587− , havingClause :: HavingClause schema from grouping params
703+ , havingClause :: HavingClause outer commons grp schemas params from
588 -- ^ If a table has been grouped using `groupBy`, but only certain groups
704 -- ^ If a table has been grouped using `groupBy`, but only certain groups
589 -- are of interest, the `havingClause` can be used, much like a
705 -- are of interest, the `havingClause` can be used, much like a
590 -- `whereClause`, to eliminate groups from the result. Expressions in the
706 -- `whereClause`, to eliminate groups from the result. Expressions in the
591 -- `havingClause` can refer both to grouped expressions and to ungrouped
707 -- `havingClause` can refer both to grouped expressions and to ungrouped
592 -- expressions (which necessarily involve an aggregate function).
708 -- expressions (which necessarily involve an aggregate function).
593− , orderByClause :: [SortExpression schema from grouping params]
709+ , orderByClause :: [SortExpression outer commons grp schemas params from]
594 -- ^ The `orderByClause` is for optional sorting. When more than one
710 -- ^ The `orderByClause` is for optional sorting. When more than one
595 -- `SortExpression` is specified, the later (right) values are used to sort
711 -- `SortExpression` is specified, the later (right) values are used to sort
596 -- rows that are equal according to the earlier (left) values.
712 -- rows that are equal according to the earlier (left) values.
@@ -600,72 +716,69 @@ data TableExpression
600 -- will be returned (but possibly fewer, if the query itself yields
716 -- will be returned (but possibly fewer, if the query itself yields
601 -- fewer rows).
717 -- fewer rows).
602 , offsetClause :: [Word64]
718 , offsetClause :: [Word64]
603− -- ^ The `offsetClause` is combined with `+` to give an offset count
719+ -- ^ The `offsetClause` is combined with `Prelude.+` to give an offset count
604 -- if nonempty. The offset count says to skip that many rows before
720 -- if nonempty. The offset count says to skip that many rows before
605 -- beginning to return rows. The rows are skipped before the limit count
721 -- beginning to return rows. The rows are skipped before the limit count
606 -- is applied.
722 -- is applied.
607− }
723+ } deriving (GHC.Generic)
608
724
609-- | Render a `TableExpression`
725-- | Render a `TableExpression`
610−renderTableExpression
611− :: TableExpression schema params from grouping
726+instance RenderSQL (TableExpression outer commons grp schemas params from) where
612− -> ByteString
727+ renderSQL
613−renderTableExpression
614− (TableExpression frm' whs' grps' hvs' srts' lims' offs') = mconcat
728+ (TableExpression frm' whs' grps' hvs' srts' lims' offs') = mconcat
615− [ "FROM ", renderFromClause frm'
729+ [ "FROM ", renderSQL frm'
616− , renderWheres whs'
730+ , renderWheres whs'
617− , renderGroupByClause grps'
731+ , renderSQL grps'
618− , renderHavingClause hvs'
732+ , renderSQL hvs'
619− , renderOrderByClause srts'
733+ , renderOrderByClause srts'
620− , renderLimits lims'
734+ , renderLimits lims'
621− , renderOffsets offs'
735+ , renderOffsets offs' ]
622− ]
623− where
736+ where
624− renderWheres = \case
737+ renderWheres = \case
625− [] -> ""
738+ [] -> ""
626− wh:[] -> " WHERE" <+> renderExpression wh
739+ wh:[] -> " WHERE" <+> renderSQL wh
627− wh:whs -> " WHERE" <+> renderExpression (foldr (.&&) wh whs)
740+ wh:whs -> " WHERE" <+> renderSQL (foldr (.&&) wh whs)
628− renderOrderByClause = \case
741+ renderOrderByClause = \case
629− [] -> ""
742+ [] -> ""
630− srts -> " ORDER BY"
743+ srts -> " ORDER BY"
631− <+> commaSeparated (renderSortExpression <$> srts)
744+ <+> commaSeparated (renderSQL <$> srts)
632− renderLimits = \case
745+ renderLimits = \case
633− [] -> ""
746+ [] -> ""
634− lims -> " LIMIT" <+> fromString (show (minimum lims))
747+ lims -> " LIMIT" <+> fromString (show (minimum lims))
635− renderOffsets = \case
748+ renderOffsets = \case
636− [] -> ""
749+ [] -> ""
637− offs -> " OFFSET" <+> fromString (show (sum offs))
750+ offs -> " OFFSET" <+> fromString (show (sum offs))
638
751
639-- | A `from` generates a `TableExpression` from a table reference that can be
752-- | A `from` generates a `TableExpression` from a table reference that can be
640-- a table name, or a derived table such as a subquery, a JOIN construct,
753-- a table name, or a derived table such as a subquery, a JOIN construct,
641-- or complex combinations of these. A `from` may be transformed by `where_`,
754-- or complex combinations of these. A `from` may be transformed by `where_`,
642−-- `group`, `having`, `orderBy`, `limit` and `offset`, using the `&` operator
755+-- `groupBy`, `having`, `orderBy`, `limit` and `offset`, using the `&` operator
643-- to match the left-to-right sequencing of their placement in SQL.
756-- to match the left-to-right sequencing of their placement in SQL.
644from
757from
645− :: FromClause schema params from -- ^ table reference
758+ :: FromClause outer commons schemas params from -- ^ table reference
646− -> TableExpression schema params from 'Ungrouped
759+ -> TableExpression outer commons 'Ungrouped schemas params from
647−from rels = TableExpression rels [] NoGroups NoHaving [] [] []
760+from tab = TableExpression tab [] noGroups NoHaving [] [] []
648
761
649-- | A `where_` is an endomorphism of `TableExpression`s which adds a
762-- | A `where_` is an endomorphism of `TableExpression`s which adds a
650-- search condition to the `whereClause`.
763-- search condition to the `whereClause`.
651where_
764where_
652− :: Condition schema from 'Ungrouped params -- ^ filtering condition
765+ :: Condition outer commons 'Ungrouped schemas params from -- ^ filtering condition
653− -> TableExpression schema params from grouping
766+ -> TableExpression outer commons grp schemas params from
654− -> TableExpression schema params from grouping
767+ -> TableExpression outer commons grp schemas params from
655where_ wh rels = rels {whereClause = wh : whereClause rels}
768where_ wh rels = rels {whereClause = wh : whereClause rels}
656
769
657-- | A `groupBy` is a transformation of `TableExpression`s which switches
770-- | A `groupBy` is a transformation of `TableExpression`s which switches
658−-- its `Grouping` from `Ungrouped` to `Grouped`. Use @group Nil@ to perform
771+-- its `Grouping` from `Ungrouped` to `Grouped`. Use @groupBy Nil@ to perform
659-- a "grand total" aggregation query.
772-- a "grand total" aggregation query.
660groupBy
773groupBy
661 :: SListI bys
774 :: SListI bys
662 => NP (By from) bys -- ^ grouped columns
775 => NP (By from) bys -- ^ grouped columns
663− -> TableExpression schema params from 'Ungrouped
776+ -> TableExpression outer commons 'Ungrouped schemas params from
664− -> TableExpression schema params from ('Grouped bys)
777+ -> TableExpression outer commons ('Grouped bys) schemas params from
665groupBy bys rels = TableExpression
778groupBy bys rels = TableExpression
666 { fromClause = fromClause rels
779 { fromClause = fromClause rels
667 , whereClause = whereClause rels
780 , whereClause = whereClause rels
668− , groupByClause = Group bys
781+ , groupByClause = group bys
669 , havingClause = Having []
782 , havingClause = Having []
670 , orderByClause = []
783 , orderByClause = []
671 , limitClause = limitClause rels
784 , limitClause = limitClause rels
@@ -675,177 +788,31 @@ groupBy bys rels = TableExpression
675-- | A `having` is an endomorphism of `TableExpression`s which adds a
788-- | A `having` is an endomorphism of `TableExpression`s which adds a
676-- search condition to the `havingClause`.
789-- search condition to the `havingClause`.
677having
790having
678− :: Condition schema from ('Grouped bys) params -- ^ having condition
791+ :: Condition outer commons ('Grouped bys) schemas params from -- ^ having condition
679− -> TableExpression schema params from ('Grouped bys)
792+ -> TableExpression outer commons ('Grouped bys) schemas params from
680− -> TableExpression schema params from ('Grouped bys)
793+ -> TableExpression outer commons ('Grouped bys) schemas params from
681having hv rels = rels
794having hv rels = rels
682 { havingClause = case havingClause rels of Having hvs -> Having (hv:hvs) }
795 { havingClause = case havingClause rels of Having hvs -> Having (hv:hvs) }
683
796
684−-- | An `orderBy` is an endomorphism of `TableExpression`s which appends an
797+instance OrderBy TableExpression where
685−-- ordering to the right of the `orderByClause`.
686−orderBy
687− :: [SortExpression schema from grouping params] -- ^ sort expressions
688− -> TableExpression schema params from grouping
689− -> TableExpression schema params from grouping
690−orderBy srts rels = rels {orderByClause = orderByClause rels ++ srts}
798+ orderBy srts rels = rels {orderByClause = orderByClause rels ++ srts}
691
799
692-- | A `limit` is an endomorphism of `TableExpression`s which adds to the
800-- | A `limit` is an endomorphism of `TableExpression`s which adds to the
693-- `limitClause`.
801-- `limitClause`.
694limit
802limit
695 :: Word64 -- ^ limit parameter
803 :: Word64 -- ^ limit parameter
696− -> TableExpression schema params from grouping
804+ -> TableExpression outer commons grp schemas params from
697− -> TableExpression schema params from grouping
805+ -> TableExpression outer commons grp schemas params from
698limit lim rels = rels {limitClause = lim : limitClause rels}
806limit lim rels = rels {limitClause = lim : limitClause rels}
699
807
700-- | An `offset` is an endomorphism of `TableExpression`s which adds to the
808-- | An `offset` is an endomorphism of `TableExpression`s which adds to the
701-- `offsetClause`.
809-- `offsetClause`.
702offset
810offset
703 :: Word64 -- ^ offset parameter
811 :: Word64 -- ^ offset parameter
704− -> TableExpression schema params from grouping
812+ -> TableExpression outer commons grp schemas params from
705− -> TableExpression schema params from grouping
813+ -> TableExpression outer commons grp schemas params from
706offset off rels = rels {offsetClause = off : offsetClause rels}
814offset off rels = rels {offsetClause = off : offsetClause rels}
707
815
708−{-----------------------------------------
709−JSON stuff
710−-----------------------------------------}
711−
712−unsafeSetOfFunction
713− :: ByteString
714− -> Expression schema '[] 'Ungrouped params ty
715− -> Query schema params row
716−unsafeSetOfFunction fun expr = UnsafeQuery $
717− "SELECT * FROM " <> fun <> "(" <> renderExpression expr <> ")"
718−
719−-- | Expands the outermost JSON object into a set of key/value pairs.
720−jsonEach
721− :: Expression schema '[] 'Ungrouped params (nullity 'PGjson) -- ^ json object
722− -> Query schema params
723− '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGjson]
724−jsonEach = unsafeSetOfFunction "json_each"
725−
726−-- | Expands the outermost binary JSON object into a set of key/value pairs.
727−jsonbEach
728− :: Expression schema '[] 'Ungrouped params (nullity 'PGjsonb) -- ^ jsonb object
729− -> Query schema params
730− '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGjsonb]
731−jsonbEach = unsafeSetOfFunction "jsonb_each"
732−
733−-- | Expands the outermost JSON object into a set of key/value pairs.
734−jsonEachAsText
735− :: Expression schema '[] 'Ungrouped params (nullity 'PGjson) -- ^ json object
736− -> Query schema params
737− '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext]
738−jsonEachAsText = unsafeSetOfFunction "json_each_text"
739−
740−-- | Expands the outermost binary JSON object into a set of key/value pairs.
741−jsonbEachAsText
742− :: Expression schema '[] 'Ungrouped params (nullity 'PGjsonb) -- ^ jsonb object
743− -> Query schema params
744− '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext]
745−jsonbEachAsText = unsafeSetOfFunction "jsonb_each_text"
746−
747−-- | Returns set of keys in the outermost JSON object.
748−jsonObjectKeys
749− :: Expression schema '[] 'Ungrouped params (nullity 'PGjson) -- ^ json object
750− -> Query schema params '["json_object_keys" ::: 'NotNull 'PGtext]
751−jsonObjectKeys = unsafeSetOfFunction "json_object_keys"
752−
753−-- | Returns set of keys in the outermost JSON object.
754−jsonbObjectKeys
755− :: Expression schema '[] 'Ungrouped params (nullity 'PGjsonb) -- ^ jsonb object
756− -> Query schema params '["jsonb_object_keys" ::: 'NotNull 'PGtext]
757−jsonbObjectKeys = unsafeSetOfFunction "jsonb_object_keys"
758−
759−unsafePopulateFunction
760− :: ByteString
761− -> TypeExpression schema (nullity ('PGcomposite row))
762− -> Expression schema '[] 'Ungrouped params ty
763− -> Query schema params row
764−unsafePopulateFunction fun ty expr = UnsafeQuery $
765− "SELECT * FROM " <> fun <> "("
766− <> "null::" <> renderTypeExpression ty <> ", "
767− <> renderExpression expr <> ")"
768−
769−-- | Expands the JSON expression to a row whose columns match the record
770−-- type defined by the given table.
771−jsonPopulateRecord
772− :: TypeExpression schema (nullity ('PGcomposite row)) -- ^ row type
773− -> Expression schema '[] 'Ungrouped params (nullity 'PGjson) -- ^ json object
774− -> Query schema params row
775−jsonPopulateRecord = unsafePopulateFunction "json_populate_record"
776−
777−-- | Expands the binary JSON expression to a row whose columns match the record
778−-- type defined by the given table.
779−jsonbPopulateRecord
780− :: TypeExpression schema (nullity ('PGcomposite row)) -- ^ row type
781− -> Expression schema '[] 'Ungrouped params (nullity 'PGjsonb) -- ^ jsonb object
782− -> Query schema params row
783−jsonbPopulateRecord = unsafePopulateFunction "jsonb_populate_record"
784−
785−-- | Expands the outermost array of objects in the given JSON expression to a
786−-- set of rows whose columns match the record type defined by the given table.
787−jsonPopulateRecordSet
788− :: TypeExpression schema (nullity ('PGcomposite row)) -- ^ row type
789− -> Expression schema '[] 'Ungrouped params (nullity 'PGjson) -- ^ json array
790− -> Query schema params row
791−jsonPopulateRecordSet = unsafePopulateFunction "json_populate_record_set"
792−
793−-- | Expands the outermost array of objects in the given binary JSON expression
794−-- to a set of rows whose columns match the record type defined by the given
795−-- table.
796−jsonbPopulateRecordSet
797− :: TypeExpression schema (nullity ('PGcomposite row)) -- ^ row type
798− -> Expression schema '[] 'Ungrouped params (nullity 'PGjsonb) -- ^ jsonb array
799− -> Query schema params row
800−jsonbPopulateRecordSet = unsafePopulateFunction "jsonb_populate_record_set"
801−
802−unsafeRecordFunction
803− :: (SListI record, json `In` PGJsonType)
804− => ByteString
805− -> Expression schema '[] 'Ungrouped params (nullity json)
806− -> NP (Aliased (TypeExpression schema)) record
807− -> Query schema params record
808−unsafeRecordFunction fun expr types = UnsafeQuery $
809− "SELECT * FROM " <> fun <> "("
810− <> renderExpression expr <> ")"
811− <+> "AS" <+> "x" <> parenthesized (renderCommaSeparated renderTy types)
812− where
813− renderTy :: Aliased (TypeExpression schema) ty -> ByteString
814− renderTy (ty `As` alias) =
815− renderAlias alias <+> renderTypeExpression ty
816−
817−-- | Builds an arbitrary record from a JSON object.
818−jsonToRecord
819− :: SListI record
820− => Expression schema '[] 'Ungrouped params (nullity 'PGjson) -- ^ json object
821− -> NP (Aliased (TypeExpression schema)) record -- ^ record types
822− -> Query schema params record
823−jsonToRecord = unsafeRecordFunction "json_to_record"
824−
825−-- | Builds an arbitrary record from a binary JSON object.
826−jsonbToRecord
827− :: SListI record
828− => Expression schema '[] 'Ungrouped params (nullity 'PGjsonb) -- ^ jsonb object
829− -> NP (Aliased (TypeExpression schema)) record -- ^ record types
830− -> Query schema params record
831−jsonbToRecord = unsafeRecordFunction "jsonb_to_record"
832−
833−-- | Builds an arbitrary set of records from a JSON array of objects.
834−jsonToRecordSet
835− :: SListI record
836− => Expression schema '[] 'Ungrouped params (nullity 'PGjson) -- ^ json array
837− -> NP (Aliased (TypeExpression schema)) record -- ^ record types
838− -> Query schema params record
839−jsonToRecordSet = unsafeRecordFunction "json_to_record_set"
840−
841−-- | Builds an arbitrary set of records from a binary JSON array of objects.
842−jsonbToRecordSet
843− :: SListI record
844− => Expression schema '[] 'Ungrouped params (nullity 'PGjsonb) -- ^ jsonb array
845− -> NP (Aliased (TypeExpression schema)) record -- ^ record types
846− -> Query schema params record
847−jsonbToRecordSet = unsafeRecordFunction "jsonb_to_record_set"
848−
849{-----------------------------------------
816{-----------------------------------------
850FROM clauses
817FROM clauses
851-----------------------------------------}
818-----------------------------------------}
@@ -854,61 +821,76 @@ FROM clauses
854A `FromClause` can be a table name, or a derived table such
821A `FromClause` can be a table name, or a derived table such
855as a subquery, a @JOIN@ construct, or complex combinations of these.
822as a subquery, a @JOIN@ construct, or complex combinations of these.
856-}
823-}
857−newtype FromClause schema params from
824+newtype FromClause outer commons schemas params from
858 = UnsafeFromClause { renderFromClause :: ByteString }
825 = UnsafeFromClause { renderFromClause :: ByteString }
859 deriving (GHC.Generic,Show,Eq,Ord,NFData)
826 deriving (GHC.Generic,Show,Eq,Ord,NFData)
827+instance RenderSQL (FromClause outer commons schemas params from) where
828+ renderSQL = renderFromClause
860
829
861−-- | A real `table` is a table from the schema.
830+-- | A real `table` is a table from the database.
862table
831table
863− :: Has tab schema ('Table table)
832+ :: (Has sch schemas schema, Has tab schema ('Table table))
864− => Aliased Alias (alias ::: tab)
833+ => Aliased (QualifiedAlias sch) (alias ::: tab)
865− -> FromClause schema params '[alias ::: TableToRow table]
834+ -> FromClause outer commons schemas params '[alias ::: TableToRow table]
866table (tab `As` alias) = UnsafeFromClause $
835table (tab `As` alias) = UnsafeFromClause $
867− renderAlias tab <+> "AS" <+> renderAlias alias
836+ renderSQL tab <+> "AS" <+> renderSQL alias
868
837
869-- | `subquery` derives a table from a `Query`.
838-- | `subquery` derives a table from a `Query`.
870subquery
839subquery
871− :: Aliased (Query schema params) rel
840+ :: Aliased (Query outer commons schemas params) query
872− -> FromClause schema params '[rel]
841+ -> FromClause outer commons schemas params '[query]
873−subquery = UnsafeFromClause . renderAliasedAs (parenthesized . renderQuery)
842+subquery = UnsafeFromClause . renderAliased (parenthesized . renderSQL)
874
843
875-- | `view` derives a table from a `View`.
844-- | `view` derives a table from a `View`.
876view
845view
877− :: Has view schema ('View row)
846+ :: (Has sch schemas schema, Has vw schema ('View view))
878− => Aliased Alias (alias ::: view)
847+ => Aliased (QualifiedAlias sch) (alias ::: vw)
879− -> FromClause schema params '[alias ::: row]
848+ -> FromClause outer commons schemas params '[alias ::: view]
880view (vw `As` alias) = UnsafeFromClause $
849view (vw `As` alias) = UnsafeFromClause $
881− renderAlias vw <+> "AS" <+> renderAlias alias
850+ renderSQL vw <+> "AS" <+> renderSQL alias
851+
852+-- | `common` derives a table from a common table expression.
853+common
854+ :: Has cte commons common
855+ => Aliased Alias (alias ::: cte)
856+ -> FromClause outer commons schemas params '[alias ::: common]
857+common (cte `As` alias) = UnsafeFromClause $
858+ renderSQL cte <+> "AS" <+> renderSQL alias
859+
860+instance Additional (FromClause outer commons schemas params) where
861+ also right left = UnsafeFromClause $
862+ renderSQL left <> ", " <> renderSQL right
882
863
864+{- |
883−{- | @left & crossJoin right@. For every possible combination of rows from
865+@left & crossJoin right@. For every possible combination of rows from
884− @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
885− 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@.
886− 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
887− have @n * m@ rows.
869+have @n * m@ rows.
888-}
870-}
889crossJoin
871crossJoin
890− :: FromClause schema params right
872+ :: FromClause outer commons schemas params right
891 -- ^ right
873 -- ^ right
892− -> FromClause schema params left
874+ -> FromClause outer commons schemas params left
893 -- ^ left
875 -- ^ left
894− -> FromClause schema params (Join left right)
876+ -> FromClause outer commons schemas params (Join left right)
895crossJoin right left = UnsafeFromClause $
877crossJoin right left = UnsafeFromClause $
896− renderFromClause left <+> "CROSS JOIN" <+> renderFromClause right
878+ renderSQL left <+> "CROSS JOIN" <+> renderSQL right
897
879
898{- | @left & innerJoin right on@. The joined table is filtered by
880{- | @left & innerJoin right on@. The joined table is filtered by
899the @on@ condition.
881the @on@ condition.
900-}
882-}
901innerJoin
883innerJoin
902− :: FromClause schema params right
884+ :: FromClause outer commons schemas params right
903 -- ^ right
885 -- ^ right
904− -> Condition schema (Join left right) 'Ungrouped params
886+ -> Condition outer commons 'Ungrouped schemas params (Join left right)
905 -- ^ @on@ condition
887 -- ^ @on@ condition
906− -> FromClause schema params left
888+ -> FromClause outer commons schemas params left
907 -- ^ left
889 -- ^ left
908− -> FromClause schema params (Join left right)
890+ -> FromClause outer commons schemas params (Join left right)
909innerJoin right on left = UnsafeFromClause $
891innerJoin right on left = UnsafeFromClause $
910− renderFromClause left <+> "INNER JOIN" <+> renderFromClause right
892+ renderSQL left <+> "INNER JOIN" <+> renderSQL right
911− <+> "ON" <+> renderExpression on
893+ <+> "ON" <+> renderSQL on
912
894
913{- | @left & leftOuterJoin right on@. First, an inner join is performed.
895{- | @left & leftOuterJoin right on@. First, an inner join is performed.
914 Then, for each row in @left@ that does not satisfy the @on@ condition with
896 Then, for each row in @left@ that does not satisfy the @on@ condition with
@@ -916,16 +898,16 @@ innerJoin right on left = UnsafeFromClause $
916 Thus, the joined table always has at least one row for each row in @left@.
898 Thus, the joined table always has at least one row for each row in @left@.
917-}
899-}
918leftOuterJoin
900leftOuterJoin
919− :: FromClause schema params right
901+ :: FromClause outer commons schemas params right
920 -- ^ right
902 -- ^ right
921− -> Condition schema (Join left right) 'Ungrouped params
903+ -> Condition outer commons 'Ungrouped schemas params (Join left right)
922 -- ^ @on@ condition
904 -- ^ @on@ condition
923− -> FromClause schema params left
905+ -> FromClause outer commons schemas params left
924 -- ^ left
906 -- ^ left
925− -> FromClause schema params (Join left (NullifyFrom right))
907+ -> FromClause outer commons schemas params (Join left (NullifyFrom right))
926leftOuterJoin right on left = UnsafeFromClause $
908leftOuterJoin right on left = UnsafeFromClause $
927− renderFromClause left <+> "LEFT OUTER JOIN" <+> renderFromClause right
909+ renderSQL left <+> "LEFT OUTER JOIN" <+> renderSQL right
928− <+> "ON" <+> renderExpression on
910+ <+> "ON" <+> renderSQL on
929
911
930{- | @left & rightOuterJoin right on@. First, an inner join is performed.
912{- | @left & rightOuterJoin right on@. First, an inner join is performed.
931 Then, for each row in @right@ that does not satisfy the @on@ condition with
913 Then, for each row in @right@ that does not satisfy the @on@ condition with
@@ -934,16 +916,16 @@ leftOuterJoin right on left = UnsafeFromClause $
934 have a row for each row in @right@.
916 have a row for each row in @right@.
935-}
917-}
936rightOuterJoin
918rightOuterJoin
937− :: FromClause schema params right
919+ :: FromClause outer commons schemas params right
938 -- ^ right
920 -- ^ right
939− -> Condition schema (Join left right) 'Ungrouped params
921+ -> Condition outer commons 'Ungrouped schemas params (Join left right)
940 -- ^ @on@ condition
922 -- ^ @on@ condition
941− -> FromClause schema params left
923+ -> FromClause outer commons schemas params left
942 -- ^ left
924 -- ^ left
943− -> FromClause schema params (Join (NullifyFrom left) right)
925+ -> FromClause outer commons schemas params (Join (NullifyFrom left) right)
944rightOuterJoin right on left = UnsafeFromClause $
926rightOuterJoin right on left = UnsafeFromClause $
945− renderFromClause left <+> "RIGHT OUTER JOIN" <+> renderFromClause right
927+ renderSQL left <+> "RIGHT OUTER JOIN" <+> renderSQL right
946− <+> "ON" <+> renderExpression on
928+ <+> "ON" <+> renderSQL on
947
929
948{- | @left & fullOuterJoin right on@. First, an inner join is performed.
930{- | @left & fullOuterJoin right on@. First, an inner join is performed.
949 Then, for each row in @left@ that does not satisfy the @on@ condition with
931 Then, for each row in @left@ that does not satisfy the @on@ condition with
@@ -953,23 +935,23 @@ rightOuterJoin right on left = UnsafeFromClause $
953 is added.
935 is added.
954-}
936-}
955fullOuterJoin
937fullOuterJoin
956− :: FromClause schema params right
938+ :: FromClause outer commons schemas params right
957 -- ^ right
939 -- ^ right
958− -> Condition schema (Join left right) 'Ungrouped params
940+ -> Condition outer commons 'Ungrouped schemas params (Join left right)
959 -- ^ @on@ condition
941 -- ^ @on@ condition
960− -> FromClause schema params left
942+ -> FromClause outer commons schemas params left
961 -- ^ left
943 -- ^ left
962− -> FromClause schema params
944+ -> FromClause outer commons schemas params
963 (Join (NullifyFrom left) (NullifyFrom right))
945 (Join (NullifyFrom left) (NullifyFrom right))
964fullOuterJoin right on left = UnsafeFromClause $
946fullOuterJoin right on left = UnsafeFromClause $
965− renderFromClause left <+> "FULL OUTER JOIN" <+> renderFromClause right
947+ renderSQL left <+> "FULL OUTER JOIN" <+> renderSQL right
966− <+> "ON" <+> renderExpression on
948+ <+> "ON" <+> renderSQL on
967
949
968{-----------------------------------------
950{-----------------------------------------
969Grouping
951Grouping
970-----------------------------------------}
952-----------------------------------------}
971
953
972−-- | `By`s are used in `group` to reference a list of columns which are then
954+-- | `By`s are used in `groupBy` to reference a list of columns which are then
973-- used to group together those rows in a table that have the same values
955-- used to group together those rows in a table that have the same values
974-- in all the columns listed. @By \#col@ will reference an unambiguous
956-- in all the columns listed. @By \#col@ will reference an unambiguous
975-- column @col@; otherwise @By2 (\#tab \! \#col)@ will reference a table
957-- column @col@; otherwise @By2 (\#tab \! \#col)@ will reference a table
@@ -989,6 +971,10 @@ data By
989deriving instance Show (By from by)
971deriving instance Show (By from by)
990deriving instance Eq (By from by)
972deriving instance Eq (By from by)
991deriving instance Ord (By from by)
973deriving instance Ord (By from by)
974+instance RenderSQL (By from by) where
975+ renderSQL = \case
976+ By1 column -> renderSQL column
977+ By2 rel column -> renderSQL rel <> "." <> renderSQL column
992
978
993instance (HasUnique rel rels cols, Has col cols ty, by ~ '(rel, col))
979instance (HasUnique rel rels cols, Has col cols ty, by ~ '(rel, col))
994 => IsLabel col (By rels by) where fromLabel = By1 fromLabel
980 => IsLabel col (By rels by) where fromLabel = By1 fromLabel
@@ -1000,417 +986,113 @@ instance (Has rel rels cols, Has col cols ty, bys ~ '[ '(rel, col)])
1000 => IsQualified rel col (NP (By rels) bys) where
986 => IsQualified rel col (NP (By rels) bys) where
1001 rel ! col = By2 rel col :* Nil
987 rel ! col = By2 rel col :* Nil
1002
988
1003−-- | Renders a `By`.
1004−renderBy :: By from by -> ByteString
1005−renderBy = \case
1006− By1 column -> renderAlias column
1007− By2 rel column -> renderAlias rel <> "." <> renderAlias column
1008−
1009-- | A `GroupByClause` indicates the `Grouping` of a `TableExpression`.
989-- | A `GroupByClause` indicates the `Grouping` of a `TableExpression`.
1010-- A `NoGroups` indicates `Ungrouped` while a `Group` indicates `Grouped`.
990-- A `NoGroups` indicates `Ungrouped` while a `Group` indicates `Grouped`.
1011-- @NoGroups@ is distinguised from @Group Nil@ since no aggregation can be
991-- @NoGroups@ is distinguised from @Group Nil@ since no aggregation can be
1012-- done on @NoGroups@ while all output `Expression`s must be aggregated
992-- done on @NoGroups@ while all output `Expression`s must be aggregated
1013-- in @Group Nil@. In general, all output `Expression`s in the
993-- in @Group Nil@. In general, all output `Expression`s in the
1014-- complement of @bys@ must be aggregated in @Group bys@.
994-- complement of @bys@ must be aggregated in @Group bys@.
1015−data GroupByClause from grouping where
995+newtype GroupByClause grp from = UnsafeGroupByClause
996+ { renderGroupByClause :: ByteString }
997+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
998+instance RenderSQL (GroupByClause grp from) where
999+ renderSQL = renderGroupByClause
1016− NoGroups :: GroupByClause from 'Ungrouped
1000+noGroups :: GroupByClause 'Ungrouped from
1017− Group
1001+noGroups = UnsafeGroupByClause ""
1002+group
1018− :: SListI bys
1003+ :: SListI bys
1019− => NP (By from) bys
1004+ => NP (By from) bys
1020− -> GroupByClause from ('Grouped bys)
1005+ -> GroupByClause ('Grouped bys) from
1021−
1006+group bys = UnsafeGroupByClause $ case bys of
1022−-- | Renders a `GroupByClause`.
1023−renderGroupByClause :: GroupByClause from grouping -> ByteString
1024−renderGroupByClause = \case
1025− NoGroups -> ""
1026− Group Nil -> ""
1007+ Nil -> ""
1027− Group bys -> " GROUP BY" <+> renderCommaSeparated renderBy bys
1008+ bys' -> " GROUP BY" <+> renderCommaSeparated renderSQL bys'
1028
1009
1029-- | 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.
1030-- An `Ungrouped` `TableExpression` may only use `NoHaving` while a `Grouped`
1011-- An `Ungrouped` `TableExpression` may only use `NoHaving` while a `Grouped`
1031-- `TableExpression` must use `Having` whose conditions are combined with
1012-- `TableExpression` must use `Having` whose conditions are combined with
1032-- `.&&`.
1013-- `.&&`.
1033−data HavingClause schema from grouping params where
1014+data HavingClause outer commons grp schemas params from where
1034− NoHaving :: HavingClause schema from 'Ungrouped params
1015+ NoHaving :: HavingClause outer commons 'Ungrouped schemas params from
1035 Having
1016 Having
1036− :: [Condition schema from ('Grouped bys) params]
1017+ :: [Condition outer commons ('Grouped bys) schemas params from]
1037− -> HavingClause schema from ('Grouped bys) params
1018+ -> HavingClause outer commons ('Grouped bys) schemas params from
1038−deriving instance Show (HavingClause schema from grouping params)
1019+deriving instance Show (HavingClause outer commons grp schemas params from)
1039−deriving instance Eq (HavingClause schema from grouping params)
1020+deriving instance Eq (HavingClause outer commons grp schemas params from)
1040−deriving instance Ord (HavingClause schema from grouping params)
1021+deriving instance Ord (HavingClause outer commons grp schemas params from)
1041
1022
1042-- | Render a `HavingClause`.
1023-- | Render a `HavingClause`.
1043−renderHavingClause :: HavingClause schema from grouping params -> ByteString
1024+instance RenderSQL (HavingClause outer commons grp schemas params from) where
1044−renderHavingClause = \case
1025+ renderSQL = \case
1045− NoHaving -> ""
1026+ NoHaving -> ""
1046− Having [] -> ""
1027+ Having [] -> ""
1047− Having conditions ->
1028+ Having conditions ->
1048− " HAVING" <+> commaSeparated (renderExpression <$> conditions)
1029+ " HAVING" <+> commaSeparated (renderSQL <$> conditions)
1049−
1050−{-----------------------------------------
1051−Sorting
1052−-----------------------------------------}
1053−
1054−-- | `SortExpression`s are used by `sortBy` to optionally sort the results
1055−-- of a `Query`. `Asc` or `Desc` set the sort direction of a `NotNull` result
1056−-- column to ascending or descending. Ascending order puts smaller values
1057−-- first, where "smaller" is defined in terms of the `.<` operator. Similarly,
1058−-- descending order is determined with the `.>` operator. `AscNullsFirst`,
1059−-- `AscNullsLast`, `DescNullsFirst` and `DescNullsLast` options are used to
1060−-- determine whether nulls appear before or after non-null values in the sort
1061−-- ordering of a `Null` result column.
1062−data SortExpression schema from grouping params where
1063− Asc
1064− :: Expression schema from grouping params ('NotNull ty)
1065− -> SortExpression schema from grouping params
1066− Desc
1067− :: Expression schema from grouping params ('NotNull ty)
1068− -> SortExpression schema from grouping params
1069− AscNullsFirst
1070− :: Expression schema from grouping params ('Null ty)
1071− -> SortExpression schema from grouping params
1072− AscNullsLast
1073− :: Expression schema from grouping params ('Null ty)
1074− -> SortExpression schema from grouping params
1075− DescNullsFirst
1076− :: Expression schema from grouping params ('Null ty)
1077− -> SortExpression schema from grouping params
1078− DescNullsLast
1079− :: Expression schema from grouping params ('Null ty)
1080− -> SortExpression schema from grouping params
1081−deriving instance Show (SortExpression schema from grouping params)
1082−
1083−-- | Render a `SortExpression`.
1084−renderSortExpression :: SortExpression schema from grouping params -> ByteString
1085−renderSortExpression = \case
1086− Asc expression -> renderExpression expression <+> "ASC"
1087− Desc expression -> renderExpression expression <+> "DESC"
1088− AscNullsFirst expression -> renderExpression expression
1089− <+> "ASC NULLS FIRST"
1090− DescNullsFirst expression -> renderExpression expression
1091− <+> "DESC NULLS FIRST"
1092− AscNullsLast expression -> renderExpression expression <+> "ASC NULLS LAST"
1093− DescNullsLast expression -> renderExpression expression <+> "DESC NULLS LAST"
1094−
1095−unsafeSubqueryExpression
1096− :: ByteString
1097− -> Expression schema from grp params ty
1098− -> Query schema params '[alias ::: ty]
1099− -> Expression schema from grp params (nullity 'PGbool)
1100−unsafeSubqueryExpression op x q = UnsafeExpression $
1101− renderExpression x <+> op <+> parenthesized (renderQuery q)
1102−
1103−unsafeRowSubqueryExpression
1104− :: SListI row
1105− => ByteString
1106− -> NP (Aliased (Expression schema from grp params)) row
1107− -> Query schema params row
1108− -> Expression schema from grp params (nullity 'PGbool)
1109−unsafeRowSubqueryExpression op xs q = UnsafeExpression $
1110− renderExpression (row xs) <+> op <+> parenthesized (renderQuery q)
1111−
1112−-- | The right-hand side is a sub`Query`, which must return exactly one column.
1113−-- The left-hand expression is evaluated and compared to each row of the
1114−-- sub`Query` result. The result of `in_` is `true` if any equal subquery row is found.
1115−-- The result is `false` if no equal row is found
1116−-- (including the case where the subquery returns no rows).
1117−--
1118−-- >>> printSQL $ true `in_` values_ (true `as` #foo)
1119−-- TRUE IN (SELECT * FROM (VALUES (TRUE)) AS t ("foo"))
1120−in_
1121− :: Expression schema from grp params ty -- ^ expression
1122− -> Query schema params '[alias ::: ty] -- ^ subquery
1123− -> Expression schema from grp params (nullity 'PGbool)
1124−in_ = unsafeSubqueryExpression "IN"
1125−
1126−{- | The left-hand side of this form of `rowIn` is a row constructor.
1127−The right-hand side is a sub`Query`,
1128−which must return exactly as many columns as
1129−there are expressions in the left-hand row.
1130−The left-hand expressions are evaluated and compared row-wise to each row
1131−of the subquery result. The result of `rowIn`
1132−is `true` if any equal subquery row is found.
1133−The result is `false` if no equal row is found
1134−(including the case where the subquery returns no rows).
1135−
1136−>>> let myRow = 1 `as` #foo :* false `as` #bar :: NP (Aliased (Expression '[] '[] 'Ungrouped '[])) '["foo" ::: 'NotNull 'PGint2, "bar" ::: 'NotNull 'PGbool]
1137−>>> printSQL $ myRow `rowIn` values_ myRow
1138−ROW(1, FALSE) IN (SELECT * FROM (VALUES (1, FALSE)) AS t ("foo", "bar"))
1139−-}
1140−rowIn
1141− :: SListI row
1142− => NP (Aliased (Expression schema from grp params)) row -- ^ row constructor
1143− -> Query schema params row -- ^ subquery
1144− -> Expression schema from grp params (nullity 'PGbool)
1145−rowIn = unsafeRowSubqueryExpression "IN"
1146−
1147−-- | >>> printSQL $ true `eqAll` values_ (true `as` #foo)
1148−-- TRUE = ALL (SELECT * FROM (VALUES (TRUE)) AS t ("foo"))
1149−eqAll
1150− :: Expression schema from grp params ty -- ^ expression
1151− -> Query schema params '[alias ::: ty] -- ^ subquery
1152− -> Expression schema from grp params (nullity 'PGbool)
1153−eqAll = unsafeSubqueryExpression "= ALL"
1154−
1155−-- | >>> let myRow = 1 `as` #foo :* false `as` #bar :: NP (Aliased (Expression '[] '[] 'Ungrouped '[])) '["foo" ::: 'NotNull 'PGint2, "bar" ::: 'NotNull 'PGbool]
1156−-- >>> printSQL $ myRow `rowEqAll` values_ myRow
1157−-- ROW(1, FALSE) = ALL (SELECT * FROM (VALUES (1, FALSE)) AS t ("foo", "bar"))
1158−rowEqAll
1159− :: SListI row
1160− => NP (Aliased (Expression schema from grp params)) row -- ^ row constructor
1161− -> Query schema params row -- ^ subquery
1162− -> Expression schema from grp params (nullity 'PGbool)
1163−rowEqAll = unsafeRowSubqueryExpression "= ALL"
1164−
1165−-- | >>> printSQL $ true `eqAny` values_ (true `as` #foo)
1166−-- TRUE = ANY (SELECT * FROM (VALUES (TRUE)) AS t ("foo"))
1167−eqAny
1168− :: Expression schema from grp params ty -- ^ expression
1169− -> Query schema params '[alias ::: ty] -- ^ subquery
1170− -> Expression schema from grp params (nullity 'PGbool)
1171−eqAny = unsafeSubqueryExpression "= ANY"
1172−
1173−-- | >>> let myRow = 1 `as` #foo :* false `as` #bar :: NP (Aliased (Expression '[] '[] 'Ungrouped '[])) '["foo" ::: 'NotNull 'PGint2, "bar" ::: 'NotNull 'PGbool]
1174−-- >>> printSQL $ myRow `rowEqAny` values_ myRow
1175−-- ROW(1, FALSE) = ANY (SELECT * FROM (VALUES (1, FALSE)) AS t ("foo", "bar"))
1176−rowEqAny
1177− :: SListI row
1178− => NP (Aliased (Expression schema from grp params)) row -- ^ row constructor
1179− -> Query schema params row -- ^ subquery
1180− -> Expression schema from grp params (nullity 'PGbool)
1181−rowEqAny = unsafeRowSubqueryExpression "= ANY"
1182−
1183−-- | >>> printSQL $ true `neqAll` values_ (true `as` #foo)
1184−-- TRUE <> ALL (SELECT * FROM (VALUES (TRUE)) AS t ("foo"))
1185−neqAll
1186− :: Expression schema from grp params ty -- ^ expression
1187− -> Query schema params '[alias ::: ty] -- ^ subquery
1188− -> Expression schema from grp params (nullity 'PGbool)
1189−neqAll = unsafeSubqueryExpression "<> ALL"
1190−
1191−-- | >>> let myRow = 1 `as` #foo :* false `as` #bar :: NP (Aliased (Expression '[] '[] 'Ungrouped '[])) '["foo" ::: 'NotNull 'PGint2, "bar" ::: 'NotNull 'PGbool]
1192−-- >>> printSQL $ myRow `rowNeqAll` values_ myRow
1193−-- ROW(1, FALSE) <> ALL (SELECT * FROM (VALUES (1, FALSE)) AS t ("foo", "bar"))
1194−rowNeqAll
1195− :: SListI row
1196− => NP (Aliased (Expression schema from grp params)) row -- ^ row constructor
1197− -> Query schema params row -- ^ subquery
1198− -> Expression schema from grp params (nullity 'PGbool)
1199−rowNeqAll = unsafeRowSubqueryExpression "<> ALL"
1200−
1201−-- | >>> printSQL $ true `neqAny` values_ (true `as` #foo)
1202−-- TRUE <> ANY (SELECT * FROM (VALUES (TRUE)) AS t ("foo"))
1203−neqAny
1204− :: Expression schema from grp params ty -- ^ expression
1205− -> Query schema params '[alias ::: ty] -- ^ subquery
1206− -> Expression schema from grp params (nullity 'PGbool)
1207−neqAny = unsafeSubqueryExpression "<> ANY"
1208−
1209−-- | >>> let myRow = 1 `as` #foo :* false `as` #bar :: NP (Aliased (Expression '[] '[] 'Ungrouped '[])) '["foo" ::: 'NotNull 'PGint2, "bar" ::: 'NotNull 'PGbool]
1210−-- >>> printSQL $ myRow `rowNeqAny` values_ myRow
1211−-- ROW(1, FALSE) <> ANY (SELECT * FROM (VALUES (1, FALSE)) AS t ("foo", "bar"))
1212−rowNeqAny
1213− :: SListI row
1214− => NP (Aliased (Expression schema from grp params)) row -- ^ row constructor
1215− -> Query schema params row -- ^ subquery
1216− -> Expression schema from grp params (nullity 'PGbool)
1217−rowNeqAny = unsafeRowSubqueryExpression "<> ANY"
1218−
1219−-- | >>> printSQL $ true `allLt` values_ (true `as` #foo)
1220−-- TRUE ALL < (SELECT * FROM (VALUES (TRUE)) AS t ("foo"))
1221−allLt
1222− :: Expression schema from grp params ty -- ^ expression
1223− -> Query schema params '[alias ::: ty] -- ^ subquery
1224− -> Expression schema from grp params (nullity 'PGbool)
1225−allLt = unsafeSubqueryExpression "ALL <"
1226−
1227−-- | >>> let myRow = 1 `as` #foo :* false `as` #bar :: NP (Aliased (Expression '[] '[] 'Ungrouped '[])) '["foo" ::: 'NotNull 'PGint2, "bar" ::: 'NotNull 'PGbool]
1228−-- >>> printSQL $ myRow `rowLtAll` values_ myRow
1229−-- ROW(1, FALSE) ALL < (SELECT * FROM (VALUES (1, FALSE)) AS t ("foo", "bar"))
1230−rowLtAll
1231− :: SListI row
1232− => NP (Aliased (Expression schema from grp params)) row -- ^ row constructor
1233− -> Query schema params row -- ^ subquery
1234− -> Expression schema from grp params (nullity 'PGbool)
1235−rowLtAll = unsafeRowSubqueryExpression "ALL <"
1236−
1237−-- | >>> printSQL $ true `ltAny` values_ (true `as` #foo)
1238−-- TRUE ANY < (SELECT * FROM (VALUES (TRUE)) AS t ("foo"))
1239−ltAny
1240− :: Expression schema from grp params ty -- ^ expression
1241− -> Query schema params '[alias ::: ty] -- ^ subquery
1242− -> Expression schema from grp params (nullity 'PGbool)
1243−ltAny = unsafeSubqueryExpression "ANY <"
1244−
1245−-- | >>> let myRow = 1 `as` #foo :* false `as` #bar :: NP (Aliased (Expression '[] '[] 'Ungrouped '[])) '["foo" ::: 'NotNull 'PGint2, "bar" ::: 'NotNull 'PGbool]
1246−-- >>> printSQL $ myRow `rowLtAll` values_ myRow
1247−-- ROW(1, FALSE) ALL < (SELECT * FROM (VALUES (1, FALSE)) AS t ("foo", "bar"))
1248−rowLtAny
1249− :: SListI row
1250− => NP (Aliased (Expression schema from grp params)) row -- ^ row constructor
1251− -> Query schema params row -- ^ subquery
1252− -> Expression schema from grp params (nullity 'PGbool)
1253−rowLtAny = unsafeRowSubqueryExpression "ANY <"
1254−
1255−-- | >>> printSQL $ true `lteAll` values_ (true `as` #foo)
1256−-- TRUE <= ALL (SELECT * FROM (VALUES (TRUE)) AS t ("foo"))
1257−lteAll
1258− :: Expression schema from grp params ty -- ^ expression
1259− -> Query schema params '[alias ::: ty] -- ^ subquery
1260− -> Expression schema from grp params (nullity 'PGbool)
1261−lteAll = unsafeSubqueryExpression "<= ALL"
1262−
1263−-- | >>> let myRow = 1 `as` #foo :* false `as` #bar :: NP (Aliased (Expression '[] '[] 'Ungrouped '[])) '["foo" ::: 'NotNull 'PGint2, "bar" ::: 'NotNull 'PGbool]
1264−-- >>> printSQL $ myRow `rowLteAll` values_ myRow
1265−-- ROW(1, FALSE) <= ALL (SELECT * FROM (VALUES (1, FALSE)) AS t ("foo", "bar"))
1266−rowLteAll
1267− :: SListI row
1268− => NP (Aliased (Expression schema from grp params)) row -- ^ row constructor
1269− -> Query schema params row -- ^ subquery
1270− -> Expression schema from grp params (nullity 'PGbool)
1271−rowLteAll = unsafeRowSubqueryExpression "<= ALL"
1272−
1273−-- | >>> printSQL $ true `lteAny` values_ (true `as` #foo)
1274−-- TRUE <= ANY (SELECT * FROM (VALUES (TRUE)) AS t ("foo"))
1275−lteAny
1276− :: Expression schema from grp params ty -- ^ expression
1277− -> Query schema params '[alias ::: ty] -- ^ subquery
1278− -> Expression schema from grp params (nullity 'PGbool)
1279−lteAny = unsafeSubqueryExpression "<= ANY"
1280−
1281−-- | >>> let myRow = 1 `as` #foo :* false `as` #bar :: NP (Aliased (Expression '[] '[] 'Ungrouped '[])) '["foo" ::: 'NotNull 'PGint2, "bar" ::: 'NotNull 'PGbool]
1282−-- >>> printSQL $ myRow `rowLteAny` values_ myRow
1283−-- ROW(1, FALSE) <= ANY (SELECT * FROM (VALUES (1, FALSE)) AS t ("foo", "bar"))
1284−rowLteAny
1285− :: SListI row
1286− => NP (Aliased (Expression schema from grp params)) row -- ^ row constructor
1287− -> Query schema params row -- ^ subquery
1288− -> Expression schema from grp params (nullity 'PGbool)
1289−rowLteAny = unsafeRowSubqueryExpression "<= ANY"
1290−
1291−-- | >>> printSQL $ true `gtAll` values_ (true `as` #foo)
1292−-- TRUE > ALL (SELECT * FROM (VALUES (TRUE)) AS t ("foo"))
1293−gtAll
1294− :: Expression schema from grp params ty -- ^ expression
1295− -> Query schema params '[alias ::: ty] -- ^ subquery
1296− -> Expression schema from grp params (nullity 'PGbool)
1297−gtAll = unsafeSubqueryExpression "> ALL"
1298−
1299−-- | >>> let myRow = 1 `as` #foo :* false `as` #bar :: NP (Aliased (Expression '[] '[] 'Ungrouped '[])) '["foo" ::: 'NotNull 'PGint2, "bar" ::: 'NotNull 'PGbool]
1300−-- >>> printSQL $ myRow `rowGtAll` values_ myRow
1301−-- ROW(1, FALSE) > ALL (SELECT * FROM (VALUES (1, FALSE)) AS t ("foo", "bar"))
1302−rowGtAll
1303− :: SListI row
1304− => NP (Aliased (Expression schema from grp params)) row -- ^ row constructor
1305− -> Query schema params row -- ^ subquery
1306− -> Expression schema from grp params (nullity 'PGbool)
1307−rowGtAll = unsafeRowSubqueryExpression "> ALL"
1308−
1309−-- | >>> printSQL $ true `gtAny` values_ (true `as` #foo)
1310−-- TRUE > ANY (SELECT * FROM (VALUES (TRUE)) AS t ("foo"))
1311−gtAny
1312− :: Expression schema from grp params ty -- ^ expression
1313− -> Query schema params '[alias ::: ty] -- ^ subquery
1314− -> Expression schema from grp params (nullity 'PGbool)
1315−gtAny = unsafeSubqueryExpression "> ANY"
1316−
1317−-- | >>> let myRow = 1 `as` #foo :* false `as` #bar :: NP (Aliased (Expression '[] '[] 'Ungrouped '[])) '["foo" ::: 'NotNull 'PGint2, "bar" ::: 'NotNull 'PGbool]
1318−-- >>> printSQL $ myRow `rowGtAny` values_ myRow
1319−-- ROW(1, FALSE) > ANY (SELECT * FROM (VALUES (1, FALSE)) AS t ("foo", "bar"))
1320−rowGtAny
1321− :: SListI row
1322− => NP (Aliased (Expression schema from grp params)) row -- ^ row constructor
1323− -> Query schema params row -- ^ subquery
1324− -> Expression schema from grp params (nullity 'PGbool)
1325−rowGtAny = unsafeRowSubqueryExpression "> ANY"
1326−
1327−-- | >>> printSQL $ true `gteAll` values_ (true `as` #foo)
1328−-- TRUE >= ALL (SELECT * FROM (VALUES (TRUE)) AS t ("foo"))
1329−gteAll
1330− :: Expression schema from grp params ty -- ^ expression
1331− -> Query schema params '[alias ::: ty] -- ^ subquery
1332− -> Expression schema from grp params (nullity 'PGbool)
1333−gteAll = unsafeSubqueryExpression ">= ALL"
1334−
1335−-- | >>> let myRow = 1 `as` #foo :* false `as` #bar :: NP (Aliased (Expression '[] '[] 'Ungrouped '[])) '["foo" ::: 'NotNull 'PGint2, "bar" ::: 'NotNull 'PGbool]
1336−-- >>> printSQL $ myRow `rowGteAll` values_ myRow
1337−-- ROW(1, FALSE) >= ALL (SELECT * FROM (VALUES (1, FALSE)) AS t ("foo", "bar"))
1338−rowGteAll
1339− :: SListI row
1340− => NP (Aliased (Expression schema from grp params)) row -- ^ row constructor
1341− -> Query schema params row -- ^ subquery
1342− -> Expression schema from grp params (nullity 'PGbool)
1343−rowGteAll = unsafeRowSubqueryExpression ">= ALL"
1344−
1345−-- | >>> printSQL $ true `gteAny` values_ (true `as` #foo)
1346−-- TRUE >= ANY (SELECT * FROM (VALUES (TRUE)) AS t ("foo"))
1347−gteAny
1348− :: Expression schema from grp params ty -- ^ expression
1349− -> Query schema params '[alias ::: ty] -- ^ subquery
1350− -> Expression schema from grp params (nullity 'PGbool)
1351−gteAny = unsafeSubqueryExpression ">= ANY"
1352−
1353−-- | >>> let myRow = 1 `as` #foo :* false `as` #bar :: NP (Aliased (Expression '[] '[] 'Ungrouped '[])) '["foo" ::: 'NotNull 'PGint2, "bar" ::: 'NotNull 'PGbool]
1354−-- >>> printSQL $ myRow `rowGteAny` values_ myRow
1355−-- ROW(1, FALSE) >= ANY (SELECT * FROM (VALUES (1, FALSE)) AS t ("foo", "bar"))
1356−rowGteAny
1357− :: SListI row
1358− => NP (Aliased (Expression schema from grp params)) row -- ^ row constructor
1359− -> Query schema params row -- ^ subquery
1360− -> Expression schema from grp params (nullity 'PGbool)
1361−rowGteAny = unsafeRowSubqueryExpression ">= ANY"
1362
1030
1363-- | A `CommonTableExpression` is an auxiliary statement in a `with` clause.
1031-- | A `CommonTableExpression` is an auxiliary statement in a `with` clause.
1364data CommonTableExpression statement
1032data CommonTableExpression statement
1033+ (schemas :: SchemasType)
1365 (params :: [NullityType])
1034 (params :: [NullityType])
1366− (schema0 :: SchemaType)
1035+ (commons0 :: FromType)
1367− (schema1 :: SchemaType) where
1036+ (commons1 :: FromType) where
1368 CommonTableExpression
1037 CommonTableExpression
1369− :: Aliased (statement schema params) (alias ::: cte)
1038+ :: Aliased (statement commons schemas params) (cte ::: common)
1370− -> CommonTableExpression
1039+ -> CommonTableExpression statement schemas params commons (cte ::: common ': commons)
1371− statement params schema (alias ::: 'View cte ': schema)
1040+instance
1372−instance (KnownSymbol alias, schema1 ~ (alias ::: 'View cte ': schema))
1041+ ( KnownSymbol cte
1042+ , commons1 ~ (cte ::: common ': commons)
1373− => Aliasable alias
1043+ ) => Aliasable cte
1374− (statement schema params cte)
1044+ (statement commons schemas params common)
1375− (CommonTableExpression statement params schema schema1) where
1045+ (CommonTableExpression statement schemas params commons commons1) where
1376− statement `as` alias = CommonTableExpression (statement `as` alias)
1046+ statement `as` cte = CommonTableExpression (statement `as` cte)
1377−instance (KnownSymbol alias, schema1 ~ (alias ::: 'View cte ': schema))
1047+instance
1048+ ( KnownSymbol cte
1049+ , commons1 ~ (cte ::: common ': commons)
1050+ ) => Aliasable cte
1378− => Aliasable alias (statement schema params cte)
1051+ (statement commons schemas params common)
1379− (AlignedList (CommonTableExpression statement params) schema schema1) where
1052+ (Path (CommonTableExpression statement schemas params) commons commons1) where
1380− statement `as` alias = single (statement `as` alias)
1053+ statement `as` cte = csingleton (statement `as` cte)
1381−
1054+
1382−-- | render a `CommonTableExpression`.
1055+instance (forall c s p r. RenderSQL (statement c s p r)) => RenderSQL
1383−renderCommonTableExpression
1384− :: (forall sch ps row. statement ps sch row -> ByteString) -- ^ render statement
1385− -> CommonTableExpression statement params schema0 schema1 -> ByteString
1056+ (CommonTableExpression statement schemas params commons0 commons1) where
1386−renderCommonTableExpression renderStatement
1387− (CommonTableExpression (statement `As` alias)) =
1057+ renderSQL (CommonTableExpression (statement `As` cte)) =
1388− renderAlias alias <+> "AS" <+> parenthesized (renderStatement statement)
1058+ renderSQL cte <+> "AS" <+> parenthesized (renderSQL statement)
1389−
1390−-- | render a non-empty `AlignedList` of `CommonTableExpression`s.
1391−renderCommonTableExpressions
1392− :: (forall sch ps row. statement ps sch row -> ByteString) -- ^ render statement
1393− -> CommonTableExpression statement params schema0 schema1
1394− -> AlignedList (CommonTableExpression statement params) schema1 schema2
1395− -> ByteString
1396−renderCommonTableExpressions renderStatement cte ctes =
1397− renderCommonTableExpression renderStatement cte <> case ctes of
1398− Done -> ""
1399− cte' :>> ctes' -> "," <+>
1400− renderCommonTableExpressions renderStatement cte' ctes'
1401
1059
1402-- | `with` provides a way to write auxiliary statements for use in a larger query.
1060-- | `with` provides a way to write auxiliary statements for use in a larger query.
1403-- These statements, referred to as `CommonTableExpression`s, can be thought of as
1061-- These statements, referred to as `CommonTableExpression`s, can be thought of as
1404-- defining temporary tables that exist just for one query.
1062-- defining temporary tables that exist just for one query.
1405class With statement where
1063class With statement where
1406 with
1064 with
1407− :: AlignedList (CommonTableExpression statement params) schema0 schema1
1065+ :: Path (CommonTableExpression statement schemas params) commons0 commons1
1408 -- ^ common table expressions
1066 -- ^ common table expressions
1409− -> statement schema1 params row
1067+ -> statement commons1 schemas params row
1410 -- ^ larger query
1068 -- ^ larger query
1411− -> statement schema0 params row
1069+ -> statement commons0 schemas params row
1412−instance With Query where
1070+instance With (Query outer) where
1413 with Done query = query
1071 with Done query = query
1414− with (cte :>> ctes) query = UnsafeQuery $
1072+ with ctes query = UnsafeQuery $
1415− "WITH" <+> renderCommonTableExpressions renderQuery cte ctes
1073+ "WITH" <+> commaSeparated (ctoList renderSQL ctes) <+> renderSQL query
1416− <+> renderQuery query
1074+
1075+{- |
1076+>>> import Data.Monoid (Sum (..))
1077+>>> import Data.Int (Int64)
1078+>>> :{
1079+ let
1080+ query :: Query_ schema () (Sum Int64)
1081+ query = withRecursive
1082+ ( values_ ((1 & astype int) `as` #n)
1083+ `unionAll`
1084+ select_ ((#n + 1) `as` #n)
1085+ (from (common #t) & where_ (#n .< 100)) `as` #t )
1086+ ( select_ (fromNull 0 (sum_ (All #n)) `as` #getSum) (from (common #t) & groupBy Nil))
1087+ in printSQL query
1088+:}
1089+WITH RECURSIVE "t" AS ((SELECT * FROM (VALUES ((1 :: int))) AS t ("n")) UNION ALL (SELECT ("n" + 1) AS "n" FROM "t" AS "t" WHERE ("n" < 100))) SELECT COALESCE(sum(ALL "n"), 0) AS "getSum" FROM "t" AS "t"
1090+-}
1091+withRecursive
1092+ :: Aliased (Query outer (recursive ': commons) schemas params) recursive
1093+ -> Query outer (recursive ': commons) schemas params row
1094+ -> Query outer commons schemas params row
1095+withRecursive (recursive `As` cte) query = UnsafeQuery $
1096+ "WITH RECURSIVE" <+> renderSQL cte
1097+ <+> "AS" <+> parenthesized (renderSQL recursive)
1098+ <+> renderSQL query
squeal-postgresql/src/Squeal/PostgreSQL/Render.hs+47−14
@@ -10,7 +10,9 @@ Rendering helper functions.
10
10
11{-# LANGUAGE
11{-# LANGUAGE
12 AllowAmbiguousTypes
12 AllowAmbiguousTypes
13+ , ConstraintKinds
13 , FlexibleContexts
14 , FlexibleContexts
15+ , LambdaCase
14 , MagicHash
16 , MagicHash
15 , OverloadedStrings
17 , OverloadedStrings
16 , PolyKinds
18 , PolyKinds
@@ -21,30 +23,34 @@ Rendering helper functions.
21
23
22module Squeal.PostgreSQL.Render
24module Squeal.PostgreSQL.Render
23 ( -- * Render
25 ( -- * Render
26+ RenderSQL (..)
27+ , printSQL
28+ , escape
24− parenthesized
29+ , parenthesized
30+ , bracketed
25 , (<+>)
31 , (<+>)
26 , commaSeparated
32 , commaSeparated
27 , doubleQuoted
33 , doubleQuoted
28 , singleQuotedText
34 , singleQuotedText
29 , singleQuotedUtf8
35 , singleQuotedUtf8
30 , renderCommaSeparated
36 , renderCommaSeparated
37+ , renderCommaSeparatedConstraint
31 , renderCommaSeparatedMaybe
38 , renderCommaSeparatedMaybe
32 , renderNat
39 , renderNat
33 , renderSymbol
40 , renderSymbol
34− , RenderSQL (..)
35− , printSQL
36 ) where
41 ) where
37
42
38−import Control.Monad.Base
43+import Control.Monad.IO.Class (MonadIO (..))
39import Data.ByteString (ByteString)
44import Data.ByteString (ByteString)
40−import Data.Maybe
45+import Data.Maybe (catMaybes)
41import Data.Monoid ((<>))
46import Data.Monoid ((<>))
42import Data.Text (Text)
47import Data.Text (Text)
43import Generics.SOP
48import Generics.SOP
44import GHC.Exts
49import GHC.Exts
45−import GHC.TypeLits
50+import GHC.TypeLits hiding (Text)
51+
46−import qualified Data.Text as T
52+import qualified Data.Text as Text
47−import qualified Data.Text.Encoding as T
53+import qualified Data.Text.Encoding as Text
48import qualified Data.ByteString as ByteString
54import qualified Data.ByteString as ByteString
49import qualified Data.ByteString.Char8 as Char8
55import qualified Data.ByteString.Char8 as Char8
50
56
@@ -52,6 +58,10 @@ import qualified Data.ByteString.Char8 as Char8
52parenthesized :: ByteString -> ByteString
58parenthesized :: ByteString -> ByteString
53parenthesized str = "(" <> str <> ")"
59parenthesized str = "(" <> str <> ")"
54
60
61+-- | Square bracket a `ByteString`
62+bracketed :: ByteString -> ByteString
63+bracketed str = "[" <> str <> "]"
64+
55-- | Concatenate two `ByteString`s with a space between.
65-- | Concatenate two `ByteString`s with a space between.
56(<+>) :: ByteString -> ByteString -> ByteString
66(<+>) :: ByteString -> ByteString -> ByteString
57infixr 7 <+>
67infixr 7 <+>
@@ -67,11 +77,12 @@ doubleQuoted str = "\"" <> str <> "\""
67
77
68-- | Add single quotes around a `Text` and escape single quotes within it.
78-- | Add single quotes around a `Text` and escape single quotes within it.
69singleQuotedText :: Text -> ByteString
79singleQuotedText :: Text -> ByteString
70−singleQuotedText str = "'" <> T.encodeUtf8 (T.replace "'" "''" str) <> "'"
80+singleQuotedText str =
81+ "'" <> Text.encodeUtf8 (Text.replace "'" "''" str) <> "'"
71
82
72-- | Add single quotes around a `ByteString` and escape single quotes within it.
83-- | Add single quotes around a `ByteString` and escape single quotes within it.
73singleQuotedUtf8 :: ByteString -> ByteString
84singleQuotedUtf8 :: ByteString -> ByteString
74−singleQuotedUtf8 = singleQuotedText . T.decodeUtf8
85+singleQuotedUtf8 = singleQuotedText . Text.decodeUtf8
75
86
76-- | Comma separate the renderings of a heterogeneous list.
87-- | Comma separate the renderings of a heterogeneous list.
77renderCommaSeparated
88renderCommaSeparated
@@ -83,6 +94,16 @@ renderCommaSeparated render
83 . hcollapse
94 . hcollapse
84 . hmap (K . render)
95 . hmap (K . render)
85
96
97+-- | Comma separate the renderings of a heterogeneous list.
98+renderCommaSeparatedConstraint
99+ :: forall c xs expression. (All c xs, SListI xs)
100+ => (forall x. c x => expression x -> ByteString)
101+ -> NP expression xs -> ByteString
102+renderCommaSeparatedConstraint render
103+ = commaSeparated
104+ . hcollapse
105+ . hcmap (Proxy @c) (K . render)
106+
86-- | Comma separate the `Maybe` renderings of a heterogeneous list, dropping
107-- | Comma separate the `Maybe` renderings of a heterogeneous list, dropping
87-- `Nothing`s.
108-- `Nothing`s.
88renderCommaSeparatedMaybe
109renderCommaSeparatedMaybe
@@ -104,9 +125,21 @@ renderSymbol :: forall s. KnownSymbol s => ByteString
104renderSymbol = fromString (symbolVal' (proxy# :: Proxy# s))
125renderSymbol = fromString (symbolVal' (proxy# :: Proxy# s))
105
126
106-- | A class for rendering SQL
127-- | A class for rendering SQL
107−class RenderSQL sql where
128+class RenderSQL sql where renderSQL :: sql -> ByteString
108− renderSQL :: sql -> ByteString
109
129
110-- | Print SQL.
130-- | Print SQL.
111−printSQL :: (RenderSQL sql, MonadBase IO io) => sql -> io ()
131+printSQL :: (RenderSQL sql, MonadIO io) => sql -> io ()
112−printSQL = liftBase . Char8.putStrLn . renderSQL
132+printSQL = liftIO . Char8.putStrLn . renderSQL
133+
134+-- | `escape` a character to prevent injection
135+escape :: Char -> String
136+escape = \case
137+ '\NUL' -> "\\0"
138+ '\'' -> "''"
139+ '"' -> "\\\""
140+ '\b' -> "\\b"
141+ '\n' -> "\\n"
142+ '\r' -> "\\r"
143+ '\t' -> "\\t"
144+ '\\' -> "\\\\"
145+ c -> [c]
squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs+223−507
@@ -1,16 +1,15 @@
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.
12-}
12-}
13−{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
14{-# LANGUAGE
13{-# LANGUAGE
15 AllowAmbiguousTypes
14 AllowAmbiguousTypes
16 , ConstraintKinds
15 , ConstraintKinds
@@ -22,6 +21,7 @@ it defines an embedding of Haskell types into Postgres types.
22 , GADTs
21 , GADTs
23 , LambdaCase
22 , LambdaCase
24 , OverloadedStrings
23 , OverloadedStrings
24+ , QuantifiedConstraints
25 , RankNTypes
25 , RankNTypes
26 , ScopedTypeVariables
26 , ScopedTypeVariables
27 , StandaloneDeriving
27 , StandaloneDeriving
@@ -39,73 +39,48 @@ module Squeal.PostgreSQL.Schema
39 , NullityType (..)
39 , NullityType (..)
40 , RowType
40 , RowType
41 , FromType
41 , FromType
42− -- * Haskell to Postgres Types
43− , PG
44− , NullPG
45− , TuplePG
46− , RowPG
47− , Json (..)
48− , Jsonb (..)
49− , Composite (..)
50− , Enumerated (..)
51 -- * Schema Types
42 -- * Schema Types
52 , ColumnType
43 , ColumnType
53 , ColumnsType
44 , ColumnsType
54 , TableType
45 , TableType
55 , SchemumType (..)
46 , SchemumType (..)
47+ , IndexType (..)
48+ , FunctionType
49+ , OperatorType (..)
50+ , ReturnsType (..)
56 , SchemaType
51 , SchemaType
52+ , SchemasType
53+ , Public
57 -- * Constraints
54 -- * Constraints
58 , (:=>)
55 , (:=>)
59 , ColumnConstraint (..)
56 , ColumnConstraint (..)
60 , TableConstraint (..)
57 , TableConstraint (..)
61 , TableConstraints
58 , TableConstraints
62 , Uniquely
59 , Uniquely
63− -- * Aliases
64− , (:::)
65− , Alias (Alias)
66− , renderAlias
67− , renderAliases
68− , Aliased (As)
69− , Aliasable (as)
70− , renderAliasedAs
71− , Has
72− , HasUnique
73− , HasAll
74− , IsLabel (..)
75− , IsQualified (..)
76− , renderAliasString
77 -- * Enumerated Labels
60 -- * Enumerated Labels
78 , IsPGlabel (..)
61 , IsPGlabel (..)
79 , PGlabel (..)
62 , PGlabel (..)
80− , renderLabel
81− , renderLabels
82− , LabelsPG
83− -- * Grouping
84− , Grouping (..)
85− , GroupedBy
86− -- * Aligned lists
87− , AlignedList (..)
88− , single
89 -- * Data Definitions
63 -- * Data Definitions
90 , Create
64 , Create
65+ , CreateIfNotExists
66+ , CreateOrReplace
91 , Drop
67 , Drop
68+ , DropSchemum
69+ , DropIfExists
70+ , DropSchemumIfExists
92 , Alter
71 , Alter
72+ , AlterIfExists
93 , Rename
73 , Rename
74+ , RenameIfExists
75+ , ConstraintInvolves
94 , DropIfConstraintsInvolve
76 , DropIfConstraintsInvolve
95− -- * Lists
77+ , IsNotElem
96− , Join
78+ , AllUnique
97− , Elem
98− , In
99− , Length
100 -- * Type Classifications
79 -- * Type Classifications
101− , HasOid (..)
102 , PGNum
80 , PGNum
103 , PGIntegral
81 , PGIntegral
104 , PGFloating
82 , PGFloating
105 , PGTypeOf
83 , PGTypeOf
106− , PGArrayOf
107− , PGArray
108− , PGTextArray
109 , PGJsonType
84 , PGJsonType
110 , PGJsonKey
85 , PGJsonKey
111 , SamePGType
86 , SamePGType
@@ -117,41 +92,27 @@ module Squeal.PostgreSQL.Schema
117 , NullifyFrom
92 , NullifyFrom
118 -- * Table Conversions
93 -- * Table Conversions
119 , TableToColumns
94 , TableToColumns
95+ , ColumnsToRow
120 , TableToRow
96 , TableToRow
121 ) where
97 ) where
122
98
123import Control.Category
99import Control.Category
124−import Control.DeepSeq
125−import Data.Aeson (Value)
126−import Data.ByteString (ByteString)
127−import Data.Int (Int16, Int32, Int64)
128import Data.Kind
100import Data.Kind
129import Data.Monoid hiding (All)
101import Data.Monoid hiding (All)
130−import Data.Scientific (Scientific)
131−import Data.String
132−import Data.Text (Text)
133−import Data.Time
134−import Data.Word (Word16, Word32, Word64)
135import Data.Type.Bool
102import Data.Type.Bool
136−import Data.UUID.Types (UUID)
137−import Data.Vector (Vector)
138import Generics.SOP
103import Generics.SOP
139−import Generics.SOP.Record
140−import GHC.OverloadedLabels
141import GHC.TypeLits
104import GHC.TypeLits
142−import Network.IP.Addr
143import Prelude hiding (id, (.))
105import Prelude hiding (id, (.))
144
106
145−import qualified Data.ByteString.Lazy as Lazy
107+import Squeal.PostgreSQL.Alias
146−import qualified Data.Text.Lazy as Lazy
108+import Squeal.PostgreSQL.List
147−import qualified GHC.Generics as GHC
148−import qualified Generics.SOP.Type.Metadata as Type
149−
150import Squeal.PostgreSQL.Render
109import Squeal.PostgreSQL.Render
151
110
111+-- $setup
112+-- >>> import Squeal.PostgreSQL
113+
152-- | `PGType` is the promoted datakind of PostgreSQL types.
114-- | `PGType` is the promoted datakind of PostgreSQL types.
153--
115--
154−-- >>> import Squeal.PostgreSQL.Schema
155-- >>> :kind 'PGbool
116-- >>> :kind 'PGbool
156-- 'PGbool :: PGType
117-- 'PGbool :: PGType
157data PGType
118data PGType
@@ -162,6 +123,7 @@ data PGType
162 | PGnumeric -- ^ arbitrary precision numeric type
123 | PGnumeric -- ^ arbitrary precision numeric type
163 | PGfloat4 -- ^ single precision floating-point number (4 bytes)
124 | PGfloat4 -- ^ single precision floating-point number (4 bytes)
164 | PGfloat8 -- ^ double precision floating-point number (8 bytes)
125 | PGfloat8 -- ^ double precision floating-point number (8 bytes)
126+ | PGmoney -- ^ currency amount
165 | PGchar Nat -- ^ fixed-length character string
127 | PGchar Nat -- ^ fixed-length character string
166 | PGvarchar Nat -- ^ variable-length character string
128 | PGvarchar Nat -- ^ variable-length character string
167 | PGtext -- ^ variable-length character string
129 | PGtext -- ^ variable-length character string
@@ -177,39 +139,15 @@ data PGType
177 | PGjson -- ^ textual JSON data
139 | PGjson -- ^ textual JSON data
178 | PGjsonb -- ^ binary JSON data, decomposed
140 | PGjsonb -- ^ binary JSON data, decomposed
179 | PGvararray NullityType -- ^ variable length array
141 | PGvararray NullityType -- ^ variable length array
180− | PGfixarray Nat NullityType -- ^ fixed length array
142+ | PGfixarray [Nat] NullityType -- ^ fixed length array
181 | 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.
182 | 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.
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.
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).
183 | UnsafePGType Symbol -- ^ an escape hatch for unsupported PostgreSQL types
149 | UnsafePGType Symbol -- ^ an escape hatch for unsupported PostgreSQL types
184
150
185−-- | The object identifier of a `PGType`.
186−--
187−-- >>> :set -XTypeApplications
188−-- >>> oid @'PGbool
189−-- 16
190−class HasOid (ty :: PGType) where oid :: Word32
191−instance HasOid 'PGbool where oid = 16
192−instance HasOid 'PGint2 where oid = 21
193−instance HasOid 'PGint4 where oid = 23
194−instance HasOid 'PGint8 where oid = 20
195−instance HasOid 'PGnumeric where oid = 1700
196−instance HasOid 'PGfloat4 where oid = 700
197−instance HasOid 'PGfloat8 where oid = 701
198−instance HasOid ('PGchar n) where oid = 18
199−instance HasOid ('PGvarchar n) where oid = 1043
200−instance HasOid 'PGtext where oid = 25
201−instance HasOid 'PGbytea where oid = 17
202−instance HasOid 'PGtimestamp where oid = 1114
203−instance HasOid 'PGtimestamptz where oid = 1184
204−instance HasOid 'PGdate where oid = 1082
205−instance HasOid 'PGtime where oid = 1083
206−instance HasOid 'PGtimetz where oid = 1266
207−instance HasOid 'PGinterval where oid = 1186
208−instance HasOid 'PGuuid where oid = 2950
209−instance HasOid 'PGinet where oid = 869
210−instance HasOid 'PGjson where oid = 114
211−instance HasOid 'PGjsonb where oid = 3802
212−
213-- | `NullityType` encodes the potential presence or definite absence of a
151-- | `NullityType` encodes the potential presence or definite absence of a
214-- @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.
215--
153--
@@ -228,11 +166,6 @@ data NullityType
228type (:=>) constraint ty = '(constraint,ty)
166type (:=>) constraint ty = '(constraint,ty)
229infixr 7 :=>
167infixr 7 :=>
230
168
231−-- | The alias operator `:::` is like a promoted version of `As`,
232−-- a type level pair between an alias and some type.
233−type (:::) (alias :: Symbol) ty = '(alias,ty)
234−infixr 6 :::
235−
236-- | `ColumnConstraint` encodes the availability of @DEFAULT@ for inserts and updates.
169-- | `ColumnConstraint` encodes the availability of @DEFAULT@ for inserts and updates.
237-- A column can be assigned a default value.
170-- A column can be assigned a default value.
238-- A data `Squeal.PostgreSQL.Manipulations.Manipulation` command can also
171-- A data `Squeal.PostgreSQL.Manipulations.Manipulation` command can also
@@ -274,7 +207,13 @@ data TableConstraint
274 | PrimaryKey [Symbol]
207 | PrimaryKey [Symbol]
275 | ForeignKey [Symbol] Symbol [Symbol]
208 | ForeignKey [Symbol] Symbol [Symbol]
276
209
277−-- | A `TableConstraints` is a row of `TableConstraint`s.
210+{- | A `TableConstraints` is a row of `TableConstraint`s.
211+
212+>>> :{
213+type family UsersConstraints :: TableConstraints where
214+ UsersConstraints = '[ "pk_users" ::: 'PrimaryKey '["id"] ]
215+:}
216+-}
278type TableConstraints = [(Symbol,TableConstraint)]
217type TableConstraints = [(Symbol,TableConstraint)]
279
218
280-- | A `ForeignKey` must reference columns that either are
219-- | A `ForeignKey` must reference columns that either are
@@ -300,7 +239,7 @@ type family Uniquely
300type TableType = (TableConstraints,ColumnsType)
239type TableType = (TableConstraints,ColumnsType)
301
240
302{- | A `RowType` is a row of `NullityType`. They correspond to Haskell
241{- | A `RowType` is a row of `NullityType`. They correspond to Haskell
303−record types by means of `RowPG` and are used in many places.
242+record types by means of `Squeal.PostgreSQL.Binary.RowPG` and are used in many places.
304
243
305>>> :{
244>>> :{
306type family PersonRow :: RowType where
245type family PersonRow :: RowType where
@@ -321,9 +260,19 @@ type FromType = [(Symbol,RowType)]
321
260
322-- | `ColumnsToRow` removes column constraints.
261-- | `ColumnsToRow` removes column constraints.
323type family ColumnsToRow (columns :: ColumnsType) :: RowType where
262type family ColumnsToRow (columns :: ColumnsType) :: RowType where
324− ColumnsToRow '[] = '[]
263+ ColumnsToRow (column ::: _ :=> ty ': column1 ::: _ :=> ty1 ': column2 ::: _ :=> ty2 ': column3 ::: _ :=> ty3 ': column4 ::: _ :=> ty4 ': column5 ::: _ :=> ty5 ': columns) =
325− 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) =
326 column ::: ty ': ColumnsToRow columns
274 column ::: ty ': ColumnsToRow columns
275+ ColumnsToRow '[] = '[]
327
276
328-- | `TableToColumns` removes table constraints.
277-- | `TableToColumns` removes table constraints.
329type family TableToColumns (table :: TableType) :: ColumnsType where
278type family TableToColumns (table :: TableType) :: ColumnsType where
@@ -333,153 +282,6 @@ type family TableToColumns (table :: TableType) :: ColumnsType where
333type family TableToRow (table :: TableType) :: RowType where
282type family TableToRow (table :: TableType) :: RowType where
334 TableToRow tab = ColumnsToRow (TableToColumns tab)
283 TableToRow tab = ColumnsToRow (TableToColumns tab)
335
284
336−-- | `Grouping` is an auxiliary namespace, created by
337−-- @GROUP BY@ clauses (`Squeal.PostgreSQL.Query.group`), and used
338−-- for typesafe aggregation
339−data Grouping
340− = Ungrouped -- ^ no aggregation permitted
341− | Grouped [(Symbol,Symbol)] -- ^ aggregation required for any column which is not grouped
342−
343−{- | A `GroupedBy` constraint indicates that a table qualified column is
344−a member of the auxiliary namespace created by @GROUP BY@ clauses and thus,
345−may be called in an output `Squeal.PostgreSQL.Expression.Expression` without aggregating.
346−-}
347−class (KnownSymbol table, KnownSymbol column)
348− => GroupedBy table column bys where
349−instance {-# OVERLAPPING #-} (KnownSymbol table, KnownSymbol column)
350− => GroupedBy table column ('(table,column) ': bys)
351−instance {-# OVERLAPPABLE #-}
352− ( KnownSymbol table
353− , KnownSymbol column
354− , GroupedBy table column bys
355− ) => GroupedBy table column (tabcol ': bys)
356−
357−-- | `Alias`es are proxies for a type level string or `Symbol`
358−-- and have an `IsLabel` instance so that with @-XOverloadedLabels@
359−--
360−-- >>> :set -XOverloadedLabels
361−-- >>> #foobar :: Alias "foobar"
362−-- Alias
363−data Alias (alias :: Symbol) = Alias
364− deriving (Eq,GHC.Generic,Ord,Show,NFData)
365−instance alias1 ~ alias2 => IsLabel alias1 (Alias alias2) where
366− fromLabel = Alias
367−instance aliases ~ '[alias] => IsLabel alias (NP Alias aliases) where
368− fromLabel = fromLabel :* Nil
369−instance KnownSymbol alias => RenderSQL (Alias alias) where renderSQL = renderAlias
370−
371−-- | >>> renderAlias #jimbob
372−-- "\"jimbob\""
373−renderAlias :: KnownSymbol alias => Alias alias -> ByteString
374−renderAlias = doubleQuoted . fromString . symbolVal
375−
376−-- | >>> renderAliasString #ohmahgerd
377−-- "'ohmahgerd'"
378−renderAliasString :: KnownSymbol alias => Alias alias -> ByteString
379−renderAliasString = singleQuotedText . fromString . symbolVal
380−
381−-- | >>> import Generics.SOP (NP(..))
382−-- >>> renderAliases (#jimbob :* #kandi)
383−-- ["\"jimbob\"","\"kandi\""]
384−renderAliases
385− :: All KnownSymbol aliases => NP Alias aliases -> [ByteString]
386−renderAliases = hcollapse
387− . hcmap (Proxy @KnownSymbol) (K . renderAlias)
388−
389−-- | The `As` operator is used to name an expression. `As` is like a demoted
390−-- version of `:::`.
391−--
392−-- >>> Just "hello" `As` #hi :: Aliased Maybe ("hi" ::: String)
393−-- As (Just "hello") Alias
394−data Aliased expression aliased where
395− As
396− :: KnownSymbol alias
397− => expression ty
398− -> Alias alias
399− -> Aliased expression (alias ::: ty)
400−deriving instance Show (expression ty)
401− => Show (Aliased expression (alias ::: ty))
402−deriving instance Eq (expression ty)
403− => Eq (Aliased expression (alias ::: ty))
404−deriving instance Ord (expression ty)
405− => Ord (Aliased expression (alias ::: ty))
406−instance (alias0 ~ alias1, alias0 ~ alias2, KnownSymbol alias2)
407− => IsLabel alias0 (Aliased Alias (alias1 ::: alias2)) where
408− fromLabel = fromLabel @alias2 `As` fromLabel @alias1
409−
410−-- | The `Aliasable` class provides a way to scrap your `Nil`s
411−-- in an `NP` list of `Aliased` expressions.
412−class KnownSymbol alias => Aliasable alias expression aliased
413− | aliased -> expression
414− , aliased -> alias
415− where as :: expression -> Alias alias -> aliased
416−instance (KnownSymbol alias, alias ~ alias1) => Aliasable alias
417− (expression ty)
418− (Aliased expression (alias1 ::: ty))
419− where
420− as = As
421−instance (KnownSymbol alias, tys ~ '[alias ::: ty]) => Aliasable alias
422− (expression ty)
423− (NP (Aliased expression) tys)
424− where
425− expression `as` alias = expression `As` alias :* Nil
426−
427−-- | >>> let renderMaybe = fromString . maybe "Nothing" (const "Just")
428−-- >>> renderAliasedAs renderMaybe (Just (3::Int) `As` #an_int)
429−-- "Just AS \"an_int\""
430−renderAliasedAs
431− :: (forall ty. expression ty -> ByteString)
432− -> Aliased expression aliased
433− -> ByteString
434−renderAliasedAs render (expression `As` alias) =
435− render expression <> " AS " <> renderAlias alias
436−
437−-- | @HasUnique alias fields field@ is a constraint that proves that
438−-- @fields@ is a singleton of @alias ::: field@.
439−type HasUnique alias fields field = fields ~ '[alias ::: field]
440−
441−-- | @Has alias fields field@ is a constraint that proves that
442−-- @fields@ has a field of @alias ::: field@, inferring @field@
443−-- from @alias@ and @fields@.
444−class KnownSymbol alias =>
445− Has (alias :: Symbol) (fields :: [(Symbol,kind)]) (field :: kind)
446− | alias fields -> field where
447−instance {-# OVERLAPPING #-} KnownSymbol alias
448− => Has alias (alias ::: field ': fields) field
449−instance {-# OVERLAPPABLE #-} (KnownSymbol alias, Has alias fields field)
450− => Has alias (field' ': fields) field
451−
452−-- | `HasAll` extends `Has` to take lists of @aliases@ and @fields@ and infer
453−-- a list of @subfields@.
454−class
455− ( All KnownSymbol aliases
456− ) => HasAll
457− (aliases :: [Symbol])
458− (fields :: [(Symbol,kind)])
459− (subfields :: [(Symbol,kind)])
460− | aliases fields -> subfields where
461−instance {-# OVERLAPPING #-} HasAll '[] fields '[]
462−instance {-# OVERLAPPABLE #-}
463− (Has alias fields field, HasAll aliases fields subfields)
464− => HasAll (alias ': aliases) fields (alias ::: field ': subfields)
465−
466−-- | Analagous to `IsLabel`, the constraint
467−-- `IsQualified` defines `!` for a column alias qualified
468−-- by a table alias.
469−class IsQualified table column expression where
470− (!) :: Alias table -> Alias column -> expression
471− infixl 9 !
472−instance IsQualified table column (Alias table, Alias column) where (!) = (,)
473−
474−-- | @Elem@ is a promoted `Data.List.elem`.
475−type family Elem x xs where
476− Elem x '[] = 'False
477− Elem x (x ': xs) = 'True
478− Elem x (_ ': xs) = Elem x xs
479−
480−-- | @In x xs@ is a constraint that proves that @x@ is in @xs@.
481−type family In x xs :: Constraint where In x xs = Elem x xs ~ 'True
482−
483-- | Numeric Postgres types.
285-- | Numeric Postgres types.
484type PGNum =
286type PGNum =
485 '[ 'PGint2, 'PGint4, 'PGint8, 'PGnumeric, 'PGfloat4, 'PGfloat8]
287 '[ 'PGint2, 'PGint4, 'PGint8, 'PGnumeric, 'PGfloat4, 'PGfloat8]
@@ -490,37 +292,6 @@ type PGFloating = '[ 'PGfloat4, 'PGfloat8, 'PGnumeric]
490-- | Integral Postgres types.
292-- | Integral Postgres types.
491type PGIntegral = '[ 'PGint2, 'PGint4, 'PGint8]
293type PGIntegral = '[ 'PGint2, 'PGint4, 'PGint8]
492
294
493−-- | Error message helper for displaying unavailable\/unknown\/placeholder type
494−-- variables whose kind is known.
495−type Placeholder k = 'Text "(_::" :<>: 'ShowType k :<>: 'Text ")"
496−
497−type ErrArrayOf arr ty = arr :<>: 'Text " " :<>: ty
498−type ErrPGfixarrayOf t = ErrArrayOf ('ShowType 'PGfixarray :<>: 'Text " " :<>: Placeholder Nat) t
499−type ErrPGvararrayOf t = ErrArrayOf ('ShowType 'PGvararray) t
500−
501−-- | Ensure a type is a valid array type.
502−type family PGArray name arr :: Constraint where
503− PGArray name ('PGvararray x) = ()
504− PGArray name ('PGfixarray n x) = ()
505− PGArray name val = TypeError
506− ('Text name :<>: 'Text ": Unsatisfied PGArray constraint. Expected either: "
507− :$$: 'Text " • " :<>: ErrPGvararrayOf (Placeholder PGType)
508− :$$: 'Text " • " :<>: ErrPGfixarrayOf (Placeholder PGType)
509− :$$: 'Text "But got: " :<>: 'ShowType val)
510−
511−-- | Ensure a type is a valid array type with a specific element type.
512−type family PGArrayOf name arr ty :: Constraint where
513− PGArrayOf name ('PGvararray x) ty = x ~ ty
514− PGArrayOf name ('PGfixarray n x) ty = x ~ ty
515− PGArrayOf name val ty = TypeError
516− ( 'Text name :<>: 'Text "Unsatisfied PGArrayOf constraint. Expected either: "
517− :$$: 'Text " • " :<>: ErrPGvararrayOf ( 'ShowType ty )
518− :$$: 'Text " • " :<>: ErrPGfixarrayOf ( 'ShowType ty )
519− :$$: 'Text "But got: " :<>: 'ShowType val)
520−
521−-- | Ensure a type is a valid array type whose elements are text.
522−type PGTextArray name arr = PGArrayOf name arr ('NotNull 'PGtext)
523−
524-- | `PGTypeOf` forgets about @NULL@ and any column constraints.
295-- | `PGTypeOf` forgets about @NULL@ and any column constraints.
525type family PGTypeOf (ty :: NullityType) :: PGType where
296type family PGTypeOf (ty :: NullityType) :: PGType where
526 PGTypeOf (nullity pg) = pg
297 PGTypeOf (nullity pg) = pg
@@ -534,14 +305,24 @@ instance ty0 ~ ty1 => SamePGType
534
305
535-- | `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.
536type 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
537 AllNotNull '[] = ()
314 AllNotNull '[] = ()
538− AllNotNull (column ::: def :=> 'NotNull ty ': columns) = AllNotNull columns
539
315
540-- | `NotAllNull` is a constraint that proves a `ColumnsType` has some
316-- | `NotAllNull` is a constraint that proves a `ColumnsType` has some
541-- @NOT NULL@.
317-- @NOT NULL@.
542type family NotAllNull (columns :: ColumnsType) :: Constraint where
318type family NotAllNull (columns :: ColumnsType) :: Constraint where
543− NotAllNull (column ::: def :=> 'NotNull ty ': columns) = ()
319+ NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()
320+ NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()
321+ NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()
322+ NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()
323+ NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()
324+ NotAllNull (_ ::: _ :=> 'NotNull _ ': _) = ()
544− NotAllNull (column ::: def :=> 'Null ty ': columns) = NotAllNull columns
325+ NotAllNull (_ ::: _ :=> 'Null _ ': columns) = NotAllNull columns
545
326
546-- | `NullifyType` is an idempotent that nullifies a `NullityType`.
327-- | `NullifyType` is an idempotent that nullifies a `NullityType`.
547type family NullifyType (ty :: NullityType) :: NullityType where
328type family NullifyType (ty :: NullityType) :: NullityType where
@@ -550,23 +331,37 @@ type family NullifyType (ty :: NullityType) :: NullityType where
550
331
551-- | `NullifyRow` is an idempotent that nullifies a `RowType`.
332-- | `NullifyRow` is an idempotent that nullifies a `RowType`.
552type family NullifyRow (columns :: RowType) :: RowType where
333type family NullifyRow (columns :: RowType) :: RowType where
553− 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
554 NullifyRow (column ::: ty ': columns) =
344 NullifyRow (column ::: ty ': columns) =
555 column ::: NullifyType ty ': NullifyRow columns
345 column ::: NullifyType ty ': NullifyRow columns
346+ NullifyRow '[] = '[]
556
347
557-- | `NullifyFrom` is an idempotent that nullifies a `FromType`
348-- | `NullifyFrom` is an idempotent that nullifies a `FromType`
558-- 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
559-- in a `Squeal.PostgreSQL.Query.FromClause`.
350-- in a `Squeal.PostgreSQL.Query.FromClause`.
560type family NullifyFrom (tables :: FromType) :: FromType where
351type family NullifyFrom (tables :: FromType) :: FromType where
561− 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
562 NullifyFrom (table ::: columns ': tables) =
362 NullifyFrom (table ::: columns ': tables) =
563 table ::: NullifyRow columns ': NullifyFrom tables
363 table ::: NullifyRow columns ': NullifyFrom tables
564−
364+ NullifyFrom '[] = '[]
565−-- | `Join` is simply promoted `++` and is used in @JOIN@s in
566−-- `Squeal.PostgreSQL.Query.FromClause`s.
567−type family Join xs ys where
568− Join '[] ys = ys
569− Join (x ': xs) ys = x ': Join xs ys
570
365
571-- | @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
572-- `Squeal.PostgreSQL.Definition.createTable` statements and in @ALTER TABLE@
367-- `Squeal.PostgreSQL.Definition.createTable` statements and in @ALTER TABLE@
@@ -576,30 +371,101 @@ type family Create alias x xs where
576 Create alias x (alias ::: y ': xs) = TypeError
371 Create alias x (alias ::: y ': xs) = TypeError
577 ('Text "Create: alias "
372 ('Text "Create: alias "
578 ':<>: 'ShowType alias
373 ':<>: 'ShowType alias
579− ':<>: 'Text "already in use")
374+ ':<>: 'Text "already exists")
580 Create alias y (x ': xs) = x ': Create alias y xs
375 Create alias y (x ': xs) = x ': Create alias y xs
581
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+
582-- | @Drop alias xs@ removes the type associated with @alias@ in @xs@
394-- | @Drop alias xs@ removes the type associated with @alias@ in @xs@
583-- and is used in `Squeal.PostgreSQL.Definition.dropTable` statements
395-- and is used in `Squeal.PostgreSQL.Definition.dropTable` statements
584-- and in @ALTER TABLE@ `Squeal.PostgreSQL.Definition.dropColumn` statements.
396-- and in @ALTER TABLE@ `Squeal.PostgreSQL.Definition.dropColumn` statements.
585type 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" )
586− Drop alias ((alias ::: x) ': xs) = xs
402+ Drop alias (alias ::: x ': xs) = xs
587 Drop alias (x ': xs) = x ': Drop alias xs
403 Drop alias (x ': xs) = x ': Drop alias xs
588
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+
589-- | @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@
590−-- 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`
591-- and `Squeal.PostgreSQL.Definition.alterColumn`.
439-- and `Squeal.PostgreSQL.Definition.alterColumn`.
592type 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" )
593 Alter alias x1 (alias ::: x0 ': xs) = alias ::: x1 ': xs
445 Alter alias x1 (alias ::: x0 ': xs) = alias ::: x1 ': xs
594 Alter alias x1 (x0 ': xs) = x0 ': Alter alias x1 xs
446 Alter alias x1 (x0 ': xs) = x0 ': Alter alias x1 xs
595
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+
596-- | @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@
597-- and is used in `Squeal.PostgreSQL.Definition.alterTableRename` and
454-- and is used in `Squeal.PostgreSQL.Definition.alterTableRename` and
598-- `Squeal.PostgreSQL.Definition.renameColumn`.
455-- `Squeal.PostgreSQL.Definition.renameColumn`.
599type 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" )
600 Rename alias0 alias1 ((alias0 ::: x0) ': xs) = (alias1 ::: x0) ': xs
461 Rename alias0 alias1 ((alias0 ::: x0) ': xs) = (alias1 ::: x0) ': xs
601 Rename alias0 alias1 (x ': xs) = x ': Rename alias0 alias1 xs
462 Rename alias0 alias1 (x ': xs) = x ': Rename alias0 alias1 xs
602
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+
603-- | Check if a `TableConstraint` involves a column
469-- | Check if a `TableConstraint` involves a column
604type family ConstraintInvolves column constraint where
470type family ConstraintInvolves column constraint where
605 ConstraintInvolves column ('Check columns) = column `Elem` columns
471 ConstraintInvolves column ('Check columns) = column `Elem` columns
@@ -616,22 +482,35 @@ type family DropIfConstraintsInvolve column constraints where
616 (DropIfConstraintsInvolve column constraints)
482 (DropIfConstraintsInvolve column constraints)
617 (alias ::: constraint ': DropIfConstraintsInvolve column constraints)
483 (alias ::: constraint ': DropIfConstraintsInvolve column constraints)
618
484
619−{- | Calculate the `Length` of a type level list
620−
621−>>> :kind! Length '[Char,String,Bool,Double]
622−Length '[Char,String,Bool,Double] :: Nat
623−= 4
624−-}
625−type family Length (xs :: [k]) :: Nat where
626− Length (x : xs) = 1 + Length xs
627− Length '[] = 0
628−
629-- | A `SchemumType` is a user-defined type, either a `Table`,
485-- | A `SchemumType` is a user-defined type, either a `Table`,
630-- `View` or `Typedef`.
486-- `View` or `Typedef`.
631data SchemumType
487data SchemumType
632 = Table TableType
488 = Table TableType
633 | View RowType
489 | View RowType
634 | 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
635
514
636{- | The schema of a database consists of a list of aliased,
515{- | The schema of a database consists of a list of aliased,
637user-defined `SchemumType`s.
516user-defined `SchemumType`s.
@@ -657,6 +536,27 @@ type family Schema :: SchemaType where
657-}
536-}
658type SchemaType = [(Symbol,SchemumType)]
537type SchemaType = [(Symbol,SchemumType)]
659
538
539+{- |
540+A database contains one or more named schemas, which in turn contain tables.
541+The same object name can be used in different schemas without conflict;
542+for example, both schema1 and myschema can contain tables named mytable.
543+Unlike databases, schemas are not rigidly separated:
544+a user can access objects in any of the schemas in the database they are connected to,
545+if they have privileges to do so.
546+
547+There are several reasons why one might want to use schemas:
548+
549+ * To allow many users to use one database without interfering with each other.
550+ * To organize database objects into logical groups to make them more manageable.
551+ * Third-party applications can be put into separate schemas
552+ so they do not collide with the names of other objects.
553+-}
554+type SchemasType = [(Symbol,SchemaType)]
555+
556+-- | A type family to use for a single schema database.
557+type family Public (schema :: SchemaType) :: SchemasType
558+ where Public schema = '["public" ::: schema]
559+
660-- | `IsPGlabel` looks very much like the `IsLabel` class. Whereas
560-- | `IsPGlabel` looks very much like the `IsLabel` class. Whereas
661-- the overloaded label, `fromLabel` is used for column references,
561-- the overloaded label, `fromLabel` is used for column references,
662-- `label`s are used for enum terms. A `label` is called with
562-- `label`s are used for enum terms. A `label` is called with
@@ -668,195 +568,13 @@ instance labels ~ '[label]
668 => IsPGlabel label (NP PGlabel labels) where label = PGlabel :* Nil
568 => IsPGlabel label (NP PGlabel labels) where label = PGlabel :* Nil
669-- | A `PGlabel` unit type with an `IsPGlabel` instance
569-- | A `PGlabel` unit type with an `IsPGlabel` instance
670data PGlabel (label :: Symbol) = PGlabel
570data PGlabel (label :: Symbol) = PGlabel
671−-- | Renders a label
672−renderLabel :: KnownSymbol label => proxy label -> ByteString
571+instance KnownSymbol label => RenderSQL (PGlabel label) where
673−renderLabel (_ :: proxy label) =
674− "\'" <> renderSymbol @label <> "\'"
572+ renderSQL _ = "\'" <> renderSymbol @label <> "\'"
675−-- | Renders a list of labels
676−renderLabels
677− :: All KnownSymbol labels => NP PGlabel labels -> [ByteString]
573+instance All KnownSymbol labels => RenderSQL (NP PGlabel labels) where
574+ renderSQL
575+ = commaSeparated
678−renderLabels = hcollapse
576+ . hcollapse
679− . hcmap (Proxy @KnownSymbol) (K . renderLabel)
577+ . hcmap (Proxy @KnownSymbol) (K . renderSQL)
680−
681−{- | The `PG` type family embeds a subset of Haskell types
682−as Postgres types. As an open type family, `PG` is extensible.
683−
684−>>> :kind! PG LocalTime
685−PG LocalTime :: PGType
686−= 'PGtimestamp
687−
688−>>> newtype MyDouble = My Double
689−>>> type instance PG MyDouble = 'PGfloat8
690−-}
691−type family PG (hask :: Type) :: PGType
692−type instance PG Bool = 'PGbool
693−type instance PG Int16 = 'PGint2
694−type instance PG Int32 = 'PGint4
695−type instance PG Int64 = 'PGint8
696−type instance PG Word16 = 'PGint2
697−type instance PG Word32 = 'PGint4
698−type instance PG Word64 = 'PGint8
699−type instance PG Scientific = 'PGnumeric
700−type instance PG Float = 'PGfloat4
701−type instance PG Double = 'PGfloat8
702−type instance PG Char = 'PGchar 1
703−type instance PG Text = 'PGtext
704−type instance PG Lazy.Text = 'PGtext
705−type instance PG String = 'PGtext
706−type instance PG ByteString = 'PGbytea
707−type instance PG Lazy.ByteString = 'PGbytea
708−type instance PG LocalTime = 'PGtimestamp
709−type instance PG UTCTime = 'PGtimestamptz
710−type instance PG Day = 'PGdate
711−type instance PG TimeOfDay = 'PGtime
712−type instance PG (TimeOfDay, TimeZone) = 'PGtimetz
713−type instance PG DiffTime = 'PGinterval
714−type instance PG UUID = 'PGuuid
715−type instance PG (NetAddr IP) = 'PGinet
716−type instance PG Value = 'PGjson
717−type instance PG (Json hask) = 'PGjson
718−type instance PG (Jsonb hask) = 'PGjsonb
719−type instance PG (Vector hask) = 'PGvararray (NullPG hask)
720−type instance PG (hask, hask) = 'PGfixarray 2 (NullPG hask)
721−type instance PG (hask, hask, hask) = 'PGfixarray 3 (NullPG hask)
722−type instance PG (hask, hask, hask, hask) = 'PGfixarray 4 (NullPG hask)
723−type instance PG (hask, hask, hask, hask, hask) = 'PGfixarray 5 (NullPG hask)
724−type instance PG (hask, hask, hask, hask, hask, hask)
725− = 'PGfixarray 6 (NullPG hask)
726−type instance PG (hask, hask, hask, hask, hask, hask, hask)
727− = 'PGfixarray 7 (NullPG hask)
728−type instance PG (hask, hask, hask, hask, hask, hask, hask, hask)
729− = 'PGfixarray 8 (NullPG hask)
730−type instance PG (hask, hask, hask, hask, hask, hask, hask, hask, hask)
731− = 'PGfixarray 9 (NullPG hask)
732−type instance PG (hask, hask, hask, hask, hask, hask, hask, hask, hask, hask)
733− = 'PGfixarray 10 (NullPG hask)
734−type instance PG (Composite hask) = 'PGcomposite (RowPG hask)
735−type instance PG (Enumerated hask) = 'PGenum (LabelsPG hask)
736−
737−{- | The `Json` newtype is an indication that the Haskell
738−type it's applied to should be stored as `PGjson`.
739−-}
740−newtype Json hask = Json {getJson :: hask}
741− deriving (Eq, Ord, Show, Read, GHC.Generic)
742−
743−{- | The `Jsonb` newtype is an indication that the Haskell
744−type it's applied to should be stored as `PGjsonb`.
745−-}
746−newtype Jsonb hask = Jsonb {getJsonb :: hask}
747− deriving (Eq, Ord, Show, Read, GHC.Generic)
748−
749−{- | The `Composite` newtype is an indication that the Haskell
750−type it's applied to should be stored as a `PGcomposite`.
751−-}
752−newtype Composite record = Composite {getComposite :: record}
753− deriving (Eq, Ord, Show, Read, GHC.Generic)
754−
755−{- | The `Enumerated` newtype is an indication that the Haskell
756−type it's applied to should be stored as `PGenum`.
757−-}
758−newtype Enumerated enum = Enumerated {getEnumerated :: enum}
759− deriving (Eq, Ord, Show, Read, GHC.Generic)
760−
761−{-| The `LabelsPG` type family calculates the constructors of a
762−Haskell enum type.
763−
764−>>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic
765−>>> instance Generic Schwarma
766−>>> instance HasDatatypeInfo Schwarma
767−>>> :kind! LabelsPG Schwarma
768−LabelsPG Schwarma :: [Type.ConstructorName]
769−= '["Beef", "Lamb", "Chicken"]
770−-}
771−type family LabelsPG (hask :: Type) :: [Type.ConstructorName] where
772− LabelsPG hask =
773− ConstructorNamesOf (ConstructorsOf (DatatypeInfoOf hask))
774−
775−{- | `RowPG` turns a Haskell record type into a `RowType`.
776−
777−>>> data Person = Person { name :: Text, age :: Int32 } deriving GHC.Generic
778−>>> instance Generic Person
779−>>> instance HasDatatypeInfo Person
780−>>> :kind! RowPG Person
781−RowPG Person :: [(Symbol, NullityType)]
782−= '["name" ::: 'NotNull 'PGtext, "age" ::: 'NotNull 'PGint4]
783−-}
784−type family RowPG (hask :: Type) :: RowType where
785− RowPG hask = RowOf (RecordCodeOf hask)
786−
787−type family RowOf (fields :: [(Symbol, Type)]) :: RowType where
788− RowOf '[] = '[]
789− RowOf (field ': fields) = FieldPG field ': RowOf fields
790−
791−type family FieldPG (field :: (Symbol, Type)) :: (Symbol, NullityType) where
792− FieldPG (field ::: hask) = field ::: NullPG hask
793−
794−{- | `NullPG` turns a Haskell type into a `NullityType`.
795−
796−>>> :kind! NullPG Double
797−NullPG Double :: NullityType
798−= 'NotNull 'PGfloat8
799−>>> :kind! NullPG (Maybe Double)
800−NullPG (Maybe Double) :: NullityType
801−= 'Null 'PGfloat8
802−-}
803−type family NullPG (hask :: Type) :: NullityType where
804− NullPG (Maybe hask) = 'Null (PG hask)
805− NullPG hask = 'NotNull (PG hask)
806−
807−{- | `TuplePG` turns a Haskell tuple type (including record types) into
808−the corresponding list of `NullityType`s.
809−
810−>>> :kind! TuplePG (Double, Maybe Char)
811−TuplePG (Double, Maybe Char) :: [NullityType]
812−= '['NotNull 'PGfloat8, 'Null ('PGchar 1)]
813−-}
814−type family TuplePG (hask :: Type) :: [NullityType] where
815− TuplePG hask = TupleOf (TupleCodeOf hask (Code hask))
816−
817−type family TupleOf (tuple :: [Type]) :: [NullityType] where
818− TupleOf '[] = '[]
819− TupleOf (hask ': tuple) = NullPG hask ': TupleOf tuple
820−
821−type family TupleCodeOf (hask :: Type) (code :: [[Type]]) :: [Type] where
822− TupleCodeOf hask '[tuple] = tuple
823− TupleCodeOf hask '[] =
824− TypeError
825− ( 'Text "The type `" :<>: 'ShowType hask :<>: 'Text "' is not a tuple type."
826− :$$: 'Text "It is a void type with no constructors."
827− )
828− TupleCodeOf hask (_ ': _ ': _) =
829− TypeError
830− ( 'Text "The type `" :<>: 'ShowType hask :<>: 'Text "' is not a tuple type."
831− :$$: 'Text "It is a sum type with more than one constructor."
832− )
833−
834−-- | Calculates constructors of a datatype.
835−type family ConstructorsOf (datatype :: Type.DatatypeInfo)
836− :: [Type.ConstructorInfo] where
837− ConstructorsOf ('Type.ADT _module _datatype constructors) =
838− constructors
839− ConstructorsOf ('Type.Newtype _module _datatype constructor) =
840− '[constructor]
841−
842−-- | Calculates the name of a nullary constructor, otherwise
843−-- generates a type error.
844−type family ConstructorNameOf (constructors :: Type.ConstructorInfo)
845− :: Type.ConstructorName where
846− ConstructorNameOf ('Type.Constructor name) = name
847− ConstructorNameOf ('Type.Infix name _assoc _fix) = TypeError
848− ('Text "ConstructorNameOf error: non-nullary constructor "
849− ':<>: 'Text name)
850− ConstructorNameOf ('Type.Record name _fields) = TypeError
851− ('Text "ConstructorNameOf error: non-nullary constructor "
852− ':<>: 'Text name)
853−
854−-- | Calculate the names of nullary constructors.
855−type family ConstructorNamesOf (constructors :: [Type.ConstructorInfo])
856− :: [Type.ConstructorName] where
857− ConstructorNamesOf '[] = '[]
858− ConstructorNamesOf (constructor ': constructors) =
859− ConstructorNameOf constructor ': ConstructorNamesOf constructors
860
578
861-- | Is a type a valid JSON key?
579-- | Is a type a valid JSON key?
862type PGJsonKey = '[ 'PGint2, 'PGint4, 'PGtext ]
580type PGJsonKey = '[ 'PGint2, 'PGint4, 'PGtext ]
@@ -864,17 +582,15 @@ type PGJsonKey = '[ 'PGint2, 'PGint4, 'PGtext ]
864-- | Is a type a valid JSON type?
582-- | Is a type a valid JSON type?
865type PGJsonType = '[ 'PGjson, 'PGjsonb ]
583type PGJsonType = '[ 'PGjson, 'PGjsonb ]
866
584
867−-- | An `AlignedList` is a type-aligned list or free category.
585+-- | Utility class for `AllUnique` to provide nicer error messages.
868−data AlignedList p x0 x1 where
586+class IsNotElem x isElem where
869− Done :: AlignedList p x x
587+instance IsNotElem x 'False where
870− (:>>) :: p x0 x1 -> AlignedList p x1 x2 -> AlignedList p x0 x2
588+instance (TypeError ( 'Text "Cannot assign to "
871−infixr 7 :>>
589+ ':<>: 'ShowType alias
872−instance Category (AlignedList p) where
590+ ':<>: 'Text " more than once"))
873− id = Done
591+ => IsNotElem '(alias, a) 'True where
874− (.) list = \case
592+
875− Done -> list
593+-- | No elem of @xs@ appears more than once, in the context of assignment.
876− step :>> steps -> step :>> (steps >>> list)
594+class AllUnique (xs :: [(Symbol, a)]) where
877−
595+instance AllUnique '[] where
878−-- | A `single` step.
596+instance (IsNotElem x (Elem x xs), AllUnique xs) => AllUnique (x ': xs) where
879−single :: p x0 x1 -> AlignedList p x0 x1
880−single step = step :>> Done
squeal-postgresql/src/Squeal/PostgreSQL/Transaction.hs+98−73
@@ -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,89 +20,114 @@ 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
31 , longRunningMode
32 , longRunningMode
32 , IsolationLevel (..)
33 , IsolationLevel (..)
33− , renderIsolationLevel
34 , AccessMode (..)
34 , AccessMode (..)
35− , renderAccessMode
36 , DeferrableMode (..)
35 , DeferrableMode (..)
37− , renderDeferrableMode
38 ) where
36 ) where
39
37
40−import Control.Exception.Lifted
38+import UnliftIO
41−import Control.Monad.Base
42−import Control.Monad.Trans.Control
43−import Data.ByteString
44−import Data.Monoid
45−import Generics.SOP
46−
47−import qualified Database.PostgreSQL.LibPQ as LibPQ
48
39
49import Squeal.PostgreSQL.Manipulation
40import Squeal.PostgreSQL.Manipulation
50import Squeal.PostgreSQL.Render
41import Squeal.PostgreSQL.Render
51import Squeal.PostgreSQL.PQ
42import Squeal.PostgreSQL.PQ
52−import Squeal.PostgreSQL.Schema
53
43
54−-- | 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+-}
55transactionally
50transactionally
56− :: (MonadBaseControl IO tx, MonadPQ schema tx)
51+ :: (MonadUnliftIO tx, MonadPQ schemas tx)
57 => TransactionMode
52 => TransactionMode
58 -> tx x -- ^ run inside a transaction
53 -> tx x -- ^ run inside a transaction
59 -> tx x
54 -> tx x
60transactionally mode tx = mask $ \restore -> do
55transactionally mode tx = mask $ \restore -> do
61− _ <- begin mode
56+ manipulate_ $ begin mode
62− result <- restore tx `onException` rollback
57+ result <- restore tx `onException` (manipulate_ rollback)
63− _ <- commit
58+ manipulate_ commit
64 return result
59 return result
65
60
66−-- | Run a schema invariant computation `transactionally_` in `defaultMode`.
61+-- | Run a computation `transactionally_`, in `defaultMode`.
67transactionally_
62transactionally_
68− :: (MonadBaseControl IO tx, MonadPQ schema tx)
63+ :: (MonadUnliftIO tx, MonadPQ schemas tx)
69 => tx x -- ^ run inside a transaction
64 => tx x -- ^ run inside a transaction
70 -> tx x
65 -> tx x
71transactionally_ = transactionally defaultMode
66transactionally_ = transactionally defaultMode
72
67
73−-- | @BEGIN@ a transaction.
68+{- |
69+`transactionallyRetry` a computation;
70+
71+* first `begin`,
72+* then `try` the computation,
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)
74−begin :: MonadPQ schema tx => TransactionMode -> tx (K Result ('[] :: RowType))
79+ => TransactionMode
75−begin mode = manipulate . UnsafeManipulation $
80+ -> tx x -- ^ run inside a transaction
76− "BEGIN" <+> renderTransactionMode mode <> ";"
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
77
112
78−-- | @COMMIT@ a schema invariant transaction.
113+{- | Run a computation `ephemerally` in `defaultMode`. -}
79−commit :: MonadPQ schema tx => tx (K Result ('[] :: RowType))
114+ephemerally_
80−commit = manipulate $ UnsafeManipulation "COMMIT;"
115+ :: (MonadUnliftIO tx, MonadPQ schemas tx)
116+ => tx x -- ^ run inside an ephemeral transaction
117+ -> tx x
118+ephemerally_ = ephemerally defaultMode
119+
120+-- | @BEGIN@ a transaction.
121+begin :: TransactionMode -> Manipulation_ schemas () ()
122+begin mode = UnsafeManipulation $ "BEGIN" <+> renderSQL mode
81
123
82−-- | @ROLLBACK@ a schema invariant transaction.
124+-- | @COMMIT@ a transaction.
83−rollback :: MonadPQ schema tx => tx (K Result ('[] :: RowType))
125+commit :: Manipulation_ schemas () ()
84−rollback = manipulate $ UnsafeManipulation "ROLLBACK;"
126+commit = UnsafeManipulation "COMMIT"
85
127
86−-- | Run a schema changing computation `transactionallySchema`.
128+-- | @ROLLBACK@ a transaction.
87−transactionallySchema
129+rollback :: Manipulation_ schemas () ()
88− :: MonadBaseControl IO io
130+rollback = UnsafeManipulation "ROLLBACK"
89− => TransactionMode
90− -> PQ schema0 schema1 io x
91− -> PQ schema0 schema1 io x
92−transactionallySchema mode u = PQ $ \ conn -> mask $ \ restore -> do
93− _ <- liftBase . LibPQ.exec (unK conn) $
94− "BEGIN" <+> renderTransactionMode mode <> ";"
95− x <- restore (unPQ u conn)
96− `onException` (liftBase (LibPQ.exec (unK conn) "ROLLBACK"))
97− _ <- liftBase $ LibPQ.exec (unK conn) "COMMIT"
98− return x
99−
100−-- | Run a schema changing computation `transactionallySchema_` in `DefaultMode`.
101−transactionallySchema_
102− :: MonadBaseControl IO io
103− => PQ schema0 schema1 io x
104− -> PQ schema0 schema1 io x
105−transactionallySchema_ = transactionallySchema defaultMode
106
131
107-- | The available transaction characteristics are the transaction `IsolationLevel`,
132-- | The available transaction characteristics are the transaction `IsolationLevel`,
108-- the transaction `AccessMode` (`ReadWrite` or `ReadOnly`), and the `DeferrableMode`.
133-- the transaction `AccessMode` (`ReadWrite` or `ReadOnly`), and the `DeferrableMode`.
@@ -115,7 +140,7 @@ data TransactionMode = TransactionMode
115-- | `TransactionMode` with a `Serializable` `IsolationLevel`,
140-- | `TransactionMode` with a `Serializable` `IsolationLevel`,
116-- `ReadWrite` `AccessMode` and `NotDeferrable` `DeferrableMode`.
141-- `ReadWrite` `AccessMode` and `NotDeferrable` `DeferrableMode`.
117defaultMode :: TransactionMode
142defaultMode :: TransactionMode
118−defaultMode = TransactionMode Serializable ReadWrite NotDeferrable
143+defaultMode = TransactionMode ReadCommitted ReadWrite NotDeferrable
119
144
120-- | `TransactionMode` with a `Serializable` `IsolationLevel`,
145-- | `TransactionMode` with a `Serializable` `IsolationLevel`,
121-- `ReadOnly` `AccessMode` and `Deferrable` `DeferrableMode`.
146-- `ReadOnly` `AccessMode` and `Deferrable` `DeferrableMode`.
@@ -124,12 +149,12 @@ longRunningMode :: TransactionMode
124longRunningMode = TransactionMode Serializable ReadOnly Deferrable
149longRunningMode = TransactionMode Serializable ReadOnly Deferrable
125
150
126-- | Render a `TransactionMode`.
151-- | Render a `TransactionMode`.
127−renderTransactionMode :: TransactionMode -> ByteString
152+instance RenderSQL TransactionMode where
128−renderTransactionMode mode =
153+ renderSQL mode =
129− "ISOLATION LEVEL"
154+ "ISOLATION LEVEL"
130− <+> renderIsolationLevel (isolationLevel mode)
155+ <+> renderSQL (isolationLevel mode)
131− <+> renderAccessMode (accessMode mode)
156+ <+> renderSQL (accessMode mode)
132− <+> renderDeferrableMode (deferrableMode mode)
157+ <+> renderSQL (deferrableMode mode)
133
158
134-- | The SQL standard defines four levels of transaction isolation.
159-- | The SQL standard defines four levels of transaction isolation.
135-- The most strict is `Serializable`, which is defined by the standard in a paragraph
160-- The most strict is `Serializable`, which is defined by the standard in a paragraph
@@ -180,12 +205,12 @@ data IsolationLevel
180 deriving (Show, Eq)
205 deriving (Show, Eq)
181
206
182-- | Render an `IsolationLevel`.
207-- | Render an `IsolationLevel`.
183−renderIsolationLevel :: IsolationLevel -> ByteString
208+instance RenderSQL IsolationLevel where
184−renderIsolationLevel = \case
209+ renderSQL = \case
185− Serializable -> "SERIALIZABLE"
210+ Serializable -> "SERIALIZABLE"
186− ReadCommitted -> "READ COMMITTED"
211+ ReadCommitted -> "READ COMMITTED"
187− ReadUncommitted -> "READ UNCOMMITTED"
212+ ReadUncommitted -> "READ UNCOMMITTED"
188− RepeatableRead -> "REPEATABLE READ"
213+ RepeatableRead -> "REPEATABLE READ"
189
214
190-- | The transaction access mode determines whether the transaction is `ReadWrite` or `ReadOnly`.
215-- | The transaction access mode determines whether the transaction is `ReadWrite` or `ReadOnly`.
191-- `ReadWrite` is the default. When a transaction is `ReadOnly`,
216-- `ReadWrite` is the default. When a transaction is `ReadOnly`,
@@ -202,10 +227,10 @@ data AccessMode
202 deriving (Show, Eq)
227 deriving (Show, Eq)
203
228
204-- | Render an `AccessMode`.
229-- | Render an `AccessMode`.
205−renderAccessMode :: AccessMode -> ByteString
230+instance RenderSQL AccessMode where
206−renderAccessMode = \case
231+ renderSQL = \case
207− ReadWrite -> "READ WRITE"
232+ ReadWrite -> "READ WRITE"
208− ReadOnly -> "READ ONLY"
233+ ReadOnly -> "READ ONLY"
209
234
210-- | The `Deferrable` transaction property has no effect
235-- | The `Deferrable` transaction property has no effect
211-- unless the transaction is also `Serializable` and `ReadOnly`.
236-- unless the transaction is also `Serializable` and `ReadOnly`.
@@ -221,7 +246,7 @@ data DeferrableMode
221 deriving (Show, Eq)
246 deriving (Show, Eq)
222
247
223-- | Render a `DeferrableMode`.
248-- | Render a `DeferrableMode`.
224−renderDeferrableMode :: DeferrableMode -> ByteString
249+instance RenderSQL DeferrableMode where
225−renderDeferrableMode = \case
250+ renderSQL = \case
226− Deferrable -> "DEFERRABLE"
251+ Deferrable -> "DEFERRABLE"
227− NotDeferrable -> "NOT DEFERRABLE"
252+ NotDeferrable -> "NOT DEFERRABLE"
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−121
@@ -1,121 +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 TypeOperators #-}
11−module ExceptionHandling
12− ( specs
13− , User (..)
14− )
15−where
16−
17−import Control.Monad (void)
18−import Control.Monad.Base (MonadBase)
19−import qualified Data.ByteString.Char8 as Char8
20−import Data.Int (Int16)
21−import Data.Text (Text)
22−import Data.Vector (Vector)
23−import qualified Generics.SOP as SOP
24−import qualified GHC.Generics as GHC
25−import Squeal.PostgreSQL
26−import Squeal.PostgreSQL.Migration
27−import Test.Hspec
28−
29−type Schema =
30− '[ "users" ::: 'Table (
31− '[ "pk_users" ::: 'PrimaryKey '["id"]
32− , "unique_names" ::: 'Unique '["name"]
33− ] :=>
34− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
35− , "name" ::: 'NoDef :=> 'NotNull 'PGtext
36− , "vec" ::: 'NoDef :=> 'NotNull ('PGvararray ('Null 'PGint2))
37− ])
38− , "emails" ::: 'Table (
39− '[ "pk_emails" ::: 'PrimaryKey '["id"]
40− , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
41− ] :=>
42− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
43− , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
44− , "email" ::: 'NoDef :=> 'Null 'PGtext
45− ])
46− ]
47−
48−data User =
49− User { userName :: Text
50− , userEmail :: Maybe Text
51− , userVec :: Vector (Maybe Int16) }
52− deriving (Show, GHC.Generic)
53−instance SOP.Generic User
54−instance SOP.HasDatatypeInfo User
55−
56−insertUser :: Manipulation Schema '[ 'NotNull 'PGtext, 'NotNull ('PGvararray ('Null 'PGint2))]
57− '[ "fromOnly" ::: 'NotNull 'PGint4 ]
58−insertUser = insertRows #users
59− (Default `as` #id :* Set (param @1) `as` #name :* Set (param @2) `as` #vec) []
60− OnConflictDoRaise (Returning (#id `as` #fromOnly))
61−
62−setup :: Definition '[] Schema
63−setup =
64− createTable #users
65− ( serial `as` #id :*
66− (text & notNullable) `as` #name :*
67− (vararray int2 & notNullable) `as` #vec )
68− ( primaryKey #id `as` #pk_users
69− :* unique #name `as` #unique_names )
70− >>>
71− createTable #emails
72− ( serial `as` #id :*
73− (int & notNullable) `as` #user_id :*
74− (text & nullable) `as` #email )
75− ( primaryKey #id `as` #pk_emails :*
76− foreignKey #user_id #users #id
77− OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
78−
79−teardown :: Definition Schema '[]
80−teardown = dropTable #emails >>> dropTable #users
81−
82−migration :: Migration IO '[] Schema
83−migration = Migration { name = "test"
84− , up = void $ define setup
85− , down = void $ define teardown }
86−
87−setupDB :: IO ()
88−setupDB = void . withConnection connectionString $
89− migrateUp $ single migration
90−
91−dropDB :: IO ()
92−dropDB = void . withConnection connectionString $
93− migrateDown $ single migration
94−
95−connectionString :: Char8.ByteString
96−connectionString = "host=localhost port=5432 dbname=exampledb"
97−
98−testUser :: User
99−testUser = User "TestUser" Nothing []
100−
101−newUser :: (MonadBase IO m, MonadPQ Schema m) => User -> m ()
102−newUser u = void $ manipulateParams insertUser (userName u, userVec u)
103−
104−insertUserTwice :: (MonadBase IO m, MonadPQ Schema m) => m ()
105−insertUserTwice = newUser testUser >> newUser testUser
106−
107−specs :: SpecWith ()
108−specs = before_ setupDB $ after_ dropDB $
109− describe "Exceptions" $ do
110−
111− let
112− dupKeyErr = PQException FatalError (Just "23505")
113− (Just "ERROR: duplicate key value violates unique constraint \"unique_names\"\nDETAIL: Key (name)=(TestUser) already exists.\n")
114−
115− it "should be thrown for unique constraint violation in a manipulation" $
116− withConnection connectionString insertUserTwice
117− `shouldThrow` (== dupKeyErr)
118−
119− it "should be rethrown for unique constraint violation in a manipulation by a transaction" $
120− withConnection connectionString (transactionally_ insertUserTwice)
121− `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
squeal-presentation-raveline.mdnew file+794
@@ -0,0 +1,794 @@
1+# Squeal
2+
3+_A bridge between SQL and Haskell_
4+
5+by [@Raveline](https://github.com/raveline)
6+
7+---
8+
9+# Rationale
10+
11+Using `postgresql-simple` you have a typical "Trial, error, despair" workflow:
12+
13+- Write query manually or semi-automatically
14+
15+- Write haskell code using the query
16+
17+- Pray that the query syntax is correct
18+
19+- Pray that it returns what you want
20+
21+- Realize the inefficiency of prayer when it comes to SQL
22+
23+- Iterate till it works
24+
25+---
26+
27+![Can't take this anymore](http://gif.eraveline.eu/static/img/0x16e.gif)
28+
29+---
30+
31+# Use your best friend: GHC
32+
33+Squeal provides several eDSL to make your SQL typesafe:
34+
35+- Type level eDSL to express schema;
36+
37+- Value level eDSL to manipulate schema (plus migration, yeehaw !);
38+
39+- Type level eDSL to express queries;
40+
41+- Value level eDSL to perform queries
42+
43+However, it's not an ORM. There's no caching, lazy loading - you retain control over your memory. Also, joins - and mostly aggregation after joins - have to be handled manually.
44+
45+---
46+
47+# Part I. Schema & migration
48+
49+---
50+
51+# The Schema
52+
53+- The schema will be used to validate _everything_: migration, queries, etc.
54+
55+- A schema is mostly a collection of tables.
56+
57+- In this presentation, we will create a very basic database modeling a parliament. We will store _members of parliament_ and _parliamentary groups_.
58+
59+- A simple Schema to represent a Parliament could be:
60+
61+```haskell
62+type Schema = '[ "mp" ::: 'Table MemberOfParliament
63+ , "groupp" ::: 'Table ParliamentGroup ]
64+```
65+
66+---
67+
68+> _note_ We need the `DataKinds` extension to be able to express heterogenous lists containing
69+> specific types like this one.
70+
71+> You can perfectly call your table "group" and not "groupp" even though it is a
72+> keyword in SQL - Squeal queries will be properly escaped.
73+
74+---
75+
76+# A small example
77+
78+```haskell
79+type ParliamentaryGroup =
80+ '[ "pk_groupp" ::: 'PrimaryKey '["groupp_id"]]
81+ :=>
82+ '[ "groupp_id" ::: 'NoDef :=> 'NotNull 'PGuuid
83+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext
84+ ]
85+```
86+
87+- That's a whole simple table defined in one go.
88+
89+- `:::` lets us define a column or a constraint.
90+
91+- `:=>` associates the constraints to the column.
92+
93+- Let's split constraints and column to study the syntax a bit more.
94+
95+---
96+
97+> _note_ We are using `:::` and `:=>` to quickly express associations when writing
98+> our schema. We need the `TypeOperators` extension.]
99+
100+---
101+
102+![What does this means ?!](http://gif.eraveline.eu/static/img/0x27e.gif)
103+
104+---
105+
106+# Defining a table
107+
108+```haskell
109+type MemberOfParliament =
110+ '[ "pk_mp" ::: 'PrimaryKey '["mp_id"]
111+ , "fk_mp_groupp" ::: 'ForeignKey '["mp_group"] "groupp" '["groupp_id"]
112+ ] :=> MpCols
113+```
114+
115+- A table is a collection of constraints associated to a collection of columns.
116+
117+- We defined a table named "mp".
118+
119+- It has a constraint named "pk_mp", defining its primary key on column "mp_id".
120+
121+- It has a constraint named "fk_mp_groupp" defining a foreign key on column "mg_group", connected to the column "groupp_id" of table "groupp".
122+
123+- These constraints will be associated to the columns defined in `MpCols`.
124+
125+---
126+
127+# Defining columns
128+
129+```haskell
130+type MpCols =
131+ '[ "mp_id" ::: 'NoDef :=> 'NotNull 'PGuuid
132+ , "first_name" ::: 'NoDef :=> 'NotNull 'PGtext
133+ , "last_name" ::: 'NoDef :=> 'NotNull 'PGtext
134+ ]
135+```
136+
137+- A listing of column associate, for each element:
138+
139+ * a name;
140+
141+ * the mention of an eventual default value;
142+
143+ * the nullability;
144+
145+ * the type (obviously).
146+
147+---
148+
149+> _note_ GHC is already helping. If I named the "mp_id" column differently,
150+> GHC would yell because I promised a primary key constraint on a column named `mp_id`, so there must be one.]
151+
152+---
153+
154+# Implementating the schema
155+
156+- We will carry this schema type pretty much everywhere.
157+
158+- But before we play with this schema, we need to implement it.
159+
160+---
161+
162+```haskell
163+setup :: Definition '[] Schema
164+setup =
165+ createTable #groupp
166+ ( notNullable uuid `as` #groupp_id
167+ :* notNullable text `as` #name)
168+ ( primaryKey #groupp_id `as` #pk_groupp )
169+ >>> createTable #mp
170+ ( notNullable uuid `as` #mp_id
171+ :* notNullable text `as` #first_name
172+ :* notNullable text `as` #last_name
173+ :* notNullable text `as` #mp_group)
174+ ( primaryKey #mp_id `as` #pk_mp
175+ :* foreignKey #mp_group #groupp #groupp_id
176+ OnDeleteCascade OnUpdateCascade
177+ `as` #fk_mp_groupp)
178+```
179+
180+---
181+
182+# Damn, that's verbose
183+
184+- Yes. But you need verbosity to get type safety.
185+
186+- On the plus side, it's fairly straightforward.
187+
188+- You use `:*` to compose the element of the heterogenous list of columns.
189+
190+- You use `>>>` to compose table creation.
191+
192+> _note_ The compiler will catch any mistype between Schema and
193+> definition; wrong nullability, wrong type, wrong name, etc.
194+
195+---
196+
197+> _note_ You'll also need `OverloadedLabels`, for naming stuff.
198+> This is mostly to avoid having to write manual proxies all
199+> the time and for convenience.
200+
201+---
202+
203+# Setting up the schema
204+
205+- Squeal comes with a very good migration manager, handling _upgrades_ AND
206+_downgrades_.
207+
208+- A migration is a simple type:
209+
210+```haskell
211+Migration io schema0 schema1
212+```
213+
214+- The first parameter is a BaseMonad (typically, IO).
215+
216+- The second parameter is "the current schema of your DB".
217+
218+- The last one is "what you will migrate to".
219+
220+- The `Definition` type used to define upgrade and downgrade functions use the
221+ same logic (from one schema to the other).
222+
223+---
224+
225+# Defining our first migration
226+
227+- We have the setup bit, we need the teardown:
228+
229+```haskell
230+tearDown :: Definition Schema '[]
231+tearDown = dropTable #mp >>> dropTable #groupp
232+```
233+
234+> _note_ GHC will also detect the _proper_ order of what you typed in
235+> downgrade and upgrade should there be any conflict (with foreign keys).
236+
237+```haskell
238+initDB :: Migration IO '[] Schema
239+initDB =
240+ Migration { name = "Schema creation"
241+ , up = void $ define setup
242+ , down = void $ define tearDown }
243+```
244+
245+---
246+
247+# Simple migrator example
248+
249+```haskell
250+main :: IO ()
251+main = do
252+ printSQL setup
253+ void $ withConnection connectionString $
254+ migrateUp $ single initDB
255+```
256+
257+- We print the migration query; you can do this for all queries generated through Squeal.
258+
259+- We use `migrateUp` to perform the migration.
260+
261+- You can run several migration at the same time, to run only one use `single`.
262+
263+---
264+
265+![That was easy](http://gif.eraveline.eu/static/img/0x47f.gif)
266+
267+---
268+
269+# Part II. Insertions
270+
271+---
272+
273+# Manipulations & Queries
274+
275+Besides the specific case of migration, you will mostly perform:
276+
277+- `Manipulation` : inserting, updating and deleting data.
278+
279+- `Query` : fetching data.
280+
281+- Both types are parametric over the same things:
282+
283+ * A schema
284+
285+ * Input parameters
286+
287+ * Output
288+
289+- Simplified, they look like this:
290+
291+```haskell
292+Manipulation schema params columns
293+
294+Query schema params columns
295+```
296+
297+
298+---
299+
300+# Our Haskell model
301+
302+```haskell
303+type Parliament = [Group]
304+
305+data Group =
306+ Group { name :: Text
307+ , members :: [MemberOfParliament] }
308+
309+data MemberOfParliament =
310+ MemberOfParliament { firstName :: Text
311+ , lastName :: Text }
312+```
313+
314+> _note_ We didn't use anything from Squeal.
315+> The model can be entirely separated from the persistence layer.
316+
317+---
318+
319+# Inserting a Parliamentary Group
320+
321+- A group is very simple: it's a uuid and a name. Let's define our params:
322+
323+```haskell
324+type GroupInsertionParams = '[ 'NotNull 'PGuuid
325+ , 'NotNull 'PGtext ]
326+```
327+
328+- Params are not named, but they are indexed. You just need nullability and type.
329+
330+---
331+
332+```haskell
333+groupInsertion :: Manipulation Schema GroupInsertionParams '[]
334+groupInsertion =
335+ insertRow_ #groupp ( Set (param @1) `as` #groupp_id
336+ :* Set (param @2) `as` #name )
337+```
338+
339+---
340+
341+- `TypeApplication` lets us use the index of parameters (counting from 1).
342+
343+- Once again: all this is checked by the compiler. Wrong name, wrong type... you'll get a compile error.
344+
345+- `insertRow_` is a simplified version of `insertRow`. `insertRow` lets you express a `RETURNING` clause and the expected behaviour in case of conflict.
346+
347+---
348+
349+_Inserting a Member of Parliament_
350+# Doing an INSERT INTO ... SELECT
351+
352+- We could create a naive query that takes MP uuid, first name, last name and group uuid...
353+
354+---
355+
356+- But that's boring. So let's use the `INSERT INTO ... SELECT`.
357+
358+---
359+
360+- We will build a query that will return as constants our MP's uuid, first name and last name...
361+
362+---
363+
364+- ... and fetch the uuid of a group given the name of the group.
365+
366+---
367+
368+- There's a `insertQuery` utility function for that. All we have to do is write the `select` !
369+
370+```haskell
371+mpInsertion :: Manipulation Schema MpParams '[]
372+mpInsertion =
373+ insertQuery_ #mp selectGroup -- we just have to write selectGroup !
374+```
375+
376+---
377+
378+_Inserting a Member of Parliament_
379+# The query type
380+
381+- A query looks just like a `Manipulation`:
382+
383+```haskell
384+Query schema params returns
385+```
386+
387+- Returns use a special syntax, that demands names, nullability and types:
388+
389+```haskell
390+type ExampleReturnType = '[ "some_column" ::: 'NotNull 'PGuuid
391+ , "other_column" ::: 'Null 'PGtext ]
392+```
393+
394+- It is not the same as the column definition we used in the schema. That one also expects that you specify, for each column, an eventual default:
395+
396+```haskell
397+type ExampleSchemaCols =
398+ '[ "some_column" ::: 'NoDef :=> 'NotNull 'PGuuid
399+ , "other_column" ::: 'NoDef :=> 'Null 'PGtext ]
400+```
401+
402+---
403+
404+_Inserting a Member of Parliament_
405+# Don't rewrite column definitions
406+
407+- We want our return type to be "all columns from table MP expressed as return type".
408+
409+- But we cannot reuse our neat `MpCols` alias, since the type do not match as we've just seen.
410+
411+- Hopefully, there's a neat Type Family that will let you convert any table you defined to the type of the equivalent row: `TableToRow`.
412+
413+- We finally have the signature for our SELECT query.
414+
415+```haskell
416+selectGroup :: Query Schema MpParams (TableToRow MemberOfParliament)
417+```
418+
419+---
420+
421+_Inserting a Member of Parliament_
422+# Our final Select query
423+
424+- Our intermediate query looks like this:
425+
426+```haskell
427+selectGroup =
428+ select
429+ ( param @1 `as` #mp_id
430+ :* param @2 `as` #first_name
431+ :* param @3 `as` #last_name
432+ :* #groupp ! #groupp_id `as` #mp_group
433+ )
434+ ( from (table #groupp)
435+ & where_ ( #groupp ! #name .== param @4 )
436+ )
437+```
438+
439+- The first three columns are constant defined through our params;
440+
441+- ... we alias the column name using `as`...
442+
443+- ... and when we need the result from the table we use the `#table ! #column` syntax.
444+
445+- We'll go back to the "from" block later.
446+
447+---
448+
449+# Dealing with the connection context
450+
451+- Queries are runned in a connection context:
452+
453+ * When dealing with a single-connection context, use the type `PQ`.
454+
455+ * When dealing with a pool of connection, use the type `PoolPQ`.
456+
457+- Or get rid of the context and use `mtl` style, with the typeclass `MonadPQ`.
458+
459+- We'll use that to demonstrate how to actually run our queries.
460+
461+---
462+
463+# Inserting a whole group
464+
465+```haskell
466+insertGroup :: (MonadPQ Schema m, MonadBaseControl IO m) => Group -> m ()
467+insertGroup g@(Group name _) = do
468+ uuid' <- liftBase nextRandom
469+ void $ manipulateParams groupInsertion (uuid', name)
470+ insertMps g
471+```
472+
473+- Remember that we defined a group as a name and a list of MPs.
474+
475+- We are in `MonadBaseControl`, so we cannot use `liftIO`, we need `liftBase`.
476+
477+- To perform a simple insertion, use `manipulateParams`. It takes into parameter
478+instances of `ToParam`, but you will typically use tuples or Generic-SOP.
479+
480+---
481+
482+# Inserting a bunch of MPs
483+
484+```haskell
485+insertMps :: (MonadPQ Schema m, MonadBaseControl IO m) => Group -> m ()
486+insertMps (Group groupName mps) =
487+ let tuplify Mp{..} = (, firstName, lastName, groupName) <$> nextRandom
488+ params = traverse tuplify mps
489+ in void $ liftBase params >>= traversePrepared mpInsertion
490+```
491+
492+- This time, we want to do a `preparedStatement`. We'll use `traversePrepare`
493+which behaves like `manipulateParams`, but expect a list of `ToParam`
494+instances.
495+
496+- We build our tuple manually again, mostly because we want to generate UUID on
497+the fly and we don't want to have them in our model.
498+
499+---
500+
501+# Inserting a whole parliament
502+
503+```haskell
504+insertParliament ::
505+ (MonadPQ Schema m, MonadBaseControl IO m) => Parliament -> m ()
506+insertParliament = traverse_ insertGroup
507+```
508+
509+- That's simple enough !
510+
511+- If we want to be a bit safer, though, we can wrap this call in a
512+`transactionally_` function, which will put all that in a transaction.
513+
514+---
515+
516+![Very simple](https://media1.tenor.com/images/0188c63209aced59f1583e1ca94e509e/tenor.gif?itemid=3550689)
517+
518+
519+---
520+
521+# Part III. Selects
522+
523+---
524+
525+# Composable queries
526+
527+- Building basic queries is easy, and is well documented.
528+
529+- However, the real interest of a tool like Squeal is in DRYness, and the documentation is still lacking in "how-to" related to composability.
530+
531+- I'll build an example showing how column selections and from clause can be factorized.
532+
533+- We want to write two queries:
534+
535+ * One to get all members of a specific group.
536+
537+ * One to get all the parliament.
538+
539+---
540+
541+# Decomposing a `Query`
542+
543+- A query typically stars with `select` (variants are available).
544+
545+- It then takes:
546+
547+ * A heterogenous list of fields with a scary signature;
548+
549+ * A virtual table (the from clause and filter clauses), called a `TableExpression`.
550+
551+- And return fields. Ours will look like this:
552+
553+```haskell
554+type GroupRowResult =
555+ '[ "groupName" ::: 'NotNull 'PGtext
556+ , "firstName" ::: 'NotNull 'PGtext
557+ , "lastName" ::: 'NotNull 'PGtext ]
558+```
559+
560+---
561+
562+# The Table Expression
563+
564+- It necessarily contains a `fromClause` (table, view or subquery, plus optional joins).
565+
566+- You can add where, groups, "HAVING" clause, order, etc.
567+
568+- `from` creates a basic `TableExpression` that you extend through various function to add clauses.
569+
570+- For our queries, we will share a common `FromClause`.
571+
572+---
573+
574+# The From Clause
575+
576+```
577+FromClause schema params from
578+```
579+
580+- We need Schema, input parameters and a `FromType` giving the available fields of the expression.
581+
582+- In our case, we'll join the table `mp` and the table `groupp`, meaning the `from` will be all fields of these tables.
583+
584+- We can use `TableToRow` to be more DRY:
585+
586+```haskell
587+type BaseParliamentSelection =
588+ '[ "g" ::: TableToRow GroupCols
589+ , "m" ::: TableToRow MpCols ]
590+```
591+
592+> _note_ We've also put everything with table aliases: "g" and "m".
593+
594+---
595+
596+# Writing our from clause
597+
598+```haskell
599+baseParliamentTables ::
600+ FromClause Schema (param :: [NullityType]) BaseParliamentSelection
601+baseParliamentTables =
602+ table
603+ (#groupp `as` #g)
604+ & innerJoin
605+ (table (#mp `as` #m))
606+ (#m ! #mp_group .== #g ! #groupp_id)
607+```
608+
609+- When picking "from" something, you need to specify the type with a function: `table` for a table, `view` for a view, etc.
610+
611+- All joins are available. `innerJoin` is the most basic one. It takes the joined table and the joining condition.
612+
613+- We have to specifiy the type of `param` (current limitation of the lib), even though _any_ params will be compatible with this, so we can plug `where` clauses depending on params should we need to !
614+
615+---
616+
617+# Typing the common selection
618+
619+- Both our querie will need the same fields. This has to be factorized too.
620+
621+- The scary signature of selection fields:
622+
623+```haskell
624+NP (Aliased (Expression schema from grouping params)) cols
625+```
626+
627+- `NP` is for heterogenous lists ("n-ary product").
628+
629+- `from` is the virtual table type, so our `BaseParliamentSelection`.
630+
631+- `grouping` is there to make a distinction between aggregated / unaggregated queries.
632+
633+- And finally, cols is the return type.
634+
635+---
636+
637+# Our common selection
638+
639+```haskell
640+groupSelection ::
641+ NP (Aliased (Expression Schema BaseParliamentSelection 'Ungrouped param))
642+ GroupRowResult
643+groupSelection =
644+ #g ! #name `as` #groupName
645+ :* #m ! #first_name `as` #firstName
646+ :* #m ! #last_name `as` #lastName
647+```
648+
649+- I hope you like big signatures.
650+
651+- But it's what let GHC checks that all alias and columns are available.
652+
653+- And that you're returning what you really intend to return.
654+
655+---
656+
657+# Putting it all together
658+
659+```haskell
660+selectParliament :: Query Schema '[] GroupRowResult
661+selectParliament =
662+ select groupSelection (from baseParliamentTables)
663+```
664+
665+```haskell
666+selectGroupMembers :: Query Schema '[ 'NotNull 'PGtext] GroupRowResult
667+selectGroupMembers =
668+ select groupSelection
669+ (from baseParliamentTables
670+ & where_ (#g ! #name .== param @1))
671+```
672+
673+- That is fairly DRY. And _entirely typesafe_.
674+
675+---
676+
677+# Actually fetching the data
678+
679+- We'll build an intermediary datatype representing our rows.
680+
681+- We'll make it match our row.
682+
683+- And we'll add generic-SOP so that we can build them from query results.
684+
685+```haskell
686+type GroupRowResult =
687+ '[ "groupName" ::: 'NotNull 'PGtext
688+ , "firstName" ::: 'NotNull 'PGtext
689+ , "lastName" ::: 'NotNull 'PGtext ]
690+```
691+
692+```haskell
693+data GroupRow =
694+ GroupRow { groupName :: Text
695+ , firstName :: Text
696+ , lastName :: Text }
697+ deriving (Generic)
698+
699+instance SOP.Generic GroupRow
700+instance SOP.HasDatatypeInfo GroupRow
701+```
702+
703+---
704+
705+# Aggregate result logic
706+
707+- We will get tabular, SQL data.
708+
709+- Our results will be `[GroupRow]`.
710+
711+- We'll build `Groups` from this:
712+
713+```haskell
714+buildGroup :: NE.NonEmpty GroupRow -> Group
715+buildGroup grs =
716+ let buildMP (GroupRow _ f l) = Mp f l
717+ name = groupName . NE.head $ grs
718+ members = NE.toList (buildMP <$> grs)
719+ in Group{..}
720+
721+rowToGroups :: [GroupRow] -> [Group]
722+rowToGroups =
723+ let grouped = fmap NE.fromList . L.groupBy ((==) `on` groupName)
724+ in fmap buildGroup . grouped
725+```
726+
727+---
728+
729+# Finally calling our queries
730+
731+- Query with params will use `runQueryParams`.
732+
733+- Query without params will use `runQuery`.
734+
735+- Result is inside a `MonadPQ` and of type `K` from generic-sop.
736+
737+- You get your actual result using `getRows`. Exemple:
738+
739+```haskell
740+getParliament :: (MonadPQ Schema m, MonadBaseControl IO m) => m [Group]
741+getParliament = do
742+ res <- runQuery selectParliament
743+ rows <- getRows res
744+ pure $ rowToGroups rows
745+```
746+
747+- In real life of course you'll write:
748+
749+```haskell
750+getParliament =
751+ rowToGroups <$> (runQuery selectParliament >>= getRows)
752+```
753+
754+---
755+
756+# Our query with params
757+
758+```haskell
759+getGroupMembers ::
760+ (MonadPQ Schema m, MonadBaseControl IO m) => Text -> m (Maybe Group)
761+getGroupMembers =
762+ listToMaybe . rowToGroups <$>
763+ (runQueryParams selectGroupMembers (Only t) >>= getRows)
764+```
765+
766+- And that's it.
767+
768+---
769+
770+![Eazy](https://media.tenor.com/images/8fc7c4077efe11b4a3a3b9ae4e643e87/tenor.gif)
771+
772+---
773+
774+# Conclusion
775+
776+---
777+
778+# Pros & Cons
779+
780+- Not everything is included: some cool stuff like array_agg and window functions are not available yet.
781+
782+- But development is _very_ active. `IN` clauses were missing but were added in the 4.0 released recently.
783+
784+- It's bleeding edge. You need latest LTS to be comfortable and psql >= 9.5.
785+
786+- It's Postgres-only but I would say that's a feature. Multi-DB tools are even more complex.
787+
788+- The author & maintainer is <3.
789+
790+- Typesafe. 'nuff said.
791+
792+---
793+
794+# Thank you !
stack.yaml+6−1
@@ -1,3 +1,8 @@
1−resolver: nightly-2018-09-03
1+resolver: nightly-2019-07-14
2packages:
2packages:
3- squeal-postgresql
3- squeal-postgresql
4+
5+extra-deps:
6+- unliftio-pool-0.2.1.0
7+- github: morphismtech/free-categories
8+ commit: c0e555fbefb5c21619e532264c4dfeac556d0630