on dev help sign in
52 files changed+8829−5224
since splitsnapshots
unifiedsplit
.circleci/config.yml+1−1 README.md+64−75 RELEASE NOTES.md+400 squeal-postgresql/exe/Example.hs+19−21 squeal-postgresql/squeal-postgresql.cabal+58−16 squeal-postgresql/src/Squeal/PostgreSQL.hs+71−52 squeal-postgresql/src/Squeal/PostgreSQL/Alias.hs+249 squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs+233−113 squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs+15−982 squeal-postgresql/src/Squeal/PostgreSQL/Definition/Function.hs+238 squeal-postgresql/src/Squeal/PostgreSQL/Definition/Index.hs+159 squeal-postgresql/src/Squeal/PostgreSQL/Definition/Schema.hs+96 squeal-postgresql/src/Squeal/PostgreSQL/Definition/Table.hs+500 squeal-postgresql/src/Squeal/PostgreSQL/Definition/Table/Constraint.hs+339 squeal-postgresql/src/Squeal/PostgreSQL/Definition/Type.hs+229 squeal-postgresql/src/Squeal/PostgreSQL/Definition/View.hs+104 squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs+268−1987 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Aggregate.hs+462 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Collection.hs+169 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Comparison.hs+206 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Json.hs+462 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Literal.hs+87 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Logic.hs+105 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Math.hs+100 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Null.hs+104 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Parameter.hs+80 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Range.hs+230 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Set.hs+139 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Sort.hs+85 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Subquery.hs+120 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Text.hs+64 squeal-postgresql/src/Squeal/PostgreSQL/Expression/TextSearch.hs+157 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Time.hs+192 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Type.hs+446 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Window.hs+284 squeal-postgresql/src/Squeal/PostgreSQL/List.hs+112 squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs+180−188 squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs+337−186 squeal-postgresql/src/Squeal/PostgreSQL/PG.hs+388 squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs+159−119 squeal-postgresql/src/Squeal/PostgreSQL/Pool.hs+72−103 squeal-postgresql/src/Squeal/PostgreSQL/Query.hs+401−686 squeal-postgresql/src/Squeal/PostgreSQL/Render.hs+46−11 squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs+207−484 squeal-postgresql/src/Squeal/PostgreSQL/Transaction.hs+78−48 squeal-postgresql/test/Doc.hs+6 squeal-postgresql/test/DocTest.hs−18 squeal-postgresql/test/Property.hs+166 squeal-postgresql/test/Spec.hs+136 squeal-postgresql/test/Specs/ExceptionHandling.hs−126 squeal-postgresql/test/Specs/Specs.hs−7 stack.yaml+6−1
.circleci/config.yml+1−1
@@ -2,7 +2,7 @@ version: 2
22jobs:
33 build:
44 docker:
5− - image: haskell:8.4.3
5+ - image: haskell:8.6.5
66 - image: circleci/postgres:latest
77 environment:
88 POSTGRES_USER: root
README.md+64−75
@@ -46,7 +46,11 @@ composable and cover a large portion of SQL.
4646* transactions
4747* views
4848* array, composite and enumerated types
49−* json operations
49+* json functions and operations
50+* multischema support
51+* correlated subqueries
52+* window functions
53+* text search
5054
5155## installation
5256
@@ -72,19 +76,17 @@ First, we need some language extensions because Squeal uses modern GHC
7276features.
7377
7478```Haskell
75−>>> :set -XDataKinds -XDeriveGeneric -XOverloadedLabels
76−>>> :set -XOverloadedStrings -XTypeApplications -XTypeOperators
79+>>> :set -XDataKinds -XDeriveGeneric -XOverloadedLabels -XFlexibleContexts
80+>>> :set -XOverloadedStrings -XTypeApplications -XTypeOperators -XGADTs
7781```
7882
7983We'll need some imports.
8084
8185```Haskell
82−>>> import Control.Monad (void)
83−>>> import Control.Monad.Base (liftBase)
86+>>> import Control.Monad.IO.Class (liftIO)
8487>>> import Data.Int (Int32)
8588>>> import Data.Text (Text)
8689>>> import Squeal.PostgreSQL
87−>>> import Squeal.PostgreSQL.Render
8890```
8991
9092We'll use generics to easily convert between Haskell and PostgreSQL values.
@@ -99,27 +101,27 @@ we use `DataKinds` and `TypeOperators`.
99101
100102```Haskell
101103>>> :{
104+type UsersColumns =
105+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
106+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext ]
107+type UsersConstraints = '[ "pk_users" ::: 'PrimaryKey '["id"] ]
108+type EmailsColumns =
109+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
110+ , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
111+ , "email" ::: 'NoDef :=> 'Null 'PGtext ]
112+type EmailsConstraints =
113+ '[ "pk_emails" ::: 'PrimaryKey '["id"]
114+ , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"] ]
102115type Schema =
103− '[ "users" ::: 'Table (
104− '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
105− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
106− , "name" ::: 'NoDef :=> 'NotNull 'PGtext
107− ])
108− , "emails" ::: 'Table (
109− '[ "pk_emails" ::: 'PrimaryKey '["id"]
110− , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
111− ] :=>
112− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
113− , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
114− , "email" ::: 'NoDef :=> 'Null 'PGtext
115− ])
116− ]
116+ '[ "users" ::: 'Table (UsersConstraints :=> UsersColumns)
117+ , "emails" ::: 'Table (EmailsConstraints :=> EmailsColumns) ]
118+type Schemas = Public Schema
117119:}
118120```
119121
120122Notice the use of type operators.
121123
122−`:::` is used to pair an alias `GHC.TypeLits.Symbol` with a `SchemumType`,
124+`:::` is used to pair an alias `Symbol` with a `SchemumType`,
123125a `TableConstraint` or a `ColumnType`. It is intended to connote Haskell's `::`
124126operator.
125127
@@ -128,7 +130,7 @@ yielding a `TableType`, or to pair a `ColumnConstraint` with a `NullityType`,
128130yielding a `ColumnType`. It is intended to connote Haskell's `=>` operator
129131
130132Next, we'll write `Definition`s to set up and tear down the schema. In
131−Squeal, a `Definition` like `createTable`, `alterTable` or `dropTable`
133+Squeal, a `Definition` like `createTable`, `alterTable` or `dropTable`
132134has two type parameters, corresponding to the schema
133135before being run and the schema after. We can compose definitions using `>>>`.
134136Here and in the rest of our commands we make use of overloaded
@@ -137,8 +139,8 @@ labels to refer to named tables and columns in our schema.
137139```Haskell
138140>>> :{
139141let
140− setup :: Definition '[] Schema
141− setup =
142+ setup :: Definition (Public '[]) Schemas
143+ setup =
142144 createTable #users
143145 ( serial `as` #id :*
144146 (text & notNullable) `as` #name )
@@ -169,7 +171,7 @@ primary and foreign keys, making them somewhat complex. Our `teardown`
169171```Haskell
170172>>> :{
171173let
172− teardown :: Definition Schema '[]
174+ teardown :: Definition Schemas (Public '[])
173175 teardown = dropTable #emails >>> dropTable #users
174176:}
175177
@@ -178,54 +180,54 @@ DROP TABLE "emails";
178180DROP TABLE "users";
179181```
180182
181−Next, we'll write `Manipulation`s to insert data into our two tables.
182−A `Manipulation` like `insertRow`, `update` or `deleteFrom`
183−has three type parameters, the schema it refers to, a list of parameters
184−it can take as input, and a list of columns it produces as output. When
183+We'll need a Haskell type for `User`s. We give the type `SOP.Generic` and
184+`SOP.HasDatatypeInfo` instances so that we can encode and decode `User`s.
185+
186+```Haskell
187+>>> data User = User { userName :: Text, userEmail :: Maybe Text } deriving (Show, GHC.Generic)
188+>>> instance SOP.Generic User
189+>>> instance SOP.HasDatatypeInfo User
190+```
191+
192+Next, we'll write `Manipulation_`s to insert `User`s into our two tables.
193+A `Manipulation_` like `insertInto`, `update` or `deleteFrom`
194+has three type parameters, the schemas it refers to, input parameters
195+and an output row. When
185196we insert into the users table, we will need a parameter for the `name`
186197field but not for the `id` field. Since it's serial, we can use a default
187198value. However, since the emails table refers to the users table, we will
188199need to retrieve the user id that the insert generates and insert it into
189−the emails table. Take a careful look at the type and definition of both
190−of our inserts.
200+the emails table. We can do this in a single `Manipulation_` by using a
201+`with` statement.
191202
192203```Haskell
193204>>> :{
194205let
195− insertUser :: Manipulation Schema '[ 'NotNull 'PGtext ] '[ "fromOnly" ::: 'NotNull 'PGint4 ]
196− insertUser = insertRow #users
197− (Default `as` #id :* Set (param @1) `as` #name)
198− OnConflictDoNothing (Returning (#id `as` #fromOnly))
199−:}
200−
201−>>> :{
202−let
203− insertEmail :: Manipulation Schema '[ 'NotNull 'PGint4, 'Null 'PGtext] '[]
204− insertEmail = insertRow #emails
205− ( Default `as` #id :*
206− Set (param @1) `as` #user_id :*
207− Set (param @2) `as` #email )
208− OnConflictDoNothing (Returning Nil)
206+ insertUser :: Manipulation_ Schemas User ()
207+ insertUser = with (u `as` #u) e
208+ where
209+ u = insertInto #users
210+ (Values_ (Default `as` #id :* Set (param @1) `as` #name))
211+ OnConflictDoRaise (Returning_ (#id :* param @2 `as` #email))
212+ e = insertInto_ #emails $ Select
213+ (Default `as` #id :* Set (#u ! #id) `as` #user_id :* Set (#u ! #email) `as` #email)
214+ (from (common #u))
209215:}
210216
211217>>> printSQL insertUser
212−INSERT INTO "users" ("id", "name") VALUES (DEFAULT, ($1 :: text)) ON CONFLICT DO NOTHING RETURNING "id" AS "fromOnly"
213−>>> printSQL insertEmail
214−INSERT INTO "emails" ("id", "user_id", "email") VALUES (DEFAULT, ($1 :: int4), ($2 :: text)) ON CONFLICT DO NOTHING
218+WITH "u" AS (INSERT INTO "users" ("id", "name") VALUES (DEFAULT, ($1 :: text)) RETURNING "id" AS "id", ($2 :: text) AS "email") INSERT INTO "emails" ("user_id", "email") SELECT "u"."id", "u"."email" FROM "u" AS "u"
215219```
216220
217−Next we write a `Query` to retrieve users from the database. We're not
221+Next we write a `Query_` to retrieve users from the database. We're not
218222interested in the ids here, just the usernames and email addresses. We
219−need to use an inner join to get the right result. A `Query` is like a
220−`Manipulation` with the same kind of type parameters.
223+need to use an `innerJoin` to get the right result. A `Query_` is like a
224+`Manipulation_` with the same kind of type parameters.
221225
222226```Haskell
223227>>> :{
224228let
225− getUsers :: Query Schema '[]
226− '[ "userName" ::: 'NotNull 'PGtext
227− , "userEmail" ::: 'Null 'PGtext ]
228− getUsers = select
229+ getUsers :: Query_ Schemas () User
230+ getUsers = select_
229231 (#u ! #name `as` #userName :* #e ! #email `as` #userEmail)
230232 ( from (table (#users `as` #u)
231233 & innerJoin (table (#emails `as` #e))
@@ -236,25 +238,13 @@ let
236238SELECT "u"."name" AS "userName", "e"."email" AS "userEmail" FROM "users" AS "u" INNER JOIN "emails" AS "e" ON ("u"."id" = "e"."user_id")
237239```
238240
239−Now that we've defined the SQL side of things, we'll need a Haskell type
240−for users. We give the type `Generics.SOP.Generic` and
241−`Generics.SOP.HasDatatypeInfo` instances so that we can decode the rows
242−we receive when we run `getUsers`. Notice that the record fields of the
243−`User` type match the column names of `getUsers`.
244−
245−```Haskell
246−>>> data User = User { userName :: Text, userEmail :: Maybe Text } deriving (Show, GHC.Generic)
247−>>> instance SOP.Generic User
248−>>> instance SOP.HasDatatypeInfo User
249−```
250−
251−Let's also create some users to add to the database.
241+Let's create some users to add to the database.
252242
253243```Haskell
254244>>> :{
255245let
256246 users :: [User]
257− users =
247+ users =
258248 [ User "Alice" (Just "alice@gmail.com")
259249 , User "Bob" Nothing
260250 , User "Carole" (Just "carole@hotmail.com")
@@ -273,19 +263,18 @@ transformer and when the schema doesn't change we can use `Monad` and
273263```Haskell
274264>>> :{
275265let
276− session :: PQ Schema Schema IO ()
266+ session :: PQ Schemas Schemas IO ()
277267 session = do
278− idResults <- traversePrepared insertUser (Only . userName <$> users)
279− ids <- traverse (fmap fromOnly . getRow 0) idResults
280− traversePrepared_ insertEmail (zip (ids :: [Int32]) (userEmail <$> users))
268+ _ <- traversePrepared_ insertUser users
281269 usersResult <- runQuery getUsers
282270 usersRows <- getRows usersResult
283− liftBase $ print (usersRows :: [User])
271+ liftIO $ print (usersRows :: [User])
284272in
285− void . withConnection "host=localhost port=5432 dbname=exampledb" $
273+ withConnection "host=localhost port=5432 dbname=exampledb" $
286274 define setup
287275 & pqThen session
288276 & pqThen (define teardown)
289277:}
290278[User {userName = "Alice", userEmail = Just "alice@gmail.com"},User {userName = "Bob", userEmail = Nothing},User {userName = "Carole", userEmail = Just "carole@hotmail.com"}]
279+-}
291280```
RELEASE NOTES.md+400
@@ -1,5 +1,405 @@
11## RELEASE NOTES
22
3+### Version 0.5
4+
5+Version 0.5 makes a number of large changes and additions to Squeal.
6+I want to thank folks who contributed issues and pull requests;
7+Raveline, rimmington, ilyakooo0, chshersh, reygoch, and more.
8+
9+**Multi-schema support**
10+
11+Previous versions of Squeal only supported definitions in the "public"
12+schema. Squeal 0.5 adds support for multiple schemas with the new kind
13+
14+```Haskell
15+type SchemasType = [(Symbol,SchemaType)]
16+```
17+
18+In order to upgrade your queries, manipulations and definitions from
19+Squeal 0.4, you will have to apply the `Public` type family, which indicates
20+that your only schema is the "public" schema.
21+
22+```Haskell
23+-- Squeal 0.4
24+setup :: Definition '[] Schema
25+
26+-- Squeal 0.5
27+setup :: Definition (Public '[]) (Public Schema)
28+```
29+
30+You can create non-public schemas using `createSchema` and inversely
31+remove them using `dropSchema`. There is also an idempotent
32+`createSchemaIfNotExists`.
33+
34+In order to handle aliases which may refer to non-public schemas, Squeal 0.5
35+introduces `QualifiedAlias`es. A `QualifiedAlias` can be referred to using
36+the `(!)` operator from the `IsQualified` typeclass; but if you want to refer
37+to an alias from the "public" schema, you can continue to use a single
38+overloaded label, no need to write `#public ! #tab`, just write `#tab`.
39+
40+**Top-level statements**
41+
42+As a consequence of multi-schema support, common table expressions that
43+a `Query` or `Manipulation` may refer to had to be broken into a new parameter.
44+Additionally, `Query` gained another new parameter for its outer scope which
45+will be discussed in the next section.
46+
47+To simplify type signatures that you have to write for top-level queries
48+and manipulations, Squeal 0.5 introduces the `Query_` and `Manipulation_`
49+type families.
50+
51+```
52+type family Query_
53+ (schemas :: SchemasType)
54+ (parameters :: Type)
55+ (row :: Type) where
56+ Query_ schemas params row =
57+ Query '[] '[] schemas (TuplePG params) (RowPG row)
58+```
59+
60+As you see, a top-level `Query_` has no outer scope and no common
61+table expressions in scope, they are empty `'[]`. Moreover,
62+its parameters and row parameters are now `Type`s, which are
63+converted to corresponding Postgres types using the `TuplePG`
64+and `RowPG` type families. This means you can write the type signatures
65+for your top-level statements using the Haskell types that you
66+intend to input and retrieve when running the statements. Similar
67+to `Query_`, there is a `Manipulation_` type, the only difference
68+being that a general `Manipulation` doesn't have an outer scope,
69+only a scope for common table expressions.
70+
71+**Subquery expressions**
72+
73+Previous versions of Squeal offered subquery expression support
74+but there were issues. The common use case of using the `IN` operator
75+from SQL was overly complex. There was a proliferation of subquery
76+functions to handle different comparison operators, each with two versions
77+for comparing `ALL` or `ANY` of the query rows. And, most confoundedly,
78+there was no way to support the `EXISTS` subquery because the "outer scope"
79+for a query was not available.
80+
81+Squeal adds an outer scope to the `Query` type.
82+
83+```Haskell
84+newtype Query
85+ (outer :: FromType)
86+ (commons :: FromType)
87+ (schemas :: SchemasType)
88+ (params :: [NullityType])
89+ (row :: RowType)
90+ = UnsafeQuery { renderQuery :: ByteString }
91+```
92+
93+This enables a well-typed `exists` function.
94+
95+```Haskell
96+exists
97+ :: Query (Join outer from) commons schemas params row
98+ -> Condition outer commons grp schemas params from
99+```
100+
101+The `in_` and `notIn` functions were simplified to handle the most
102+common use case of comparing to a list of values.
103+
104+```Haskell
105+in_
106+ :: Expression outer commons grp schemas params from ty -- ^ expression
107+ -> [Expression outer commons grp schemas params from ty]
108+ -> Condition outer commons grp schemas params from
109+```
110+
111+Finally, general subquery comparisons were abstracted to work with
112+any comparison operators, using the `Operator` type which will be discussed in
113+the next section.
114+
115+```Haskell
116+subAll
117+ :: Expression outer commons grp schemas params from ty1
118+ -> Operator ty1 ty2 ('Null 'PGbool)
119+ -> Query (Join outer from) commons schemas params '[col ::: ty2]
120+ -> Condition outer commons grp schemas params from
121+
122+subAny
123+ :: Expression outer commons grp schemas params from ty1
124+ -> Operator ty1 ty2 ('Null 'PGbool)
125+ -> Query (Join outer from) commons schemas params '[col ::: ty2]
126+ -> Condition outer commons grp schemas params from
127+```
128+
129+**Expression RankNTypes**
130+
131+Squeal 0.5 introduces RankNType type synonyms for common expression patterns.
132+The simplest example is the `Expr` type, a type for "closed" expressions
133+that cannot reference any aliases or parameters.
134+
135+```Haskell
136+type Expr x
137+ = forall outer commons grp schemas params from
138+ . Expression outer commons grp schemas params from x
139+```
140+
141+There is also a function type `(-->)`, which is a subtype of the usual Haskell function
142+type `(->)`.
143+
144+```Haskell
145+type (-->) x y
146+ = forall outer commons grp schemas params from
147+ . Expression outer commons grp schemas params from x
148+ -> Expression outer commons grp schemas params from y
149+```
150+
151+We saw in the subquery section that there is an `Operator` type.
152+
153+```Haskell
154+type Operator x1 x2 y
155+ = forall outer commons grp schemas params from
156+ . Expression outer commons grp schemas params from x1
157+ -> Expression outer commons grp schemas params from x2
158+ -> Expression outer commons grp schemas params from y
159+```
160+
161+There are also types `FunctionN` and `FunctionVar` for n-ary functions
162+and variadic functions.
163+
164+```
165+type FunctionN xs y
166+ = forall outer commons grp schemas params from
167+ . NP (Expression outer commons grp schemas params from) xs
168+ -> Expression outer commons grp schemas params from y
169+```
170+
171+An n-ary function takes an `NP` list of `Expression`s as its argument.
172+Squeal 0.5 adds a helpful operator `(*:)`, to help scrap your `Nil`s.
173+You can construct an `NP` list now by using the operator `(:*)`,
174+until your last element, using `(*:)` there. For instance, the function
175+`atan2_` takes two arguments, `atan2_ (pi *: 2)`.
176+
177+**Selections**
178+
179+Previously, Squeal provided a couple versions of `SELECT` depending
180+on whether you wanted to select all columns of a unique table
181+in the from clause, i.e. `*`, all columns of a particular table
182+in the from clause, i.e. `.*`, or a list of columns from the from clause.
183+
184+Squeal 0.5 refactors this pattern into a `Selection` GADT type, allowing
185+for abstraction and combinations that were not possible before.
186+
187+```Haskell
188+data Selection outer commons grp schemas params from row where
189+ Star
190+ :: HasUnique tab from row
191+ => Selection outer commons 'Ungrouped schemas params from row
192+ DotStar
193+ :: Has tab from row
194+ => Alias tab
195+ -> Selection outer commons 'Ungrouped schemas params from row
196+ List
197+ :: SListI row
198+ => NP (Aliased (Expression outer commons grp schemas params from)) row
199+ -> Selection outer commons grp schemas params from row
200+ Over
201+ :: SListI row
202+ => NP (Aliased (WindowFunction outer commons grp schemas params from)) row
203+ -> WindowDefinition outer commons grp schemas params from
204+ -> Selection outer commons grp schemas params from row
205+ Also
206+ :: Selection outer commons grp schemas params from right
207+ -> Selection outer commons grp schemas params from left
208+ -> Selection outer commons grp schemas params from (Join left right)
209+```
210+
211+In addition to the `Star`, `DotStar` and `List` constructors, there is an
212+`Also` constructor combinator, which enables users to combine `Selection`s.
213+Additionally, there is an `Over` constructor that is used to enable
214+window functions, described in the next section.
215+
216+To upgrade from Squeal 0.4, you will replace `selectStar` with `select Star`,
217+replace `selectDotStar #tab` with `select (DotStar #tab)`. The `List`
218+selection is such a common use case that there is a function `select_` which
219+automatically applies it, so to upgrade from Squeal 0.4, replace `select`
220+with `select_`. There are also independent `selectDistinct` and `selectDistinct_`
221+functions to filter out duplicate rows.
222+
223+**Query clauses**
224+
225+Previously, Squeal provided a couple versions of `INSERT` depending
226+on whether you wanted to insert `VALUES` or a query.
227+
228+Squeal 0.5 refactors this pattern into a `QueryClause` GADT.
229+
230+```
231+-- Squeal 0.4
232+insertRow_ #tab (Set 2 `as` #col1 :* Default `as` #col2)
233+insertQuery_ #tab (selectStar (from (table #other_tab)))
234+
235+-- Squeal 0.5
236+insertInto_ #tab (Values_ (Set 2 `as` #col1 :* Default `as` #col2))
237+insertInto_ #tab (Subquery (select Star (from (table #other_tab))))
238+```
239+
240+**Window functions and aggregation**
241+
242+Previous versions of Squeal provided no support for window functions.
243+Squeal 0.5 adds support for window functions. We saw `Over` in the
244+previous section.
245+
246+```Haskell
247+Over
248+ :: SListI row
249+ => NP (Aliased (WindowFunction outer commons grp schemas params from)) row
250+ -> WindowDefinition outer commons grp schemas params from
251+ -> Selection outer commons grp schemas params from row
252+```
253+
254+`Over` combines window functions with window definitions. A `WindowDefinition`
255+is constructed using the `partitionBy` function, optionally with an `orderBy`
256+clause. For example,
257+
258+```Haskell
259+query :: Query_ (Public Schema) () (Row Int32 Int32)
260+query = select
261+ (#col1 & Also (rank `as` #col2 `Over` (partitionBy #col1 & orderBy [#col2 & Asc])))
262+ (from (table #tab))
263+```
264+
265+Here the `rank` function is a `WindowFunction`
266+
267+```Haskell
268+rank :: WinFun0 ('NotNull 'PGint8)
269+rank = UnsafeWindowFunction "rank()"
270+```
271+
272+`WinFun0` is a RankNType, like `Expr` was, used for no argument window functions.
273+Similarly, there are also `WinFun1` and `WinFunN` types for
274+window functions and n-ary window functions.
275+
276+In order to use the same syntax for certain window functions and aggregate functions,
277+a new typeclass `Aggregate` was introduced. So for instance, `sum_` can be
278+either a `Distinction` `Expression` or a `WindowFunction`, used either with
279+a `groupBy` or with a `partitionBy` in the appropriate way.
280+
281+```
282+data Distinction (expr :: kind -> Type) (ty :: kind)
283+ = All (expr ty)
284+ | Distinct (expr ty)
285+```
286+
287+Aggregate functions can be run over all rows or only over distinct rows,
288+while window functions bear no such distinction.
289+
290+**Migrations**
291+
292+Thanks to [https://github.com/Raveline](Raveline) Squeal 0.5 introduces
293+a function `defaultMain` to easily create a command line program to
294+run or rewind your migrations.
295+
296+Previously, Squeal's migrations were impure, allowing in addition to
297+running `Definition`s to run arbitrary `IO` operations, such as inserting
298+data into the database or printing out status messages. In order to
299+provide compatibility with other migration systems, Squeal 0.5 introduces
300+pure migrations, that is migrations that are only `Definition`s.
301+
302+```Haskell
303+data Migration p schemas0 schemas1 = Migration
304+ { name :: Text -- ^ The `name` of a `Migration`.
305+ -- Each `name` in a `Migration` should be unique.
306+ , up :: p schemas0 schemas1 -- ^ The `up` instruction of a `Migration`.
307+ , down :: p schemas1 schemas0 -- ^ The `down` instruction of a `Migration`.
308+ } deriving (GHC.Generic)
309+```
310+
311+A pure migration is a `Migration Definition`, a pair of inverse
312+`Definition`s with a unique name. To recover impure migrations, Squeal 0.5
313+introduces the `Terminally` type.
314+
315+```Haskell
316+newtype Terminally trans monad x0 x1 = Terminally
317+ { runTerminally :: trans x0 x1 monad () }
318+```
319+
320+`Terminally` applies the indexed monad transformer and the monad it transforms
321+to the unit type `()`, thereby turning an indexed monad into a `Category`. An
322+impure migration is a `Migration (Terminally PQ IO)`. You can always cast
323+a pure migration into an impure migration with the functor, `pureMigration`.
324+
325+```Haskell
326+pureMigration
327+ :: Migration Definition schemas0 schemas1
328+ -> Migration (Terminally PQ IO) schemas0 schemas1
329+```
330+
331+To run either pure or impure migrations, Squeal 0.5 introduces
332+a typeclass, `Migratory`.
333+
334+```
335+class Category p => Migratory p where
336+
337+ migrateUp
338+ :: AlignedList (Migration p) schemas0 schemas1
339+ -> PQ schemas0 schemas1 IO ()
340+
341+ migrateDown
342+ :: AlignedList (Migration p) schemas0 schemas1
343+ -> PQ schemas1 schemas0 IO ()
344+```
345+
346+The signatures of `migrateUp` and `migrateDown` have been changed
347+to make them easier to compose with other `PQ` actions.
348+
349+**Transactions**
350+
351+You can now run transactions `ephemerally`, guaranteed to roll back,
352+but return the result or throw the exception that the transaction
353+would have generated. This is useful for testing. You can also
354+`transactionallyRetry` computations, retrying the transaction if
355+a [serialization failure](https://www.postgresql.org/docs/11/transaction-iso.html#XACT-REPEATABLE-READ) occurs.
356+
357+**Types**
358+
359+Squeal now supports money via a `Money` Haskell `Type` and a `'PGmoney`
360+`PGType`. Squeal 0.5 also adds support for creating domain types
361+with `createDomain`.
362+
363+**Time**
364+
365+Squeal 0.5 adds support for new functions; `now`, `makeDate`, `makeTime`,
366+, `makeTimestamp`, and `makeTimestamptz`, a function `interval_` for
367+constructing time intervals out multiples of `TimeUnit`s, and a new
368+`TimeOp` class, defining affine space operators for time types and their
369+differences.
370+
371+**Literals**
372+
373+Squeal allows you to include Haskell values in your statements using
374+out of line `parameter`s, but often you want to include them inline,
375+as a SQL `literal`. Squeal 0.5 enables this using the `Literal` class.
376+
377+**Set returning functions**
378+
379+Squeal 0.5 adds support for set returning functions such as `unnest`,
380+with the `RankNType` `SetOfFunction`, which can be used as as a `FromClause`.
381+
382+**Text search**
383+
384+Squeal 0.5 adds extensive support for text search types, functions and operators.
385+
386+**Much more**
387+
388+Lots more changes went into and under the hood of the new version.
389+The `Expression` module was split into coherent submodules since it
390+had grown to immense proportions. New modules `Alias`, `PG` and `List`
391+were added to relieve some of the burden that the `Schema` module
392+had been carrying. Rendering has been better unified with a new
393+`RenderSQL` typeclass. Type level list concatenation with the `Additional`
394+typeclass has been added. `Manipulation`s `update` and `delete`
395+were upgraded, so you can leave out fields you don't want to update and
396+use `USING` clauses in deletes. Upserts which were previously broken
397+now work. The `IO` typeclass hierarchy was changed from `MonadBase`
398+and `MonadBaseControl` to `MonadIO` and `MonadUnliftIO`. A new
399+`withRecursive` `Manipulation` was added. `SquealException`s were
400+refactored and a `trySqueal` function added. Arrays were refactored.
401+And there was probably more I've forgotten.
402+
3403### Version 0.4
4404
5405Version 0.4 strengthens Squeal's type system, adds
squeal-postgresql/exe/Example.hs+19−21
@@ -11,8 +11,7 @@
1111
1212module Main (main, main2) where
1313
14−import Control.Monad (void)
15−import Control.Monad.Base (liftBase, MonadBase)
14+import Control.Monad.IO.Class (MonadIO (..))
1615import Data.Int (Int16, Int32)
1716import Data.Monoid ((<>))
1817import Data.Text (Text)
@@ -39,12 +38,13 @@ type Schema =
3938 , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
4039 , "email" ::: 'NoDef :=> 'Null 'PGtext
4140 ])
41+ , "positive" ::: 'Typedef 'PGfloat4
4242 ]
4343
4444type Schemas = Public Schema
4545
4646setup :: Definition (Public '[]) Schemas
47−setup =
47+setup =
4848 createTable #users
4949 ( serial `as` #id :*
5050 (text & notNullable) `as` #name :*
@@ -53,29 +53,27 @@ setup =
5353 >>>
5454 createTable #emails
5555 ( serial `as` #id :*
56− (int & notNullable) `as` #user_id :*
57− (text & nullable) `as` #email )
56+ hask @Int32 `as` #user_id :*
57+ hask @(Maybe Text) `as` #email )
5858 ( primaryKey #id `as` #pk_emails :*
5959 foreignKey #user_id #users #id
6060 OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
61+ >>>
62+ createDomain #positive real (#value .> 0 .&& (#value & isNotNull))
6163
6264teardown :: Definition Schemas (Public '[])
63−teardown = dropTable #emails >>> dropTable #users
65+teardown = dropType #positive >>> dropTable #emails >>> dropTable #users
6466
65−insertUser :: Manipulation '[] Schemas '[ 'NotNull 'PGtext, 'NotNull ('PGvararray ('Null 'PGint2))]
66− '[ "fromOnly" ::: 'NotNull 'PGint4 ]
67+insertUser :: Manipulation_ Schemas (Text, VarArray (Vector (Maybe Int16))) (Only Int32)
6768insertUser = insertInto #users
68− (Values_ (defaultAs #id :* param @1 `as` #name :* param @2 `as` #vec))
69+ (Values_ (Default `as` #id :* Set (param @1) `as` #name :* Set (param @2) `as` #vec))
6970 (OnConflict (OnConstraint #pk_users) DoNothing) (Returning_ (#id `as` #fromOnly))
7071
71−insertEmail :: Manipulation '[] Schemas '[ 'NotNull 'PGint4, 'Null 'PGtext] '[]
72+insertEmail :: Manipulation_ Schemas (Int32, Maybe Text) ()
7273insertEmail = insertInto_ #emails
73− (Values_ (defaultAs #id :* param @1 `as` #user_id :* param @2 `as` #email))
74+ (Values_ (Default `as` #id :* Set (param @1) `as` #user_id :* Set (param @2) `as` #email))
7475
75−getUsers :: Query '[] Schemas '[]
76− '[ "userName" ::: 'NotNull 'PGtext
77− , "userEmail" ::: 'Null 'PGtext
78− , "userVec" ::: 'NotNull ('PGvararray ('Null 'PGint2))]
76+getUsers :: Query_ Schemas () User
7977getUsers = select_
8078 (#u ! #name `as` #userName :* #e ! #email `as` #userEmail :* #u ! #vec `as` #userVec)
8179 ( from (table (#users `as` #u)
@@ -88,22 +86,22 @@ instance SOP.Generic User
8886instance SOP.HasDatatypeInfo User
8987
9088users :: [User]
91−users =
89+users =
9290 [ User "Alice" (Just "alice@gmail.com") (VarArray [Nothing, Just 1])
9391 , User "Bob" Nothing (VarArray [Just 2, Nothing])
9492 , User "Carole" (Just "carole@hotmail.com") (VarArray [Just 3])
9593 ]
9694
97−session :: (MonadBase IO pq, MonadPQ Schemas pq) => pq ()
95+session :: (MonadIO pq, MonadPQ Schemas pq) => pq ()
9896session = do
99− liftBase $ Char8.putStrLn "manipulating"
97+ liftIO $ Char8.putStrLn "manipulating"
10098 idResults <- traversePrepared insertUser ([(userName user, userVec user) | user <- users])
10199 ids <- traverse (fmap fromOnly . getRow 0) idResults
102100 traversePrepared_ insertEmail (zip (ids :: [Int32]) (userEmail <$> users))
103− liftBase $ Char8.putStrLn "querying"
101+ liftIO $ Char8.putStrLn "querying"
104102 usersResult <- runQuery getUsers
105103 usersRows <- getRows usersResult
106− liftBase $ print (usersRows :: [User])
104+ liftIO $ print (usersRows :: [User])
107105
108106main :: IO ()
109107main = do
@@ -121,7 +119,7 @@ main = do
121119
122120main2 :: IO ()
123121main2 =
124− void . withConnection "host=localhost port=5432 dbname=exampledb" $
122+ withConnection "host=localhost port=5432 dbname=exampledb" $
125123 define setup
126124 & pqThen session
127125 & pqThen (define teardown)
squeal-postgresql/squeal-postgresql.cabal+58−16
@@ -1,5 +1,5 @@
11name: squeal-postgresql
2−version: 0.4.9.0
2+version: 0.5.1.0
33synopsis: Squeal PostgreSQL Library
44description: Squeal is a type-safe embedding of PostgreSQL in Haskell
55homepage: https://github.com/morphismtech/squeal
@@ -22,12 +22,40 @@ library
2222 hs-source-dirs: src
2323 exposed-modules:
2424 Squeal.PostgreSQL
25+ Squeal.PostgreSQL.Alias
2526 Squeal.PostgreSQL.Binary
2627 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
2735 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
2855 Squeal.PostgreSQL.Manipulation
2956 Squeal.PostgreSQL.Migration
3057 Squeal.PostgreSQL.Pool
58+ Squeal.PostgreSQL.PG
3159 Squeal.PostgreSQL.PQ
3260 Squeal.PostgreSQL.Render
3361 Squeal.PostgreSQL.Query
@@ -42,10 +70,9 @@ library
4270 , bytestring >= 0.10.8.2
4371 , bytestring-strict-builder >= 0.4.5
4472 , deepseq >= 1.4.3.0
45− , generics-sop >= 0.3.2.0
46− , lifted-base >= 0.2.3.12
73+ , free-categories >= 0.1.0.0
74+ , generics-sop >= 0.3.2.0 && < 0.5.0.0
4775 , mmorph >= 1.1.1
48− , monad-control >= 1.0.2.3
4976 , mtl >= 2.2.2
5077 , network-ip >= 0.3.0.2
5178 , postgresql-binary >= 0.12.1
@@ -56,39 +83,55 @@ library
5683 , text >= 1.2.3.0
5784 , time >= 1.8.0.2
5885 , transformers >= 0.5.2.0
59− , transformers-base >= 0.4.4
86+ , unliftio >= 0.2.10
87+ , unliftio-pool >= 0.2.1.0
6088 , uuid-types >= 1.0.3
6189 , vector >= 0.12.0.1
6290
63−test-suite squeal-postgresql-doctest
91+test-suite doctest
6492 default-language: Haskell2010
6593 type: exitcode-stdio-1.0
6694 hs-source-dirs: test
6795 ghc-options: -Wall
68− main-is: DocTest.hs
96+ main-is: Doc.hs
6997 build-depends:
7098 base >= 4.10.0.0
7199 , doctest >= 0.11.4
100+ , squeal-postgresql
72101
73−test-suite squeal-postgresql-specs
102+test-suite properties
74103 default-language: Haskell2010
75104 type: exitcode-stdio-1.0
76− hs-source-dirs: test/Specs
77− ghc-options: -Wall -main-is Specs
78− main-is: Specs.hs
79− other-modules: ExceptionHandling
105+ hs-source-dirs: test
106+ ghc-options: -Wall
107+ main-is: Property.hs
80108 build-depends:
81109 base >= 4.10.0.0
82110 , 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
83127 , generics-sop >= 0.3.1.0
84128 , hspec >= 2.4.8
129+ , mtl >= 2.2.2
85130 , squeal-postgresql
86131 , text >= 1.2.2.2
87− , transformers >= 0.5.2.0
88− , transformers-base >= 0.4.4
89132 , vector >= 0.12.0.1
90133
91−executable squeal-postgresql-example
134+executable example
92135 default-language: Haskell2010
93136 hs-source-dirs: exe
94137 ghc-options: -Wall
@@ -101,5 +144,4 @@ executable squeal-postgresql-example
101144 , squeal-postgresql
102145 , text >= 1.2.2.2
103146 , transformers >= 0.5.2.0
104− , transformers-base >= 0.4.4
105147 , vector >= 0.12.0.1
squeal-postgresql/src/Squeal/PostgreSQL.hs+71−52
@@ -1,7 +1,7 @@
11{-|
22Module: Squeal.PostgreSQL
3−Description: Squeel export module
4−Copyright: (c) Eitan Chatav, 2017
3+Description: Squeal export module
4+Copyright: (c) Eitan Chatav, 2019
55Maintainer: eitan@morphism.tech
66Stability: experimental
77
@@ -11,17 +11,15 @@ Let's see an example!
1111First, we need some language extensions because Squeal uses modern GHC
1212features.
1313
14−>>> :set -XDataKinds -XDeriveGeneric -XOverloadedLabels
14+>>> :set -XDataKinds -XDeriveGeneric -XOverloadedLabels -XFlexibleContexts
1515>>> :set -XOverloadedStrings -XTypeApplications -XTypeOperators -XGADTs
16−
16+
1717We'll need some imports.
1818
19−>>> import Control.Monad (void)
20−>>> import Control.Monad.Base (liftBase)
19+>>> import Control.Monad.IO.Class (liftIO)
2120>>> import Data.Int (Int32)
2221>>> import Data.Text (Text)
2322>>> import Squeal.PostgreSQL
24−>>> import Squeal.PostgreSQL.Render
2523
2624We'll use generics to easily convert between Haskell and PostgreSQL values.
2725
@@ -60,7 +58,7 @@ yielding a `TableType`, or to pair a `ColumnConstraint` with a `NullityType`,
6058yielding a `ColumnType`. It is intended to connote Haskell's @=>@ operator
6159
6260Next, 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`
6462has two type parameters, corresponding to the schema
6563before being run and the schema after. We can compose definitions using `>>>`.
6664Here and in the rest of our commands we make use of overloaded
@@ -69,7 +67,7 @@ labels to refer to named tables and columns in our schema.
6967>>> :{
7068let
7169 setup :: Definition (Public '[]) Schemas
72− setup =
70+ setup =
7371 createTable #users
7472 ( serial `as` #id :*
7573 (text & notNullable) `as` #name )
@@ -104,25 +102,23 @@ let
104102DROP TABLE "emails";
105103DROP TABLE "users";
106104
107−Next, we'll write `Manipulation`s to insert data into our two tables.
108−A `Manipulation` like `insertRow`, `update` or `deleteFrom`
109−has three type parameters, the schema it refers to, a list of parameters
110−it can take as input, and a list of columns it produces as output. When
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+
112+Next, we'll write `Manipulation_`s to insert @User@s into our two tables.
113+A `Manipulation_` like `insertInto`, `update` or `deleteFrom`
114+has three type parameters, the schemas it refers to, input parameters
115+and an output row. When
111116we insert into the users table, we will need a parameter for the @name@
112117field but not for the @id@ field. Since it's serial, we can use a default
113118value. However, since the emails table refers to the users table, we will
114119need to retrieve the user id that the insert generates and insert it into
115−the emails table. Take a careful look at the type and definition of both
116−of our inserts.
117−
118−We'll need a Haskell type for users. We give the type `Generics.SOP.Generic` and
119−`Generics.SOP.HasDatatypeInfo` instances so that we can decode the rows
120−we receive when we run @getUsers@. Notice that the record fields of the
121−@User@ type match the column names of @getUsers@.
122−
123−>>> data User = User { userName :: Text, userEmail :: Maybe Text } deriving (Show, GHC.Generic)
124−>>> instance SOP.Generic User
125−>>> instance SOP.HasDatatypeInfo User
120+the emails table. We can do this in a single `Manipulation_` by using a
121+`with` statement.
126122
127123>>> :{
128124let
@@ -130,19 +126,20 @@ let
130126 insertUser = with (u `as` #u) e
131127 where
132128 u = insertInto #users
133− (Values_ (defaultAs #id :* param @1 `as` #name))
129+ (Values_ (Default `as` #id :* Set (param @1) `as` #name))
134130 OnConflictDoRaise (Returning_ (#id :* param @2 `as` #email))
135− e = insertInto_ #emails
136− (Select (defaultAs #id :* #u ! #id `as` #user_id :* #u ! #email) (from (common #u)))
131+ e = insertInto_ #emails $ Select
132+ (Default `as` #id :* Set (#u ! #id) `as` #user_id :* Set (#u ! #email) `as` #email)
133+ (from (common #u))
137134:}
138135
139136>>> printSQL insertUser
140137WITH "u" AS (INSERT INTO "users" ("id", "name") VALUES (DEFAULT, ($1 :: text)) RETURNING "id" AS "id", ($2 :: text) AS "email") INSERT INTO "emails" ("user_id", "email") SELECT "u"."id", "u"."email" FROM "u" AS "u"
141138
142−Next we write a `Query` to retrieve users from the database. We're not
139+Next we write a `Query_` to retrieve users from the database. We're not
143140interested in the ids here, just the usernames and email addresses. We
144−need to use an inner join to get the right result. A `Query` is like a
145−`Manipulation` with the same kind of type parameters.
141+need to use an `innerJoin` to get the right result. A `Query_` is like a
142+`Manipulation_` with the same kind of type parameters.
146143
147144>>> :{
148145let
@@ -162,7 +159,7 @@ Let's create some users to add to the database.
162159>>> :{
163160let
164161 users :: [User]
165− users =
162+ users =
166163 [ User "Alice" (Just "alice@gmail.com")
167164 , User "Bob" Nothing
168165 , User "Carole" (Just "carole@hotmail.com")
@@ -184,31 +181,53 @@ let
184181 _ <- traversePrepared_ insertUser users
185182 usersResult <- runQuery getUsers
186183 usersRows <- getRows usersResult
187− liftBase $ print (usersRows :: [User])
184+ liftIO $ print (usersRows :: [User])
188185in
189− void . withConnection "host=localhost port=5432 dbname=exampledb" $
186+ withConnection "host=localhost port=5432 dbname=exampledb" $
190187 define setup
191188 & pqThen session
192189 & pqThen (define teardown)
193190:}
194191[User {userName = "Alice", userEmail = Just "alice@gmail.com"},User {userName = "Bob", userEmail = Nothing},User {userName = "Carole", userEmail = Just "carole@hotmail.com"}]
195192-}
196−module Squeal.PostgreSQL
197− ( module Squeal.PostgreSQL.Binary
198− , module Squeal.PostgreSQL.Definition
199− , module Squeal.PostgreSQL.Expression
200− , module Squeal.PostgreSQL.Manipulation
201− , module Squeal.PostgreSQL.PQ
202− , module Squeal.PostgreSQL.Query
203− , module Squeal.PostgreSQL.Schema
204− , module Squeal.PostgreSQL.Transaction
205− ) where
206−
207−import Squeal.PostgreSQL.Binary
208−import Squeal.PostgreSQL.Definition
209−import Squeal.PostgreSQL.Expression
210−import Squeal.PostgreSQL.Manipulation
211−import Squeal.PostgreSQL.PQ
212−import Squeal.PostgreSQL.Query
213−import Squeal.PostgreSQL.Schema
214−import Squeal.PostgreSQL.Transaction
193+module Squeal.PostgreSQL (module X, RenderSQL(..), printSQL) where
194+
195+import Squeal.PostgreSQL.Alias as X
196+import Squeal.PostgreSQL.Binary as X
197+import Squeal.PostgreSQL.Definition as X
198+import Squeal.PostgreSQL.Definition.Function as X
199+import Squeal.PostgreSQL.Definition.Index as X
200+import Squeal.PostgreSQL.Definition.Schema as X
201+import Squeal.PostgreSQL.Definition.Table as X
202+import Squeal.PostgreSQL.Definition.Table.Constraint as X
203+import Squeal.PostgreSQL.Definition.Type as X
204+import Squeal.PostgreSQL.Definition.View as X
205+import Squeal.PostgreSQL.Expression as X
206+import Squeal.PostgreSQL.Expression.Aggregate as X
207+import Squeal.PostgreSQL.Expression.Collection as X
208+import Squeal.PostgreSQL.Expression.Comparison as X
209+import Squeal.PostgreSQL.Expression.Json as X
210+import Squeal.PostgreSQL.Expression.Literal as X
211+import Squeal.PostgreSQL.Expression.Logic as X
212+import Squeal.PostgreSQL.Expression.Math as X
213+import Squeal.PostgreSQL.Expression.Null as X
214+import Squeal.PostgreSQL.Expression.Parameter as X
215+import Squeal.PostgreSQL.Expression.Range as X
216+import Squeal.PostgreSQL.Expression.Set as X
217+import Squeal.PostgreSQL.Expression.Sort as X
218+import Squeal.PostgreSQL.Expression.Subquery as X
219+import Squeal.PostgreSQL.Expression.Text as X
220+import Squeal.PostgreSQL.Expression.TextSearch as X
221+import Squeal.PostgreSQL.Expression.Time as X
222+import Squeal.PostgreSQL.Expression.Type as X
223+import Squeal.PostgreSQL.Expression.Window as X
224+import Squeal.PostgreSQL.List as X
225+import Squeal.PostgreSQL.Manipulation as X
226+import Squeal.PostgreSQL.Migration as X
227+import Squeal.PostgreSQL.PG as X
228+import Squeal.PostgreSQL.Pool as X
229+import Squeal.PostgreSQL.PQ as X
230+import Squeal.PostgreSQL.Query as X
231+import Squeal.PostgreSQL.Render (RenderSQL(..), printSQL)
232+import Squeal.PostgreSQL.Schema as X
233+import Squeal.PostgreSQL.Transaction as X
squeal-postgresql/src/Squeal/PostgreSQL/Alias.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+233−113
@@ -1,7 +1,3 @@
1−{-# LANGUAGE
2− TypeFamilies
3−#-}
4−
51{-|
62Module: Squeal.PostgreSQL.Binary
73Description: Binary encoding and decoding
@@ -11,7 +7,7 @@ Stability: experimental
117
128This module provides binary encoding and decoding between Haskell and PostgreSQL types.
139
14−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
1511do not need to define your own instances to decode retrieved rows into Haskell values or
1612to encode Haskell values into statement parameters.
1713
@@ -20,10 +16,10 @@ Let's see some examples. We'll need some imports
2016>>> import Data.Int (Int16)
2117>>> import Data.Text (Text)
2218>>> import Control.Monad (void)
23−>>> import Control.Monad.Base (liftBase)
19+>>> import Control.Monad.IO.Class (liftIO)
2420>>> import Squeal.PostgreSQL
2521
26−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
2723round trip query.
2824
2925>>> data Row = Row { col1 :: Int16, col2 :: Text, col3 :: Maybe Bool } deriving (Eq, GHC.Generic)
@@ -43,15 +39,15 @@ the input and output should be equal.
4339
4440>>> let input = Row 2 "hi" (Just True)
4541>>> :{
46−void . withConnection "host=localhost port=5432 dbname=exampledb" $ do
42+withConnection "host=localhost port=5432 dbname=exampledb" $ do
4743 result <- runQueryParams roundTrip input
4844 Just output <- firstRow result
49− liftBase . print $ input == output
45+ liftIO . print $ input == output
5046:}
5147True
5248
5349In addition to being able to encode and decode basic Haskell types
54−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
5551Postgres array, enumerated and composite types and json. Let's see another example,
5652this time using the `Vector` type which corresponds to variable length arrays
5753and homogeneous tuples which correspond to fixed length arrays. We can even
@@ -82,10 +78,10 @@ let
8278>>> :set -XOverloadedLists
8379>>> let input = Row (VarArray [1,2]) (FixArray (Just 1,Nothing)) (FixArray ((1,2),(3,4),(5,6)))
8480>>> :{
85−void . withConnection "host=localhost port=5432 dbname=exampledb" $ do
81+withConnection "host=localhost port=5432 dbname=exampledb" $ do
8682 result <- runQueryParams roundTrip input
8783 Just output <- firstRow result
88− liftBase . print $ input == output
84+ liftIO . print $ input == output
8985:}
9086True
9187
@@ -124,9 +120,9 @@ let
124120 createTypeCompositeFrom @Person #person
125121:}
126122
127−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@
128124with enumerated, composite or json types in Postgres. First create a Haskell
129−`Row` type using the `Enumerated`, `Composite` and `Json` newtypes as fields.
125+@Row@ type using the `Enumerated`, `Composite` and `Json` newtypes as fields.
130126
131127>>> :{
132128data Row = Row
@@ -172,9 +168,9 @@ let
172168 session = do
173169 result <- runQueryParams roundTrip input
174170 Just output <- firstRow result
175− liftBase . print $ input == output
171+ liftIO . print $ input == output
176172in
177− void . withConnection "host=localhost port=5432 dbname=exampledb" $
173+ withConnection "host=localhost port=5432 dbname=exampledb" $
178174 define setup
179175 & pqThen session
180176 & pqThen (define teardown)
@@ -198,25 +194,31 @@ True
198194 , MultiParamTypeClasses
199195 , ScopedTypeVariables
200196 , TypeApplications
197+ , TypeFamilies
201198 , TypeInType
202199 , TypeOperators
203200 , UndecidableInstances
201+ , UndecidableSuperClasses
204202#-}
205203
206204module Squeal.PostgreSQL.Binary
207− ( Json (..)
208− , Jsonb (..)
209− , Composite (..)
210− , Enumerated (..)
211− , VarArray (..)
212− -- * Encoding
213− , ToParam (..)
205+ ( -- * Encoding
206+ ToParam (..)
214207 , ToParams (..)
208+ , ToNullityParam (..)
209+ , ToField (..)
210+ , ToFixArray (..)
215211 -- * Decoding
216212 , FromValue (..)
217213 , FromRow (..)
214+ , FromField (..)
215+ , FromFixArray (..)
218216 -- * Only
219217 , Only (..)
218+ -- * Oid
219+ , OidOf (..)
220+ , OidOfParam (..)
221+ , OidOfField (..)
220222 ) where
221223
222224import BinaryParser
@@ -230,6 +232,7 @@ import Data.Time
230232import Data.UUID.Types
231233import Data.Vector (Vector)
232234import Data.Word
235+import Foreign.C.Types (CUInt(CUInt))
233236import Generics.SOP
234237import Generics.SOP.Record
235238import GHC.TypeLits
@@ -243,10 +246,14 @@ import qualified Data.Text.Lazy as Lazy (Text)
243246import qualified Data.Text as Strict (Text)
244247import qualified Data.Text as Strict.Text
245248import qualified Data.Vector as Vector
249+import qualified Database.PostgreSQL.LibPQ as LibPQ
246250import qualified GHC.Generics as GHC
247251import qualified PostgreSQL.Binary.Decoding as Decoding
248252import qualified PostgreSQL.Binary.Encoding as Encoding
249253
254+import Squeal.PostgreSQL.Alias
255+import Squeal.PostgreSQL.List
256+import Squeal.PostgreSQL.PG
250257import Squeal.PostgreSQL.Schema
251258
252259-- | A `ToParam` constraint gives an encoding of a Haskell `Type` into
@@ -270,14 +277,13 @@ class ToParam (x :: Type) (pg :: PGType) where
270277 toParam :: x -> K Encoding.Encoding pg
271278instance ToParam Bool 'PGbool where toParam = K . Encoding.bool
272279instance ToParam Int16 'PGint2 where toParam = K . Encoding.int2_int16
273−instance ToParam Word16 'PGint2 where toParam = K . Encoding.int2_word16
274280instance ToParam Int32 'PGint4 where toParam = K . Encoding.int4_int32
275−instance ToParam Word32 'PGint4 where toParam = K . Encoding.int4_word32
276281instance ToParam Int64 'PGint8 where toParam = K . Encoding.int8_int64
277−instance ToParam Word64 'PGint8 where toParam = K . Encoding.int8_word64
282+instance ToParam Oid 'PGoid where toParam = K . Encoding.int4_word32 . getOid
278283instance ToParam Float 'PGfloat4 where toParam = K . Encoding.float4
279284instance ToParam Double 'PGfloat8 where toParam = K . Encoding.float8
280285instance ToParam Scientific 'PGnumeric where toParam = K . Encoding.numeric
286+instance ToParam Money 'PGmoney where toParam = K . Encoding.int8_int64 . cents
281287instance ToParam UUID 'PGuuid where toParam = K . Encoding.uuid
282288instance ToParam (NetAddr IP) 'PGinet where toParam = K . Encoding.inet
283289instance ToParam Char ('PGchar 1) where toParam = K . Encoding.char_utf8
@@ -306,24 +312,26 @@ instance Aeson.ToJSON x => ToParam (Json x) 'PGjson where
306312instance Aeson.ToJSON x => ToParam (Jsonb x) 'PGjsonb where
307313 toParam = K . Encoding.jsonb_bytes
308314 . Lazy.ByteString.toStrict . Aeson.encode . getJsonb
309−instance (ToNullityParam x ty, ty ~ nullity pg, HasOid pg)
315+instance (ToNullityParam x ty, ty ~ nullity pg, OidOf pg)
310316 => ToParam (VarArray [x]) ('PGvararray ty) where
311317 toParam = K
312− . Encoding.array_foldable (oid @pg) (unK . toNullityParam @x @ty)
318+ . Encoding.array_foldable
319+ (getOid (oidOf @pg)) (unK . toNullityParam @x @ty)
313320 . getVarArray
314−instance (ToParam x pg, HasOid pg)
321+instance (ToParam x pg, OidOf pg)
315322 => ToParam (VarArray (Vector x)) ('PGvararray ('NotNull pg)) where
316323 toParam = K
317− . Encoding.array_vector (oid @pg) (unK . toParam @x @pg)
324+ . Encoding.array_vector (getOid (oidOf @pg)) (unK . toParam @x @pg)
318325 . getVarArray
319−instance (ToParam x pg, HasOid pg)
326+instance (ToParam x pg, OidOf pg)
320327 => ToParam (VarArray (Vector (Maybe x))) ('PGvararray ('Null pg)) where
321328 toParam = K
322− . Encoding.nullableArray_vector (oid @pg) (unK . toParam @x @pg)
329+ . Encoding.nullableArray_vector
330+ (getOid (oidOf @pg)) (unK . toParam @x @pg)
323331 . getVarArray
324−instance (ToFixArray x dims ty, ty ~ nullity pg, HasOid pg)
332+instance (ToFixArray x dims ty, ty ~ nullity pg, OidOf pg)
325333 => ToParam (FixArray x) ('PGfixarray dims ty) where
326− toParam = K . Encoding.array (oid @pg)
334+ toParam = K . Encoding.array (getOid (oidOf @pg))
327335 . unK . unK . toFixArray @x @dims @ty . getFixArray
328336instance
329337 ( IsEnumType x
@@ -348,7 +356,7 @@ instance
348356 ( SListI fields
349357 , IsRecord x xs
350358 , AllZip ToField xs fields
351− , All HasAliasedOid fields
359+ , All OidOfField fields
352360 ) => ToParam (Composite x) ('PGcomposite fields) where
353361 toParam =
354362 let
@@ -356,7 +364,7 @@ instance
356364 encoders = htrans (Proxy @ToField) toField
357365
358366 composite
359− :: All HasAliasedOid row
367+ :: All OidOfField row
360368 => NP (K (Maybe Encoding.Encoding)) row
361369 -> K Encoding.Encoding ('PGcomposite row)
362370 composite fields = K $
@@ -373,27 +381,142 @@ instance
373381 int32BE (fromIntegral (lengthSList (Proxy @xs))) <>
374382 let
375383 each
376− :: HasAliasedOid field
384+ :: OidOfField field
377385 => K (Maybe Encoding.Encoding) field
378386 -> Encoding.Encoding
379387 each (K field :: K (Maybe Encoding.Encoding) field) =
380− word32BE (aliasedOid @field)
388+ word32BE (getOid (oidOfField @field))
381389 <> case field of
382390 Nothing -> int64BE (-1)
383391 Just value ->
384392 int32BE (fromIntegral (builderLength value))
385393 <> value
386394 in
387− hcfoldMap (Proxy @HasAliasedOid) each fields
395+ hcfoldMap (Proxy @OidOfField) each fields
388396
389397 in
390398 composite . encoders . toRecord . getComposite
391399
392−class HasAliasedOid (field :: (Symbol, NullityType)) where
393− aliasedOid :: Word32
394−instance HasOid ty => HasAliasedOid (alias ::: nullity ty) where
395− aliasedOid = oid @ty
396−
400+-- | The object identifier of a `PGType`.
401+--
402+-- >>> :set -XTypeApplications
403+-- >>> oidOf @'PGbool
404+-- Oid 16
405+class OidOf (ty :: PGType) where oidOf :: LibPQ.Oid
406+instance OidOf 'PGbool where oidOf = LibPQ.Oid 16
407+instance OidOf ('PGfixarray ns (null 'PGbool)) where oidOf = LibPQ.Oid 1000
408+instance OidOf ('PGvararray (null 'PGbool)) where oidOf = LibPQ.Oid 1000
409+instance OidOf 'PGint2 where oidOf = LibPQ.Oid 21
410+instance OidOf ('PGfixarray ns (null 'PGint2)) where oidOf = LibPQ.Oid 1005
411+instance OidOf ('PGvararray (null 'PGint2)) where oidOf = LibPQ.Oid 1005
412+instance OidOf 'PGint4 where oidOf = LibPQ.Oid 23
413+instance OidOf ('PGfixarray ns (null 'PGint4)) where oidOf = LibPQ.Oid 1007
414+instance OidOf ('PGvararray (null 'PGint4)) where oidOf = LibPQ.Oid 1007
415+instance OidOf 'PGint8 where oidOf = LibPQ.Oid 20
416+instance OidOf ('PGfixarray ns (null 'PGint8)) where oidOf = LibPQ.Oid 1016
417+instance OidOf ('PGvararray (null 'PGint8)) where oidOf = LibPQ.Oid 1016
418+instance OidOf 'PGnumeric where oidOf = LibPQ.Oid 1700
419+instance OidOf ('PGfixarray ns (null 'PGnumeric)) where oidOf = LibPQ.Oid 1231
420+instance OidOf ('PGvararray (null 'PGnumeric)) where oidOf = LibPQ.Oid 1231
421+instance OidOf 'PGfloat4 where oidOf = LibPQ.Oid 700
422+instance OidOf ('PGfixarray ns (null 'PGfloat4)) where oidOf = LibPQ.Oid 1021
423+instance OidOf ('PGvararray (null 'PGfloat4)) where oidOf = LibPQ.Oid 1021
424+instance OidOf 'PGfloat8 where oidOf = LibPQ.Oid 701
425+instance OidOf ('PGfixarray ns (null 'PGfloat8)) where oidOf = LibPQ.Oid 1022
426+instance OidOf ('PGvararray (null 'PGfloat8)) where oidOf = LibPQ.Oid 1022
427+instance OidOf 'PGmoney where oidOf = LibPQ.Oid 790
428+instance OidOf ('PGfixarray ns (null 'PGmoney)) where oidOf = LibPQ.Oid 791
429+instance OidOf ('PGvararray (null 'PGmoney)) where oidOf = LibPQ.Oid 791
430+instance OidOf ('PGchar n) where oidOf = LibPQ.Oid 18
431+instance OidOf ('PGfixarray ns (null ('PGchar n))) where oidOf = LibPQ.Oid 1002
432+instance OidOf ('PGvararray (null ('PGchar n))) where oidOf = LibPQ.Oid 1002
433+instance OidOf ('PGvarchar n) where oidOf = LibPQ.Oid 1043
434+instance OidOf ('PGfixarray ns (null ('PGvarchar n))) where oidOf = LibPQ.Oid 1015
435+instance OidOf ('PGvararray (null ('PGvarchar n))) where oidOf = LibPQ.Oid 1015
436+instance OidOf 'PGtext where oidOf = LibPQ.Oid 25
437+instance OidOf ('PGfixarray ns (null 'PGtext)) where oidOf = LibPQ.Oid 1009
438+instance OidOf ('PGvararray (null 'PGtext)) where oidOf = LibPQ.Oid 1009
439+instance OidOf 'PGbytea where oidOf = LibPQ.Oid 17
440+instance OidOf ('PGfixarray ns (null 'PGbytea)) where oidOf = LibPQ.Oid 1001
441+instance OidOf ('PGvararray (null 'PGbytea)) where oidOf = LibPQ.Oid 1001
442+instance OidOf 'PGtimestamp where oidOf = LibPQ.Oid 1114
443+instance OidOf ('PGfixarray ns (null 'PGtimestamp)) where oidOf = LibPQ.Oid 1115
444+instance OidOf ('PGvararray (null 'PGtimestamp)) where oidOf = LibPQ.Oid 1115
445+instance OidOf 'PGtimestamptz where oidOf = LibPQ.Oid 1184
446+instance OidOf ('PGfixarray ns (null 'PGtimestamptz)) where oidOf = LibPQ.Oid 1185
447+instance OidOf ('PGvararray (null 'PGtimestamptz)) where oidOf = LibPQ.Oid 1185
448+instance OidOf 'PGdate where oidOf = LibPQ.Oid 1082
449+instance OidOf ('PGfixarray ns (null 'PGdate)) where oidOf = LibPQ.Oid 1182
450+instance OidOf ('PGvararray (null 'PGdate)) where oidOf = LibPQ.Oid 1182
451+instance OidOf 'PGtime where oidOf = LibPQ.Oid 1083
452+instance OidOf ('PGfixarray ns (null 'PGtime)) where oidOf = LibPQ.Oid 1183
453+instance OidOf ('PGvararray (null 'PGtime)) where oidOf = LibPQ.Oid 1183
454+instance OidOf 'PGtimetz where oidOf = LibPQ.Oid 1266
455+instance OidOf ('PGfixarray ns (null 'PGtimetz)) where oidOf = LibPQ.Oid 1270
456+instance OidOf ('PGvararray (null 'PGtimetz)) where oidOf = LibPQ.Oid 1270
457+instance OidOf 'PGinterval where oidOf = LibPQ.Oid 1186
458+instance OidOf ('PGfixarray ns (null 'PGinterval)) where oidOf = LibPQ.Oid 1187
459+instance OidOf ('PGvararray (null 'PGinterval)) where oidOf = LibPQ.Oid 1187
460+instance OidOf 'PGuuid where oidOf = LibPQ.Oid 2950
461+instance OidOf ('PGfixarray ns (null 'PGuuid)) where oidOf = LibPQ.Oid 2951
462+instance OidOf ('PGvararray (null 'PGuuid)) where oidOf = LibPQ.Oid 2951
463+instance OidOf 'PGinet where oidOf = LibPQ.Oid 869
464+instance OidOf ('PGfixarray ns (null 'PGinet)) where oidOf = LibPQ.Oid 1041
465+instance OidOf ('PGvararray (null 'PGinet)) where oidOf = LibPQ.Oid 1041
466+instance OidOf 'PGjson where oidOf = LibPQ.Oid 114
467+instance OidOf ('PGfixarray ns (null 'PGjson)) where oidOf = LibPQ.Oid 199
468+instance OidOf ('PGvararray (null 'PGjson)) where oidOf = LibPQ.Oid 199
469+instance OidOf 'PGjsonb where oidOf = LibPQ.Oid 3802
470+instance OidOf ('PGfixarray ns (null 'PGjsonb)) where oidOf = LibPQ.Oid 3807
471+instance OidOf ('PGvararray (null 'PGjsonb)) where oidOf = LibPQ.Oid 3807
472+instance OidOf 'PGtsvector where oidOf = LibPQ.Oid 3614
473+instance OidOf ('PGfixarray ns (null 'PGtsvector)) where oidOf = LibPQ.Oid 3643
474+instance OidOf ('PGvararray (null 'PGtsvector)) where oidOf = LibPQ.Oid 3643
475+instance OidOf 'PGtsquery where oidOf = LibPQ.Oid 3615
476+instance OidOf ('PGfixarray ns (null 'PGtsquery)) where oidOf = LibPQ.Oid 3645
477+instance OidOf ('PGvararray (null 'PGtsquery)) where oidOf = LibPQ.Oid 3645
478+instance OidOf 'PGoid where oidOf = LibPQ.Oid 26
479+instance OidOf ('PGfixarray ns (null 'PGoid)) where oidOf = LibPQ.Oid 1028
480+instance OidOf ('PGvararray (null 'PGoid)) where oidOf = LibPQ.Oid 1028
481+instance OidOf ('PGrange 'PGint4) where oidOf = LibPQ.Oid 3904
482+instance OidOf ('PGfixarray ns (null ('PGrange 'PGint4))) where oidOf = LibPQ.Oid 3905
483+instance OidOf ('PGvararray (null ('PGrange 'PGint4))) where oidOf = LibPQ.Oid 3905
484+instance OidOf ('PGrange 'PGint8) where oidOf = LibPQ.Oid 3926
485+instance OidOf ('PGfixarray ns (null ('PGrange 'PGint8))) where oidOf = LibPQ.Oid 3927
486+instance OidOf ('PGvararray (null ('PGrange 'PGint8))) where oidOf = LibPQ.Oid 3927
487+instance OidOf ('PGrange 'PGnumeric) where oidOf = LibPQ.Oid 3906
488+instance OidOf ('PGfixarray ns (null ('PGrange 'PGnumeric))) where oidOf = LibPQ.Oid 3907
489+instance OidOf ('PGvararray (null ('PGrange 'PGnumeric))) where oidOf = LibPQ.Oid 3907
490+instance OidOf ('PGrange 'PGtimestamp) where oidOf = LibPQ.Oid 3908
491+instance OidOf ('PGfixarray ns (null ('PGrange 'PGtimestamp))) where oidOf = LibPQ.Oid 3909
492+instance OidOf ('PGvararray (null ('PGrange 'PGtimestamp))) where oidOf = LibPQ.Oid 3909
493+instance OidOf ('PGrange 'PGtimestamptz) where oidOf = LibPQ.Oid 3910
494+instance OidOf ('PGfixarray ns (null ('PGrange 'PGtimestamptz))) where oidOf = LibPQ.Oid 3911
495+instance OidOf ('PGvararray (null ('PGrange 'PGtimestamptz))) where oidOf = LibPQ.Oid 3911
496+instance OidOf ('PGrange 'PGdate) where oidOf = LibPQ.Oid 3912
497+instance OidOf ('PGfixarray ns (null ('PGrange 'PGdate))) where oidOf = LibPQ.Oid 3913
498+instance OidOf ('PGvararray (null ('PGrange 'PGdate))) where oidOf = LibPQ.Oid 3913
499+instance {-# OVERLAPPABLE #-} OidOf ('PGrange ty) where oidOf = LibPQ.invalidOid
500+instance {-# OVERLAPPABLE #-} OidOf ('PGfixarray ns (null ('PGrange ty))) where oidOf = LibPQ.invalidOid
501+instance {-# OVERLAPPABLE #-} OidOf ('PGvararray (null ('PGrange ty))) where oidOf = LibPQ.invalidOid
502+instance {-# OVERLAPPABLE #-} OidOf ('PGcomposite row) where oidOf = LibPQ.invalidOid
503+instance {-# OVERLAPPABLE #-} OidOf ('PGfixarray ns (null ('PGcomposite row))) where oidOf = LibPQ.invalidOid
504+instance {-# OVERLAPPABLE #-} OidOf ('PGvararray (null ('PGcomposite row))) where oidOf = LibPQ.invalidOid
505+instance {-# OVERLAPPABLE #-} OidOf ('PGenum labels) where oidOf = LibPQ.invalidOid
506+instance {-# OVERLAPPABLE #-} OidOf ('PGfixarray ns (null ('PGenum labels))) where oidOf = LibPQ.invalidOid
507+instance {-# OVERLAPPABLE #-} OidOf ('PGvararray (null ('PGenum labels))) where oidOf = LibPQ.invalidOid
508+
509+class OidOfParam (ty :: NullityType) where oidOfParam :: Oid
510+instance OidOf ty => OidOfParam (null ty) where oidOfParam = oidOf @ty
511+
512+-- | Lifts a `OidOf` constraint to a field.
513+class OidOfField (field :: (Symbol, NullityType)) where
514+ oidOfField :: Oid
515+instance OidOf ty => OidOfField (alias ::: nullity ty) where
516+ oidOfField = oidOf @ty
517+
518+-- | A `ToNullityParam` constraint gives an encoding of a Haskell `Type` into
519+-- into the binary format of a PostgreSQL `NullityType`.
397520class ToNullityParam (x :: Type) (ty :: NullityType) where
398521 toNullityParam :: x -> K (Maybe Encoding.Encoding) ty
399522instance ToParam x pg => ToNullityParam x ('NotNull pg) where
@@ -401,11 +524,19 @@ instance ToParam x pg => ToNullityParam x ('NotNull pg) where
401524instance ToParam x pg => ToNullityParam (Maybe x) ('Null pg) where
402525 toNullityParam = K . fmap (unK . toParam @x @pg)
403526
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.
404531class ToField (x :: (Symbol, Type)) (field :: (Symbol, NullityType)) where
405532 toField :: P x -> K (Maybe Encoding.Encoding) field
406533instance ToNullityParam x ty => ToField (alias ::: x) (alias ::: ty) where
407534 toField (P x) = K . unK $ toNullityParam @x @ty x
408535
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.
409540class ToFixArray (x :: Type) (dims :: [Nat]) (array :: NullityType) where
410541 toFixArray :: x -> K (K Encoding.Array dims) array
411542instance ToNullityParam x ty => ToFixArray x '[] ty where
@@ -422,7 +553,7 @@ instance
422553
423554-- | A `ToParams` constraint generically sequences the encodings of `Type`s
424555-- of the fields of a tuple or record to a row of `ColumnType`s. You should
425−-- not define instances of `ToParams`. Instead define `Generic` instances
556+-- not define instances of `ToParams`. Instead define `SOP.Generic` instances
426557-- which in turn provide `ToParams` instances.
427558class SListI tys => ToParams (x :: Type) (tys :: [NullityType]) where
428559 -- | >>> type Params = '[ 'NotNull 'PGbool, 'Null 'PGint2]
@@ -451,9 +582,11 @@ instance FromValue 'PGbool Bool where fromValue = Decoding.bool
451582instance FromValue 'PGint2 Int16 where fromValue = Decoding.int
452583instance FromValue 'PGint4 Int32 where fromValue = Decoding.int
453584instance FromValue 'PGint8 Int64 where fromValue = Decoding.int
585+instance FromValue 'PGoid Word32 where fromValue = Decoding.int
454586instance FromValue 'PGfloat4 Float where fromValue = Decoding.float4
455587instance FromValue 'PGfloat8 Double where fromValue = Decoding.float8
456588instance FromValue 'PGnumeric Scientific where fromValue = Decoding.numeric
589+instance FromValue 'PGmoney Money where fromValue = Money <$> Decoding.int
457590instance FromValue 'PGuuid UUID where fromValue = Decoding.uuid
458591instance FromValue 'PGinet (NetAddr IP) where fromValue = Decoding.inet
459592instance FromValue ('PGchar 1) Char where fromValue = Decoding.char
@@ -588,6 +721,10 @@ instance FromValue pg y
588721 K (Just bytestring) -> P . Just <$>
589722 Decoding.valueParser (fromValue @pg) bytestring
590723
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.
591728class FromFixArray (dims :: [Nat]) (ty :: NullityType) (y :: Type) where
592729 fromFixArray :: Decoding.Array y
593730instance FromValue pg y => FromFixArray '[] ('NotNull pg) y where
@@ -609,7 +746,7 @@ instance
609746-- | A `FromRow` constraint generically sequences the parsings of the columns
610747-- of a `RowType` into the fields of a record `Type` provided they have
611748-- the same field names. You should not define instances of `FromRow`.
612−-- Instead define `Generic` and `HasDatatypeInfo` instances which in turn
749+-- Instead define `SOP.Generic` and `SOP.HasDatatypeInfo` instances which in turn
613750-- provide `FromRow` instances.
614751class SListI result => FromRow (result :: RowType) y where
615752 -- | >>> :set -XOverloadedStrings
@@ -632,6 +769,53 @@ instance
632769 = fmap fromRecord
633770 . hsequence'
634771 . 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)
635819
636820-- | `Only` is a 1-tuple type, useful for encoding a single parameter with
637821-- `toParams` or decoding a single value with `fromRow`.
@@ -658,71 +842,7 @@ replicateMN
658842 :: forall x xs m. (All ((~) x) xs, Monad m, SListI xs)
659843 => m x -> m (NP I xs)
660844replicateMN mx = hsequence' $
661− hcpure (Proxy :: Proxy ((~) x)) (Comp (I <$> mx))
662−
663−{- | The `Json` newtype is an indication that the Haskell
664−type it's applied to should be stored as a `PGjson`.
665−-}
666−newtype Json hask = Json {getJson :: hask}
667− deriving (Eq, Ord, Show, Read, GHC.Generic)
668−type instance PG (Json hask) = 'PGjson
845+ hcpure (Proxy :: Proxy ((~) x)) (Comp (I <$> mx))
669846
670−{- | The `Jsonb` newtype is an indication that the Haskell
671−type it's applied to should be stored as a `PGjsonb`.
672−-}
673−newtype Jsonb hask = Jsonb {getJsonb :: hask}
674− deriving (Eq, Ord, Show, Read, GHC.Generic)
675−type instance PG (Jsonb hask) = 'PGjsonb
676−
677−{- | The `Composite` newtype is an indication that the Haskell
678−type it's applied to should be stored as a `PGcomposite`.
679−-}
680−newtype Composite record = Composite {getComposite :: record}
681− deriving (Eq, Ord, Show, Read, GHC.Generic)
682−type instance PG (Composite hask) = 'PGcomposite (RowPG hask)
683−
684−{- | The `Enumerated` newtype is an indication that the Haskell
685−type it's applied to should be stored as a `PGenum`.
686−-}
687−newtype Enumerated enum = Enumerated {getEnumerated :: enum}
688− deriving (Eq, Ord, Show, Read, GHC.Generic)
689−type instance PG (Enumerated hask) = 'PGenum (LabelsPG hask)
690−
691−{- | The `VarArray` newtype is an indication that the Haskell
692−type it's applied to should be stored as a `PGvararray`.
693−-}
694−newtype VarArray arr = VarArray {getVarArray :: arr}
695− deriving (Eq, Ord, Show, Read, GHC.Generic)
696−type instance PG (VarArray (Vector hask)) = 'PGvararray (NullPG hask)
697−
698−{- | The `FixArray` newtype is an indication that the Haskell
699−type it's applied to should be stored as a `PGfixarray`.
700−-}
701−newtype FixArray arr = FixArray {getFixArray :: arr}
702− deriving (Eq, Ord, Show, Read, GHC.Generic)
703−type instance PG (FixArray x) = 'PGfixarray (DimPG x) (FixPG x)
704−
705−type family DimPG (hask :: Type) :: [Nat] where
706− DimPG (x,x) = 2 ': DimPG x
707− DimPG (x,x,x) = 3 ': DimPG x
708− DimPG (x,x,x,x) = 4 ': DimPG x
709− DimPG (x,x,x,x,x) = 5 ': DimPG x
710− DimPG (x,x,x,x,x,x) = 6 ': DimPG x
711− DimPG (x,x,x,x,x,x,x) = 7 ': DimPG x
712− DimPG (x,x,x,x,x,x,x,x) = 8 ': DimPG x
713− DimPG (x,x,x,x,x,x,x,x,x) = 9 ': DimPG x
714− DimPG (x,x,x,x,x,x,x,x,x,x) = 10 ': DimPG x
715− DimPG x = '[]
716−
717−type family FixPG (hask :: Type) :: NullityType where
718− FixPG (x,x) = FixPG x
719− FixPG (x,x,x) = FixPG x
720− FixPG (x,x,x,x) = FixPG x
721− FixPG (x,x,x,x,x) = FixPG x
722− FixPG (x,x,x,x,x,x) = FixPG x
723− FixPG (x,x,x,x,x,x,x) = FixPG x
724− FixPG (x,x,x,x,x,x,x,x) = FixPG x
725− FixPG (x,x,x,x,x,x,x,x,x) = FixPG x
726− FixPG (x,x,x,x,x,x,x,x,x,x) = FixPG x
727− FixPG (x,x,x,x,x,x,x,x,x,x,x) = FixPG x
728− FixPG x = NullPG x
847+getOid :: LibPQ.Oid -> Word32
848+getOid (LibPQ.Oid (CUInt oid)) = oid
squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs+15−982
@@ -11,13 +11,15 @@ Squeal data definition language.
1111{-# LANGUAGE
1212 AllowAmbiguousTypes
1313 , ConstraintKinds
14+ , DeriveAnyClass
1415 , DeriveGeneric
16+ , DerivingStrategies
1517 , FlexibleContexts
1618 , FlexibleInstances
1719 , GADTs
18− , GeneralizedNewtypeDeriving
1920 , LambdaCase
2021 , MultiParamTypeClasses
22+ , OverloadedLabels
2123 , OverloadedStrings
2224 , RankNTypes
2325 , ScopedTypeVariables
@@ -25,81 +27,31 @@ Squeal data definition language.
2527 , TypeInType
2628 , TypeOperators
2729 , UndecidableSuperClasses
30+ , UndecidableInstances
2831#-}
2932
3033module Squeal.PostgreSQL.Definition
3134 ( -- * Definition
3235 Definition (..)
3336 , (>>>)
34− -- * Tables
35− -- ** Create
36− , createSchema
37− , createSchemaIfNotExists
38− , createTable
39− , createTableIfNotExists
40− , createView
41− , createTypeEnum
42− , createTypeEnumFrom
43− , createTypeComposite
44− , createTypeCompositeFrom
45− , TableConstraintExpression (..)
46− , check
47− , unique
48− , primaryKey
49− , foreignKey
50− , ForeignKeyed
51− , OnDeleteClause (..)
52− , OnUpdateClause (..)
53− -- ** Drop
54− , dropSchema
55− , dropTable
56− , dropView
57− , dropType
58− -- ** Alter
59− , alterTable
60− , alterTableRename
61− , AlterTable (..)
62− , addConstraint
63− , dropConstraint
64− , AddColumn (..)
65− , dropColumn
66− , renameColumn
67− , alterColumn
68− , AlterColumn (..)
69− , setDefault
70− , dropDefault
71− , setNotNull
72− , dropNotNull
73− , alterType
74− -- * Columns
75− , ColumnTypeExpression (..)
76− , nullable
77− , notNullable
78− , default_
79− , serial2
80− , smallserial
81− , serial4
82− , serial
83− , serial8
84− , bigserial
37+ , manipDefinition
8538 ) where
8639
8740import Control.Category
8841import Control.DeepSeq
8942import Data.ByteString
9043import Data.Monoid
91−import GHC.TypeLits
9244import Prelude hiding ((.), id)
9345
94−import qualified Generics.SOP as SOP
9546import qualified GHC.Generics as GHC
9647
97−import Squeal.PostgreSQL.Binary
98−import Squeal.PostgreSQL.Expression
99−import Squeal.PostgreSQL.Query
48+import Squeal.PostgreSQL.Manipulation
10049import Squeal.PostgreSQL.Render
10150import Squeal.PostgreSQL.Schema
10251
52+-- $setup
53+-- >>> import Squeal.PostgreSQL
54+
10355{-----------------------------------------
10456statements
10557-----------------------------------------}
@@ -121,929 +73,10 @@ instance Category Definition where
12173 ddl1 . ddl0 = UnsafeDefinition $
12274 renderSQL ddl0 <> "\n" <> renderSQL ddl1
12375
124−{-----------------------------------------
125−CREATE statements
126−-----------------------------------------}
127−
128−createSchema
129− :: KnownSymbol sch
130− => Alias sch
131− -> Definition schemas (Create sch '[] schemas)
132−createSchema sch = UnsafeDefinition $
133− "CREATE" <+> "SCHEMA" <+> renderSQL sch <> ";"
134−
135−createSchemaIfNotExists
136− :: (KnownSymbol sch, Has sch schemas schema)
137− => Alias sch
138− -> Definition schemas schemas
139−createSchemaIfNotExists sch = UnsafeDefinition $
140− "CREATE" <+> "SCHEMA" <+> "IF" <+> "NOT" <+> "EXISTS"
141− <+> renderSQL sch <> ";"
142−
143−{- | `createTable` adds a table to the schema.
144−
145−>>> :set -XOverloadedLabels
146−>>> :{
147−type Table = '[] :=>
148− '[ "a" ::: 'NoDef :=> 'Null 'PGint4
149− , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]
150−:}
151−
152−>>> :{
153−let
154− setup :: Definition (Public '[]) (Public '["tab" ::: 'Table Table])
155− setup = createTable #tab
156− (nullable int `as` #a :* nullable real `as` #b) Nil
157−in printSQL setup
158−:}
159−CREATE TABLE "tab" ("a" int NULL, "b" real NULL);
160−-}
161−createTable
162− :: ( KnownSymbol sch
163− , KnownSymbol tab
164− , columns ~ (col ': cols)
165− , SOP.SListI columns
166− , SOP.SListI constraints
167− , Has sch schemas0 schema0
168− , schemas1 ~ Alter sch (Create tab ('Table (constraints :=> columns)) schema0) schemas0 )
169− => QualifiedAlias sch tab -- ^ the name of the table to add
170− -> NP (Aliased (ColumnTypeExpression schemas0)) columns
171− -- ^ the names and datatype of each column
172− -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints
173− -- ^ constraints that must hold for the table
174− -> Definition schemas0 schemas1
175−createTable tab columns constraints = UnsafeDefinition $
176− "CREATE TABLE" <+> renderCreation tab columns constraints
177−
178−{-| `createTableIfNotExists` creates a table if it doesn't exist, but does not add it to the schema.
179−Instead, the schema already has the table so if the table did not yet exist, the schema was wrong.
180−`createTableIfNotExists` fixes this. Interestingly, this property makes it an idempotent in
181−the `Category` of `Definition`s.
182−
183−>>> :set -XOverloadedLabels -XTypeApplications
184−>>> :{
185−type Table = '[] :=>
186− '[ "a" ::: 'NoDef :=> 'Null 'PGint4
187− , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]
188−:}
189−
190−>>> type Schemas = Public '["tab" ::: 'Table Table]
191−
192−>>> :{
193−let
194− setup :: Definition Schemas Schemas
195− setup = createTableIfNotExists #tab
196− (nullable int `as` #a :* nullable real `as` #b) Nil
197−in printSQL setup
198−:}
199−CREATE TABLE IF NOT EXISTS "tab" ("a" int NULL, "b" real NULL);
200−-}
201−createTableIfNotExists
202− :: ( Has sch schemas schema
203− , Has tab schema ('Table (constraints :=> columns))
204− , SOP.SListI columns
205− , SOP.SListI constraints )
206− => QualifiedAlias sch tab -- ^ the name of the table to add
207− -> NP (Aliased (ColumnTypeExpression schemas)) columns
208− -- ^ the names and datatype of each column
209− -> NP (Aliased (TableConstraintExpression sch tab schemas)) constraints
210− -- ^ constraints that must hold for the table
76+-- | A `Manipulation` without input or output can be run as a statement
77+-- along with other `Definition`s, by embedding it using `manipDefinition`.
78+manipDefinition
79+ :: Manipulation '[] schemas '[] '[]
80+ -- ^ no input or output
21181 -> Definition schemas schemas
212−createTableIfNotExists tab columns constraints = UnsafeDefinition $
213− "CREATE TABLE IF NOT EXISTS"
214− <+> renderCreation tab columns constraints
215−
216−-- helper function for `createTable` and `createTableIfNotExists`
217−renderCreation
218− :: ( KnownSymbol sch
219− , KnownSymbol tab
220− , SOP.SListI columns
221− , SOP.SListI constraints )
222− => QualifiedAlias sch tab -- ^ the name of the table to add
223− -> NP (Aliased (ColumnTypeExpression schemas0)) columns
224− -- ^ the names and datatype of each column
225− -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints
226− -- ^ constraints that must hold for the table
227− -> ByteString
228−renderCreation tab columns constraints = renderSQL tab
229− <+> parenthesized
230− ( renderCommaSeparated renderColumnDef columns
231− <> ( case constraints of
232− Nil -> ""
233− _ -> ", " <>
234− renderCommaSeparated renderConstraint constraints ) )
235− <> ";"
236− where
237− renderColumnDef :: Aliased (ColumnTypeExpression schemas) x -> ByteString
238− renderColumnDef (ty `As` column) =
239− renderSQL column <+> renderColumnTypeExpression ty
240− renderConstraint
241− :: Aliased (TableConstraintExpression sch tab schemas) constraint
242− -> ByteString
243− renderConstraint (constraint `As` alias) =
244− "CONSTRAINT" <+> renderSQL alias <+> renderSQL constraint
245−
246−-- | Data types are a way to limit the kind of data that can be stored in a
247−-- table. For many applications, however, the constraint they provide is
248−-- too coarse. For example, a column containing a product price should
249−-- probably only accept positive values. But there is no standard data type
250−-- that accepts only positive numbers. Another issue is that you might want
251−-- to constrain column data with respect to other columns or rows.
252−-- For example, in a table containing product information,
253−-- there should be only one row for each product number.
254−-- `TableConstraint`s give you as much control over the data in your tables
255−-- as you wish. If a user attempts to store data in a column that would
256−-- violate a constraint, an error is raised. This applies
257−-- even if the value came from the default value definition.
258−newtype TableConstraintExpression
259− (sch :: Symbol)
260− (tab :: Symbol)
261− (schemas :: SchemasType)
262− (constraint :: TableConstraint)
263− = UnsafeTableConstraintExpression
264− { renderTableConstraintExpression :: ByteString }
265− deriving (GHC.Generic,Show,Eq,Ord,NFData)
266−instance RenderSQL
267− (TableConstraintExpression sch tab schemas constraint) where
268− renderSQL = renderTableConstraintExpression
269−
270−{-| A `check` constraint is the most generic `TableConstraint` type.
271−It allows you to specify that the value in a certain column must satisfy
272−a Boolean (truth-value) expression.
273−
274−>>> :{
275−type Schema = '[
276− "tab" ::: 'Table ('[ "inequality" ::: 'Check '["a","b"]] :=> '[
277− "a" ::: 'NoDef :=> 'NotNull 'PGint4,
278− "b" ::: 'NoDef :=> 'NotNull 'PGint4
279− ])]
280−:}
281−
282−>>> :{
283−let
284− definition :: Definition (Public '[]) (Public Schema)
285− definition = createTable #tab
286− ( (int & notNullable) `as` #a :*
287− (int & notNullable) `as` #b )
288− ( check (#a :* #b) (#a .> #b) `as` #inequality )
289−:}
290−
291−>>> printSQL definition
292−CREATE TABLE "tab" ("a" int NOT NULL, "b" int NOT NULL, CONSTRAINT "inequality" CHECK (("a" > "b")));
293−-}
294−check
295− :: ( Has sch schemas schema
296− , Has tab schema ('Table table)
297− , HasAll aliases (TableToRow table) subcolumns )
298− => NP Alias aliases
299− -- ^ specify the subcolumns which are getting checked
300− -> (forall t. Condition 'Ungrouped '[] schemas '[] '[t ::: subcolumns])
301− -- ^ a closed `Condition` on those subcolumns
302− -> TableConstraintExpression sch tab schemas ('Check aliases)
303−check _cols condition = UnsafeTableConstraintExpression $
304− "CHECK" <+> parenthesized (renderSQL condition)
305−
306−{-| A `unique` constraint ensure that the data contained in a column,
307−or a group of columns, is unique among all the rows in the table.
308−
309−>>> :{
310−type Schema = '[
311− "tab" ::: 'Table( '[ "uq_a_b" ::: 'Unique '["a","b"]] :=> '[
312− "a" ::: 'NoDef :=> 'Null 'PGint4,
313− "b" ::: 'NoDef :=> 'Null 'PGint4
314− ])]
315−:}
316−
317−>>> :{
318−let
319− definition :: Definition (Public '[]) (Public Schema)
320− definition = createTable #tab
321− ( (int & nullable) `as` #a :*
322− (int & nullable) `as` #b )
323− ( unique (#a :* #b) `as` #uq_a_b )
324−:}
325−
326−>>> printSQL definition
327−CREATE TABLE "tab" ("a" int NULL, "b" int NULL, CONSTRAINT "uq_a_b" UNIQUE ("a", "b"));
328−-}
329−unique
330− :: ( Has sch schemas schema
331− , Has tab schema('Table table)
332− , HasAll aliases (TableToRow table) subcolumns )
333− => NP Alias aliases
334− -- ^ specify subcolumns which together are unique for each row
335− -> TableConstraintExpression sch tab schemas ('Unique aliases)
336−unique columns = UnsafeTableConstraintExpression $
337− "UNIQUE" <+> parenthesized (renderSQL columns)
338−
339−{-| A `primaryKey` constraint indicates that a column, or group of columns,
340−can be used as a unique identifier for rows in the table.
341−This requires that the values be both unique and not null.
342−
343−>>> :{
344−type Schema = '[
345− "tab" ::: 'Table ('[ "pk_id" ::: 'PrimaryKey '["id"]] :=> '[
346− "id" ::: 'Def :=> 'NotNull 'PGint4,
347− "name" ::: 'NoDef :=> 'NotNull 'PGtext
348− ])]
349−:}
350−
351−>>> :{
352−let
353− definition :: Definition (Public '[]) (Public Schema)
354− definition = createTable #tab
355− ( serial `as` #id :*
356− (text & notNullable) `as` #name )
357− ( primaryKey #id `as` #pk_id )
358−:}
359−
360−>>> printSQL definition
361−CREATE TABLE "tab" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_id" PRIMARY KEY ("id"));
362−-}
363−primaryKey
364− :: ( Has sch schemas schema
365− , Has tab schema ('Table table)
366− , HasAll aliases (TableToColumns table) subcolumns
367− , AllNotNull subcolumns )
368− => NP Alias aliases
369− -- ^ specify the subcolumns which together form a primary key.
370− -> TableConstraintExpression sch tab schemas ('PrimaryKey aliases)
371−primaryKey columns = UnsafeTableConstraintExpression $
372− "PRIMARY KEY" <+> parenthesized (renderSQL columns)
373−
374−{-| A `foreignKey` specifies that the values in a column
375−(or a group of columns) must match the values appearing in some row of
376−another table. We say this maintains the referential integrity
377−between two related tables.
378−
379−>>> :{
380−type Schema =
381− '[ "users" ::: 'Table (
382− '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
383− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
384− , "name" ::: 'NoDef :=> 'NotNull 'PGtext
385− ])
386− , "emails" ::: 'Table (
387− '[ "pk_emails" ::: 'PrimaryKey '["id"]
388− , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
389− ] :=>
390− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
391− , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
392− , "email" ::: 'NoDef :=> 'Null 'PGtext
393− ])
394− ]
395−:}
396−
397−>>> :{
398−let
399− setup :: Definition (Public '[]) (Public Schema)
400− setup =
401− createTable #users
402− ( serial `as` #id :*
403− (text & notNullable) `as` #name )
404− ( primaryKey #id `as` #pk_users ) >>>
405− createTable #emails
406− ( serial `as` #id :*
407− (int & notNullable) `as` #user_id :*
408− (text & nullable) `as` #email )
409− ( primaryKey #id `as` #pk_emails :*
410− foreignKey #user_id #users #id
411− OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
412−in printSQL setup
413−:}
414−CREATE TABLE "users" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_users" PRIMARY KEY ("id"));
415−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);
416−
417−A `foreignKey` can even be a table self-reference.
418−
419−>>> :{
420−type Schema =
421− '[ "employees" ::: 'Table (
422− '[ "employees_pk" ::: 'PrimaryKey '["id"]
423− , "employees_employer_fk" ::: 'ForeignKey '["employer_id"] "employees" '["id"]
424− ] :=>
425− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
426− , "name" ::: 'NoDef :=> 'NotNull 'PGtext
427− , "employer_id" ::: 'NoDef :=> 'Null 'PGint4
428− ])
429− ]
430−:}
431−
432−>>> :{
433−let
434− setup :: Definition (Public '[]) (Public Schema)
435− setup =
436− createTable #employees
437− ( serial `as` #id :*
438− (text & notNullable) `as` #name :*
439− (integer & nullable) `as` #employer_id )
440− ( primaryKey #id `as` #employees_pk :*
441− foreignKey #employer_id #employees #id
442− OnDeleteCascade OnUpdateCascade `as` #employees_employer_fk )
443−in printSQL setup
444−:}
445−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);
446−-}
447−foreignKey
448− :: (ForeignKeyed schemas sch schema child parent
449− table reftable
450− columns refcolumns
451− constraints cols
452− reftys tys )
453− => NP Alias columns
454− -- ^ column or columns in the table
455− -> Alias parent
456− -- ^ reference table
457− -> NP Alias refcolumns
458− -- ^ reference column or columns in the reference table
459− -> OnDeleteClause
460− -- ^ what to do when reference is deleted
461− -> OnUpdateClause
462− -- ^ what to do when reference is updated
463− -> TableConstraintExpression sch child schemas
464− ('ForeignKey columns parent refcolumns)
465−foreignKey keys parent refs ondel onupd = UnsafeTableConstraintExpression $
466− "FOREIGN KEY" <+> parenthesized (renderSQL keys)
467− <+> "REFERENCES" <+> renderSQL parent
468− <+> parenthesized (renderSQL refs)
469− <+> renderSQL ondel
470− <+> renderSQL onupd
471−
472−-- | A constraint synonym between types involved in a foreign key constraint.
473−type ForeignKeyed schemas
474− sch
475− schema
476− child parent
477− table reftable
478− columns refcolumns
479− constraints cols
480− reftys tys =
481− ( Has sch schemas schema
482− , Has child schema ('Table table)
483− , Has parent schema ('Table reftable)
484− , HasAll columns (TableToColumns table) tys
485− , reftable ~ (constraints :=> cols)
486− , HasAll refcolumns cols reftys
487− , SOP.AllZip SamePGType tys reftys
488− , Uniquely refcolumns constraints )
489−
490−-- | `OnDeleteClause` indicates what to do with rows that reference a deleted row.
491−data OnDeleteClause
492− = OnDeleteNoAction
493− -- ^ if any referencing rows still exist when the constraint is checked,
494− -- an error is raised
495− | OnDeleteRestrict -- ^ prevents deletion of a referenced row
496− | OnDeleteCascade
497− -- ^ specifies that when a referenced row is deleted,
498− -- row(s) referencing it should be automatically deleted as well
499− deriving (GHC.Generic,Show,Eq,Ord)
500−instance NFData OnDeleteClause
501−-- | Render `OnDeleteClause`.
502−instance RenderSQL OnDeleteClause where
503− renderSQL = \case
504− OnDeleteNoAction -> "ON DELETE NO ACTION"
505− OnDeleteRestrict -> "ON DELETE RESTRICT"
506− OnDeleteCascade -> "ON DELETE CASCADE"
507−
508−-- | Analagous to `OnDeleteClause` there is also `OnUpdateClause` which is invoked
509−-- when a referenced column is changed (updated).
510−data OnUpdateClause
511− = OnUpdateNoAction
512− -- ^ if any referencing rows has not changed when the constraint is checked,
513− -- an error is raised
514− | OnUpdateRestrict -- ^ prevents update of a referenced row
515− | OnUpdateCascade
516− -- ^ the updated values of the referenced column(s) should be copied
517− -- into the referencing row(s)
518− deriving (GHC.Generic,Show,Eq,Ord)
519−instance NFData OnUpdateClause
520−
521−-- | Render `OnUpdateClause`.
522−instance RenderSQL OnUpdateClause where
523− renderSQL = \case
524− OnUpdateNoAction -> "ON UPDATE NO ACTION"
525− OnUpdateRestrict -> "ON UPDATE RESTRICT"
526− OnUpdateCascade -> "ON UPDATE CASCADE"
527−
528−{-----------------------------------------
529−DROP statements
530−-----------------------------------------}
531−
532−-- >>> :{
533−-- let
534−-- definition :: Definition '["muh_schema" ::: schema, "public" ::: public] '["public" ::: public]
535−-- definition = dropSchema #muh_schema
536−-- :}
537−--
538−-- >>> printSQL definition
539−-- DROP SCHEMA "muh_schema";
540−dropSchema
541− :: Has sch schemas schema
542− => Alias sch
543− -> Definition schemas (Drop sch schemas)
544−dropSchema sch = UnsafeDefinition $ "DROP SCHEMA" <+> renderSQL sch <> ";"
545−
546−-- | `dropTable` removes a table from the schema.
547−--
548−-- >>> :{
549−-- let
550−-- definition :: Definition '["public" ::: '["muh_table" ::: 'Table t]] (Public '[])
551−-- definition = dropTable #muh_table
552−-- :}
553−--
554−-- >>> printSQL definition
555−-- DROP TABLE "muh_table";
556−dropTable
557− :: ( Has sch schemas schema
558− , Has tab schema ('Table table))
559− => QualifiedAlias sch tab -- ^ table to remove
560− -> Definition schemas (Alter sch (Drop tab schema) schemas)
561−dropTable tab = UnsafeDefinition $ "DROP TABLE" <+> renderSQL tab <> ";"
562−
563−{-----------------------------------------
564−ALTER statements
565−-----------------------------------------}
566−
567−-- | `alterTable` changes the definition of a table from the schema.
568−alterTable
569− :: (Has sch schemas schema, Has tab schema ('Table table0))
570− => QualifiedAlias sch tab -- ^ table to alter
571− -> AlterTable sch tab schemas table1 -- ^ alteration to perform
572− -> Definition schemas (Alter sch (Alter tab ('Table table1) schema) schemas)
573−alterTable tab alteration = UnsafeDefinition $
574− "ALTER TABLE"
575− <+> renderSQL tab
576− <+> renderAlterTable alteration
577− <> ";"
578−
579−-- | `alterTableRename` changes the name of a table from the schema.
580−--
581−-- >>> printSQL $ alterTableRename #foo #bar
582−-- ALTER TABLE "foo" RENAME TO "bar";
583−alterTableRename
584− :: (KnownSymbol table0, KnownSymbol table1)
585− => Alias table0 -- ^ table to rename
586− -> Alias table1 -- ^ what to rename it
587− -> Definition schema (Rename table0 table1 schema)
588−alterTableRename table0 table1 = UnsafeDefinition $
589− "ALTER TABLE" <+> renderSQL table0
590− <+> "RENAME TO" <+> renderSQL table1 <> ";"
591−
592−-- | An `AlterTable` describes the alteration to perform on the columns
593−-- of a table.
594−newtype AlterTable
595− (sch :: Symbol)
596− (tab :: Symbol)
597− (schemas :: SchemasType)
598− (table :: TableType) =
599− UnsafeAlterTable {renderAlterTable :: ByteString}
600− deriving (GHC.Generic,Show,Eq,Ord,NFData)
601−
602−-- | An `addConstraint` adds a table constraint.
603−--
604−-- >>> :{
605−-- let
606−-- definition :: Definition
607−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
608−-- '["public" ::: '["tab" ::: 'Table ('["positive" ::: 'Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
609−-- definition = alterTable #tab (addConstraint #positive (check #col (#col .> 0)))
610−-- in printSQL definition
611−-- :}
612−-- ALTER TABLE "tab" ADD CONSTRAINT "positive" CHECK (("col" > 0));
613−addConstraint
614− :: ( KnownSymbol alias
615− , Has sch schemas schema
616− , Has tab schema ('Table table0)
617− , table0 ~ (constraints :=> columns)
618− , table1 ~ (Create alias constraint constraints :=> columns) )
619− => Alias alias
620− -> TableConstraintExpression sch tab schemas constraint
621− -- ^ constraint to add
622− -> AlterTable sch tab schemas table1
623−addConstraint alias constraint = UnsafeAlterTable $
624− "ADD" <+> "CONSTRAINT" <+> renderSQL alias
625− <+> renderSQL constraint
626−
627−-- | A `dropConstraint` drops a table constraint.
628−--
629−-- >>> :{
630−-- let
631−-- definition :: Definition
632−-- '["public" ::: '["tab" ::: 'Table ('["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
633−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
634−-- definition = alterTable #tab (dropConstraint #positive)
635−-- in printSQL definition
636−-- :}
637−-- ALTER TABLE "tab" DROP CONSTRAINT "positive";
638−dropConstraint
639− :: ( KnownSymbol constraint
640− , Has sch schemas schema
641− , Has tab schema ('Table table0)
642− , table0 ~ (constraints :=> columns)
643− , table1 ~ (Drop constraint constraints :=> columns) )
644− => Alias constraint
645− -- ^ constraint to drop
646− -> AlterTable sch tab schemas table1
647−dropConstraint constraint = UnsafeAlterTable $
648− "DROP" <+> "CONSTRAINT" <+> renderSQL constraint
649−
650−-- | An `AddColumn` is either @NULL@ or has @DEFAULT@.
651−class AddColumn ty where
652− -- | `addColumn` adds a new column, initially filled with whatever
653− -- default value is given or with @NULL@.
654− --
655− -- >>> :{
656− -- let
657− -- definition :: Definition
658− -- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]
659− -- '["public" ::: '["tab" ::: 'Table ('[] :=>
660− -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
661− -- , "col2" ::: 'Def :=> 'Null 'PGtext ])]]
662− -- definition = alterTable #tab (addColumn #col2 (text & nullable & default_ "foo"))
663− -- in printSQL definition
664− -- :}
665− -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL DEFAULT E'foo';
666− --
667− -- >>> :{
668− -- let
669− -- definition :: Definition
670− -- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]
671− -- '["public" ::: '["tab" ::: 'Table ('[] :=>
672− -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
673− -- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]]
674− -- definition = alterTable #tab (addColumn #col2 (text & nullable))
675− -- in printSQL definition
676− -- :}
677− -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL;
678− addColumn
679− :: ( KnownSymbol column
680− , Has sch schemas schema
681− , Has tab schema ('Table table0)
682− , table0 ~ (constraints :=> columns) )
683− => Alias column -- ^ column to add
684− -> ColumnTypeExpression schemas ty -- ^ type of the new column
685− -> AlterTable sch tab schemas (constraints :=> Create column ty columns)
686− addColumn column ty = UnsafeAlterTable $
687− "ADD COLUMN" <+> renderSQL column <+> renderColumnTypeExpression ty
688−instance {-# OVERLAPPING #-} AddColumn ('Def :=> ty)
689−instance {-# OVERLAPPABLE #-} AddColumn ('NoDef :=> 'Null ty)
690−
691−-- | A `dropColumn` removes a column. Whatever data was in the column
692−-- disappears. Table constraints involving the column are dropped, too.
693−-- However, if the column is referenced by a foreign key constraint of
694−-- another table, PostgreSQL will not silently drop that constraint.
695−--
696−-- >>> :{
697−-- let
698−-- definition :: Definition
699−-- '["public" ::: '["tab" ::: 'Table ('[] :=>
700−-- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
701−-- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]]
702−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]
703−-- definition = alterTable #tab (dropColumn #col2)
704−-- in printSQL definition
705−-- :}
706−-- ALTER TABLE "tab" DROP COLUMN "col2";
707−dropColumn
708− :: ( KnownSymbol column
709− , Has sch schemas schema
710− , Has tab schema ('Table table0)
711− , table0 ~ (constraints :=> columns)
712− , table1 ~ (constraints :=> Drop column columns) )
713− => Alias column -- ^ column to remove
714− -> AlterTable sch tab schemas table1
715−dropColumn column = UnsafeAlterTable $
716− "DROP COLUMN" <+> renderSQL column
717−
718−-- | A `renameColumn` renames a column.
719−--
720−-- >>> :{
721−-- let
722−-- definition :: Definition
723−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["foo" ::: 'NoDef :=> 'Null 'PGint4])]]
724−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["bar" ::: 'NoDef :=> 'Null 'PGint4])]]
725−-- definition = alterTable #tab (renameColumn #foo #bar)
726−-- in printSQL definition
727−-- :}
728−-- ALTER TABLE "tab" RENAME COLUMN "foo" TO "bar";
729−renameColumn
730− :: ( KnownSymbol column0
731− , KnownSymbol column1
732− , Has sch schemas schema
733− , Has tab schema ('Table table0)
734− , table0 ~ (constraints :=> columns)
735− , table1 ~ (constraints :=> Rename column0 column1 columns) )
736− => Alias column0 -- ^ column to rename
737− -> Alias column1 -- ^ what to rename the column
738− -> AlterTable sch tab schemas table1
739−renameColumn column0 column1 = UnsafeAlterTable $
740− "RENAME COLUMN" <+> renderSQL column0 <+> "TO" <+> renderSQL column1
741−
742−-- | An `alterColumn` alters a single column.
743−alterColumn
744− :: ( KnownSymbol column
745− , Has sch schemas schema
746− , Has tab schema ('Table table0)
747− , table0 ~ (constraints :=> columns)
748− , Has column columns ty0
749− , table1 ~ (constraints :=> Alter column ty1 columns))
750− => Alias column -- ^ column to alter
751− -> AlterColumn schemas ty0 ty1 -- ^ alteration to perform
752− -> AlterTable sch tab schemas table1
753−alterColumn column alteration = UnsafeAlterTable $
754− "ALTER COLUMN" <+> renderSQL column <+> renderAlterColumn alteration
755−
756−-- | An `AlterColumn` describes the alteration to perform on a single column.
757−newtype AlterColumn (schemas :: SchemasType) (ty0 :: ColumnType) (ty1 :: ColumnType) =
758− UnsafeAlterColumn {renderAlterColumn :: ByteString}
759− deriving (GHC.Generic,Show,Eq,Ord,NFData)
760−
761−-- | A `setDefault` sets a new default for a column. Note that this doesn't
762−-- affect any existing rows in the table, it just changes the default for
763−-- future insert and update commands.
764−--
765−-- >>> :{
766−-- let
767−-- definition :: Definition
768−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
769−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]]
770−-- definition = alterTable #tab (alterColumn #col (setDefault 5))
771−-- in printSQL definition
772−-- :}
773−-- ALTER TABLE "tab" ALTER COLUMN "col" SET DEFAULT 5;
774−setDefault
775− :: Expression 'Ungrouped '[] schemas '[] '[] ty -- ^ default value to set
776− -> AlterColumn schemas (constraint :=> ty) ('Def :=> ty)
777−setDefault expression = UnsafeAlterColumn $
778− "SET DEFAULT" <+> renderExpression expression
779−
780−-- | A `dropDefault` removes any default value for a column.
781−--
782−-- >>> :{
783−-- let
784−-- definition :: Definition
785−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]]
786−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
787−-- definition = alterTable #tab (alterColumn #col dropDefault)
788−-- in printSQL definition
789−-- :}
790−-- ALTER TABLE "tab" ALTER COLUMN "col" DROP DEFAULT;
791−dropDefault :: AlterColumn schemas ('Def :=> ty) ('NoDef :=> ty)
792−dropDefault = UnsafeAlterColumn $ "DROP DEFAULT"
793−
794−-- | A `setNotNull` adds a @NOT NULL@ constraint to a column.
795−-- The constraint will be checked immediately, so the table data must satisfy
796−-- the constraint before it can be added.
797−--
798−-- >>> :{
799−-- let
800−-- definition :: Definition
801−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
802−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
803−-- definition = alterTable #tab (alterColumn #col setNotNull)
804−-- in printSQL definition
805−-- :}
806−-- ALTER TABLE "tab" ALTER COLUMN "col" SET NOT NULL;
807−setNotNull
808− :: AlterColumn schemas (constraint :=> 'Null ty) (constraint :=> 'NotNull ty)
809−setNotNull = UnsafeAlterColumn $ "SET NOT NULL"
810−
811−-- | A `dropNotNull` drops a @NOT NULL@ constraint from a column.
812−--
813−-- >>> :{
814−-- let
815−-- definition :: Definition
816−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
817−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
818−-- definition = alterTable #tab (alterColumn #col dropNotNull)
819−-- in printSQL definition
820−-- :}
821−-- ALTER TABLE "tab" ALTER COLUMN "col" DROP NOT NULL;
822−dropNotNull
823− :: AlterColumn schemas (constraint :=> 'NotNull ty) (constraint :=> 'Null ty)
824−dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL"
825−
826−-- | An `alterType` converts a column to a different data type.
827−-- This will succeed only if each existing entry in the column can be
828−-- converted to the new type by an implicit cast.
829−--
830−-- >>> :{
831−-- let
832−-- definition :: Definition
833−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
834−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGnumeric])]]
835−-- definition =
836−-- alterTable #tab (alterColumn #col (alterType (numeric & notNullable)))
837−-- in printSQL definition
838−-- :}
839−-- ALTER TABLE "tab" ALTER COLUMN "col" TYPE numeric NOT NULL;
840−alterType :: ColumnTypeExpression schemas ty -> AlterColumn schemas ty0 ty
841−alterType ty = UnsafeAlterColumn $ "TYPE" <+> renderColumnTypeExpression ty
842−
843−{- | Create a view.
844−>>> type ABC = '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4]
845−>>> type BC = '["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4]
846−>>> :{
847−let
848− definition :: Definition
849− '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC)]]
850− '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC), "bc" ::: 'View BC]]
851− definition =
852− createView #bc (select_ (#b :* #c) (from (table #abc)))
853−in printSQL definition
854−:}
855−CREATE VIEW "bc" AS SELECT "b" AS "b", "c" AS "c" FROM "abc" AS "abc";
856−-}
857−createView
858− :: (KnownSymbol sch, KnownSymbol vw, Has sch schemas schema)
859− => QualifiedAlias sch vw -- ^ the name of the view to add
860− -> Query '[] schemas '[] view -- ^ query
861− -> Definition schemas (Alter sch (Create vw ('View view) schema) schemas)
862−createView alias query = UnsafeDefinition $
863− "CREATE" <+> "VIEW" <+> renderSQL alias <+> "AS"
864− <+> renderQuery query <> ";"
865−
866−-- | Drop a view.
867−--
868−-- >>> :{
869−-- let
870−-- definition :: Definition
871−-- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])
872−-- , "bc" ::: 'View ('["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4])]]
873−-- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])]]
874−-- definition = dropView #bc
875−-- in printSQL definition
876−-- :}
877−-- DROP VIEW "bc";
878−dropView
879− :: (Has sch schemas schema, Has vw schema ('View view))
880− => QualifiedAlias sch vw -- ^ view to remove
881− -> Definition schemas (Alter sch (Drop vw schema) schemas)
882−dropView vw = UnsafeDefinition $ "DROP VIEW" <+> renderSQL vw <> ";"
883−
884−-- | Enumerated types are created using the `createTypeEnum` command, for example
885−--
886−-- >>> printSQL $ (createTypeEnum #mood (label @"sad" :* label @"ok" :* label @"happy") :: Definition (Public '[]) '["public" ::: '["mood" ::: 'Typedef ('PGenum '["sad","ok","happy"])]])
887−-- CREATE TYPE "mood" AS ENUM ('sad', 'ok', 'happy');
888−createTypeEnum
889− :: (KnownSymbol enum, Has sch schemas schema, SOP.All KnownSymbol labels)
890− => QualifiedAlias sch enum
891− -- ^ name of the user defined enumerated type
892− -> NP PGlabel labels
893− -- ^ labels of the enumerated type
894− -> Definition schemas (Alter sch (Create enum ('Typedef ('PGenum labels)) schema) schemas)
895−createTypeEnum enum labels = UnsafeDefinition $
896− "CREATE" <+> "TYPE" <+> renderSQL enum <+> "AS" <+> "ENUM" <+>
897− parenthesized (renderSQL labels) <> ";"
898−
899−-- | Enumerated types can also be generated from a Haskell type, for example
900−--
901−-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic
902−-- >>> instance SOP.Generic Schwarma
903−-- >>> instance SOP.HasDatatypeInfo Schwarma
904−-- >>> :{
905−-- let
906−-- createSchwarma :: Definition (Public '[]) '["public" ::: '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))]]
907−-- createSchwarma = createTypeEnumFrom @Schwarma #schwarma
908−-- in
909−-- printSQL createSchwarma
910−-- :}
911−-- CREATE TYPE "schwarma" AS ENUM ('Beef', 'Lamb', 'Chicken');
912−createTypeEnumFrom
913− :: forall hask sch enum schemas schema.
914− ( SOP.Generic hask
915− , SOP.All KnownSymbol (LabelsPG hask)
916− , KnownSymbol enum
917− , Has sch schemas schema )
918− => QualifiedAlias sch enum
919− -- ^ name of the user defined enumerated type
920− -> Definition schemas (Alter sch (Create enum ('Typedef (PG (Enumerated hask))) schema) schemas)
921−createTypeEnumFrom enum = createTypeEnum enum
922− (SOP.hpure label :: NP PGlabel (LabelsPG hask))
923−
924−{- | `createTypeComposite` creates a composite type. The composite type is
925−specified by a list of attribute names and data types.
926−
927−>>> :{
928−type PGcomplex = 'PGcomposite
929− '[ "real" ::: 'NotNull 'PGfloat8
930− , "imaginary" ::: 'NotNull 'PGfloat8 ]
931−:}
932−
933−>>> :{
934−let
935− setup :: Definition (Public '[]) '["public" ::: '["complex" ::: 'Typedef PGcomplex]]
936− setup = createTypeComposite #complex
937− (float8 `as` #real :* float8 `as` #imaginary)
938−in printSQL setup
939−:}
940−CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);
941−-}
942−createTypeComposite
943− :: (KnownSymbol ty, Has sch schemas schema, SOP.SListI fields)
944− => QualifiedAlias sch ty
945− -- ^ name of the user defined composite type
946− -> NP (Aliased (TypeExpression schemas)) fields
947− -- ^ list of attribute names and data types
948− -> Definition schemas (Alter sch (Create ty ('Typedef ('PGcomposite fields)) schema) schemas)
949−createTypeComposite ty fields = UnsafeDefinition $
950− "CREATE" <+> "TYPE" <+> renderSQL ty <+> "AS" <+> parenthesized
951− (renderCommaSeparated renderField fields) <> ";"
952− where
953− renderField :: Aliased (TypeExpression schemas) x -> ByteString
954− renderField (typ `As` alias) =
955− renderSQL alias <+> renderSQL typ
956−
957−-- | Composite types can also be generated from a Haskell type, for example
958−--
959−-- >>> data Complex = Complex {real :: Double, imaginary :: Double} deriving GHC.Generic
960−-- >>> instance SOP.Generic Complex
961−-- >>> instance SOP.HasDatatypeInfo Complex
962−-- >>> type Schema = '["complex" ::: 'Typedef (PG (Composite Complex))]
963−-- >>> :{
964−-- let
965−-- createComplex :: Definition (Public '[]) (Public Schema)
966−-- createComplex = createTypeCompositeFrom @Complex #complex
967−-- in
968−-- printSQL createComplex
969−-- :}
970−-- CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);
971−createTypeCompositeFrom
972− :: forall hask sch ty schemas schema.
973− ( SOP.All (FieldTyped schemas) (RowPG hask)
974− , KnownSymbol ty
975− , Has sch schemas schema )
976− => QualifiedAlias sch ty
977− -- ^ name of the user defined composite type
978− -> Definition schemas (Alter sch (Create ty ( 'Typedef (PG (Composite hask))) schema) schemas)
979−createTypeCompositeFrom ty = createTypeComposite ty
980− (SOP.hcpure (SOP.Proxy :: SOP.Proxy (FieldTyped schemas)) fieldtype
981− :: NP (Aliased (TypeExpression schemas)) (RowPG hask))
982−
983−class FieldTyped schemas ty where
984− fieldtype :: Aliased (TypeExpression schemas) ty
985−instance (KnownSymbol alias, PGTyped schemas ty)
986− => FieldTyped schemas (alias ::: ty) where
987− fieldtype = pgtype `As` Alias
988−
989−-- | Drop a type.
990−--
991−-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic
992−-- >>> instance SOP.Generic Schwarma
993−-- >>> instance SOP.HasDatatypeInfo Schwarma
994−-- >>> printSQL (dropType #schwarma :: Definition '["public" ::: '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))]] (Public '[]))
995−-- DROP TYPE "schwarma";
996−dropType
997− :: (Has sch schemas schema, Has td schema ('Typedef ty))
998− => QualifiedAlias sch td
999− -- ^ name of the user defined type
1000− -> Definition schemas (Alter sch (Drop td schema) schemas)
1001−dropType tydef = UnsafeDefinition $ "DROP" <+> "TYPE" <+> renderSQL tydef <> ";"
1002−
1003−-- | `ColumnTypeExpression`s are used in `createTable` commands.
1004−newtype ColumnTypeExpression (schemas :: SchemasType) (ty :: ColumnType)
1005− = UnsafeColumnTypeExpression { renderColumnTypeExpression :: ByteString }
1006− deriving (GHC.Generic,Show,Eq,Ord,NFData)
1007−instance RenderSQL (ColumnTypeExpression schemas ty) where
1008− renderSQL = renderColumnTypeExpression
1009−
1010−-- | used in `createTable` commands as a column constraint to note that
1011−-- @NULL@ may be present in a column
1012−nullable
1013− :: TypeExpression schemas (nullity ty)
1014− -> ColumnTypeExpression schemas ('NoDef :=> 'Null ty)
1015−nullable ty = UnsafeColumnTypeExpression $ renderSQL ty <+> "NULL"
1016−
1017−-- | used in `createTable` commands as a column constraint to ensure
1018−-- @NULL@ is not present in a column
1019−notNullable
1020− :: TypeExpression schemas (nullity ty)
1021− -> ColumnTypeExpression schemas ('NoDef :=> 'NotNull ty)
1022−notNullable ty = UnsafeColumnTypeExpression $ renderSQL ty <+> "NOT NULL"
1023−
1024−-- | used in `createTable` commands as a column constraint to give a default
1025−default_
1026− :: Expression 'Ungrouped '[] schemas '[] '[] ty
1027− -> ColumnTypeExpression schemas ('NoDef :=> ty)
1028− -> ColumnTypeExpression schemas ('Def :=> ty)
1029−default_ x ty = UnsafeColumnTypeExpression $
1030− renderSQL ty <+> "DEFAULT" <+> renderExpression x
1031−
1032−-- | not a true type, but merely a notational convenience for creating
1033−-- unique identifier columns with type `PGint2`
1034−serial2, smallserial
1035− :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint2)
1036−serial2 = UnsafeColumnTypeExpression "serial2"
1037−smallserial = UnsafeColumnTypeExpression "smallserial"
1038−-- | not a true type, but merely a notational convenience for creating
1039−-- unique identifier columns with type `PGint4`
1040−serial4, serial
1041− :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint4)
1042−serial4 = UnsafeColumnTypeExpression "serial4"
1043−serial = UnsafeColumnTypeExpression "serial"
1044−-- | not a true type, but merely a notational convenience for creating
1045−-- unique identifier columns with type `PGint8`
1046−serial8, bigserial
1047− :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint8)
1048−serial8 = UnsafeColumnTypeExpression "serial8"
1049−bigserial = UnsafeColumnTypeExpression "bigserial"
82+manipDefinition = UnsafeDefinition . (<> ";") . renderSQL
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Function.hsnew file+238
@@ -0,0 +1,238 @@
1+{-|
2+Module: Squeal.PostgreSQL.Definition.Function
3+Description: Create and drop function and operator definitions
4+Copyright: (c) Eitan Chatav, 2017
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Create and drop function and operator definitions.
9+-}
10+
11+{-# LANGUAGE
12+ AllowAmbiguousTypes
13+ , ConstraintKinds
14+ , DeriveAnyClass
15+ , DeriveGeneric
16+ , DerivingStrategies
17+ , FlexibleContexts
18+ , FlexibleInstances
19+ , GADTs
20+ , LambdaCase
21+ , MultiParamTypeClasses
22+ , OverloadedLabels
23+ , OverloadedStrings
24+ , RankNTypes
25+ , ScopedTypeVariables
26+ , TypeApplications
27+ , TypeInType
28+ , TypeOperators
29+ , UndecidableSuperClasses
30+#-}
31+
32+module Squeal.PostgreSQL.Definition.Function
33+ ( createFunction
34+ , createOrReplaceFunction
35+ , createSetFunction
36+ , createOrReplaceSetFunction
37+ , createBinaryOp
38+ , createLeftOp
39+ , createRightOp
40+ , dropFunction
41+ , dropFunctionIfExists
42+ , dropOperator
43+ , dropOperatorIfExists
44+ , FunctionDefinition(..)
45+ , languageSqlExpr
46+ , languageSqlQuery
47+ ) where
48+
49+import Control.DeepSeq
50+import Data.ByteString
51+import GHC.TypeLits
52+
53+import qualified Generics.SOP as SOP
54+import qualified GHC.Generics as GHC
55+
56+import Squeal.PostgreSQL.Alias
57+import Squeal.PostgreSQL.Definition
58+import Squeal.PostgreSQL.Expression
59+import Squeal.PostgreSQL.Expression.Type
60+import Squeal.PostgreSQL.List
61+import Squeal.PostgreSQL.Query
62+import Squeal.PostgreSQL.Render
63+import Squeal.PostgreSQL.Schema
64+
65+-- $setup
66+-- >>> import Squeal.PostgreSQL
67+
68+createFunction
69+ :: ( Has sch schemas schema
70+ , KnownSymbol fun
71+ , SOP.SListI args )
72+ => QualifiedAlias sch fun
73+ -> NP (TypeExpression schemas) args
74+ -> TypeExpression schemas ret
75+ -> FunctionDefinition schemas args ('Returns ret)
76+ -> Definition schemas (Alter sch (Create fun ('Function (args :=> 'Returns ret)) schema) schemas)
77+createFunction fun args ret fundef = UnsafeDefinition $
78+ "CREATE" <+> "FUNCTION" <+> renderSQL fun
79+ <+> parenthesized (renderCommaSeparated renderSQL args)
80+ <+> "RETURNS" <+> renderSQL ret <+> renderSQL fundef <> ";"
81+
82+createOrReplaceFunction
83+ :: ( Has sch schemas schema
84+ , KnownSymbol fun
85+ , SOP.SListI args )
86+ => QualifiedAlias sch fun
87+ -> NP (TypeExpression schemas) args
88+ -> TypeExpression schemas ret
89+ -> FunctionDefinition schemas args ('Returns ret)
90+ -> Definition schemas (Alter sch (CreateOrReplace fun ('Function (args :=> 'Returns ret)) schema) schemas)
91+createOrReplaceFunction fun args ret fundef = UnsafeDefinition $
92+ "CREATE" <+> "OR" <+> "REPLACE" <+> "FUNCTION" <+> renderSQL fun
93+ <+> parenthesized (renderCommaSeparated renderSQL args)
94+ <+> "RETURNS" <+> renderSQL ret <+> renderSQL fundef <> ";"
95+
96+languageSqlExpr
97+ :: Expression '[] '[] 'Ungrouped schemas args '[] ret
98+ -> FunctionDefinition schemas args ('Returns ret)
99+languageSqlExpr expr = UnsafeFunctionDefinition $
100+ "language sql as"
101+ <+> "$$" <+> renderSQL (values_ (expr `as` #ret)) <+> "$$"
102+
103+languageSqlQuery
104+ :: Query '[] '[] schemas args rets
105+ -> FunctionDefinition schemas args ('ReturnsTable rets)
106+languageSqlQuery qry = UnsafeFunctionDefinition $
107+ "language sql as" <+> "$$" <+> renderSQL qry <+> "$$"
108+
109+createSetFunction
110+ :: ( Has sch schemas schema
111+ , KnownSymbol fun
112+ , SOP.SListI args
113+ , SOP.SListI rets )
114+ => QualifiedAlias sch fun
115+ -> NP (TypeExpression schemas) args
116+ -> NP (Aliased (TypeExpression schemas)) rets
117+ -> FunctionDefinition schemas args ('ReturnsTable rets)
118+ -> Definition schemas (Alter sch (Create fun ('Function (args :=> 'ReturnsTable rets)) schema) schemas)
119+createSetFunction fun args rets fundef = UnsafeDefinition $
120+ "CREATE" <+> "FUNCTION" <+> renderSQL fun
121+ <+> parenthesized (renderCommaSeparated renderSQL args)
122+ <+> "RETURNS" <+> "TABLE"
123+ <+> parenthesized (renderCommaSeparated renderRet rets)
124+ <+> renderSQL fundef <> ";"
125+ where
126+ renderRet :: Aliased (TypeExpression s) r -> ByteString
127+ renderRet (ty `As` col) = renderSQL col <+> renderSQL ty
128+
129+createOrReplaceSetFunction
130+ :: ( Has sch schemas schema
131+ , KnownSymbol fun
132+ , SOP.SListI args
133+ , SOP.SListI rets )
134+ => QualifiedAlias sch fun
135+ -> NP (TypeExpression schemas) args
136+ -> NP (Aliased (TypeExpression schemas)) rets
137+ -> FunctionDefinition schemas args ('ReturnsTable rets)
138+ -> Definition schemas (Alter sch (CreateOrReplace fun ('Function (args :=> 'ReturnsTable rets)) schema) schemas)
139+createOrReplaceSetFunction fun args rets fundef = UnsafeDefinition $
140+ "CREATE" <+> "OR" <+> "REPLACE" <+> "FUNCTION" <+> renderSQL fun
141+ <+> parenthesized (renderCommaSeparated renderSQL args)
142+ <+> "RETURNS" <+> "TABLE"
143+ <+> parenthesized (renderCommaSeparated renderRet rets)
144+ <+> renderSQL fundef <> ";"
145+ where
146+ renderRet :: Aliased (TypeExpression s) r -> ByteString
147+ renderRet (ty `As` col) = renderSQL col <+> renderSQL ty
148+
149+createBinaryOp
150+ :: forall op fun sch schemas schema x y z.
151+ ( Has sch schemas schema
152+ , Has fun schema ('Function ('[x,y] :=> 'Returns z))
153+ , KnownSymbol op )
154+ => QualifiedAlias sch fun
155+ -> TypeExpression schemas x
156+ -> TypeExpression schemas y
157+ -> Definition schemas
158+ (Alter sch (Create op ('Operator ('BinaryOp x y z)) schema) schemas)
159+createBinaryOp fun x y = UnsafeDefinition $
160+ "CREATE" <+> "OPERATOR" <+> renderSymbol @op
161+ <+> parenthesized (commaSeparated opdef)
162+ where
163+ opdef =
164+ [ "FUNCTION" <+> "=" <+> renderSQL fun
165+ , "LEFTARG" <+> "=" <+> renderSQL x
166+ , "RIGHTARG" <+> "=" <+> renderSQL y ]
167+
168+createLeftOp
169+ :: forall op fun sch schemas schema x y.
170+ ( Has sch schemas schema
171+ , Has fun schema ('Function ('[x] :=> 'Returns y))
172+ , KnownSymbol op )
173+ => QualifiedAlias sch fun
174+ -> TypeExpression schemas x
175+ -> Definition schemas
176+ (Alter sch (Create op ('Operator ('LeftOp x y)) schema) schemas)
177+createLeftOp fun x = UnsafeDefinition $
178+ "CREATE" <+> "OPERATOR" <+> renderSymbol @op
179+ <+> parenthesized (commaSeparated opdef)
180+ where
181+ opdef =
182+ [ "FUNCTION" <+> "=" <+> renderSQL fun
183+ , "RIGHTARG" <+> "=" <+> renderSQL x ]
184+
185+createRightOp
186+ :: forall op fun sch schemas schema x y.
187+ ( Has sch schemas schema
188+ , Has fun schema ('Function ('[x] :=> 'Returns y))
189+ , KnownSymbol op )
190+ => QualifiedAlias sch fun
191+ -> TypeExpression schemas x
192+ -> Definition schemas
193+ (Alter sch (Create op ('Operator ('RightOp x y)) schema) schemas)
194+createRightOp fun x = UnsafeDefinition $
195+ "CREATE" <+> "OPERATOR" <+> renderSymbol @op
196+ <+> parenthesized (commaSeparated opdef)
197+ where
198+ opdef =
199+ [ "FUNCTION" <+> "=" <+> renderSQL fun
200+ , "LEFTARG" <+> "=" <+> renderSQL x ]
201+
202+dropFunction
203+ :: (Has sch schemas schema, KnownSymbol fun)
204+ => QualifiedAlias sch fun
205+ -- ^ name of the user defined function
206+ -> Definition schemas (Alter sch (DropSchemum fun 'Function schema) schemas)
207+dropFunction fun = UnsafeDefinition $
208+ "DROP" <+> "FUNCTION" <+> renderSQL fun <> ";"
209+
210+dropFunctionIfExists
211+ :: (Has sch schemas schema, KnownSymbol fun)
212+ => QualifiedAlias sch fun
213+ -- ^ name of the user defined function
214+ -> Definition schemas (Alter sch (DropSchemumIfExists fun 'Function schema) schemas)
215+dropFunctionIfExists fun = UnsafeDefinition $
216+ "DROP FUNCTION IF EXISTS" <+> renderSQL fun <> ";"
217+
218+dropOperator
219+ :: (Has sch schemas schema, KnownSymbol op)
220+ => QualifiedAlias sch op
221+ -- ^ name of the user defined operator
222+ -> Definition schemas (Alter sch (DropSchemum op 'Operator schema) schemas)
223+dropOperator op = UnsafeDefinition $
224+ "DROP" <+> "OPERATOR" <+> renderSQL op <> ";"
225+
226+dropOperatorIfExists
227+ :: (Has sch schemas schema, KnownSymbol op)
228+ => QualifiedAlias sch op
229+ -- ^ name of the user defined operator
230+ -> Definition schemas (Alter sch (DropSchemumIfExists op 'Operator schema) schemas)
231+dropOperatorIfExists op = UnsafeDefinition $
232+ "DROP OPERATOR IF EXISTS" <+> renderSQL op <> ";"
233+
234+newtype FunctionDefinition schemas args ret = UnsafeFunctionDefinition
235+ { renderFunctionDefinition :: ByteString }
236+ deriving (Eq,Show,GHC.Generic,NFData)
237+instance RenderSQL (FunctionDefinition schemas args ret) where
238+ renderSQL = renderFunctionDefinition
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Index.hsnew file+159
@@ -0,0 +1,159 @@
1+{-|
2+Module: Squeal.PostgreSQL.Definition.Index
3+Description: Create and drop index definitions
4+Copyright: (c) Eitan Chatav, 2017
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Create and drop index definitions.
9+-}
10+
11+{-# LANGUAGE
12+ AllowAmbiguousTypes
13+ , ConstraintKinds
14+ , DeriveAnyClass
15+ , DeriveGeneric
16+ , DerivingStrategies
17+ , FlexibleContexts
18+ , FlexibleInstances
19+ , GADTs
20+ , LambdaCase
21+ , MultiParamTypeClasses
22+ , OverloadedLabels
23+ , OverloadedStrings
24+ , RankNTypes
25+ , ScopedTypeVariables
26+ , TypeApplications
27+ , TypeInType
28+ , TypeOperators
29+ , UndecidableSuperClasses
30+#-}
31+
32+module Squeal.PostgreSQL.Definition.Index
33+ ( createIndex
34+ , createIndexIfNotExists
35+ , dropIndex
36+ , dropIndexIfExists
37+ , IndexMethod (..)
38+ , btree
39+ , hash
40+ , gist
41+ , spgist
42+ , gin
43+ , brin
44+ ) where
45+
46+import Data.ByteString
47+import GHC.TypeLits
48+
49+import qualified GHC.Generics as GHC
50+
51+import Squeal.PostgreSQL.Alias
52+import Squeal.PostgreSQL.Definition
53+import Squeal.PostgreSQL.Expression.Sort
54+import Squeal.PostgreSQL.Render
55+import Squeal.PostgreSQL.Schema
56+
57+-- $setup
58+-- >>> import Squeal.PostgreSQL
59+
60+{- |
61+>>> :{
62+type Table = '[] :=>
63+ '[ "a" ::: 'NoDef :=> 'Null 'PGint4
64+ , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]
65+:}
66+
67+>>> :{
68+let
69+ setup :: Definition (Public '[]) (Public '["tab" ::: 'Table Table, "ix" ::: 'Index 'Btree])
70+ setup =
71+ createTable #tab (nullable int `as` #a :* nullable real `as` #b) Nil >>>
72+ createIndex #ix #tab btree [#a & AscNullsFirst, #b & AscNullsLast]
73+in printSQL setup
74+:}
75+CREATE TABLE "tab" ("a" int NULL, "b" real NULL);
76+CREATE INDEX "ix" ON "tab" USING btree (("a") ASC NULLS FIRST, ("b") ASC NULLS LAST);
77+-}
78+createIndex
79+ :: (Has sch schemas schema, Has tab schema ('Table table), KnownSymbol ix)
80+ => Alias ix
81+ -> QualifiedAlias sch tab
82+ -> IndexMethod method
83+ -> [SortExpression '[] '[] 'Ungrouped schemas '[] '[tab ::: TableToRow table]]
84+ -> Definition schemas (Alter sch (Create ix ('Index method) schema) schemas)
85+createIndex ix tab method cols = UnsafeDefinition $
86+ "CREATE" <+> "INDEX" <+> renderSQL ix <+> "ON" <+> renderSQL tab
87+ <+> "USING" <+> renderSQL method
88+ <+> parenthesized (commaSeparated (renderIndex <$> cols))
89+ <> ";"
90+ where
91+ renderIndex = \case
92+ Asc expression -> parenthesized (renderSQL expression) <+> "ASC"
93+ Desc expression -> parenthesized (renderSQL expression) <+> "DESC"
94+ AscNullsFirst expression -> parenthesized (renderSQL expression)
95+ <+> "ASC NULLS FIRST"
96+ DescNullsFirst expression -> parenthesized (renderSQL expression)
97+ <+> "DESC NULLS FIRST"
98+ AscNullsLast expression -> parenthesized (renderSQL expression)
99+ <+> "ASC NULLS LAST"
100+ DescNullsLast expression -> parenthesized (renderSQL expression)
101+ <+> "DESC NULLS LAST"
102+
103+createIndexIfNotExists
104+ :: (Has sch schemas schema, Has tab schema ('Table table), KnownSymbol ix)
105+ => Alias ix
106+ -> QualifiedAlias sch tab
107+ -> IndexMethod method
108+ -> [SortExpression '[] '[] 'Ungrouped schemas '[] '[tab ::: TableToRow table]]
109+ -> Definition schemas (Alter sch (CreateIfNotExists ix ('Index method) schema) schemas)
110+createIndexIfNotExists ix tab method cols = UnsafeDefinition $
111+ "CREATE INDEX IF NOT EXISTS" <+> renderSQL ix <+> "ON" <+> renderSQL tab
112+ <+> "USING" <+> renderSQL method
113+ <+> parenthesized (commaSeparated (renderIndex <$> cols))
114+ <> ";"
115+ where
116+ renderIndex = \case
117+ Asc expression -> parenthesized (renderSQL expression) <+> "ASC"
118+ Desc expression -> parenthesized (renderSQL expression) <+> "DESC"
119+ AscNullsFirst expression -> parenthesized (renderSQL expression)
120+ <+> "ASC NULLS FIRST"
121+ DescNullsFirst expression -> parenthesized (renderSQL expression)
122+ <+> "DESC NULLS FIRST"
123+ AscNullsLast expression -> parenthesized (renderSQL expression)
124+ <+> "ASC NULLS LAST"
125+ DescNullsLast expression -> parenthesized (renderSQL expression)
126+ <+> "DESC NULLS LAST"
127+
128+newtype IndexMethod ty = UnsafeIndexMethod {renderIndexMethod :: ByteString}
129+ deriving stock (Eq, Ord, Show, GHC.Generic)
130+instance RenderSQL (IndexMethod ty) where renderSQL = renderIndexMethod
131+btree :: IndexMethod 'Btree
132+btree = UnsafeIndexMethod "btree"
133+hash :: IndexMethod 'Hash
134+hash = UnsafeIndexMethod "hash"
135+gist :: IndexMethod 'Gist
136+gist = UnsafeIndexMethod "gist"
137+spgist :: IndexMethod 'Spgist
138+spgist = UnsafeIndexMethod "spgist"
139+gin :: IndexMethod 'Gin
140+gin = UnsafeIndexMethod "gin"
141+brin :: IndexMethod 'Brin
142+brin = UnsafeIndexMethod "brin"
143+
144+-- |
145+-- >>> printSQL (dropIndex #ix :: Definition (Public '["ix" ::: 'Index 'Btree]) (Public '[]))
146+-- DROP INDEX "ix";
147+dropIndex
148+ :: (Has sch schemas schema, KnownSymbol ix)
149+ => QualifiedAlias sch ix
150+ -- ^ name of the user defined index
151+ -> Definition schemas (Alter sch (DropSchemum ix 'Index schema) schemas)
152+dropIndex ix = UnsafeDefinition $ "DROP" <+> "INDEX" <+> renderSQL ix <> ";"
153+
154+dropIndexIfExists
155+ :: (Has sch schemas schema, KnownSymbol ix)
156+ => QualifiedAlias sch ix
157+ -- ^ name of the user defined index
158+ -> Definition schemas (Alter sch (DropSchemumIfExists ix 'Index schema) schemas)
159+dropIndexIfExists ix = UnsafeDefinition $ "DROP INDEX IF EXISTS" <+> renderSQL ix <> ";"
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Schema.hsnew file+96
@@ -0,0 +1,96 @@
1+{-|
2+Module: Squeal.PostgreSQL.Definition.Schema
3+Description: Create and drop schema definitions
4+Copyright: (c) Eitan Chatav, 2017
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Create and drop schema definitions.
9+-}
10+
11+{-# LANGUAGE
12+ AllowAmbiguousTypes
13+ , ConstraintKinds
14+ , DeriveAnyClass
15+ , DeriveGeneric
16+ , DerivingStrategies
17+ , FlexibleContexts
18+ , FlexibleInstances
19+ , GADTs
20+ , LambdaCase
21+ , MultiParamTypeClasses
22+ , OverloadedLabels
23+ , OverloadedStrings
24+ , RankNTypes
25+ , ScopedTypeVariables
26+ , TypeApplications
27+ , TypeInType
28+ , TypeOperators
29+ , UndecidableSuperClasses
30+#-}
31+
32+module Squeal.PostgreSQL.Definition.Schema
33+ ( createSchema
34+ , createSchemaIfNotExists
35+ , dropSchema
36+ , dropSchemaIfExists
37+ ) where
38+
39+import GHC.TypeLits
40+
41+import Squeal.PostgreSQL.Alias
42+import Squeal.PostgreSQL.Definition
43+import Squeal.PostgreSQL.Render
44+import Squeal.PostgreSQL.Schema
45+
46+-- $setup
47+-- >>> import Squeal.PostgreSQL
48+
49+{- |
50+`createSchema` enters a new schema into the current database.
51+The schema name must be distinct from the name of any existing schema
52+in the current database.
53+
54+A schema is essentially a namespace: it contains named objects
55+(tables, data types, functions, and operators) whose names
56+can duplicate those of other objects existing in other schemas.
57+Named objects are accessed by `QualifiedAlias`es with the schema
58+name as a prefix.
59+-}
60+createSchema
61+ :: KnownSymbol sch
62+ => Alias sch
63+ -> Definition schemas (Create sch '[] schemas)
64+createSchema sch = UnsafeDefinition $
65+ "CREATE" <+> "SCHEMA" <+> renderSQL sch <> ";"
66+
67+{- | Idempotent version of `createSchema`. -}
68+createSchemaIfNotExists
69+ :: (KnownSymbol sch, Has sch schemas schema)
70+ => Alias sch
71+ -> Definition schemas (CreateIfNotExists sch '[] schemas)
72+createSchemaIfNotExists sch = UnsafeDefinition $
73+ "CREATE" <+> "SCHEMA" <+> "IF" <+> "NOT" <+> "EXISTS"
74+ <+> renderSQL sch <> ";"
75+
76+-- | >>> :{
77+-- let
78+-- definition :: Definition '["muh_schema" ::: schema, "public" ::: public] '["public" ::: public]
79+-- definition = dropSchema #muh_schema
80+-- :}
81+--
82+-- >>> printSQL definition
83+-- DROP SCHEMA "muh_schema";
84+dropSchema
85+ :: KnownSymbol sch
86+ => Alias sch
87+ -- ^ user defined schema
88+ -> Definition schemas (Drop sch schemas)
89+dropSchema sch = UnsafeDefinition $ "DROP SCHEMA" <+> renderSQL sch <> ";"
90+
91+dropSchemaIfExists
92+ :: KnownSymbol sch
93+ => Alias sch
94+ -- ^ user defined schema
95+ -> Definition schemas (DropIfExists sch schemas)
96+dropSchemaIfExists sch = UnsafeDefinition $ "DROP SCHEMA" <+> renderSQL sch <> ";"
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Table.hsnew file+500
@@ -0,0 +1,500 @@
1+{-|
2+Module: Squeal.PostgreSQL.Definition.Table
3+Description: Create, drop and alter table definitions
4+Copyright: (c) Eitan Chatav, 2017
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Create, drop and alter table definitions.
9+-}
10+
11+{-# LANGUAGE
12+ AllowAmbiguousTypes
13+ , ConstraintKinds
14+ , DeriveAnyClass
15+ , DeriveGeneric
16+ , DerivingStrategies
17+ , FlexibleContexts
18+ , FlexibleInstances
19+ , GADTs
20+ , LambdaCase
21+ , MultiParamTypeClasses
22+ , OverloadedLabels
23+ , OverloadedStrings
24+ , RankNTypes
25+ , ScopedTypeVariables
26+ , TypeApplications
27+ , TypeInType
28+ , TypeOperators
29+ , UndecidableSuperClasses
30+#-}
31+
32+module Squeal.PostgreSQL.Definition.Table
33+ ( createTable
34+ , createTableIfNotExists
35+ , dropTable
36+ , dropTableIfExists
37+ , alterTable
38+ , alterTableIfExists
39+ , alterTableRename
40+ , alterTableIfExistsRename
41+ , AlterTable (..)
42+ , addConstraint
43+ , dropConstraint
44+ , AddColumn (..)
45+ , dropColumn
46+ , renameColumn
47+ , alterColumn
48+ , AlterColumn (..)
49+ , setDefault
50+ , dropDefault
51+ , setNotNull
52+ , dropNotNull
53+ , alterType
54+ ) where
55+
56+import Control.DeepSeq
57+import Data.ByteString
58+import GHC.TypeLits
59+
60+import qualified Generics.SOP as SOP
61+import qualified GHC.Generics as GHC
62+
63+import Squeal.PostgreSQL.Alias
64+import Squeal.PostgreSQL.Definition
65+import Squeal.PostgreSQL.Definition.Table.Constraint
66+import Squeal.PostgreSQL.Expression
67+import Squeal.PostgreSQL.Expression.Type
68+import Squeal.PostgreSQL.List
69+import Squeal.PostgreSQL.Render
70+import Squeal.PostgreSQL.Schema
71+
72+-- $setup
73+-- >>> import Squeal.PostgreSQL
74+
75+{- | `createTable` adds a table to the schema.
76+
77+>>> :set -XOverloadedLabels
78+>>> :{
79+type Table = '[] :=>
80+ '[ "a" ::: 'NoDef :=> 'Null 'PGint4
81+ , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]
82+:}
83+
84+>>> :{
85+let
86+ setup :: Definition (Public '[]) (Public '["tab" ::: 'Table Table])
87+ setup = createTable #tab
88+ (nullable int `as` #a :* nullable real `as` #b) Nil
89+in printSQL setup
90+:}
91+CREATE TABLE "tab" ("a" int NULL, "b" real NULL);
92+-}
93+createTable
94+ :: ( KnownSymbol sch
95+ , KnownSymbol tab
96+ , columns ~ (col ': cols)
97+ , SOP.SListI columns
98+ , SOP.SListI constraints
99+ , Has sch schemas0 schema0
100+ , schemas1 ~ Alter sch (Create tab ('Table (constraints :=> columns)) schema0) schemas0 )
101+ => QualifiedAlias sch tab -- ^ the name of the table to add
102+ -> NP (Aliased (ColumnTypeExpression schemas0)) columns
103+ -- ^ the names and datatype of each column
104+ -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints
105+ -- ^ constraints that must hold for the table
106+ -> Definition schemas0 schemas1
107+createTable tab columns constraints = UnsafeDefinition $
108+ "CREATE TABLE" <+> renderCreation tab columns constraints
109+
110+{-| `createTableIfNotExists` creates a table if it doesn't exist, but does not add it to the schema.
111+Instead, the schema already has the table so if the table did not yet exist, the schema was wrong.
112+`createTableIfNotExists` fixes this. Interestingly, this property makes it an idempotent in
113+the `Category` of `Definition`s.
114+
115+>>> :set -XOverloadedLabels -XTypeApplications
116+>>> :{
117+type Table = '[] :=>
118+ '[ "a" ::: 'NoDef :=> 'Null 'PGint4
119+ , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]
120+:}
121+
122+>>> type Schemas = Public '["tab" ::: 'Table Table]
123+
124+>>> :{
125+let
126+ setup :: Definition Schemas Schemas
127+ setup = createTableIfNotExists #tab
128+ (nullable int `as` #a :* nullable real `as` #b) Nil
129+in printSQL setup
130+:}
131+CREATE TABLE IF NOT EXISTS "tab" ("a" int NULL, "b" real NULL);
132+-}
133+createTableIfNotExists
134+ :: ( KnownSymbol sch
135+ , KnownSymbol tab
136+ , columns ~ (col ': cols)
137+ , SOP.SListI columns
138+ , SOP.SListI constraints
139+ , Has sch schemas0 schema0
140+ , schemas1 ~ Alter sch (CreateIfNotExists tab ('Table (constraints :=> columns)) schema0) schemas0 )
141+ => QualifiedAlias sch tab -- ^ the name of the table to add
142+ -> NP (Aliased (ColumnTypeExpression schemas0)) columns
143+ -- ^ the names and datatype of each column
144+ -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints
145+ -- ^ constraints that must hold for the table
146+ -> Definition schemas0 schemas1
147+createTableIfNotExists tab columns constraints = UnsafeDefinition $
148+ "CREATE TABLE IF NOT EXISTS"
149+ <+> renderCreation tab columns constraints
150+
151+-- helper function for `createTable` and `createTableIfNotExists`
152+renderCreation
153+ :: ( KnownSymbol sch
154+ , KnownSymbol tab
155+ , SOP.SListI columns
156+ , SOP.SListI constraints )
157+ => QualifiedAlias sch tab -- ^ the name of the table to add
158+ -> NP (Aliased (ColumnTypeExpression schemas0)) columns
159+ -- ^ the names and datatype of each column
160+ -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints
161+ -- ^ constraints that must hold for the table
162+ -> ByteString
163+renderCreation tab columns constraints = renderSQL tab
164+ <+> parenthesized
165+ ( renderCommaSeparated renderColumnDef columns
166+ <> ( case constraints of
167+ Nil -> ""
168+ _ -> ", " <>
169+ renderCommaSeparated renderConstraint constraints ) )
170+ <> ";"
171+ where
172+ renderColumnDef :: Aliased (ColumnTypeExpression schemas) x -> ByteString
173+ renderColumnDef (ty `As` column) =
174+ renderSQL column <+> renderColumnTypeExpression ty
175+ renderConstraint
176+ :: Aliased (TableConstraintExpression sch tab schemas) constraint
177+ -> ByteString
178+ renderConstraint (constraint `As` alias) =
179+ "CONSTRAINT" <+> renderSQL alias <+> renderSQL constraint
180+
181+-- | `dropTable` removes a table from the schema.
182+--
183+-- >>> :{
184+-- let
185+-- definition :: Definition '["public" ::: '["muh_table" ::: 'Table t]] (Public '[])
186+-- definition = dropTable #muh_table
187+-- :}
188+--
189+-- >>> printSQL definition
190+-- DROP TABLE "muh_table";
191+dropTable
192+ :: ( Has sch schemas schema
193+ , KnownSymbol tab )
194+ => QualifiedAlias sch tab -- ^ table to remove
195+ -> Definition schemas (Alter sch (DropSchemum tab 'Table schema) schemas)
196+dropTable tab = UnsafeDefinition $ "DROP TABLE" <+> renderSQL tab <> ";"
197+
198+dropTableIfExists
199+ :: ( Has sch schemas schema
200+ , KnownSymbol tab)
201+ => QualifiedAlias sch tab -- ^ table to remove
202+ -> Definition schemas (Alter sch (DropSchemumIfExists tab 'Table schema) schemas)
203+dropTableIfExists tab = UnsafeDefinition $ "DROP TABLE IF EXISTS" <+> renderSQL tab <> ";"
204+
205+-- | `alterTable` changes the definition of a table from the schema.
206+alterTable
207+ :: (Has sch schemas schema, KnownSymbol tab)
208+ => QualifiedAlias sch tab -- ^ table to alter
209+ -> AlterTable sch tab schemas table -- ^ alteration to perform
210+ -> Definition schemas (Alter sch (Alter tab ('Table table) schema) schemas)
211+alterTable tab alteration = UnsafeDefinition $
212+ "ALTER TABLE"
213+ <+> renderSQL tab
214+ <+> renderAlterTable alteration
215+ <> ";"
216+
217+-- | `alterTable` changes the definition of a table from the schema.
218+alterTableIfExists
219+ :: (Has sch schemas schema, KnownSymbol tab)
220+ => QualifiedAlias sch tab -- ^ table to alter
221+ -> AlterTable sch tab schemas table -- ^ alteration to perform
222+ -> Definition schemas (Alter sch (AlterIfExists tab ('Table table) schema) schemas)
223+alterTableIfExists tab alteration = UnsafeDefinition $
224+ "ALTER TABLE IF EXISTS"
225+ <+> renderSQL tab
226+ <+> renderAlterTable alteration
227+ <> ";"
228+
229+-- | `alterTableRename` changes the name of a table from the schema.
230+--
231+-- >>> printSQL $ alterTableRename #foo #bar
232+-- ALTER TABLE "foo" RENAME TO "bar";
233+alterTableRename
234+ :: (KnownSymbol tab0, KnownSymbol tab1)
235+ => Alias tab0 -- ^ table to rename
236+ -> Alias tab1 -- ^ what to rename it
237+ -> Definition schema (Rename tab0 tab1 schema)
238+alterTableRename tab0 tab1 = UnsafeDefinition $
239+ "ALTER TABLE" <+> renderSQL tab0
240+ <+> "RENAME TO" <+> renderSQL tab1 <> ";"
241+
242+alterTableIfExistsRename
243+ :: (KnownSymbol tab0, KnownSymbol tab1)
244+ => Alias tab0 -- ^ table to rename
245+ -> Alias tab1 -- ^ what to rename it
246+ -> Definition schema (RenameIfExists tab0 tab1 schema)
247+alterTableIfExistsRename tab0 tab1 = UnsafeDefinition $
248+ "ALTER TABLE IF EXISTS" <+> renderSQL tab0
249+ <+> "RENAME TO" <+> renderSQL tab1 <> ";"
250+
251+-- | An `AlterTable` describes the alteration to perform on the columns
252+-- of a table.
253+newtype AlterTable
254+ (sch :: Symbol)
255+ (tab :: Symbol)
256+ (schemas :: SchemasType)
257+ (table :: TableType) =
258+ UnsafeAlterTable {renderAlterTable :: ByteString}
259+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
260+
261+-- | An `addConstraint` adds a table constraint.
262+--
263+-- >>> :{
264+-- let
265+-- definition :: Definition
266+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
267+-- '["public" ::: '["tab" ::: 'Table ('["positive" ::: 'Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
268+-- definition = alterTable #tab (addConstraint #positive (check #col (#col .> 0)))
269+-- in printSQL definition
270+-- :}
271+-- ALTER TABLE "tab" ADD CONSTRAINT "positive" CHECK (("col" > 0));
272+addConstraint
273+ :: ( KnownSymbol alias
274+ , Has sch schemas schema
275+ , Has tab schema ('Table table0)
276+ , table0 ~ (constraints :=> columns)
277+ , table1 ~ (Create alias constraint constraints :=> columns) )
278+ => Alias alias
279+ -> TableConstraintExpression sch tab schemas constraint
280+ -- ^ constraint to add
281+ -> AlterTable sch tab schemas table1
282+addConstraint alias constraint = UnsafeAlterTable $
283+ "ADD" <+> "CONSTRAINT" <+> renderSQL alias
284+ <+> renderSQL constraint
285+
286+-- | A `dropConstraint` drops a table constraint.
287+--
288+-- >>> :{
289+-- let
290+-- definition :: Definition
291+-- '["public" ::: '["tab" ::: 'Table ('["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
292+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
293+-- definition = alterTable #tab (dropConstraint #positive)
294+-- in printSQL definition
295+-- :}
296+-- ALTER TABLE "tab" DROP CONSTRAINT "positive";
297+dropConstraint
298+ :: ( KnownSymbol constraint
299+ , Has sch schemas schema
300+ , Has tab schema ('Table table0)
301+ , table0 ~ (constraints :=> columns)
302+ , table1 ~ (Drop constraint constraints :=> columns) )
303+ => Alias constraint
304+ -- ^ constraint to drop
305+ -> AlterTable sch tab schemas table1
306+dropConstraint constraint = UnsafeAlterTable $
307+ "DROP" <+> "CONSTRAINT" <+> renderSQL constraint
308+
309+-- | An `AddColumn` is either @NULL@ or has @DEFAULT@.
310+class AddColumn ty where
311+ -- | `addColumn` adds a new column, initially filled with whatever
312+ -- default value is given or with @NULL@.
313+ --
314+ -- >>> :{
315+ -- let
316+ -- definition :: Definition
317+ -- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]
318+ -- '["public" ::: '["tab" ::: 'Table ('[] :=>
319+ -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
320+ -- , "col2" ::: 'Def :=> 'Null 'PGtext ])]]
321+ -- definition = alterTable #tab (addColumn #col2 (text & nullable & default_ "foo"))
322+ -- in printSQL definition
323+ -- :}
324+ -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL DEFAULT E'foo';
325+ --
326+ -- >>> :{
327+ -- let
328+ -- definition :: Definition
329+ -- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]
330+ -- '["public" ::: '["tab" ::: 'Table ('[] :=>
331+ -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
332+ -- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]]
333+ -- definition = alterTable #tab (addColumn #col2 (text & nullable))
334+ -- in printSQL definition
335+ -- :}
336+ -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL;
337+ addColumn
338+ :: ( KnownSymbol column
339+ , Has sch schemas schema
340+ , Has tab schema ('Table table0)
341+ , table0 ~ (constraints :=> columns) )
342+ => Alias column -- ^ column to add
343+ -> ColumnTypeExpression schemas ty -- ^ type of the new column
344+ -> AlterTable sch tab schemas (constraints :=> Create column ty columns)
345+ addColumn column ty = UnsafeAlterTable $
346+ "ADD COLUMN" <+> renderSQL column <+> renderColumnTypeExpression ty
347+instance {-# OVERLAPPING #-} AddColumn ('Def :=> ty)
348+instance {-# OVERLAPPABLE #-} AddColumn ('NoDef :=> 'Null ty)
349+
350+-- | A `dropColumn` removes a column. Whatever data was in the column
351+-- disappears. Table constraints involving the column are dropped, too.
352+-- However, if the column is referenced by a foreign key constraint of
353+-- another table, PostgreSQL will not silently drop that constraint.
354+--
355+-- >>> :{
356+-- let
357+-- definition :: Definition
358+-- '["public" ::: '["tab" ::: 'Table ('[] :=>
359+-- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
360+-- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]]
361+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]
362+-- definition = alterTable #tab (dropColumn #col2)
363+-- in printSQL definition
364+-- :}
365+-- ALTER TABLE "tab" DROP COLUMN "col2";
366+dropColumn
367+ :: ( KnownSymbol column
368+ , Has sch schemas schema
369+ , Has tab schema ('Table table0)
370+ , table0 ~ (constraints :=> columns)
371+ , table1 ~ (constraints :=> Drop column columns) )
372+ => Alias column -- ^ column to remove
373+ -> AlterTable sch tab schemas table1
374+dropColumn column = UnsafeAlterTable $
375+ "DROP COLUMN" <+> renderSQL column
376+
377+-- | A `renameColumn` renames a column.
378+--
379+-- >>> :{
380+-- let
381+-- definition :: Definition
382+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["foo" ::: 'NoDef :=> 'Null 'PGint4])]]
383+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["bar" ::: 'NoDef :=> 'Null 'PGint4])]]
384+-- definition = alterTable #tab (renameColumn #foo #bar)
385+-- in printSQL definition
386+-- :}
387+-- ALTER TABLE "tab" RENAME COLUMN "foo" TO "bar";
388+renameColumn
389+ :: ( KnownSymbol column0
390+ , KnownSymbol column1
391+ , Has sch schemas schema
392+ , Has tab schema ('Table table0)
393+ , table0 ~ (constraints :=> columns)
394+ , table1 ~ (constraints :=> Rename column0 column1 columns) )
395+ => Alias column0 -- ^ column to rename
396+ -> Alias column1 -- ^ what to rename the column
397+ -> AlterTable sch tab schemas table1
398+renameColumn column0 column1 = UnsafeAlterTable $
399+ "RENAME COLUMN" <+> renderSQL column0 <+> "TO" <+> renderSQL column1
400+
401+-- | An `alterColumn` alters a single column.
402+alterColumn
403+ :: ( KnownSymbol column
404+ , Has sch schemas schema
405+ , Has tab schema ('Table table0)
406+ , table0 ~ (constraints :=> columns)
407+ , Has column columns ty0
408+ , table1 ~ (constraints :=> Alter column ty1 columns))
409+ => Alias column -- ^ column to alter
410+ -> AlterColumn schemas ty0 ty1 -- ^ alteration to perform
411+ -> AlterTable sch tab schemas table1
412+alterColumn column alteration = UnsafeAlterTable $
413+ "ALTER COLUMN" <+> renderSQL column <+> renderAlterColumn alteration
414+
415+-- | An `AlterColumn` describes the alteration to perform on a single column.
416+newtype AlterColumn (schemas :: SchemasType) (ty0 :: ColumnType) (ty1 :: ColumnType) =
417+ UnsafeAlterColumn {renderAlterColumn :: ByteString}
418+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
419+
420+-- | A `setDefault` sets a new default for a column. Note that this doesn't
421+-- affect any existing rows in the table, it just changes the default for
422+-- future insert and update commands.
423+--
424+-- >>> :{
425+-- let
426+-- definition :: Definition
427+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
428+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]]
429+-- definition = alterTable #tab (alterColumn #col (setDefault 5))
430+-- in printSQL definition
431+-- :}
432+-- ALTER TABLE "tab" ALTER COLUMN "col" SET DEFAULT 5;
433+setDefault
434+ :: Expression '[] '[] 'Ungrouped schemas '[] '[] ty -- ^ default value to set
435+ -> AlterColumn schemas (constraint :=> ty) ('Def :=> ty)
436+setDefault expression = UnsafeAlterColumn $
437+ "SET DEFAULT" <+> renderExpression expression
438+
439+-- | A `dropDefault` removes any default value for a column.
440+--
441+-- >>> :{
442+-- let
443+-- definition :: Definition
444+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]]
445+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
446+-- definition = alterTable #tab (alterColumn #col dropDefault)
447+-- in printSQL definition
448+-- :}
449+-- ALTER TABLE "tab" ALTER COLUMN "col" DROP DEFAULT;
450+dropDefault :: AlterColumn schemas ('Def :=> ty) ('NoDef :=> ty)
451+dropDefault = UnsafeAlterColumn $ "DROP DEFAULT"
452+
453+-- | A `setNotNull` adds a @NOT NULL@ constraint to a column.
454+-- The constraint will be checked immediately, so the table data must satisfy
455+-- the constraint before it can be added.
456+--
457+-- >>> :{
458+-- let
459+-- definition :: Definition
460+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
461+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
462+-- definition = alterTable #tab (alterColumn #col setNotNull)
463+-- in printSQL definition
464+-- :}
465+-- ALTER TABLE "tab" ALTER COLUMN "col" SET NOT NULL;
466+setNotNull
467+ :: AlterColumn schemas (constraint :=> 'Null ty) (constraint :=> 'NotNull ty)
468+setNotNull = UnsafeAlterColumn $ "SET NOT NULL"
469+
470+-- | A `dropNotNull` drops a @NOT NULL@ constraint from a column.
471+--
472+-- >>> :{
473+-- let
474+-- definition :: Definition
475+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
476+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
477+-- definition = alterTable #tab (alterColumn #col dropNotNull)
478+-- in printSQL definition
479+-- :}
480+-- ALTER TABLE "tab" ALTER COLUMN "col" DROP NOT NULL;
481+dropNotNull
482+ :: AlterColumn schemas (constraint :=> 'NotNull ty) (constraint :=> 'Null ty)
483+dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL"
484+
485+-- | An `alterType` converts a column to a different data type.
486+-- This will succeed only if each existing entry in the column can be
487+-- converted to the new type by an implicit cast.
488+--
489+-- >>> :{
490+-- let
491+-- definition :: Definition
492+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
493+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGnumeric])]]
494+-- definition =
495+-- alterTable #tab (alterColumn #col (alterType (numeric & notNullable)))
496+-- in printSQL definition
497+-- :}
498+-- ALTER TABLE "tab" ALTER COLUMN "col" TYPE numeric NOT NULL;
499+alterType :: ColumnTypeExpression schemas ty -> AlterColumn schemas ty0 ty
500+alterType ty = UnsafeAlterColumn $ "TYPE" <+> renderColumnTypeExpression ty
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Table/Constraint.hsnew file+339
@@ -0,0 +1,339 @@
1+{-|
2+Module: Squeal.PostgreSQL.Definition.Table.Constraint
3+Description: Table constraint expressions
4+Copyright: (c) Eitan Chatav, 2017
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Table constraint expressions.
9+-}
10+
11+{-# LANGUAGE
12+ AllowAmbiguousTypes
13+ , ConstraintKinds
14+ , DeriveAnyClass
15+ , DeriveGeneric
16+ , DerivingStrategies
17+ , FlexibleContexts
18+ , FlexibleInstances
19+ , GADTs
20+ , LambdaCase
21+ , MultiParamTypeClasses
22+ , OverloadedLabels
23+ , OverloadedStrings
24+ , RankNTypes
25+ , ScopedTypeVariables
26+ , TypeApplications
27+ , TypeInType
28+ , TypeOperators
29+ , UndecidableSuperClasses
30+#-}
31+
32+module Squeal.PostgreSQL.Definition.Table.Constraint
33+ ( TableConstraintExpression (..)
34+ , check
35+ , unique
36+ , primaryKey
37+ , foreignKey
38+ , ForeignKeyed
39+ , OnDeleteClause (..)
40+ , OnUpdateClause (..)
41+ ) where
42+
43+import Control.DeepSeq
44+import Data.ByteString
45+import GHC.TypeLits
46+
47+import qualified Generics.SOP as SOP
48+import qualified GHC.Generics as GHC
49+
50+import Squeal.PostgreSQL.Alias
51+import Squeal.PostgreSQL.Expression.Logic
52+import Squeal.PostgreSQL.List
53+import Squeal.PostgreSQL.Render
54+import Squeal.PostgreSQL.Schema
55+
56+-- $setup
57+-- >>> import Squeal.PostgreSQL
58+
59+-- | Data types are a way to limit the kind of data that can be stored in a
60+-- table. For many applications, however, the constraint they provide is
61+-- too coarse. For example, a column containing a product price should
62+-- probably only accept positive values. But there is no standard data type
63+-- that accepts only positive numbers. Another issue is that you might want
64+-- to constrain column data with respect to other columns or rows.
65+-- For example, in a table containing product information,
66+-- there should be only one row for each product number.
67+-- `TableConstraint`s give you as much control over the data in your tables
68+-- as you wish. If a user attempts to store data in a column that would
69+-- violate a constraint, an error is raised. This applies
70+-- even if the value came from the default value definition.
71+newtype TableConstraintExpression
72+ (sch :: Symbol)
73+ (tab :: Symbol)
74+ (schemas :: SchemasType)
75+ (constraint :: TableConstraint)
76+ = UnsafeTableConstraintExpression
77+ { renderTableConstraintExpression :: ByteString }
78+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
79+instance RenderSQL
80+ (TableConstraintExpression sch tab schemas constraint) where
81+ renderSQL = renderTableConstraintExpression
82+
83+{-| A `check` constraint is the most generic `TableConstraint` type.
84+It allows you to specify that the value in a certain column must satisfy
85+a Boolean (truth-value) expression.
86+
87+>>> :{
88+type Schema = '[
89+ "tab" ::: 'Table ('[ "inequality" ::: 'Check '["a","b"]] :=> '[
90+ "a" ::: 'NoDef :=> 'NotNull 'PGint4,
91+ "b" ::: 'NoDef :=> 'NotNull 'PGint4
92+ ])]
93+:}
94+
95+>>> :{
96+let
97+ definition :: Definition (Public '[]) (Public Schema)
98+ definition = createTable #tab
99+ ( (int & notNullable) `as` #a :*
100+ (int & notNullable) `as` #b )
101+ ( check (#a :* #b) (#a .> #b) `as` #inequality )
102+:}
103+
104+>>> printSQL definition
105+CREATE TABLE "tab" ("a" int NOT NULL, "b" int NOT NULL, CONSTRAINT "inequality" CHECK (("a" > "b")));
106+-}
107+check
108+ :: ( Has sch schemas schema
109+ , Has tab schema ('Table table)
110+ , HasAll aliases (TableToRow table) subcolumns )
111+ => NP Alias aliases
112+ -- ^ specify the subcolumns which are getting checked
113+ -> (forall t. Condition '[] '[] 'Ungrouped schemas '[] '[t ::: subcolumns])
114+ -- ^ a closed `Condition` on those subcolumns
115+ -> TableConstraintExpression sch tab schemas ('Check aliases)
116+check _cols condition = UnsafeTableConstraintExpression $
117+ "CHECK" <+> parenthesized (renderSQL condition)
118+
119+{-| A `unique` constraint ensure that the data contained in a column,
120+or a group of columns, is unique among all the rows in the table.
121+
122+>>> :{
123+type Schema = '[
124+ "tab" ::: 'Table( '[ "uq_a_b" ::: 'Unique '["a","b"]] :=> '[
125+ "a" ::: 'NoDef :=> 'Null 'PGint4,
126+ "b" ::: 'NoDef :=> 'Null 'PGint4
127+ ])]
128+:}
129+
130+>>> :{
131+let
132+ definition :: Definition (Public '[]) (Public Schema)
133+ definition = createTable #tab
134+ ( (int & nullable) `as` #a :*
135+ (int & nullable) `as` #b )
136+ ( unique (#a :* #b) `as` #uq_a_b )
137+:}
138+
139+>>> printSQL definition
140+CREATE TABLE "tab" ("a" int NULL, "b" int NULL, CONSTRAINT "uq_a_b" UNIQUE ("a", "b"));
141+-}
142+unique
143+ :: ( Has sch schemas schema
144+ , Has tab schema('Table table)
145+ , HasAll aliases (TableToRow table) subcolumns )
146+ => NP Alias aliases
147+ -- ^ specify subcolumns which together are unique for each row
148+ -> TableConstraintExpression sch tab schemas ('Unique aliases)
149+unique columns = UnsafeTableConstraintExpression $
150+ "UNIQUE" <+> parenthesized (renderSQL columns)
151+
152+{-| A `primaryKey` constraint indicates that a column, or group of columns,
153+can be used as a unique identifier for rows in the table.
154+This requires that the values be both unique and not null.
155+
156+>>> :{
157+type Schema = '[
158+ "tab" ::: 'Table ('[ "pk_id" ::: 'PrimaryKey '["id"]] :=> '[
159+ "id" ::: 'Def :=> 'NotNull 'PGint4,
160+ "name" ::: 'NoDef :=> 'NotNull 'PGtext
161+ ])]
162+:}
163+
164+>>> :{
165+let
166+ definition :: Definition (Public '[]) (Public Schema)
167+ definition = createTable #tab
168+ ( serial `as` #id :*
169+ (text & notNullable) `as` #name )
170+ ( primaryKey #id `as` #pk_id )
171+:}
172+
173+>>> printSQL definition
174+CREATE TABLE "tab" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_id" PRIMARY KEY ("id"));
175+-}
176+primaryKey
177+ :: ( Has sch schemas schema
178+ , Has tab schema ('Table table)
179+ , HasAll aliases (TableToColumns table) subcolumns
180+ , AllNotNull subcolumns )
181+ => NP Alias aliases
182+ -- ^ specify the subcolumns which together form a primary key.
183+ -> TableConstraintExpression sch tab schemas ('PrimaryKey aliases)
184+primaryKey columns = UnsafeTableConstraintExpression $
185+ "PRIMARY KEY" <+> parenthesized (renderSQL columns)
186+
187+{-| A `foreignKey` specifies that the values in a column
188+(or a group of columns) must match the values appearing in some row of
189+another table. We say this maintains the referential integrity
190+between two related tables.
191+
192+>>> :{
193+type Schema =
194+ '[ "users" ::: 'Table (
195+ '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
196+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
197+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext
198+ ])
199+ , "emails" ::: 'Table (
200+ '[ "pk_emails" ::: 'PrimaryKey '["id"]
201+ , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
202+ ] :=>
203+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
204+ , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
205+ , "email" ::: 'NoDef :=> 'Null 'PGtext
206+ ])
207+ ]
208+:}
209+
210+>>> :{
211+let
212+ setup :: Definition (Public '[]) (Public Schema)
213+ setup =
214+ createTable #users
215+ ( serial `as` #id :*
216+ (text & notNullable) `as` #name )
217+ ( primaryKey #id `as` #pk_users ) >>>
218+ createTable #emails
219+ ( serial `as` #id :*
220+ (int & notNullable) `as` #user_id :*
221+ (text & nullable) `as` #email )
222+ ( primaryKey #id `as` #pk_emails :*
223+ foreignKey #user_id #users #id
224+ OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
225+in printSQL setup
226+:}
227+CREATE TABLE "users" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_users" PRIMARY KEY ("id"));
228+CREATE TABLE "emails" ("id" serial, "user_id" int NOT NULL, "email" text NULL, CONSTRAINT "pk_emails" PRIMARY KEY ("id"), CONSTRAINT "fk_user_id" FOREIGN KEY ("user_id") REFERENCES "users" ("id") ON DELETE CASCADE ON UPDATE CASCADE);
229+
230+A `foreignKey` can even be a table self-reference.
231+
232+>>> :{
233+type Schema =
234+ '[ "employees" ::: 'Table (
235+ '[ "employees_pk" ::: 'PrimaryKey '["id"]
236+ , "employees_employer_fk" ::: 'ForeignKey '["employer_id"] "employees" '["id"]
237+ ] :=>
238+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
239+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext
240+ , "employer_id" ::: 'NoDef :=> 'Null 'PGint4
241+ ])
242+ ]
243+:}
244+
245+>>> :{
246+let
247+ setup :: Definition (Public '[]) (Public Schema)
248+ setup =
249+ createTable #employees
250+ ( serial `as` #id :*
251+ (text & notNullable) `as` #name :*
252+ (integer & nullable) `as` #employer_id )
253+ ( primaryKey #id `as` #employees_pk :*
254+ foreignKey #employer_id #employees #id
255+ OnDeleteCascade OnUpdateCascade `as` #employees_employer_fk )
256+in printSQL setup
257+:}
258+CREATE TABLE "employees" ("id" serial, "name" text NOT NULL, "employer_id" integer NULL, CONSTRAINT "employees_pk" PRIMARY KEY ("id"), CONSTRAINT "employees_employer_fk" FOREIGN KEY ("employer_id") REFERENCES "employees" ("id") ON DELETE CASCADE ON UPDATE CASCADE);
259+-}
260+foreignKey
261+ :: (ForeignKeyed schemas sch schema child parent
262+ table reftable
263+ columns refcolumns
264+ constraints cols
265+ reftys tys )
266+ => NP Alias columns
267+ -- ^ column or columns in the table
268+ -> Alias parent
269+ -- ^ reference table
270+ -> NP Alias refcolumns
271+ -- ^ reference column or columns in the reference table
272+ -> OnDeleteClause
273+ -- ^ what to do when reference is deleted
274+ -> OnUpdateClause
275+ -- ^ what to do when reference is updated
276+ -> TableConstraintExpression sch child schemas
277+ ('ForeignKey columns parent refcolumns)
278+foreignKey keys parent refs ondel onupd = UnsafeTableConstraintExpression $
279+ "FOREIGN KEY" <+> parenthesized (renderSQL keys)
280+ <+> "REFERENCES" <+> renderSQL parent
281+ <+> parenthesized (renderSQL refs)
282+ <+> renderSQL ondel
283+ <+> renderSQL onupd
284+
285+-- | A constraint synonym between types involved in a foreign key constraint.
286+type ForeignKeyed schemas
287+ sch
288+ schema
289+ child parent
290+ table reftable
291+ columns refcolumns
292+ constraints cols
293+ reftys tys =
294+ ( Has sch schemas schema
295+ , Has child schema ('Table table)
296+ , Has parent schema ('Table reftable)
297+ , HasAll columns (TableToColumns table) tys
298+ , reftable ~ (constraints :=> cols)
299+ , HasAll refcolumns cols reftys
300+ , SOP.AllZip SamePGType tys reftys
301+ , Uniquely refcolumns constraints )
302+
303+-- | `OnDeleteClause` indicates what to do with rows that reference a deleted row.
304+data OnDeleteClause
305+ = OnDeleteNoAction
306+ -- ^ if any referencing rows still exist when the constraint is checked,
307+ -- an error is raised
308+ | OnDeleteRestrict -- ^ prevents deletion of a referenced row
309+ | OnDeleteCascade
310+ -- ^ specifies that when a referenced row is deleted,
311+ -- row(s) referencing it should be automatically deleted as well
312+ deriving (GHC.Generic,Show,Eq,Ord)
313+instance NFData OnDeleteClause
314+-- | Render `OnDeleteClause`.
315+instance RenderSQL OnDeleteClause where
316+ renderSQL = \case
317+ OnDeleteNoAction -> "ON DELETE NO ACTION"
318+ OnDeleteRestrict -> "ON DELETE RESTRICT"
319+ OnDeleteCascade -> "ON DELETE CASCADE"
320+
321+-- | Analagous to `OnDeleteClause` there is also `OnUpdateClause` which is invoked
322+-- when a referenced column is changed (updated).
323+data OnUpdateClause
324+ = OnUpdateNoAction
325+ -- ^ if any referencing rows has not changed when the constraint is checked,
326+ -- an error is raised
327+ | OnUpdateRestrict -- ^ prevents update of a referenced row
328+ | OnUpdateCascade
329+ -- ^ the updated values of the referenced column(s) should be copied
330+ -- into the referencing row(s)
331+ deriving (GHC.Generic,Show,Eq,Ord)
332+instance NFData OnUpdateClause
333+
334+-- | Render `OnUpdateClause`.
335+instance RenderSQL OnUpdateClause where
336+ renderSQL = \case
337+ OnUpdateNoAction -> "ON UPDATE NO ACTION"
338+ OnUpdateRestrict -> "ON UPDATE RESTRICT"
339+ OnUpdateCascade -> "ON UPDATE CASCADE"
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Type.hsnew file+229
@@ -0,0 +1,229 @@
1+{-|
2+Module: Squeal.PostgreSQL.Definition.Type
3+Description: Create and drop type definitions
4+Copyright: (c) Eitan Chatav, 2017
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Create and drop type definitions.
9+-}
10+
11+{-# LANGUAGE
12+ AllowAmbiguousTypes
13+ , ConstraintKinds
14+ , DeriveAnyClass
15+ , DeriveGeneric
16+ , DerivingStrategies
17+ , FlexibleContexts
18+ , FlexibleInstances
19+ , GADTs
20+ , LambdaCase
21+ , MultiParamTypeClasses
22+ , OverloadedLabels
23+ , OverloadedStrings
24+ , RankNTypes
25+ , ScopedTypeVariables
26+ , TypeApplications
27+ , TypeInType
28+ , TypeOperators
29+ , UndecidableSuperClasses
30+#-}
31+
32+module Squeal.PostgreSQL.Definition.Type
33+ ( createTypeEnum
34+ , createTypeEnumFrom
35+ , createTypeComposite
36+ , createTypeCompositeFrom
37+ , createTypeRange
38+ , createDomain
39+ , dropType
40+ , dropTypeIfExists
41+ ) where
42+
43+import Data.ByteString
44+import Data.Monoid
45+import GHC.TypeLits
46+import Prelude hiding ((.), id)
47+
48+import qualified Generics.SOP as SOP
49+
50+import Squeal.PostgreSQL.Alias
51+import Squeal.PostgreSQL.Expression.Logic
52+import Squeal.PostgreSQL.Expression.Type
53+import Squeal.PostgreSQL.Definition
54+import Squeal.PostgreSQL.List
55+import Squeal.PostgreSQL.PG
56+import Squeal.PostgreSQL.Render
57+import Squeal.PostgreSQL.Schema
58+
59+-- $setup
60+-- >>> import Squeal.PostgreSQL
61+-- >>> import qualified GHC.Generics as GHC
62+-- >>> import qualified Generics.SOP as SOP
63+
64+-- | Enumerated types are created using the `createTypeEnum` command, for example
65+--
66+-- >>> printSQL $ (createTypeEnum #mood (label @"sad" :* label @"ok" :* label @"happy") :: Definition (Public '[]) '["public" ::: '["mood" ::: 'Typedef ('PGenum '["sad","ok","happy"])]])
67+-- CREATE TYPE "mood" AS ENUM ('sad', 'ok', 'happy');
68+createTypeEnum
69+ :: (KnownSymbol enum, Has sch schemas schema, SOP.All KnownSymbol labels)
70+ => QualifiedAlias sch enum
71+ -- ^ name of the user defined enumerated type
72+ -> NP PGlabel labels
73+ -- ^ labels of the enumerated type
74+ -> Definition schemas (Alter sch (Create enum ('Typedef ('PGenum labels)) schema) schemas)
75+createTypeEnum enum labels = UnsafeDefinition $
76+ "CREATE" <+> "TYPE" <+> renderSQL enum <+> "AS" <+> "ENUM" <+>
77+ parenthesized (renderSQL labels) <> ";"
78+
79+-- | Enumerated types can also be generated from a Haskell type, for example
80+--
81+-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic
82+-- >>> instance SOP.Generic Schwarma
83+-- >>> instance SOP.HasDatatypeInfo Schwarma
84+-- >>> :{
85+-- let
86+-- createSchwarma :: Definition (Public '[]) '["public" ::: '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))]]
87+-- createSchwarma = createTypeEnumFrom @Schwarma #schwarma
88+-- in
89+-- printSQL createSchwarma
90+-- :}
91+-- CREATE TYPE "schwarma" AS ENUM ('Beef', 'Lamb', 'Chicken');
92+createTypeEnumFrom
93+ :: forall hask sch enum schemas schema.
94+ ( SOP.Generic hask
95+ , SOP.All KnownSymbol (LabelsPG hask)
96+ , KnownSymbol enum
97+ , Has sch schemas schema )
98+ => QualifiedAlias sch enum
99+ -- ^ name of the user defined enumerated type
100+ -> Definition schemas (Alter sch (Create enum ('Typedef (PG (Enumerated hask))) schema) schemas)
101+createTypeEnumFrom enum = createTypeEnum enum
102+ (SOP.hpure label :: NP PGlabel (LabelsPG hask))
103+
104+{- | `createTypeComposite` creates a composite type. The composite type is
105+specified by a list of attribute names and data types.
106+
107+>>> :{
108+type PGcomplex = 'PGcomposite
109+ '[ "real" ::: 'NotNull 'PGfloat8
110+ , "imaginary" ::: 'NotNull 'PGfloat8 ]
111+:}
112+
113+>>> :{
114+let
115+ setup :: Definition (Public '[]) '["public" ::: '["complex" ::: 'Typedef PGcomplex]]
116+ setup = createTypeComposite #complex
117+ (float8 `as` #real :* float8 `as` #imaginary)
118+in printSQL setup
119+:}
120+CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);
121+-}
122+createTypeComposite
123+ :: (KnownSymbol ty, Has sch schemas schema, SOP.SListI fields)
124+ => QualifiedAlias sch ty
125+ -- ^ name of the user defined composite type
126+ -> NP (Aliased (TypeExpression schemas)) fields
127+ -- ^ list of attribute names and data types
128+ -> Definition schemas (Alter sch (Create ty ('Typedef ('PGcomposite fields)) schema) schemas)
129+createTypeComposite ty fields = UnsafeDefinition $
130+ "CREATE" <+> "TYPE" <+> renderSQL ty <+> "AS" <+> parenthesized
131+ (renderCommaSeparated renderField fields) <> ";"
132+ where
133+ renderField :: Aliased (TypeExpression schemas) x -> ByteString
134+ renderField (typ `As` alias) =
135+ renderSQL alias <+> renderSQL typ
136+
137+-- | Composite types can also be generated from a Haskell type, for example
138+--
139+-- >>> data Complex = Complex {real :: Double, imaginary :: Double} deriving GHC.Generic
140+-- >>> instance SOP.Generic Complex
141+-- >>> instance SOP.HasDatatypeInfo Complex
142+-- >>> type Schema = '["complex" ::: 'Typedef (PG (Composite Complex))]
143+-- >>> :{
144+-- let
145+-- createComplex :: Definition (Public '[]) (Public Schema)
146+-- createComplex = createTypeCompositeFrom @Complex #complex
147+-- in
148+-- printSQL createComplex
149+-- :}
150+-- CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);
151+createTypeCompositeFrom
152+ :: forall hask sch ty schemas schema.
153+ ( SOP.All (FieldTyped schemas) (RowPG hask)
154+ , KnownSymbol ty
155+ , Has sch schemas schema )
156+ => QualifiedAlias sch ty
157+ -- ^ name of the user defined composite type
158+ -> Definition schemas (Alter sch (Create ty ( 'Typedef (PG (Composite hask))) schema) schemas)
159+createTypeCompositeFrom ty = createTypeComposite ty
160+ (SOP.hcpure (SOP.Proxy :: SOP.Proxy (FieldTyped schemas)) fieldtype
161+ :: NP (Aliased (TypeExpression schemas)) (RowPG hask))
162+
163+{-|
164+`createDomain` creates a new domain. A domain is essentially a data type
165+with constraints (restrictions on the allowed set of values).
166+
167+Domains are useful for abstracting common constraints on fields
168+into a single location for maintenance. For example, several tables might
169+contain email address columns, all requiring the same `check` constraint
170+to verify the address syntax. Define a domain rather than setting up
171+each table's constraint individually.
172+
173+>>> :{
174+let
175+ createPositive :: Definition (Public '[]) (Public '["positive" ::: 'Typedef 'PGfloat4])
176+ createPositive = createDomain #positive real (#value .> 0 .&& (#value & isNotNull))
177+in printSQL createPositive
178+:}
179+CREATE DOMAIN "positive" AS real CHECK ((("value" > 0) AND "value" IS NOT NULL));
180+-}
181+createDomain
182+ :: (Has sch schemas schema, KnownSymbol dom)
183+ => QualifiedAlias sch dom
184+ -> (forall null. TypeExpression schemas (null ty))
185+ -> (forall tab. Condition '[] '[] 'Ungrouped schemas '[] '[tab ::: '["value" ::: 'Null ty]])
186+ -> Definition schemas (Alter sch (Create dom ('Typedef ty) schema) schemas)
187+createDomain dom ty condition =
188+ UnsafeDefinition $ "CREATE DOMAIN" <+> renderSQL dom
189+ <+> "AS" <+> renderTypeExpression ty
190+ <+> "CHECK" <+> parenthesized (renderSQL condition) <> ";"
191+
192+{- |
193+>>> :{
194+let
195+ createSmallIntRange :: Definition (Public '[]) (Public '["int2range" ::: 'Typedef ('PGrange 'PGint2)])
196+ createSmallIntRange = createTypeRange #int2range int2
197+in printSQL createSmallIntRange
198+:}
199+CREATE TYPE "int2range" AS RANGE (subtype = int2);
200+-}
201+createTypeRange
202+ :: (Has sch schemas schema, KnownSymbol range)
203+ => QualifiedAlias sch range
204+ -> (forall null. TypeExpression schemas (null ty))
205+ -> Definition schemas (Alter sch (Create range ('Typedef ('PGrange ty)) schema) schemas)
206+createTypeRange range ty = UnsafeDefinition $
207+ "CREATE" <+> "TYPE" <+> renderSQL range <+> "AS" <+> "RANGE" <+>
208+ parenthesized ("subtype" <+> "=" <+> renderTypeExpression ty) <> ";"
209+
210+-- | Drop a type.
211+--
212+-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic
213+-- >>> instance SOP.Generic Schwarma
214+-- >>> instance SOP.HasDatatypeInfo Schwarma
215+-- >>> printSQL (dropType #schwarma :: Definition '["public" ::: '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))]] (Public '[]))
216+-- DROP TYPE "schwarma";
217+dropType
218+ :: (Has sch schemas schema, KnownSymbol td)
219+ => QualifiedAlias sch td
220+ -- ^ name of the user defined type
221+ -> Definition schemas (Alter sch (DropSchemum td 'Typedef schema) schemas)
222+dropType tydef = UnsafeDefinition $ "DROP" <+> "TYPE" <+> renderSQL tydef <> ";"
223+
224+dropTypeIfExists
225+ :: (Has sch schemas schema, KnownSymbol td)
226+ => QualifiedAlias sch td
227+ -- ^ name of the user defined type
228+ -> Definition schemas (Alter sch (DropSchemumIfExists td 'Typedef schema) schemas)
229+dropTypeIfExists tydef = UnsafeDefinition $ "DROP" <+> "TYPE" <+> renderSQL tydef <> ";"
squeal-postgresql/src/Squeal/PostgreSQL/Definition/View.hsnew file+104
@@ -0,0 +1,104 @@
1+{-|
2+Module: Squeal.PostgreSQL.Definition.View
3+Description: Create and drop view definitions
4+Copyright: (c) Eitan Chatav, 2017
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Create and drop view definitions.
9+-}
10+
11+{-# LANGUAGE
12+ AllowAmbiguousTypes
13+ , ConstraintKinds
14+ , DeriveAnyClass
15+ , DeriveGeneric
16+ , DerivingStrategies
17+ , FlexibleContexts
18+ , FlexibleInstances
19+ , GADTs
20+ , LambdaCase
21+ , MultiParamTypeClasses
22+ , OverloadedLabels
23+ , OverloadedStrings
24+ , RankNTypes
25+ , ScopedTypeVariables
26+ , TypeApplications
27+ , TypeInType
28+ , TypeOperators
29+ , UndecidableSuperClasses
30+#-}
31+
32+module Squeal.PostgreSQL.Definition.View
33+ ( createView
34+ , createOrReplaceView
35+ , dropView
36+ , dropViewIfExists
37+ ) where
38+
39+import GHC.TypeLits
40+
41+import Squeal.PostgreSQL.Alias
42+import Squeal.PostgreSQL.Definition
43+import Squeal.PostgreSQL.Query
44+import Squeal.PostgreSQL.Render
45+import Squeal.PostgreSQL.Schema
46+
47+-- $setup
48+-- >>> import Squeal.PostgreSQL
49+
50+{- | Create a view.
51+>>> type ABC = '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4]
52+>>> type BC = '["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4]
53+>>> :{
54+let
55+ definition :: Definition
56+ '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC)]]
57+ '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC), "bc" ::: 'View BC]]
58+ definition =
59+ createView #bc (select_ (#b :* #c) (from (table #abc)))
60+in printSQL definition
61+:}
62+CREATE VIEW "bc" AS SELECT "b" AS "b", "c" AS "c" FROM "abc" AS "abc";
63+-}
64+createView
65+ :: (Has sch schemas schema, KnownSymbol vw)
66+ => QualifiedAlias sch vw -- ^ the name of the view to add
67+ -> Query '[] '[] schemas '[] view -- ^ query
68+ -> Definition schemas (Alter sch (Create vw ('View view) schema) schemas)
69+createView alias query = UnsafeDefinition $
70+ "CREATE" <+> "VIEW" <+> renderSQL alias <+> "AS"
71+ <+> renderQuery query <> ";"
72+
73+createOrReplaceView
74+ :: (Has sch schemas schema, KnownSymbol vw)
75+ => QualifiedAlias sch vw -- ^ the name of the view to add
76+ -> Query '[] '[] schemas '[] view -- ^ query
77+ -> Definition schemas (Alter sch (CreateOrReplace vw ('View view) schema) schemas)
78+createOrReplaceView alias query = UnsafeDefinition $
79+ "CREATE OR REPLACE VIEW" <+> renderSQL alias <+> "AS"
80+ <+> renderQuery query <> ";"
81+
82+-- | Drop a view.
83+--
84+-- >>> :{
85+-- let
86+-- definition :: Definition
87+-- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])
88+-- , "bc" ::: 'View ('["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4])]]
89+-- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])]]
90+-- definition = dropView #bc
91+-- in printSQL definition
92+-- :}
93+-- DROP VIEW "bc";
94+dropView
95+ :: (Has sch schemas schema, KnownSymbol vw)
96+ => QualifiedAlias sch vw -- ^ view to remove
97+ -> Definition schemas (Alter sch (DropSchemum vw 'View schema) schemas)
98+dropView vw = UnsafeDefinition $ "DROP VIEW" <+> renderSQL vw <> ";"
99+
100+dropViewIfExists
101+ :: (Has sch schemas schema, KnownSymbol vw)
102+ => QualifiedAlias sch vw -- ^ view to remove
103+ -> Definition schemas (Alter sch (DropIfExists vw schema) schemas)
104+dropViewIfExists vw = UnsafeDefinition $ "DROP VIEW IF EXISTS" <+> renderSQL vw <> ";"
squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs+268−1987
@@ -1,14 +1,13 @@
11{-|
2−Module: Squeal.PostgreSQL.Query
2+Module: Squeal.PostgreSQL.Expression
33Description: Squeal expressions
4−Copyright: (c) Eitan Chatav, 2017
4+Copyright: (c) Eitan Chatav, 2019
55Maintainer: eitan@morphism.tech
66Stability: experimental
77
88Squeal expressions are the atoms used to build statements.
99-}
1010
11−{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
1211{-# LANGUAGE
1312 AllowAmbiguousTypes
1413 , ConstraintKinds
@@ -34,585 +33,350 @@ Squeal expressions are the atoms used to build statements.
3433module Squeal.PostgreSQL.Expression
3534 ( -- * Expression
3635 Expression (..)
37− , HasParameter (parameter)
38− , param
39− -- ** Null
40− , null_
41− , notNull
42− , coalesce
43− , fromNull
44− , isNull
45− , isNotNull
46− , matchNull
47− , nullIf
48− -- ** Collections
49− , array
50− , index
51− , row
52− , field
53− -- ** Functions
54− , unsafeBinaryOp
55− , unsafeUnaryOp
36+ , Expr
37+ , type (-->)
38+ , FunctionDB
5639 , unsafeFunction
57− , unsafeVariadicFunction
58− , atan2_
59− , cast
60− , quot_
61− , rem_
62− , trunc
63− , round_
64− , ceiling_
65− , greatest
66− , least
67− -- ** Conditions
68− , true
69− , false
70− , not_
71− , (.&&)
72− , (.||)
73− , Condition
74− , caseWhenThenElse
75− , ifThenElse
76− , (.==)
77− , (./=)
78− , (.>=)
79− , (.<)
80− , (.<=)
81− , (.>)
82− -- ** Time
83− , currentDate
84− , currentTime
85− , currentTimestamp
86− , localTime
87− , localTimestamp
88− -- ** Text
89− , lower
90− , upper
91− , charLength
92− , like
93− , ilike
94− -- ** Json
95− -- *** Json and Jsonb operators
96− , (.->)
97− , (.->>)
98− , (.#>)
99− , (.#>>)
100− -- *** Jsonb operators
101− , (.@>)
102− , (.<@)
103− , (.?)
104− , (.?|)
105− , (.?&)
106− , (.-.)
107− , (#-.)
108− -- *** Functions
109− , jsonLit
110− , jsonbLit
111− , toJson
112− , toJsonb
113− , arrayToJson
114− , rowToJson
115− , jsonBuildArray
116− , jsonbBuildArray
117− , jsonBuildObject
118− , jsonbBuildObject
119− , jsonObject
120− , jsonbObject
121− , jsonZipObject
122− , jsonbZipObject
123− , jsonArrayLength
124− , jsonbArrayLength
125− , jsonExtractPath
126− , jsonbExtractPath
127− , jsonExtractPathAsText
128− , jsonbExtractPathAsText
129− , jsonTypeof
130− , jsonbTypeof
131− , jsonStripNulls
132− , jsonbStripNulls
133− , jsonbSet
134− , jsonbInsert
135− , jsonbPretty
136− -- ** Aggregation
137− , Aggregate (..)
138− , Distinction (..)
139− , PGAvg
140− -- * Window Functions
141− , WindowDefinition (..)
142− , partitionBy
143− , WindowFunction (..)
144− , rank
145− , rowNumber
146− , denseRank
147− , percentRank
148− , cumeDist
149− , ntile
150− , lag
151− , lead
152− , firstValue
153− , lastValue
154− , nthValue
155− -- * Sorting
156− , SortExpression (..)
157− , OrderBy (..)
158− -- * Types
159− , TypeExpression (..)
160− , PGTyped (..)
161− , typedef
162− , typetable
163− , typeview
164− , bool
165− , int2
166− , smallint
167− , int4
168− , int
169− , integer
170− , int8
171− , bigint
172− , numeric
173− , float4
174− , real
175− , float8
176− , doublePrecision
177− , text
178− , char
179− , character
180− , varchar
181− , characterVarying
182− , bytea
183− , timestamp
184− , timestampWithTimeZone
185− , date
186− , time
187− , timeWithTimeZone
188− , interval
189− , uuid
190− , inet
191− , json
192− , jsonb
193− , vararray
194− , fixarray
40+ , function
41+ , unsafeLeftOp
42+ , leftOp
43+ , unsafeRightOp
44+ , rightOp
45+ , Operator
46+ , OperatorDB
47+ , unsafeBinaryOp
48+ , binaryOp
49+ , FunctionVar
50+ , unsafeFunctionVar
51+ , type (--->)
52+ , FunctionNDB
53+ , unsafeFunctionN
54+ , functionN
55+ , PGSubset (..)
56+ , PGIntersect (..)
19557 -- * Re-export
19658 , (&)
197− , NP (..)
198− , (:*:) (..)
199− , I (..)
20059 , K (..)
60+ , unK
20161 ) where
20262
20363import Control.Category
20464import Control.DeepSeq
20565import Data.ByteString (ByteString)
206−import Data.ByteString.Lazy (toStrict)
20766import Data.Function ((&))
20867import Data.Semigroup hiding (All)
209−import qualified Data.Aeson as JSON
210−import Data.Ratio
21168import Data.String
212−import Data.Word
213−import Generics.SOP hiding (from)
214−import GHC.Generics ((:*:) (..))
69+import Generics.SOP hiding (All, from)
21570import GHC.OverloadedLabels
21671import GHC.TypeLits
72+import Numeric
21773import Prelude hiding (id, (.))
21874
219−import qualified Data.ByteString as ByteString
22075import qualified GHC.Generics as GHC
22176
77+import Squeal.PostgreSQL.Alias
78+import Squeal.PostgreSQL.List
22279import Squeal.PostgreSQL.Render
22380import Squeal.PostgreSQL.Schema
22481
82+-- $setup
83+-- >>> import Squeal.PostgreSQL
84+
22585{-----------------------------------------
22686column expressions
22787-----------------------------------------}
22888
22989{- | `Expression`s are used in a variety of contexts,
230−such as in the target list of the `Squeal.PostgreSQL.Query.select` command,
90+such as in the target `Squeal.PostgreSQL.Query.List` of the
91+`Squeal.PostgreSQL.Query.select` command,
23192as new column values in `Squeal.PostgreSQL.Manipulation.insertRow` or
23293`Squeal.PostgreSQL.Manipulation.update`,
233−or in search `Condition`s in a number of commands.
94+or in search `Squeal.PostgreSQL.Logic.Condition`s in a number of commands.
23495
23596The expression syntax allows the calculation of
23697values from primitive expression using arithmetic, logical,
23798and 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`.
238113-}
239114newtype Expression
240− (grp :: Grouping)
115+ (outer :: FromType)
241116 (commons :: FromType)
117+ (grp :: Grouping)
242118 (schemas :: SchemasType)
243119 (params :: [NullityType])
244120 (from :: FromType)
245121 (ty :: NullityType)
246122 = UnsafeExpression { renderExpression :: ByteString }
247123 deriving (GHC.Generic,Show,Eq,Ord,NFData)
248−
249−instance RenderSQL (Expression grp commons schemas params from ty) where
124+instance RenderSQL (Expression outer commons grp schemas params from ty) where
250125 renderSQL = renderExpression
251126
252−{- | A `HasParameter` constraint is used to indicate a value that is
253−supplied externally to a SQL statement.
254−`Squeal.PostgreSQL.PQ.manipulateParams`,
255−`Squeal.PostgreSQL.PQ.queryParams` and
256−`Squeal.PostgreSQL.PQ.traversePrepared` support specifying data values
257−separately from the SQL command string, in which case `param`s are used to
258−refer to the out-of-line data values.
127+-- | An `Expr` is a closed `Expression`.
128+-- It is a F@RankNType@ but don't be scared.
129+-- Think of it as an expression which sees no
130+-- namespaces, so you can't use parameters
131+-- or alias references. It can be used as
132+-- a simple piece of more complex `Expression`s.
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)
259181-}
260−class KnownNat n => HasParameter
261− (n :: Nat)
262− (params :: [NullityType])
263− (ty :: NullityType)
264− | n params -> ty where
265− -- | `parameter` takes a `Nat` using type application and a `TypeExpression`.
266− --
267− -- >>> let expr = parameter @1 int4 :: Expression grp '[] schemas '[ 'Null 'PGint4] from ('Null 'PGint4)
268− -- >>> printSQL expr
269− -- ($1 :: int4)
270− parameter
271− :: TypeExpression schemas ty
272− -> Expression grp commons schemas params from ty
273− parameter ty = UnsafeExpression $ parenthesized $
274− "$" <> renderNat @n <+> "::"
275− <+> renderSQL ty
276−instance {-# OVERLAPPING #-} HasParameter 1 (ty1:tys) ty1
277−instance {-# OVERLAPPABLE #-} (KnownNat n, HasParameter (n-1) params ty)
278− => HasParameter n (ty' : params) ty
279−
280−-- | `param` takes a `Nat` using type application and for basic types,
281−-- infers a `TypeExpression`.
282−--
283−-- >>> let expr = param @1 :: Expression grp commons schemas '[ 'Null 'PGint4] from ('Null 'PGint4)
284−-- >>> printSQL expr
285−-- ($1 :: int4)
286−param
287− :: forall n commons schemas params from grp ty
288− . (PGTyped schemas ty, HasParameter n params ty)
289− => Expression grp commons schemas params from ty -- ^ param
290−param = parameter @n (pgtype @schemas)
182+type (--->) xs y
183+ = forall outer commons grp schemas params from
184+ . NP (Expression outer commons grp schemas params from) xs
185+ -- ^ inputs
186+ -> Expression outer commons grp schemas params from y
187+ -- ^ output
188+
189+type FunctionNDB schemas xs y
190+ = forall outer commons grp params from
191+ . NP (Expression outer commons grp schemas params from) xs
192+ -- ^ inputs
193+ -> Expression outer commons grp schemas params from y
194+ -- ^ output
195+
196+{- | A @RankNType@ for functions with a variable-length list of
197+homogeneous arguments and at least 1 more argument.
198+-}
199+type FunctionVar x0 x1 y
200+ = forall outer commons grp schemas params from
201+ . [Expression outer commons grp schemas params from x0]
202+ -- ^ inputs
203+ -> Expression outer commons grp schemas params from x1
204+ -- ^ must have at least 1 input
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)
291214
292−instance (HasUnique tab from row, Has col row ty)
293− => IsLabel col (Expression 'Ungrouped commons schemas params from ty) where
215+instance (HasUnique tab (Join outer from) row, Has col row ty)
216+ => IsLabel col (Expression outer commons 'Ungrouped schemas params from ty) where
294217 fromLabel = UnsafeExpression $ renderSQL (Alias @col)
295−instance (HasUnique tab from row, Has col row ty, tys ~ '[ty])
296− => IsLabel col (NP (Expression 'Ungrouped commons schemas params from) tys) where
218+instance (HasUnique tab (Join outer from) row, Has col row ty, tys ~ '[ty])
219+ => IsLabel col (NP (Expression outer commons 'Ungrouped schemas params from) tys) where
297220 fromLabel = fromLabel @col :* Nil
298−instance (HasUnique tab from row, Has col row ty, column ~ (col ::: ty))
221+instance (HasUnique tab (Join outer from) row, Has col row ty, column ~ (col ::: ty))
299222 => IsLabel col
300− (Aliased (Expression 'Ungrouped commons schemas params from) column) where
223+ (Aliased (Expression outer commons 'Ungrouped schemas params from) column) where
301224 fromLabel = fromLabel @col `As` Alias
302−instance (HasUnique tab from row, Has col row ty, columns ~ '[col ::: ty])
225+instance (HasUnique tab (Join outer from) row, Has col row ty, columns ~ '[col ::: ty])
303226 => IsLabel col
304− (NP (Aliased (Expression 'Ungrouped commons schemas params from)) columns) where
227+ (NP (Aliased (Expression outer commons 'Ungrouped schemas params from)) columns) where
305228 fromLabel = fromLabel @col :* Nil
306229
307−instance (Has tab from row, Has col row ty)
308− => IsQualified tab col (Expression 'Ungrouped commons schemas params from ty) where
230+instance (Has tab (Join outer from) row, Has col row ty)
231+ => IsQualified tab col (Expression outer commons 'Ungrouped schemas params from ty) where
309232 tab ! col = UnsafeExpression $
310233 renderSQL tab <> "." <> renderSQL col
311−instance (Has tab from row, Has col row ty, tys ~ '[ty])
312− => IsQualified tab col (NP (Expression 'Ungrouped commons schemas params from) tys) where
234+instance (Has tab (Join outer from) row, Has col row ty, tys ~ '[ty])
235+ => IsQualified tab col (NP (Expression outer commons 'Ungrouped schemas params from) tys) where
313236 tab ! col = tab ! col :* Nil
314−instance (Has tab from row, Has col row ty, column ~ (col ::: ty))
237+instance (Has tab (Join outer from) row, Has col row ty, column ~ (col ::: ty))
315238 => IsQualified tab col
316− (Aliased (Expression 'Ungrouped commons schemas params from) column) where
239+ (Aliased (Expression outer commons 'Ungrouped schemas params from) column) where
317240 tab ! col = tab ! col `As` col
318−instance (Has tab from row, Has col row ty, columns ~ '[col ::: ty])
241+instance (Has tab (Join outer from) row, Has col row ty, columns ~ '[col ::: ty])
319242 => IsQualified tab col
320− (NP (Aliased (Expression 'Ungrouped commons schemas params from)) columns) where
243+ (NP (Aliased (Expression outer commons 'Ungrouped schemas params from)) columns) where
321244 tab ! col = tab ! col :* Nil
322245
323246instance
324− ( HasUnique tab from row
247+ ( HasUnique tab (Join outer from) row
325248 , Has col row ty
326249 , GroupedBy tab col bys
327250 ) => IsLabel col
328− (Expression ('Grouped bys) commons schemas params from ty) where
251+ (Expression outer commons ('Grouped bys) schemas params from ty) where
329252 fromLabel = UnsafeExpression $ renderSQL (Alias @col)
330253instance
331− ( HasUnique tab from row
254+ ( HasUnique tab (Join outer from) row
332255 , Has col row ty
333256 , GroupedBy tab col bys
334257 , tys ~ '[ty]
335258 ) => IsLabel col
336− (NP (Expression ('Grouped bys) commons schemas params from) tys) where
259+ (NP (Expression outer commons ('Grouped bys) schemas params from) tys) where
337260 fromLabel = fromLabel @col :* Nil
338261instance
339− ( HasUnique tab from row
262+ ( HasUnique tab (Join outer from) row
340263 , Has col row ty
341264 , GroupedBy tab col bys
342265 , column ~ (col ::: ty)
343266 ) => IsLabel col
344− (Aliased (Expression ('Grouped bys) commons schemas params from) column) where
267+ (Aliased (Expression outer commons ('Grouped bys) schemas params from) column) where
345268 fromLabel = fromLabel @col `As` Alias
346269instance
347− ( HasUnique tab from row
270+ ( HasUnique tab (Join outer from) row
348271 , Has col row ty
349272 , GroupedBy tab col bys
350273 , columns ~ '[col ::: ty]
351274 ) => IsLabel col
352− (NP (Aliased (Expression ('Grouped bys) commons schemas params from)) columns) where
275+ (NP (Aliased (Expression outer commons ('Grouped bys) schemas params from)) columns) where
353276 fromLabel = fromLabel @col :* Nil
354277
355278instance
356− ( Has tab from row
279+ ( Has tab (Join outer from) row
357280 , Has col row ty
358281 , GroupedBy tab col bys
359282 ) => IsQualified tab col
360− (Expression ('Grouped bys) commons schemas params from ty) where
283+ (Expression outer commons ('Grouped bys) schemas params from ty) where
361284 tab ! col = UnsafeExpression $
362285 renderSQL tab <> "." <> renderSQL col
363286instance
364− ( Has tab from row
287+ ( Has tab (Join outer from) row
365288 , Has col row ty
366289 , GroupedBy tab col bys
367290 , tys ~ '[ty]
368291 ) => IsQualified tab col
369− (NP (Expression ('Grouped bys) commons schemas params from) tys) where
292+ (NP (Expression outer commons ('Grouped bys) schemas params from) tys) where
370293 tab ! col = tab ! col :* Nil
371294instance
372− ( Has tab from row
295+ ( Has tab (Join outer from) row
373296 , Has col row ty
374297 , GroupedBy tab col bys
375298 , column ~ (col ::: ty)
376299 ) => IsQualified tab col
377− (Aliased (Expression ('Grouped bys) commons schemas params from) column) where
300+ (Aliased (Expression outer commons ('Grouped bys) schemas params from) column) where
378301 tab ! col = tab ! col `As` col
379302instance
380− ( Has tab from row
303+ ( Has tab (Join outer from) row
381304 , Has col row ty
382305 , GroupedBy tab col bys
383306 , columns ~ '[col ::: ty]
384307 ) => IsQualified tab col
385− (NP (Aliased (Expression ('Grouped bys) commons schemas params from)) columns) where
308+ (NP (Aliased (Expression outer commons ('Grouped bys) schemas params from)) columns) where
386309 tab ! col = tab ! col :* Nil
387310
388−-- | analagous to `Nothing`
389−--
390−-- >>> printSQL null_
391−-- NULL
392−null_ :: Expression commons schemas rels grouping params ('Null ty)
393−null_ = UnsafeExpression "NULL"
394−
395−-- | analagous to `Just`
396−--
397−-- >>> printSQL $ notNull true
398−-- TRUE
399−notNull
400− :: Expression commons schemas rels grouping params ('NotNull ty)
401− -> Expression commons schemas rels grouping params ('Null ty)
402−notNull = UnsafeExpression . renderSQL
403−
404−-- | return the leftmost value which is not NULL
405−--
406−-- >>> printSQL $ coalesce [null_, true] false
407−-- COALESCE(NULL, TRUE, FALSE)
408−coalesce
409− :: [Expression grp commons schemas params from ('Null ty)]
410− -- ^ @NULL@s may be present
411− -> Expression grp commons schemas params from ('NotNull ty)
412− -- ^ @NULL@ is absent
413− -> Expression grp commons schemas params from ('NotNull ty)
414−coalesce nullxs notNullx = UnsafeExpression $
415− "COALESCE" <> parenthesized (commaSeparated
416− ((renderSQL <$> nullxs) <> [renderSQL notNullx]))
417−
418−-- | analagous to `Data.Maybe.fromMaybe` using @COALESCE@
419−--
420−-- >>> printSQL $ fromNull true null_
421−-- COALESCE(NULL, TRUE)
422−fromNull
423− :: Expression grp commons schemas params from ('NotNull ty)
424− -- ^ what to convert @NULL@ to
425− -> Expression grp commons schemas params from ('Null ty)
426− -> Expression grp commons schemas params from ('NotNull ty)
427−fromNull notNullx nullx = coalesce [nullx] notNullx
428−
429−-- | >>> printSQL $ null_ & isNull
430−-- NULL IS NULL
431−isNull
432− :: Expression grp commons schemas params from ('Null ty)
433− -- ^ possibly @NULL@
434− -> Condition grp commons schemas params from
435−isNull x = UnsafeExpression $ renderSQL x <+> "IS NULL"
436−
437−-- | >>> printSQL $ null_ & isNotNull
438−-- NULL IS NOT NULL
439−isNotNull
440− :: Expression grp commons schemas params from ('Null ty)
441− -- ^ possibly @NULL@
442− -> Condition grp commons schemas params from
443−isNotNull x = UnsafeExpression $ renderSQL x <+> "IS NOT NULL"
444−
445−-- | analagous to `maybe` using @IS NULL@
446−--
447−-- >>> printSQL $ matchNull true not_ null_
448−-- CASE WHEN NULL IS NULL THEN TRUE ELSE (NOT NULL) END
449−matchNull
450− :: Expression grp commons schemas params from (nullty)
451− -- ^ what to convert @NULL@ to
452− -> ( Expression grp commons schemas params from ('NotNull ty)
453− -> Expression grp commons schemas params from (nullty) )
454− -- ^ function to perform when @NULL@ is absent
455− -> Expression grp commons schemas params from ('Null ty)
456− -> Expression grp commons schemas params from (nullty)
457−matchNull y f x = ifThenElse (isNull x) y
458− (f (UnsafeExpression (renderSQL x)))
459−
460−{-| right inverse to `fromNull`, if its arguments are equal then
461−`nullIf` gives @NULL@.
462−
463−>>> :set -XTypeApplications -XDataKinds
464−>>> let expr = nullIf false (param @1) :: Expression grp commons schemas '[ 'NotNull 'PGbool] from ('Null 'PGbool)
465−>>> printSQL expr
466−NULL IF (FALSE, ($1 :: bool))
467−-}
468−nullIf
469− :: Expression grp commons schemas params from ('NotNull ty)
470− -- ^ @NULL@ is absent
471− -> Expression grp commons schemas params from ('NotNull ty)
472− -- ^ @NULL@ is absent
473− -> Expression grp commons schemas params from ('Null ty)
474−nullIf x y = UnsafeExpression $ "NULL IF" <+> parenthesized
475− (renderSQL x <> ", " <> renderSQL y)
476−
477−-- | >>> printSQL $ array [null_, false, true]
478−-- ARRAY[NULL, FALSE, TRUE]
479−array
480− :: [Expression grp commons schemas params from ty]
481− -- ^ array elements
482− -> Expression grp commons schemas params from (nullity ('PGvararray ty))
483−array xs = UnsafeExpression $
484− "ARRAY[" <> commaSeparated (renderSQL <$> xs) <> "]"
485−
486−-- | >>> printSQL $ array [null_, false, true] & index 2
487−-- (ARRAY[NULL, FALSE, TRUE])[2]
488−index
489− :: Word64 -- ^ index
490− -> Expression grp commons schemas params from (nullity ('PGvararray ty)) -- ^ array
491− -> Expression grp commons schemas params from (NullifyType ty)
492−index n expr = UnsafeExpression $
493− parenthesized (renderSQL expr) <> "[" <> fromString (show n) <> "]"
494−
495311instance (KnownSymbol label, label `In` labels) => IsPGlabel label
496− (Expression grp commons schemas params from (nullity ('PGenum labels))) where
312+ (Expression outer commons grp schemas params from (null ('PGenum labels))) where
497313 label = UnsafeExpression $ renderSQL (PGlabel @label)
498314
499−-- | A row constructor is an expression that builds a row value
500−-- (also called a composite value) using values for its member fields.
501−--
502−-- >>> :{
503−-- type Complex = 'PGcomposite
504−-- '[ "real" ::: 'NotNull 'PGfloat8
505−-- , "imaginary" ::: 'NotNull 'PGfloat8 ]
506−-- :}
507−--
508−-- >>> let i = row (0 `as` #real :* 1 `as` #imaginary) :: Expression grp commons schemas params from ('NotNull Complex)
509−-- >>> printSQL i
510−-- ROW(0, 1)
511−row
512− :: SListI row
513− => NP (Aliased (Expression grp commons schemas params from)) row
514− -- ^ zero or more expressions for the row field values
515− -> Expression grp commons schemas params from (nullity ('PGcomposite row))
516−row exprs = UnsafeExpression $ "ROW" <> parenthesized
517− (renderCommaSeparated (\ (expr `As` _) -> renderSQL expr) exprs)
518−
519−-- | >>> :{
520−-- type Complex = 'PGcomposite
521−-- '[ "real" ::: 'NotNull 'PGfloat8
522−-- , "imaginary" ::: 'NotNull 'PGfloat8 ]
523−-- type Schema = '["complex" ::: 'Typedef Complex]
524−-- :}
525−--
526−-- >>> let i = row (0 `as` #real :* 1 `as` #imaginary) :: Expression grp '[] (Public Schema) from params ('NotNull Complex)
527−-- >>> printSQL $ i & field #complex #imaginary
528−-- (ROW(0, 1)::"complex")."imaginary"
529−field
530− :: ( Has sch schemas schema
531− , Has tydef schema ('Typedef ('PGcomposite row))
532− , Has field row ty)
533− => QualifiedAlias sch tydef -- ^ row type
534− -> Alias field -- ^ field name
535− -> Expression grp commons schemas params from ('NotNull ('PGcomposite row))
536− -> Expression grp commons schemas params from ty
537−field td fld expr = UnsafeExpression $
538− parenthesized (renderSQL expr <> "::" <> renderSQL td)
539− <> "." <> renderSQL fld
540−
541−instance Semigroup
542− (Expression grp commons schemas params from (nullity ('PGvararray ty))) where
543− (<>) = unsafeBinaryOp "||"
544−
545−instance Monoid
546− (Expression grp commons schemas params from (nullity ('PGvararray ty))) where
547− mempty = array []
548− mappend = (<>)
549−
550−-- | >>> let expr = greatest currentTimestamp [param @1] :: Expression grp commons schemas '[ 'NotNull 'PGtimestamptz] from ('NotNull 'PGtimestamptz)
551−-- >>> printSQL expr
552−-- GREATEST(CURRENT_TIMESTAMP, ($1 :: timestamp with time zone))
553−greatest
554− :: Expression grp commons schemas params from (nullty)
555− -- ^ needs at least 1 argument
556− -> [Expression grp commons schemas params from (nullty)]
557− -- ^ or more
558− -> Expression grp commons schemas params from (nullty)
559−greatest x xs = UnsafeExpression $ "GREATEST("
560− <> commaSeparated (renderSQL <$> (x:xs)) <> ")"
561−
562−-- | >>> printSQL $ least currentTimestamp [null_]
563−-- LEAST(CURRENT_TIMESTAMP, NULL)
564−least
565− :: Expression grp commons schemas params from (nullty)
566− -- ^ needs at least 1 argument
567− -> [Expression grp commons schemas params from (nullty)]
568− -- ^ or more
569− -> Expression grp commons schemas params from (nullty)
570−least x xs = UnsafeExpression $ "LEAST("
571− <> commaSeparated (renderSQL <$> (x:xs)) <> ")"
572−
573315-- | >>> printSQL $ unsafeBinaryOp "OR" true false
574316-- (TRUE OR FALSE)
575−unsafeBinaryOp
576− :: ByteString
577− -- ^ operator
578− -> Expression grp commons schemas params from (ty0)
579− -> Expression grp commons schemas params from (ty1)
580− -> Expression grp commons schemas params from (ty2)
317+unsafeBinaryOp :: ByteString -> Operator ty0 ty1 ty2
581318unsafeBinaryOp op x y = UnsafeExpression $ parenthesized $
582319 renderSQL x <+> op <+> renderSQL y
583320
584−-- | >>> printSQL $ unsafeUnaryOp "NOT" true
321+binaryOp
322+ :: forall op sch schemas schema x y z.
323+ ( Has sch schemas schema
324+ , Has op schema ('Operator ('BinaryOp x y z)) )
325+ => OperatorDB schemas x y z
326+binaryOp = unsafeBinaryOp $ renderSymbol @op
327+
328+-- | >>> printSQL $ unsafeLeftOp "NOT" true
585329-- (NOT TRUE)
586−unsafeUnaryOp
587− :: ByteString
588− -- ^ operator
589− -> Expression grp commons schemas params from (ty0)
590− -> Expression grp commons schemas params from (ty1)
591−unsafeUnaryOp op x = UnsafeExpression $ parenthesized $
592− op <+> renderSQL x
330+unsafeLeftOp :: ByteString -> x --> y
331+unsafeLeftOp op x = UnsafeExpression $ parenthesized $ op <+> renderSQL x
332+
333+leftOp
334+ :: forall op sch schemas schema x y.
335+ ( Has sch schemas schema
336+ , Has op schema ('Operator ('LeftOp x y)) )
337+ => FunctionDB schemas x y
338+leftOp = unsafeLeftOp $ renderSymbol @op
339+
340+-- | >>> printSQL $ true & unsafeRightOp "IS NOT TRUE"
341+-- (TRUE IS NOT TRUE)
342+unsafeRightOp :: ByteString -> x --> y
343+unsafeRightOp op x = UnsafeExpression $ parenthesized $ renderSQL x <+> op
344+
345+rightOp
346+ :: forall op sch schemas schema x y.
347+ ( Has sch schemas schema
348+ , Has op schema ('Operator ('RightOp x y)) )
349+ => FunctionDB schemas x y
350+rightOp = unsafeRightOp $ renderSymbol @op
593351
594352-- | >>> printSQL $ unsafeFunction "f" true
595353-- f(TRUE)
596−unsafeFunction
597− :: ByteString
598− -- ^ function
599− -> Expression grp commons schemas params from (xty)
600− -> Expression grp commons schemas params from (yty)
354+unsafeFunction :: ByteString -> x --> y
601355unsafeFunction fun x = UnsafeExpression $
602356 fun <> parenthesized (renderSQL x)
603357
604−-- | Helper for defining variadic functions.
605−unsafeVariadicFunction
606− :: SListI elems
607− => ByteString
608− -- ^ function
609− -> NP (Expression grp commons schemas params from) elems
610− -> Expression grp commons schemas params from ret
611−unsafeVariadicFunction fun x = UnsafeExpression $
612− fun <> parenthesized (commaSeparated (hcollapse (hmap (K . renderSQL) x)))
358+function
359+ :: (Has sch schemas schema, Has fun schema ('Function ('[x] :=> 'Returns y)))
360+ => QualifiedAlias sch fun
361+ -> FunctionDB schemas x y
362+function = unsafeFunction . renderSQL
363+
364+-- | >>> printSQL $ unsafeFunctionN "f" (currentTime :* localTimestamp :* false *: literal 'a')
365+-- f(CURRENT_TIME, LOCALTIMESTAMP, FALSE, E'a')
366+unsafeFunctionN :: SListI xs => ByteString -> xs ---> y
367+unsafeFunctionN fun xs = UnsafeExpression $
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
613377
614378instance ty `In` PGNum
615− => Num (Expression grp commons schemas params from (nullity ty)) where
379+ => Num (Expression outer commons grp schemas params from (null ty)) where
616380 (+) = unsafeBinaryOp "+"
617381 (-) = unsafeBinaryOp "-"
618382 (*) = unsafeBinaryOp "*"
@@ -624,12 +388,17 @@ instance ty `In` PGNum
624388 . show
625389
626390instance (ty `In` PGNum, ty `In` PGFloating) => Fractional
627− (Expression grp commons schemas params from (nullity ty)) where
391+ (Expression outer commons grp schemas params from (null ty)) where
628392 (/) = unsafeBinaryOp "/"
629− fromRational x = fromInteger (numerator x) / fromInteger (denominator x)
393+ fromRational
394+ = UnsafeExpression
395+ . fromString
396+ . ($ "")
397+ . showFFloat Nothing
398+ . fromRat @Double
630399
631400instance (ty `In` PGNum, ty `In` PGFloating) => Floating
632− (Expression grp commons schemas params from (nullity ty)) where
401+ (Expression outer commons grp schemas params from (null ty)) where
633402 pi = UnsafeExpression "pi()"
634403 exp = unsafeFunction "exp"
635404 log = unsafeFunction "ln"
@@ -650,1542 +419,54 @@ instance (ty `In` PGNum, ty `In` PGFloating) => Floating
650419 acosh x = log (x + sqrt (x*x - 1))
651420 atanh x = log ((1 + x) / (1 - x)) / 2
652421
653−-- | >>> :{
654−-- let
655−-- expression :: Expression grp commons schemas params from (nullity 'PGfloat4)
656−-- expression = atan2_ pi 2
657−-- in printSQL expression
658−-- :}
659−-- atan2(pi(), 2)
660−atan2_
661− :: float `In` PGFloating
662− => Expression grp commons schemas params from (nullity float)
663− -- ^ numerator
664− -> Expression grp commons schemas params from (nullity float)
665− -- ^ denominator
666− -> Expression grp commons schemas params from (nullity float)
667−atan2_ y x = UnsafeExpression $
668− "atan2(" <> renderSQL y <> ", " <> renderSQL x <> ")"
669−
670−-- When a `cast` is applied to an `Expression` of a known type, it
671−-- represents a run-time type conversion. The cast will succeed only if a
672−-- suitable type conversion operation has been defined.
673−--
674−-- | >>> printSQL $ true & cast int4
675−-- (TRUE :: int4)
676−cast
677− :: TypeExpression schemas ty1
678− -- ^ type to cast as
679− -> Expression grp commons schemas params from ty0
680− -- ^ value to convert
681− -> Expression grp commons schemas params from ty1
682−cast ty x = UnsafeExpression $ parenthesized $
683− renderSQL x <+> "::" <+> renderSQL ty
684−
685−-- | integer division, truncates the result
686−--
687−-- >>> :{
688−-- let
689−-- expression :: Expression grp commons schemas params from (nullity 'PGint2)
690−-- expression = 5 `quot_` 2
691−-- in printSQL expression
692−-- :}
693−-- (5 / 2)
694−quot_
695− :: int `In` PGIntegral
696− => Expression grp commons schemas params from (nullity int)
697− -- ^ numerator
698− -> Expression grp commons schemas params from (nullity int)
699− -- ^ denominator
700− -> Expression grp commons schemas params from (nullity int)
701−quot_ = unsafeBinaryOp "/"
702−
703−-- | remainder upon integer division
704−--
705−-- >>> :{
706−-- let
707−-- expression :: Expression grp commons schemas params from (nullity 'PGint2)
708−-- expression = 5 `rem_` 2
709−-- in printSQL expression
710−-- :}
711−-- (5 % 2)
712−rem_
713− :: int `In` PGIntegral
714− => Expression grp commons schemas params from (nullity int)
715− -- ^ numerator
716− -> Expression grp commons schemas params from (nullity int)
717− -- ^ denominator
718− -> Expression grp commons schemas params from (nullity int)
719−rem_ = unsafeBinaryOp "%"
720−
721−-- | >>> :{
722−-- let
723−-- expression :: Expression grp commons schemas params from (nullity 'PGfloat4)
724−-- expression = trunc pi
725−-- in printSQL expression
726−-- :}
727−-- trunc(pi())
728−trunc
729− :: frac `In` PGFloating
730− => Expression grp commons schemas params from (nullity frac)
731− -- ^ fractional number
732− -> Expression grp commons schemas params from (nullity frac)
733−trunc = unsafeFunction "trunc"
734−
735−-- | >>> :{
736−-- let
737−-- expression :: Expression grp commons schemas params from (nullity 'PGfloat4)
738−-- expression = round_ pi
739−-- in printSQL expression
740−-- :}
741−-- round(pi())
742−round_
743− :: frac `In` PGFloating
744− => Expression grp commons schemas params from (nullity frac)
745− -- ^ fractional number
746− -> Expression grp commons schemas params from (nullity frac)
747−round_ = unsafeFunction "round"
748−
749−-- | >>> :{
750−-- let
751−-- expression :: Expression grp commons schemas params from (nullity 'PGfloat4)
752−-- expression = ceiling_ pi
753−-- in printSQL expression
754−-- :}
755−-- ceiling(pi())
756−ceiling_
757− :: frac `In` PGFloating
758− => Expression grp commons schemas params from (nullity frac)
759− -- ^ fractional number
760− -> Expression grp commons schemas params from (nullity frac)
761−ceiling_ = unsafeFunction "ceiling"
762−
763−-- | A `Condition` is an `Expression`, which can evaluate
764−-- to `true`, `false` or `null_`. This is because SQL uses
765−-- a three valued logic.
766−type Condition grp commons schemas params from =
767− Expression grp commons schemas params from ('Null 'PGbool)
768−
769−-- | >>> printSQL true
770−-- TRUE
771−true :: Expression grp commons schemas params from (nullity 'PGbool)
772−true = UnsafeExpression "TRUE"
773−
774−-- | >>> printSQL false
775−-- FALSE
776−false :: Expression grp commons schemas params from (nullity 'PGbool)
777−false = UnsafeExpression "FALSE"
778−
779−-- | >>> printSQL $ not_ true
780−-- (NOT TRUE)
781−not_
782− :: Expression grp commons schemas params from (nullity 'PGbool)
783− -> Expression grp commons schemas params from (nullity 'PGbool)
784−not_ = unsafeUnaryOp "NOT"
785−
786−-- | >>> printSQL $ true .&& false
787−-- (TRUE AND FALSE)
788−(.&&)
789− :: Expression grp commons schemas params from (nullity 'PGbool)
790− -> Expression grp commons schemas params from (nullity 'PGbool)
791− -> Expression grp commons schemas params from (nullity 'PGbool)
792−infixr 3 .&&
793−(.&&) = unsafeBinaryOp "AND"
794−
795−-- | >>> printSQL $ true .|| false
796−-- (TRUE OR FALSE)
797−(.||)
798− :: Expression grp commons schemas params from (nullity 'PGbool)
799− -> Expression grp commons schemas params from (nullity 'PGbool)
800− -> Expression grp commons schemas params from (nullity 'PGbool)
801−infixr 2 .||
802−(.||) = unsafeBinaryOp "OR"
803−
804−-- | >>> :{
805−-- let
806−-- expression :: Expression grp commons schemas params from (nullity 'PGint2)
807−-- expression = caseWhenThenElse [(true, 1), (false, 2)] 3
808−-- in printSQL expression
809−-- :}
810−-- CASE WHEN TRUE THEN 1 WHEN FALSE THEN 2 ELSE 3 END
811−caseWhenThenElse
812− :: [ ( Condition grp commons schemas params from
813− , Expression grp commons schemas params from ty
814− ) ]
815− -- ^ whens and thens
816− -> Expression grp commons schemas params from ty
817− -- ^ else
818− -> Expression grp commons schemas params from ty
819−caseWhenThenElse whenThens else_ = UnsafeExpression $ mconcat
820− [ "CASE"
821− , mconcat
822− [ mconcat
823− [ " WHEN ", renderSQL when_
824− , " THEN ", renderSQL then_
825− ]
826− | (when_,then_) <- whenThens
827− ]
828− , " ELSE ", renderSQL else_
829− , " END"
830− ]
831−
832−-- | >>> :{
833−-- let
834−-- expression :: Expression grp commons schemas params from (nullity 'PGint2)
835−-- expression = ifThenElse true 1 0
836−-- in printSQL expression
837−-- :}
838−-- CASE WHEN TRUE THEN 1 ELSE 0 END
839−ifThenElse
840− :: Condition grp commons schemas params from
841− -> Expression grp commons schemas params from ty -- ^ then
842− -> Expression grp commons schemas params from ty -- ^ else
843− -> Expression grp commons schemas params from ty
844−ifThenElse if_ then_ else_ = caseWhenThenElse [(if_,then_)] else_
845−
846−-- | Comparison operations like `.==`, `./=`, `.>`, `.>=`, `.<` and `.<=`
847−-- will produce @NULL@s if one of their arguments is @NULL@.
848−--
849−-- >>> printSQL $ true .== null_
850−-- (TRUE = NULL)
851−(.==)
852− :: Expression grp commons schemas params from (nullity0 ty) -- ^ lhs
853− -> Expression grp commons schemas params from (nullity1 ty) -- ^ rhs
854− -> Condition grp commons schemas params from
855−(.==) = unsafeBinaryOp "="
856−infix 4 .==
857−
858−-- | >>> printSQL $ true ./= null_
859−-- (TRUE <> NULL)
860−(./=)
861− :: Expression grp commons schemas params from (nullity0 ty) -- ^ lhs
862− -> Expression grp commons schemas params from (nullity1 ty) -- ^ rhs
863− -> Condition grp commons schemas params from
864−(./=) = unsafeBinaryOp "<>"
865−infix 4 ./=
866−
867−-- | >>> printSQL $ true .>= null_
868−-- (TRUE >= NULL)
869−(.>=)
870− :: Expression grp commons schemas params from (nullity0 ty) -- ^ lhs
871− -> Expression grp commons schemas params from (nullity1 ty) -- ^ rhs
872− -> Condition grp commons schemas params from
873−(.>=) = unsafeBinaryOp ">="
874−infix 4 .>=
875−
876−-- | >>> printSQL $ true .< null_
877−-- (TRUE < NULL)
878−(.<)
879− :: Expression grp commons schemas params from (nullity0 ty) -- ^ lhs
880− -> Expression grp commons schemas params from (nullity1 ty) -- ^ rhs
881− -> Condition grp commons schemas params from
882−(.<) = unsafeBinaryOp "<"
883−infix 4 .<
884−
885−-- | >>> printSQL $ true .<= null_
886−-- (TRUE <= NULL)
887−(.<=)
888− :: Expression grp commons schemas params from (nullity0 ty) -- ^ lhs
889− -> Expression grp commons schemas params from (nullity1 ty) -- ^ rhs
890− -> Condition grp commons schemas params from
891−(.<=) = unsafeBinaryOp "<="
892−infix 4 .<=
893−
894−-- | >>> printSQL $ true .> null_
895−-- (TRUE > NULL)
896−(.>)
897− :: Expression grp commons schemas params from (nullity0 ty) -- ^ lhs
898− -> Expression grp commons schemas params from (nullity1 ty) -- ^ rhs
899− -> Condition grp commons schemas params from
900−(.>) = unsafeBinaryOp ">"
901−infix 4 .>
902−
903−-- | >>> printSQL currentDate
904−-- CURRENT_DATE
905−currentDate
906− :: Expression grp commons schemas params from (nullity 'PGdate)
907−currentDate = UnsafeExpression "CURRENT_DATE"
908−
909−-- | >>> printSQL currentTime
910−-- CURRENT_TIME
911−currentTime
912− :: Expression grp commons schemas params from (nullity 'PGtimetz)
913−currentTime = UnsafeExpression "CURRENT_TIME"
914−
915−-- | >>> printSQL currentTimestamp
916−-- CURRENT_TIMESTAMP
917−currentTimestamp
918− :: Expression grp commons schemas params from (nullity 'PGtimestamptz)
919−currentTimestamp = UnsafeExpression "CURRENT_TIMESTAMP"
920−
921−-- | >>> printSQL localTime
922−-- LOCALTIME
923−localTime
924− :: Expression grp commons schemas params from (nullity 'PGtime)
925−localTime = UnsafeExpression "LOCALTIME"
926−
927−-- | >>> printSQL localTimestamp
928−-- LOCALTIMESTAMP
929−localTimestamp
930− :: Expression grp commons schemas params from (nullity 'PGtimestamp)
931−localTimestamp = UnsafeExpression "LOCALTIMESTAMP"
932−
933−{-----------------------------------------
934−text
935−-----------------------------------------}
422+-- | Contained by operators
423+class PGSubset ty where
424+ (@>) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
425+ (@>) = unsafeBinaryOp "@>"
426+ (<@) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
427+ (<@) = unsafeBinaryOp "<@"
428+instance PGSubset 'PGjsonb
429+instance PGSubset 'PGtsquery
430+instance PGSubset ('PGvararray ty)
431+instance PGSubset ('PGrange ty)
432+
433+class PGIntersect ty where
434+ (@&&) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
435+ (@&&) = unsafeBinaryOp "&&"
436+instance PGIntersect ('PGvararray ty)
437+instance PGIntersect ('PGrange ty)
936438
937439instance IsString
938− (Expression grp commons schemas params from (nullity 'PGtext)) where
440+ (Expression outer commons grp schemas params from (null 'PGtext)) where
939441 fromString str = UnsafeExpression $
940442 "E\'" <> fromString (escape =<< str) <> "\'"
941− where
942− escape = \case
943− '\NUL' -> "\\0"
944− '\'' -> "''"
945− '"' -> "\\\""
946− '\b' -> "\\b"
947− '\n' -> "\\n"
948− '\r' -> "\\r"
949− '\t' -> "\\t"
950− '\\' -> "\\\\"
951− c -> [c]
443+instance IsString
444+ (Expression outer commons grp schemas params from (null 'PGtsvector)) where
445+ fromString str = UnsafeExpression . parenthesized . (<> " :: tsvector") $
446+ "E\'" <> fromString (escape =<< str) <> "\'"
447+instance IsString
448+ (Expression outer commons grp schemas params from (null 'PGtsquery)) where
449+ fromString str = UnsafeExpression . parenthesized . (<> " :: tsquery") $
450+ "E\'" <> fromString (escape =<< str) <> "\'"
952451
953452instance Semigroup
954− (Expression grp commons schemas params from (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
955463 (<>) = unsafeBinaryOp "||"
956464
957465instance Monoid
958− (Expression grp commons schemas params from (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
959471 mempty = fromString ""
960472 mappend = (<>)
961−
962−-- | >>> printSQL $ lower "ARRRGGG"
963−-- lower(E'ARRRGGG')
964−lower
965− :: Expression grp commons schemas params from (nullity 'PGtext)
966− -- ^ string to lower case
967− -> Expression grp commons schemas params from (nullity 'PGtext)
968−lower = unsafeFunction "lower"
969−
970−-- | >>> printSQL $ upper "eeee"
971−-- upper(E'eeee')
972−upper
973− :: Expression grp commons schemas params from (nullity 'PGtext)
974− -- ^ string to upper case
975− -> Expression grp commons schemas params from (nullity 'PGtext)
976−upper = unsafeFunction "upper"
977−
978−-- | >>> printSQL $ charLength "four"
979−-- char_length(E'four')
980−charLength
981− :: Expression grp commons schemas params from (nullity 'PGtext)
982− -- ^ string to measure
983− -> Expression grp commons schemas params from (nullity 'PGint4)
984−charLength = unsafeFunction "char_length"
985−
986−-- | The `like` expression returns true if the @string@ matches
987−-- the supplied @pattern@. If @pattern@ does not contain percent signs
988−-- or underscores, then the pattern only represents the string itself;
989−-- in that case `like` acts like the equals operator. An underscore (_)
990−-- in pattern stands for (matches) any single character; a percent sign (%)
991−-- matches any sequence of zero or more characters.
992−--
993−-- >>> printSQL $ "abc" `like` "a%"
994−-- (E'abc' LIKE E'a%')
995−like
996− :: Expression grp commons schemas params from (nullity 'PGtext)
997− -- ^ string
998− -> Expression grp commons schemas params from (nullity 'PGtext)
999− -- ^ pattern
1000− -> Expression grp commons schemas params from (nullity 'PGbool)
1001−like = unsafeBinaryOp "LIKE"
1002−
1003−-- | The key word ILIKE can be used instead of LIKE to make the
1004−-- match case-insensitive according to the active locale.
1005−--
1006−-- >>> printSQL $ "abc" `ilike` "a%"
1007−-- (E'abc' ILIKE E'a%')
1008−ilike
1009− :: Expression grp commons schemas params from (nullity 'PGtext)
1010− -- ^ string
1011− -> Expression grp commons schemas params from (nullity 'PGtext)
1012− -- ^ pattern
1013− -> Expression grp commons schemas params from (nullity 'PGbool)
1014−ilike = unsafeBinaryOp "ILIKE"
1015−
1016−{-----------------------------------------
1017− -- json and jsonb support
1018−
1019−See https://www.postgresql.org/docs/10/static/functions-json.html -- most
1020−comments lifted directly from this page.
1021−
1022−Table 9.44: json and jsonb operators
1023−-----------------------------------------}
1024−
1025−-- | Get JSON value (object field or array element) at a key.
1026−(.->)
1027− :: (json `In` PGJsonType, key `In` PGJsonKey)
1028− => Expression grp commons schemas params from (nullity json)
1029− -> Expression grp commons schemas params from (nullity key)
1030− -> Expression grp commons schemas params from ('Null json)
1031−infixl 8 .->
1032−(.->) = unsafeBinaryOp "->"
1033−
1034−-- | Get JSON value (object field or array element) at a key, as text.
1035−(.->>)
1036− :: (json `In` PGJsonType, key `In` PGJsonKey)
1037− => Expression grp commons schemas params from (nullity json)
1038− -> Expression grp commons schemas params from (nullity key)
1039− -> Expression grp commons schemas params from ('Null 'PGtext)
1040−infixl 8 .->>
1041−(.->>) = unsafeBinaryOp "->>"
1042−
1043−-- | Get JSON value at a specified path.
1044−(.#>)
1045− :: (json `In` PGJsonType, PGTextArray "(.#>)" path)
1046− => Expression grp commons schemas params from (nullity json)
1047− -> Expression grp commons schemas params from (nullity path)
1048− -> Expression grp commons schemas params from ('Null json)
1049−infixl 8 .#>
1050−(.#>) = unsafeBinaryOp "#>"
1051−
1052−-- | Get JSON value at a specified path as text.
1053−(.#>>)
1054− :: (json `In` PGJsonType, PGTextArray "(.#>>)" path)
1055− => Expression grp commons schemas params from (nullity json)
1056− -> Expression grp commons schemas params from (nullity path)
1057− -> Expression grp commons schemas params from ('Null 'PGtext)
1058−infixl 8 .#>>
1059−(.#>>) = unsafeBinaryOp "#>>"
1060−
1061−-- Additional jsonb operators
1062−
1063−-- | Does the left JSON value contain the right JSON path/value entries at the
1064−-- top level?
1065−(.@>)
1066− :: Expression grp commons schemas params from (nullity 'PGjsonb)
1067− -> Expression grp commons schemas params from (nullity 'PGjsonb)
1068− -> Condition grp commons schemas params from
1069−infixl 9 .@>
1070−(.@>) = unsafeBinaryOp "@>"
1071−
1072−-- | Are the left JSON path/value entries contained at the top level within the
1073−-- right JSON value?
1074−(.<@)
1075− :: Expression grp commons schemas params from (nullity 'PGjsonb)
1076− -> Expression grp commons schemas params from (nullity 'PGjsonb)
1077− -> Condition grp commons schemas params from
1078−infixl 9 .<@
1079−(.<@) = unsafeBinaryOp "<@"
1080−
1081−-- | Does the string exist as a top-level key within the JSON value?
1082−(.?)
1083− :: Expression grp commons schemas params from (nullity 'PGjsonb)
1084− -> Expression grp commons schemas params from (nullity 'PGtext)
1085− -> Condition grp commons schemas params from
1086−infixl 9 .?
1087−(.?) = unsafeBinaryOp "?"
1088−
1089−-- | Do any of these array strings exist as top-level keys?
1090−(.?|)
1091− :: Expression grp commons schemas params from (nullity 'PGjsonb)
1092− -> Expression grp commons schemas params from (nullity ('PGvararray ('NotNull 'PGtext)))
1093− -> Condition grp commons schemas params from
1094−infixl 9 .?|
1095−(.?|) = unsafeBinaryOp "?|"
1096−
1097−-- | Do all of these array strings exist as top-level keys?
1098−(.?&)
1099− :: Expression grp commons schemas params from (nullity 'PGjsonb)
1100− -> Expression grp commons schemas params from (nullity ('PGvararray ('NotNull 'PGtext)))
1101− -> Condition grp commons schemas params from
1102−infixl 9 .?&
1103−(.?&) = unsafeBinaryOp "?&"
1104−
1105−-- | Concatenate two jsonb values into a new jsonb value.
1106−instance
1107− Semigroup (Expression commons schemas from grouping param (nullity 'PGjsonb)) where
1108− (<>) = unsafeBinaryOp "||"
1109−
1110−-- | Delete a key or keys from a JSON object, or remove an array element.
1111−--
1112−-- If the right operand is..
1113−--
1114−-- @ text @: Delete key/value pair or string element from left operand. Key/value pairs
1115−-- are matched based on their key value.
1116−--
1117−-- @ text[] @: Delete multiple key/value pairs or string elements
1118−-- from left operand. Key/value pairs are matched based on their key value.
1119−--
1120−-- @ integer @: Delete the array element with specified index (Negative integers
1121−-- count from the end). Throws an error if top level container is not an array.
1122−(.-.)
1123− :: (key `In` '[ 'PGtext, 'PGvararray ('NotNull 'PGtext), 'PGint4, 'PGint2 ]) -- hlint error without parens here
1124− => Expression grp commons schemas params from (nullity 'PGjsonb)
1125− -> Expression grp commons schemas params from (nullity key)
1126− -> Expression grp commons schemas params from (nullity 'PGjsonb)
1127−infixl 6 .-.
1128−(.-.) = unsafeBinaryOp "-"
1129−
1130−-- | Delete the field or element with specified path (for JSON arrays, negative
1131−-- integers count from the end)
1132−(#-.)
1133− :: PGTextArray "(#-.)" arrayty
1134− => Expression grp commons schemas params from (nullity 'PGjsonb)
1135− -> Expression grp commons schemas params from (nullity arrayty)
1136− -> Expression grp commons schemas params from (nullity 'PGjsonb)
1137−infixl 6 #-.
1138−(#-.) = unsafeBinaryOp "#-"
1139−
1140−{-----------------------------------------
1141−Table 9.45: JSON creation functions
1142−-----------------------------------------}
1143−
1144−-- | Literal binary JSON
1145−jsonbLit
1146− :: JSON.ToJSON x
1147− => x -> Expression grp commons schemas params from (nullity 'PGjsonb)
1148−jsonbLit = cast jsonb . UnsafeExpression
1149− . singleQuotedUtf8 . toStrict . JSON.encode
1150−
1151−-- | Literal JSON
1152−jsonLit
1153− :: JSON.ToJSON x
1154− => x -> Expression grp commons schemas params from (nullity 'PGjson)
1155−jsonLit = cast json . UnsafeExpression
1156− . singleQuotedUtf8 . toStrict . JSON.encode
1157−
1158−-- | Returns the value as json. Arrays and composites are converted
1159−-- (recursively) to arrays and objects; otherwise, if there is a cast from the
1160−-- type to json, the cast function will be used to perform the conversion;
1161−-- otherwise, a scalar value is produced. For any scalar type other than a
1162−-- number, a Boolean, or a null value, the text representation will be used, in
1163−-- such a fashion that it is a valid json value.
1164−toJson
1165− :: Expression grp commons schemas params from (nullity ty)
1166− -> Expression grp commons schemas params from (nullity 'PGjson)
1167−toJson = unsafeFunction "to_json"
1168−
1169−-- | Returns the value as jsonb. Arrays and composites are converted
1170−-- (recursively) to arrays and objects; otherwise, if there is a cast from the
1171−-- type to json, the cast function will be used to perform the conversion;
1172−-- otherwise, a scalar value is produced. For any scalar type other than a
1173−-- number, a Boolean, or a null value, the text representation will be used, in
1174−-- such a fashion that it is a valid jsonb value.
1175−toJsonb
1176− :: Expression grp commons schemas params from (nullity ty)
1177− -> Expression grp commons schemas params from (nullity 'PGjsonb)
1178−toJsonb = unsafeFunction "to_jsonb"
1179−
1180−-- | Returns the array as a JSON array. A PostgreSQL multidimensional array
1181−-- becomes a JSON array of arrays.
1182−arrayToJson
1183− :: PGArray "arrayToJson" arr
1184− => Expression grp commons schemas params from (nullity arr)
1185− -> Expression grp commons schemas params from (nullity 'PGjson)
1186−arrayToJson = unsafeFunction "array_to_json"
1187−
1188−-- | Returns the row as a JSON object.
1189−rowToJson
1190− :: Expression grp commons schemas params from (nullity ('PGcomposite ty))
1191− -> Expression grp commons schemas params from (nullity 'PGjson)
1192−rowToJson = unsafeFunction "row_to_json"
1193−
1194−-- | Builds a possibly-heterogeneously-typed JSON array out of a variadic
1195−-- argument list.
1196−jsonBuildArray
1197− :: SListI elems
1198− => NP (Expression grp commons schemas params from) elems
1199− -> Expression grp commons schemas params from (nullity 'PGjson)
1200−jsonBuildArray = unsafeVariadicFunction "json_build_array"
1201−
1202−-- | Builds a possibly-heterogeneously-typed (binary) JSON array out of a
1203−-- variadic argument list.
1204−jsonbBuildArray
1205− :: SListI elems
1206− => NP (Expression grp commons schemas params from) elems
1207− -> Expression grp commons schemas params from (nullity 'PGjsonb)
1208−jsonbBuildArray = unsafeVariadicFunction "jsonb_build_array"
1209−
1210−unsafeRowFunction
1211− :: All Top elems
1212− => NP (Aliased (Expression grp commons schemas params from)) elems
1213− -> [ByteString]
1214−unsafeRowFunction =
1215− (`appEndo` []) . hcfoldMap (Proxy :: Proxy Top)
1216− (\(col `As` name) -> Endo $ \xs ->
1217− renderAliasString name : renderSQL col : xs)
1218− where
1219− renderAliasString :: KnownSymbol alias => Alias alias -> ByteString
1220− renderAliasString = singleQuotedText . fromString . symbolVal
1221−
1222−-- | Builds a possibly-heterogeneously-typed JSON object out of a variadic
1223−-- argument list. The elements of the argument list must alternate between text
1224−-- and values.
1225−jsonBuildObject
1226− :: All Top elems
1227− => NP (Aliased (Expression grp commons schemas params from)) elems
1228− -> Expression grp commons schemas params from (nullity 'PGjson)
1229−jsonBuildObject
1230− = unsafeFunction "json_build_object"
1231− . UnsafeExpression
1232− . commaSeparated
1233− . unsafeRowFunction
1234−
1235−-- | Builds a possibly-heterogeneously-typed (binary) JSON object out of a
1236−-- variadic argument list. The elements of the argument list must alternate
1237−-- between text and values.
1238−jsonbBuildObject
1239− :: All Top elems
1240− => NP (Aliased (Expression grp commons schemas params from)) elems
1241− -> Expression grp commons schemas params from (nullity 'PGjsonb)
1242−jsonbBuildObject
1243− = unsafeFunction "jsonb_build_object"
1244− . UnsafeExpression
1245− . commaSeparated
1246− . unsafeRowFunction
1247−
1248−-- | Builds a JSON object out of a text array. The array must have either
1249−-- exactly one dimension with an even number of members, in which case they are
1250−-- taken as alternating key/value pairs, or two dimensions such that each inner
1251−-- array has exactly two elements, which are taken as a key/value pair.
1252−jsonObject
1253− :: PGArrayOf "jsonObject" arr ('NotNull 'PGtext)
1254− => Expression grp commons schemas params from (nullity arr)
1255− -> Expression grp commons schemas params from (nullity 'PGjson)
1256−jsonObject = unsafeFunction "json_object"
1257−
1258−-- | Builds a binary JSON object out of a text array. The array must have either
1259−-- exactly one dimension with an even number of members, in which case they are
1260−-- taken as alternating key/value pairs, or two dimensions such that each inner
1261−-- array has exactly two elements, which are taken as a key/value pair.
1262−jsonbObject
1263− :: PGArrayOf "jsonbObject" arr ('NotNull 'PGtext)
1264− => Expression grp commons schemas params from (nullity arr)
1265− -> Expression grp commons schemas params from (nullity 'PGjsonb)
1266−jsonbObject = unsafeFunction "jsonb_object"
1267−
1268−-- | This is an alternate form of 'jsonObject' that takes two arrays; one for
1269−-- keys and one for values, that are zipped pairwise to create a JSON object.
1270−jsonZipObject
1271− :: ( PGArrayOf "jsonZipObject" keysArray ('NotNull 'PGtext)
1272− , PGArrayOf "jsonZipObject" valuesArray ('NotNull 'PGtext))
1273− => Expression grp commons schemas params from (nullity keysArray)
1274− -> Expression grp commons schemas params from (nullity valuesArray)
1275− -> Expression grp commons schemas params from (nullity 'PGjson)
1276−jsonZipObject ks vs =
1277− unsafeVariadicFunction "json_object" (ks :* vs :* Nil)
1278−
1279−-- | This is an alternate form of 'jsonObject' that takes two arrays; one for
1280−-- keys and one for values, that are zipped pairwise to create a binary JSON
1281−-- object.
1282−jsonbZipObject
1283− :: ( PGArrayOf "jsonbZipObject" keysArray ('NotNull 'PGtext)
1284− , PGArrayOf "jsonbZipObject" valuesArray ('NotNull 'PGtext))
1285− => Expression grp commons schemas params from (nullity keysArray)
1286− -> Expression grp commons schemas params from (nullity valuesArray)
1287− -> Expression grp commons schemas params from (nullity 'PGjsonb)
1288−jsonbZipObject ks vs =
1289− unsafeVariadicFunction "jsonb_object" (ks :* vs :* Nil)
1290−
1291−{-----------------------------------------
1292−Table 9.46: JSON processing functions
1293−-----------------------------------------}
1294−
1295−-- | Returns the number of elements in the outermost JSON array.
1296−jsonArrayLength
1297− :: Expression grp commons schemas params from (nullity 'PGjson)
1298− -> Expression grp commons schemas params from (nullity 'PGint4)
1299−jsonArrayLength = unsafeFunction "json_array_length"
1300−
1301−-- | Returns the number of elements in the outermost binary JSON array.
1302−jsonbArrayLength
1303− :: Expression grp commons schemas params from (nullity 'PGjsonb)
1304− -> Expression grp commons schemas params from (nullity 'PGint4)
1305−jsonbArrayLength = unsafeFunction "jsonb_array_length"
1306−
1307−-- | Returns JSON value pointed to by the given path (equivalent to #>
1308−-- operator).
1309−jsonExtractPath
1310− :: SListI elems
1311− => Expression grp commons schemas params from (nullity 'PGjson)
1312− -> NP (Expression grp commons schemas params from) elems
1313− -> Expression grp commons schemas params from (nullity 'PGjsonb)
1314−jsonExtractPath x xs =
1315− unsafeVariadicFunction "json_extract_path" (x :* xs)
1316−
1317−-- | Returns JSON value pointed to by the given path (equivalent to #>
1318−-- operator).
1319−jsonbExtractPath
1320− :: SListI elems
1321− => Expression grp commons schemas params from (nullity 'PGjsonb)
1322− -> NP (Expression grp commons schemas params from) elems
1323− -> Expression grp commons schemas params from (nullity 'PGjsonb)
1324−jsonbExtractPath x xs =
1325− unsafeVariadicFunction "jsonb_extract_path" (x :* xs)
1326−
1327−-- | Returns JSON value pointed to by the given path (equivalent to #>
1328−-- operator), as text.
1329−jsonExtractPathAsText
1330− :: SListI elems
1331− => Expression grp commons schemas params from (nullity 'PGjson)
1332− -> NP (Expression grp commons schemas params from) elems
1333− -> Expression grp commons schemas params from (nullity 'PGjson)
1334−jsonExtractPathAsText x xs =
1335− unsafeVariadicFunction "json_extract_path_text" (x :* xs)
1336−
1337−-- | Returns JSON value pointed to by the given path (equivalent to #>
1338−-- operator), as text.
1339−jsonbExtractPathAsText
1340− :: SListI elems
1341− => Expression grp commons schemas params from (nullity 'PGjsonb)
1342− -> NP (Expression grp commons schemas params from) elems
1343− -> Expression grp commons schemas params from (nullity 'PGjsonb)
1344−jsonbExtractPathAsText x xs =
1345− unsafeVariadicFunction "jsonb_extract_path_text" (x :* xs)
1346−
1347−-- | Returns the type of the outermost JSON value as a text string. Possible
1348−-- types are object, array, string, number, boolean, and null.
1349−jsonTypeof
1350− :: Expression grp commons schemas params from (nullity 'PGjson)
1351− -> Expression grp commons schemas params from (nullity 'PGtext)
1352−jsonTypeof = unsafeFunction "json_typeof"
1353−
1354−-- | Returns the type of the outermost binary JSON value as a text string.
1355−-- Possible types are object, array, string, number, boolean, and null.
1356−jsonbTypeof
1357− :: Expression grp commons schemas params from (nullity 'PGjsonb)
1358− -> Expression grp commons schemas params from (nullity 'PGtext)
1359−jsonbTypeof = unsafeFunction "jsonb_typeof"
1360−
1361−-- | Returns its argument with all object fields that have null values omitted.
1362−-- Other null values are untouched.
1363−jsonStripNulls
1364− :: Expression grp commons schemas params from (nullity 'PGjson)
1365− -> Expression grp commons schemas params from (nullity 'PGjson)
1366−jsonStripNulls = unsafeFunction "json_strip_nulls"
1367−
1368−-- | Returns its argument with all object fields that have null values omitted.
1369−-- Other null values are untouched.
1370−jsonbStripNulls
1371− :: Expression grp commons schemas params from (nullity 'PGjsonb)
1372− -> Expression grp commons schemas params from (nullity 'PGjsonb)
1373−jsonbStripNulls = unsafeFunction "jsonb_strip_nulls"
1374−
1375−-- | @ jsonbSet target path new_value create_missing @
1376−--
1377−-- Returns target with the section designated by path replaced by new_value,
1378−-- or with new_value added if create_missing is true ( default is true) and the
1379−-- item designated by path does not exist. As with the path orientated
1380−-- operators, negative integers that appear in path count from the end of JSON
1381−-- arrays.
1382−jsonbSet
1383− :: PGTextArray "jsonbSet" arr
1384− => Expression grp commons schemas params from (nullity 'PGjsonb)
1385− -> Expression grp commons schemas params from (nullity arr)
1386− -> Expression grp commons schemas params from (nullity 'PGjsonb)
1387− -> Maybe (Expression grp commons schemas params from (nullity 'PGbool))
1388− -> Expression grp commons schemas params from (nullity 'PGjsonb)
1389−jsonbSet tgt path val createMissing = case createMissing of
1390− Just m -> unsafeVariadicFunction "jsonb_set" (tgt :* path :* val :* m :* Nil)
1391− Nothing -> unsafeVariadicFunction "jsonb_set" (tgt :* path :* val :* Nil)
1392−
1393−-- | @ jsonbInsert target path new_value insert_after @
1394−--
1395−-- Returns target with new_value inserted. If target section designated by
1396−-- path is in a JSONB array, new_value will be inserted before target or after
1397−-- if insert_after is true (default is false). If target section designated by
1398−-- path is in JSONB object, new_value will be inserted only if target does not
1399−-- exist. As with the path orientated operators, negative integers that appear
1400−-- in path count from the end of JSON arrays.
1401−jsonbInsert
1402− :: PGTextArray "jsonbInsert" arr
1403− => Expression grp commons schemas params from (nullity 'PGjsonb)
1404− -> Expression grp commons schemas params from (nullity arr)
1405− -> Expression grp commons schemas params from (nullity 'PGjsonb)
1406− -> Maybe (Expression grp commons schemas params from (nullity 'PGbool))
1407− -> Expression grp commons schemas params from (nullity 'PGjsonb)
1408−jsonbInsert tgt path val insertAfter = case insertAfter of
1409− Just i -> unsafeVariadicFunction "jsonb_insert" (tgt :* path :* val :* i :* Nil)
1410− Nothing -> unsafeVariadicFunction "jsonb_insert" (tgt :* path :* val :* Nil)
1411−
1412−-- | Returns its argument as indented JSON text.
1413−jsonbPretty
1414− :: Expression grp commons schemas params from (nullity 'PGjsonb)
1415− -> Expression grp commons schemas params from (nullity 'PGtext)
1416−jsonbPretty = unsafeFunction "jsonb_pretty"
1417−
1418−{-----------------------------------------
1419−aggregation
1420−-----------------------------------------}
1421−
1422−class Aggregate expr1 expr2 aggr
1423− | aggr -> expr1, aggr -> expr2 where
1424−
1425− -- | A special aggregation that does not require an input
1426− --
1427− -- >>> :{
1428− -- let
1429− -- expression :: Expression (Grouped bys) commons schemas params from ('NotNull 'PGint8)
1430− -- expression = countStar
1431− -- in printSQL expression
1432− -- :}
1433− -- count(*)
1434− countStar :: aggr ('NotNull 'PGint8)
1435−
1436− -- | >>> :{
1437− -- let
1438− -- expression :: Expression (Grouped bys) commons schemas params '[tab ::: '["col" ::: nullity ty]] ('NotNull 'PGint8)
1439− -- expression = count (All #col)
1440− -- in printSQL expression
1441− -- :}
1442− -- count(ALL "col")
1443− count
1444− :: expr1 ty
1445− -- ^ what to count
1446− -> aggr ('NotNull 'PGint8)
1447−
1448− -- | >>> :{
1449− -- let
1450− -- expression :: Expression ('Grouped bys) commons schemas params '[tab ::: '["col" ::: 'Null 'PGnumeric]] ('Null 'PGnumeric)
1451− -- expression = sum_ (Distinct #col)
1452− -- in printSQL expression
1453− -- :}
1454− -- sum(DISTINCT "col")
1455− sum_
1456− :: ty `In` PGNum
1457− => expr1 (nullity ty)
1458− -> aggr (nullity ty)
1459−
1460− -- | >>> :{
1461− -- let
1462− -- expression :: Expression ('Grouped bys) commons schemas params '[tab ::: '["col" ::: nullity 'PGint4]] (nullity 'PGint4)
1463− -- expression = bitAnd (Distinct #col)
1464− -- in printSQL expression
1465− -- :}
1466− -- bit_and(DISTINCT "col")
1467− bitAnd
1468− :: int `In` PGIntegral
1469− => expr1 (nullity int)
1470− -- ^ what to aggregate
1471− -> aggr (nullity int)
1472−
1473− -- | >>> :{
1474− -- let
1475− -- expression :: Expression ('Grouped bys) commons schemas params '[tab ::: '["col" ::: nullity 'PGint4]] (nullity 'PGint4)
1476− -- expression = bitOr (All #col)
1477− -- in printSQL expression
1478− -- :}
1479− -- bit_or(ALL "col")
1480− bitOr
1481− :: int `In` PGIntegral
1482− => expr1 (nullity int)
1483− -- ^ what to aggregate
1484− -> aggr (nullity int)
1485−
1486− -- | >>> :{
1487− -- let
1488− -- winFun :: WindowFunction 'Ungrouped commons schemas params '[tab ::: '["col" ::: nullity 'PGbool]] (nullity 'PGbool)
1489− -- winFun = boolAnd #col
1490− -- in printSQL winFun
1491− -- :}
1492− -- bool_and("col")
1493− boolAnd
1494− :: expr1 (nullity 'PGbool)
1495− -- ^ what to aggregate
1496− -> aggr (nullity 'PGbool)
1497−
1498− -- | >>> :{
1499− -- let
1500− -- expression :: Expression (Grouped bys) commons schemas params '[tab ::: '["col" ::: nullity 'PGbool]] (nullity 'PGbool)
1501− -- expression = boolOr (All #col)
1502− -- in printSQL expression
1503− -- :}
1504− -- bool_or(ALL "col")
1505− boolOr
1506− :: expr1(nullity 'PGbool)
1507− -- ^ what to aggregate
1508− -> aggr (nullity 'PGbool)
1509−
1510− -- | synonym for `boolAnd`
1511− --
1512− -- >>> :{
1513− -- let
1514− -- expression :: Expression ('Grouped bys) commons schemas params '[tab ::: '["col" ::: nullity 'PGbool]] (nullity 'PGbool)
1515− -- expression = every (Distinct #col)
1516− -- in printSQL expression
1517− -- :}
1518− -- every(DISTINCT "col")
1519− every
1520− :: expr1 (nullity 'PGbool)
1521− -- ^ what to aggregate
1522− -> aggr (nullity 'PGbool)
1523−
1524− -- | maximum value of expression across all input values
1525− max_
1526− :: expr1 (nullity ty)
1527− -- ^ what to maximize
1528− -> aggr (nullity ty)
1529−
1530− -- | minimum value of expression across all input values
1531− min_
1532− :: expr1 (nullity ty)
1533− -- ^ what to minimize
1534− -> aggr (nullity ty)
1535−
1536− -- | average aggregation
1537− avg
1538− :: expr1 (nullity ty)
1539− -- ^ what to average
1540− -> aggr (nullity (PGAvg ty))
1541−
1542− {- | correlation coefficient
1543− >>> :{
1544− let
1545− expression :: Expression ('Grouped g) c s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('NotNull 'PGfloat8)
1546− expression = corr (All (#y :*: #x))
1547− in printSQL expression
1548− :}
1549− corr(ALL "y", "x")
1550− -}
1551− corr
1552− :: expr2 (nullity 'PGfloat8)
1553− -> aggr (nullity 'PGfloat8)
1554−
1555− {- | population covariance
1556− >>> :{
1557− let
1558− expression :: Expression ('Grouped g) c s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('NotNull 'PGfloat8)
1559− expression = covarPop (All (#y :*: #x))
1560− in printSQL expression
1561− :}
1562− covar_pop(ALL "y", "x")
1563− -}
1564− covarPop
1565− :: expr2 (nullity 'PGfloat8)
1566− -> aggr (nullity 'PGfloat8)
1567−
1568− {- | sample covariance
1569− >>> :{
1570− let
1571− winFun :: WindowFunction 'Ungrouped c s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('NotNull 'PGfloat8)
1572− winFun = covarSamp (#y :*: #x)
1573− in printSQL winFun
1574− :}
1575− covar_samp("y", "x")
1576− -}
1577− covarSamp
1578− :: expr2 (nullity 'PGfloat8)
1579− -> aggr (nullity 'PGfloat8)
1580−
1581− {- | average of the independent variable (sum(X)/N)
1582− >>> :{
1583− let
1584− expression :: Expression ('Grouped g) c s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('NotNull 'PGfloat8)
1585− expression = regrAvgX (All (#y :*: #x))
1586− in printSQL expression
1587− :}
1588− regr_avgx(ALL "y", "x")
1589− -}
1590− regrAvgX
1591− :: expr2 (nullity 'PGfloat8)
1592− -> aggr (nullity 'PGfloat8)
1593−
1594− {- | average of the dependent variable (sum(Y)/N)
1595− >>> :{
1596− let
1597− winFun :: WindowFunction 'Ungrouped c s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('NotNull 'PGfloat8)
1598− winFun = regrAvgY (#y :*: #x)
1599− in printSQL winFun
1600− :}
1601− regr_avgy("y", "x")
1602− -}
1603− regrAvgY
1604− :: expr2 (nullity 'PGfloat8)
1605− -> aggr (nullity 'PGfloat8)
1606−
1607− {- | number of input rows in which both expressions are nonnull
1608− >>> :{
1609− let
1610− winFun :: WindowFunction 'Ungrouped c s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('NotNull 'PGint8)
1611− winFun = regrCount (#y :*: #x)
1612− in printSQL winFun
1613− :}
1614− regr_count("y", "x")
1615− -}
1616− regrCount
1617− :: expr2 (nullity 'PGfloat8)
1618− -> aggr (nullity 'PGint8)
1619−
1620− {- | y-intercept of the least-squares-fit linear equation determined by the (X, Y) pairs
1621− >>> :{
1622− let
1623− expression :: Expression ('Grouped g) c s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('NotNull 'PGfloat8)
1624− expression = regrIntercept (All (#y :*: #x))
1625− in printSQL expression
1626− :}
1627− regr_intercept(ALL "y", "x")
1628− -}
1629− regrIntercept
1630− :: expr2 (nullity 'PGfloat8)
1631− -> aggr (nullity 'PGfloat8)
1632−
1633− -- | @regr_r2(Y, X)@, square of the correlation coefficient
1634− regrR2
1635− :: expr2 (nullity 'PGfloat8)
1636− -> aggr (nullity 'PGfloat8)
1637−
1638− -- | @regr_slope(Y, X)@, slope of the least-squares-fit linear equation
1639− -- determined by the (X, Y) pairs
1640− regrSlope
1641− :: expr2 (nullity 'PGfloat8)
1642− -> aggr (nullity 'PGfloat8)
1643−
1644− -- | @regr_sxx(Y, X)@, sum(X^2) - sum(X)^2/N
1645− -- (“sum of squares” of the independent variable)
1646− regrSxx
1647− :: expr2 (nullity 'PGfloat8)
1648− -> aggr (nullity 'PGfloat8)
1649−
1650− -- | @regr_sxy(Y, X)@, sum(X*Y) - sum(X) * sum(Y)/N
1651− -- (“sum of products” of independent times dependent variable)
1652− regrSxy
1653− :: expr2 (nullity 'PGfloat8)
1654− -> aggr (nullity 'PGfloat8)
1655−
1656− -- | @regr_syy(Y, X)@, sum(Y^2) - sum(Y)^2/N
1657− -- (“sum of squares” of the dependent variable)
1658− regrSyy
1659− :: expr2 (nullity 'PGfloat8)
1660− -> aggr (nullity 'PGfloat8)
1661−
1662− -- | historical alias for `stddevSamp`
1663− stddev
1664− :: expr1 (nullity ty)
1665− -> aggr (nullity (PGAvg ty))
1666−
1667− -- | population standard deviation of the input values
1668− stddevPop
1669− :: expr1 (nullity ty)
1670− -> aggr (nullity (PGAvg ty))
1671−
1672− -- | sample standard deviation of the input values
1673− stddevSamp
1674− :: expr1 (nullity ty)
1675− -> aggr (nullity (PGAvg ty))
1676−
1677− -- | historical alias for `varSamp`
1678− variance
1679− :: expr1 (nullity ty)
1680− -> aggr (nullity (PGAvg ty))
1681−
1682− -- | population variance of the input values
1683− -- (square of the population standard deviation)
1684− varPop
1685− :: expr1 (nullity ty)
1686− -> aggr (nullity (PGAvg ty))
1687−
1688− -- | sample variance of the input values
1689− -- (square of the sample standard deviation)
1690− varSamp
1691− :: expr1 (nullity ty)
1692− -> aggr (nullity (PGAvg ty))
1693−
1694−data Distinction expr ty
1695− = All (expr ty)
1696− | Distinct (expr ty)
1697− deriving (GHC.Generic,Show,Eq,Ord)
1698−instance NFData (Distinction (Expression grp commons schemas params from) ty)
1699−instance RenderSQL (Distinction (Expression grp commons schemas params from) ty) where
1700− renderSQL = \case
1701− All x -> "ALL" <+> renderSQL x
1702− Distinct x -> "DISTINCT" <+> renderSQL x
1703−instance RenderSQL
1704− (Distinction
1705− ( Expression grp commons schemas params from
1706− :*:
1707− Expression grp commons schemas params from) xty ) where
1708− renderSQL = \case
1709− All (x :*: x') ->
1710− "ALL" <+> renderSQL x <> ", " <> renderSQL x'
1711− Distinct (x :*: x') ->
1712− "DISTINCT" <+> renderSQL x <> ", " <> renderSQL x'
1713−
1714−instance Aggregate
1715− (Distinction (Expression 'Ungrouped commons schemas params from))
1716− (Distinction (Expression 'Ungrouped commons schemas params from :*: Expression 'Ungrouped commons schemas params from))
1717− (Expression ('Grouped bys) commons schemas params from) where
1718− countStar = UnsafeExpression "count(*)"
1719− count = unsafeAggregate1 "count"
1720− sum_ = unsafeAggregate1 "sum"
1721− bitAnd = unsafeAggregate1 "bit_and"
1722− bitOr = unsafeAggregate1 "bit_or"
1723− boolAnd = unsafeAggregate1 "bool_and"
1724− boolOr = unsafeAggregate1 "bool_or"
1725− every = unsafeAggregate1 "every"
1726− max_ = unsafeAggregate1 "max"
1727− min_ = unsafeAggregate1 "min"
1728− avg = unsafeAggregate1 "avg"
1729− corr = unsafeAggregate2 "corr"
1730− covarPop = unsafeAggregate2 "covar_pop"
1731− covarSamp = unsafeAggregate2 "covar_samp"
1732− regrAvgX = unsafeAggregate2 "regr_avgx"
1733− regrAvgY = unsafeAggregate2 "regr_avgy"
1734− regrCount = unsafeAggregate2 "regr_count"
1735− regrIntercept = unsafeAggregate2 "regr_intercept"
1736− regrR2 = unsafeAggregate2 "regr_r2"
1737− regrSlope = unsafeAggregate2 "regr_slope"
1738− regrSxx = unsafeAggregate2 "regr_sxx"
1739− regrSxy = unsafeAggregate2 "regr_sxy"
1740− regrSyy = unsafeAggregate2 "regr_syy"
1741− stddev = unsafeAggregate1 "stddev"
1742− stddevPop = unsafeAggregate1 "stddev_pop"
1743− stddevSamp = unsafeAggregate1 "stddev_samp"
1744− variance = unsafeAggregate1 "variance"
1745− varPop = unsafeAggregate1 "var_pop"
1746− varSamp = unsafeAggregate1 "var_samp"
1747−instance Aggregate
1748− (Expression grp commons schemas params from)
1749− (Expression grp commons schemas params from :*: Expression grp commons schemas params from)
1750− (WindowFunction grp commons schemas params from) where
1751− countStar = UnsafeWindowFunction "count(*)"
1752− count = unsafeWindowFunction1 "count"
1753− sum_ = unsafeWindowFunction1 "sum"
1754− bitAnd = unsafeWindowFunction1 "bit_and"
1755− bitOr = unsafeWindowFunction1 "bit_or"
1756− boolAnd = unsafeWindowFunction1 "bool_and"
1757− boolOr = unsafeWindowFunction1 "bool_or"
1758− every = unsafeWindowFunction1 "every"
1759− max_ = unsafeWindowFunction1 "max"
1760− min_ = unsafeWindowFunction1 "min"
1761− avg = unsafeWindowFunction1 "avg"
1762− corr = unsafeWindowFunction2 "corr"
1763− covarPop = unsafeWindowFunction2 "covar_pop"
1764− covarSamp = unsafeWindowFunction2 "covar_samp"
1765− regrAvgX = unsafeWindowFunction2 "regr_avgx"
1766− regrAvgY = unsafeWindowFunction2 "regr_avgy"
1767− regrCount = unsafeWindowFunction2 "regr_count"
1768− regrIntercept = unsafeWindowFunction2 "regr_intercept"
1769− regrR2 = unsafeWindowFunction2 "regr_r2"
1770− regrSlope = unsafeWindowFunction2 "regr_slope"
1771− regrSxx = unsafeWindowFunction2 "regr_sxx"
1772− regrSxy = unsafeWindowFunction2 "regr_sxy"
1773− regrSyy = unsafeWindowFunction2 "regr_syy"
1774− stddev = unsafeWindowFunction1 "stddev"
1775− stddevPop = unsafeWindowFunction1 "stddev_pop"
1776− stddevSamp = unsafeWindowFunction1 "stddev_samp"
1777− variance = unsafeWindowFunction1 "variance"
1778− varPop = unsafeWindowFunction1 "var_pop"
1779− varSamp = unsafeWindowFunction1 "var_samp"
1780−
1781−-- | escape hatch to define aggregate functions
1782−unsafeAggregate1
1783− :: ByteString -- ^ aggregate function
1784− -> Distinction (Expression 'Ungrouped commons schemas params from) xty
1785− -> Expression ('Grouped bys) commons schemas params from yty
1786−unsafeAggregate1 fun x = UnsafeExpression $ mconcat
1787− [fun, "(", renderSQL x, ")"]
1788−
1789−-- | escape hatch to define aggregate binary functions
1790−unsafeAggregate2
1791− :: ByteString -- ^ aggregate function
1792− -> Distinction (Expression 'Ungrouped commons schemas params from :*: Expression 'Ungrouped commons schemas params from) xty
1793− -> Expression ('Grouped bys) commons schemas params from yty
1794−unsafeAggregate2 fun xx = UnsafeExpression $ mconcat
1795− [fun, "(", renderSQL xx, ")"]
1796−
1797−-- | A type family that calculates `PGAvg` type of a `PGType`.
1798−type family PGAvg ty where
1799− PGAvg 'PGint2 = 'PGnumeric
1800− PGAvg 'PGint4 = 'PGnumeric
1801− PGAvg 'PGint8 = 'PGnumeric
1802− PGAvg 'PGnumeric = 'PGnumeric
1803− PGAvg 'PGfloat4 = 'PGfloat8
1804− PGAvg 'PGfloat8 = 'PGfloat8
1805− PGAvg 'PGinterval = 'PGinterval
1806− PGAvg pg = TypeError
1807− ('Text "Squeal type error: No average for " ':<>: 'ShowType pg)
1808−
1809−{-----------------------------------------
1810−type expressions
1811−-----------------------------------------}
1812−
1813−-- | `TypeExpression`s are used in `cast`s and `createTable` commands.
1814−newtype TypeExpression (schemas :: SchemasType) (ty :: NullityType)
1815− = UnsafeTypeExpression { renderTypeExpression :: ByteString }
1816− deriving (GHC.Generic,Show,Eq,Ord,NFData)
1817−instance RenderSQL (TypeExpression schemas ty) where
1818− renderSQL = renderTypeExpression
1819−
1820−-- | The enum or composite type in a `Typedef` can be expressed by its alias.
1821−typedef
1822− :: (Has sch schemas schema, Has td schema ('Typedef ty))
1823− => QualifiedAlias sch td
1824− -> TypeExpression schemas (nullity ty)
1825−typedef = UnsafeTypeExpression . renderSQL
1826−
1827−-- | The composite type corresponding to a `Table` definition can be expressed
1828−-- by its alias.
1829−typetable
1830− :: (Has sch schemas schema, Has tab schema ('Table table))
1831− => QualifiedAlias sch tab
1832− -> TypeExpression schemas (nullity ('PGcomposite (TableToRow table)))
1833−typetable = UnsafeTypeExpression . renderSQL
1834−
1835−-- | The composite type corresponding to a `View` definition can be expressed
1836−-- by its alias.
1837−typeview
1838− :: (Has sch schemas schema, Has vw schema ('View view))
1839− => QualifiedAlias sch vw
1840− -> TypeExpression schemas (nullity ('PGcomposite view))
1841−typeview = UnsafeTypeExpression . renderSQL
1842−
1843−-- | logical Boolean (true/false)
1844−bool :: TypeExpression schemas (nullity 'PGbool)
1845−bool = UnsafeTypeExpression "bool"
1846−-- | signed two-byte integer
1847−int2, smallint :: TypeExpression schemas (nullity 'PGint2)
1848−int2 = UnsafeTypeExpression "int2"
1849−smallint = UnsafeTypeExpression "smallint"
1850−-- | signed four-byte integer
1851−int4, int, integer :: TypeExpression schemas (nullity 'PGint4)
1852−int4 = UnsafeTypeExpression "int4"
1853−int = UnsafeTypeExpression "int"
1854−integer = UnsafeTypeExpression "integer"
1855−-- | signed eight-byte integer
1856−int8, bigint :: TypeExpression schemas (nullity 'PGint8)
1857−int8 = UnsafeTypeExpression "int8"
1858−bigint = UnsafeTypeExpression "bigint"
1859−-- | arbitrary precision numeric type
1860−numeric :: TypeExpression schemas (nullity 'PGnumeric)
1861−numeric = UnsafeTypeExpression "numeric"
1862−-- | single precision floating-point number (4 bytes)
1863−float4, real :: TypeExpression schemas (nullity 'PGfloat4)
1864−float4 = UnsafeTypeExpression "float4"
1865−real = UnsafeTypeExpression "real"
1866−-- | double precision floating-point number (8 bytes)
1867−float8, doublePrecision :: TypeExpression schemas (nullity 'PGfloat8)
1868−float8 = UnsafeTypeExpression "float8"
1869−doublePrecision = UnsafeTypeExpression "double precision"
1870−-- | variable-length character string
1871−text :: TypeExpression schemas (nullity 'PGtext)
1872−text = UnsafeTypeExpression "text"
1873−-- | fixed-length character string
1874−char, character
1875− :: forall n schemas nullity. (KnownNat n, 1 <= n)
1876− => TypeExpression schemas (nullity ('PGchar n))
1877−char = UnsafeTypeExpression $ "char(" <> renderNat @n <> ")"
1878−character = UnsafeTypeExpression $ "character(" <> renderNat @n <> ")"
1879−-- | variable-length character string
1880−varchar, characterVarying
1881− :: forall n schemas nullity. (KnownNat n, 1 <= n)
1882− => TypeExpression schemas (nullity ('PGvarchar n))
1883−varchar = UnsafeTypeExpression $ "varchar(" <> renderNat @n <> ")"
1884−characterVarying = UnsafeTypeExpression $
1885− "character varying(" <> renderNat @n <> ")"
1886−-- | binary data ("byte array")
1887−bytea :: TypeExpression schemas (nullity 'PGbytea)
1888−bytea = UnsafeTypeExpression "bytea"
1889−-- | date and time (no time zone)
1890−timestamp :: TypeExpression schemas (nullity 'PGtimestamp)
1891−timestamp = UnsafeTypeExpression "timestamp"
1892−-- | date and time, including time zone
1893−timestampWithTimeZone :: TypeExpression schemas (nullity 'PGtimestamptz)
1894−timestampWithTimeZone = UnsafeTypeExpression "timestamp with time zone"
1895−-- | calendar date (year, month, day)
1896−date :: TypeExpression schemas (nullity 'PGdate)
1897−date = UnsafeTypeExpression "date"
1898−-- | time of day (no time zone)
1899−time :: TypeExpression schemas (nullity 'PGtime)
1900−time = UnsafeTypeExpression "time"
1901−-- | time of day, including time zone
1902−timeWithTimeZone :: TypeExpression schemas (nullity 'PGtimetz)
1903−timeWithTimeZone = UnsafeTypeExpression "time with time zone"
1904−-- | time span
1905−interval :: TypeExpression schemas (nullity 'PGinterval)
1906−interval = UnsafeTypeExpression "interval"
1907−-- | universally unique identifier
1908−uuid :: TypeExpression schemas (nullity 'PGuuid)
1909−uuid = UnsafeTypeExpression "uuid"
1910−-- | IPv4 or IPv6 host address
1911−inet :: TypeExpression schemas (nullity 'PGinet)
1912−inet = UnsafeTypeExpression "inet"
1913−-- | textual JSON data
1914−json :: TypeExpression schemas (nullity 'PGjson)
1915−json = UnsafeTypeExpression "json"
1916−-- | binary JSON data, decomposed
1917−jsonb :: TypeExpression schemas (nullity 'PGjsonb)
1918−jsonb = UnsafeTypeExpression "jsonb"
1919−-- | variable length array
1920−vararray
1921− :: TypeExpression schemas pg
1922− -> TypeExpression schemas (nullity ('PGvararray pg))
1923−vararray ty = UnsafeTypeExpression $ renderSQL ty <> "[]"
1924−-- | fixed length array
1925−--
1926−-- >>> renderSQL (fixarray @'[2] json)
1927−-- "json[2]"
1928−fixarray
1929− :: forall dims schemas nullity pg. All KnownNat dims
1930− => TypeExpression schemas pg
1931− -> TypeExpression schemas (nullity ('PGfixarray dims pg))
1932−fixarray ty = UnsafeTypeExpression $
1933− renderSQL ty <> renderDims @dims
1934− where
1935− renderDims :: forall ns. All KnownNat ns => ByteString
1936− renderDims =
1937− ("[" <>)
1938− . (<> "]")
1939− . ByteString.intercalate "]["
1940− . hcollapse
1941− $ hcmap (Proxy @KnownNat)
1942− (K . fromString . show . natVal)
1943− (hpure Proxy :: NP Proxy ns)
1944−
1945−-- | `pgtype` is a demoted version of a `PGType`
1946−class PGTyped schemas (ty :: NullityType) where
1947− pgtype :: TypeExpression schemas ty
1948−instance PGTyped schemas (nullity 'PGbool) where pgtype = bool
1949−instance PGTyped schemas (nullity 'PGint2) where pgtype = int2
1950−instance PGTyped schemas (nullity 'PGint4) where pgtype = int4
1951−instance PGTyped schemas (nullity 'PGint8) where pgtype = int8
1952−instance PGTyped schemas (nullity 'PGnumeric) where pgtype = numeric
1953−instance PGTyped schemas (nullity 'PGfloat4) where pgtype = float4
1954−instance PGTyped schemas (nullity 'PGfloat8) where pgtype = float8
1955−instance PGTyped schemas (nullity 'PGtext) where pgtype = text
1956−instance (KnownNat n, 1 <= n)
1957− => PGTyped schemas (nullity ('PGchar n)) where pgtype = char @n
1958−instance (KnownNat n, 1 <= n)
1959− => PGTyped schemas (nullity ('PGvarchar n)) where pgtype = varchar @n
1960−instance PGTyped schemas (nullity 'PGbytea) where pgtype = bytea
1961−instance PGTyped schemas (nullity 'PGtimestamp) where pgtype = timestamp
1962−instance PGTyped schemas (nullity 'PGtimestamptz) where pgtype = timestampWithTimeZone
1963−instance PGTyped schemas (nullity 'PGdate) where pgtype = date
1964−instance PGTyped schemas (nullity 'PGtime) where pgtype = time
1965−instance PGTyped schemas (nullity 'PGtimetz) where pgtype = timeWithTimeZone
1966−instance PGTyped schemas (nullity 'PGinterval) where pgtype = interval
1967−instance PGTyped schemas (nullity 'PGuuid) where pgtype = uuid
1968−instance PGTyped schemas (nullity 'PGjson) where pgtype = json
1969−instance PGTyped schemas (nullity 'PGjsonb) where pgtype = jsonb
1970−instance PGTyped schemas ty
1971− => PGTyped schemas (nullity ('PGvararray ty)) where
1972− pgtype = vararray (pgtype @schemas @ty)
1973−instance (All KnownNat dims, PGTyped schemas ty)
1974− => PGTyped schemas (nullity ('PGfixarray dims ty)) where
1975− pgtype = fixarray @dims (pgtype @schemas @ty)
1976−
1977−{-----------------------------------------
1978−Sorting
1979−-----------------------------------------}
1980−
1981−-- | `SortExpression`s are used by `sortBy` to optionally sort the results
1982−-- of a `Query`. `Asc` or `Desc` set the sort direction of a `NotNull` result
1983−-- column to ascending or descending. Ascending order puts smaller values
1984−-- first, where "smaller" is defined in terms of the `.<` operator. Similarly,
1985−-- descending order is determined with the `.>` operator. `AscNullsFirst`,
1986−-- `AscNullsLast`, `DescNullsFirst` and `DescNullsLast` options are used to
1987−-- determine whether nulls appear before or after non-null values in the sort
1988−-- ordering of a `Null` result column.
1989−data SortExpression grp commons schemas params from where
1990− Asc
1991− :: Expression grp commons schemas params from ('NotNull ty)
1992− -> SortExpression grp commons schemas params from
1993− Desc
1994− :: Expression grp commons schemas params from ('NotNull ty)
1995− -> SortExpression grp commons schemas params from
1996− AscNullsFirst
1997− :: Expression grp commons schemas params from ('Null ty)
1998− -> SortExpression grp commons schemas params from
1999− AscNullsLast
2000− :: Expression grp commons schemas params from ('Null ty)
2001− -> SortExpression grp commons schemas params from
2002− DescNullsFirst
2003− :: Expression grp commons schemas params from ('Null ty)
2004− -> SortExpression grp commons schemas params from
2005− DescNullsLast
2006− :: Expression grp commons schemas params from ('Null ty)
2007− -> SortExpression grp commons schemas params from
2008−deriving instance Show (SortExpression grp commons schemas params from)
2009−
2010−class OrderBy expr where
2011− orderBy
2012− :: [SortExpression grp commons schemas params from]
2013− -> expr grp commons schemas params from
2014− -> expr grp commons schemas params from
2015−
2016−-- | Render a `SortExpression`.
2017−instance RenderSQL (SortExpression grp commons schemas params from) where
2018− renderSQL = \case
2019− Asc expression -> renderSQL expression <+> "ASC"
2020− Desc expression -> renderSQL expression <+> "DESC"
2021− AscNullsFirst expression -> renderSQL expression
2022− <+> "ASC NULLS FIRST"
2023− DescNullsFirst expression -> renderSQL expression
2024− <+> "DESC NULLS FIRST"
2025− AscNullsLast expression -> renderSQL expression <+> "ASC NULLS LAST"
2026− DescNullsLast expression -> renderSQL expression <+> "DESC NULLS LAST"
2027−
2028−data WindowDefinition grp commons schemas params from where
2029− WindowDefinition
2030− :: SListI bys
2031− => NP (Expression grp commons schemas params from) bys
2032− -> [SortExpression grp commons schemas params from]
2033− -> WindowDefinition grp commons schemas params from
2034−
2035−instance OrderBy WindowDefinition where
2036− orderBy sortsR (WindowDefinition parts sortsL)
2037− = WindowDefinition parts (sortsL ++ sortsR)
2038−
2039−instance RenderSQL (WindowDefinition commons schemas from grp params) where
2040− renderSQL (WindowDefinition part ord) =
2041− renderPartitionByClause part <> renderOrderByClause ord
2042− where
2043− renderPartitionByClause = \case
2044− Nil -> ""
2045− parts -> "PARTITION" <+> "BY" <+> renderCommaSeparated renderExpression parts
2046− renderOrderByClause = \case
2047− [] -> ""
2048− srts -> " ORDER" <+> "BY"
2049− <+> commaSeparated (renderSQL <$> srts)
2050−
2051−partitionBy
2052− :: SListI bys
2053− => NP (Expression grp commons schemas params from) bys
2054− -> WindowDefinition grp commons schemas params from
2055−partitionBy bys = WindowDefinition bys []
2056−
2057−newtype WindowFunction
2058− (grp :: Grouping)
2059− (commons :: FromType)
2060− (schemas :: SchemasType)
2061− (params :: [NullityType])
2062− (from :: FromType)
2063− (ty :: NullityType)
2064− = UnsafeWindowFunction { renderWindowFunction :: ByteString }
2065− deriving (GHC.Generic,Show,Eq,Ord,NFData)
2066−
2067−instance RenderSQL (WindowFunction grp commons schemas params from ty) where
2068− renderSQL = renderWindowFunction
2069−
2070−unsafeWindowFunction1
2071− :: ByteString
2072− -> Expression grp commons schemas params from ty0
2073− -> WindowFunction grp commons schemas params from ty1
2074−unsafeWindowFunction1 fun x
2075− = UnsafeWindowFunction $ fun <> parenthesized (renderSQL x)
2076−
2077−unsafeWindowFunction2
2078− :: ByteString
2079− -> (Expression grp commons schemas params from :*: Expression grp commons schemas params from) ty0
2080− -> WindowFunction grp commons schemas params from ty1
2081−unsafeWindowFunction2 fun (x :*: x')
2082− = UnsafeWindowFunction $ fun <> parenthesized (renderSQL x <> ", " <> renderSQL x')
2083−
2084−{- | rank of the current row with gaps; same as `rowNumber` of its first peer
2085−>>> printSQL rank
2086−rank()
2087−-}
2088−rank :: WindowFunction grp commons schemas params from ('NotNull 'PGint8)
2089−rank = UnsafeWindowFunction "rank()"
2090−
2091−{- | number of the current row within its partition, counting from 1
2092−>>> printSQL rowNumber
2093−row_number()
2094−-}
2095−rowNumber :: WindowFunction grp commons schemas params from ('NotNull 'PGint8)
2096−rowNumber = UnsafeWindowFunction "row_number()"
2097−
2098−{- | rank of the current row without gaps; this function counts peer groups
2099−>>> printSQL denseRank
2100−dense_rank()
2101−-}
2102−denseRank :: WindowFunction grp commons schemas params from ('NotNull 'PGint8)
2103−denseRank = UnsafeWindowFunction "dense_rank()"
2104−
2105−{- | relative rank of the current row: (rank - 1) / (total partition rows - 1)
2106−>>> printSQL percentRank
2107−percent_rank()
2108−-}
2109−percentRank :: WindowFunction grp commons schemas params from ('NotNull 'PGfloat8)
2110−percentRank = UnsafeWindowFunction "percent_rank()"
2111−
2112−{- | cumulative distribution: (number of partition rows
2113−preceding or peer with current row) / total partition rows
2114−>>> printSQL cumeDist
2115−cume_dist()
2116−-}
2117−cumeDist :: WindowFunction grp commons schemas params from ('NotNull 'PGfloat8)
2118−cumeDist = UnsafeWindowFunction "cume_dist()"
2119−
2120−{- | integer ranging from 1 to the argument value,
2121−dividing the partition as equally as possible
2122−-}
2123−ntile
2124− :: Expression grp commons schemas params from ('NotNull 'PGint4)
2125− -- ^ num buckets
2126− -> WindowFunction grp commons schemas params from ('NotNull 'PGint4)
2127−ntile = unsafeWindowFunction1 "ntile"
2128−
2129−{- | returns value evaluated at the row that is offset rows before the current
2130−row within the partition; if there is no such row, instead return default
2131−(which must be of the same type as value). Both offset and default are
2132−evaluated with respect to the current row.
2133−-}
2134−lag
2135− :: Expression grp commons schemas params from ty
2136− -- ^ value
2137− -> Expression grp commons schemas params from ('NotNull 'PGint4)
2138− -- ^ offset
2139− -> Expression grp commons schemas params from ty
2140− -- ^ default
2141− -> WindowFunction grp commons schemas params from ty
2142−lag value offset def = UnsafeWindowFunction $ "lag"
2143− <> parenthesized
2144− (commaSeparated ([renderSQL value, renderSQL offset, renderSQL def]))
2145−
2146−{- | returns value evaluated at the row that is offset rows after the current
2147−row within the partition; if there is no such row, instead return default
2148−(which must be of the same type as value). Both offset and default are
2149−evaluated with respect to the current row.
2150−-}
2151−lead
2152− :: Expression grp commons schemas params from ty
2153− -- ^ value
2154− -> Expression grp commons schemas params from ('NotNull 'PGint4)
2155− -- ^ offset
2156− -> Expression grp commons schemas params from ty
2157− -- ^ default
2158− -> WindowFunction grp commons schemas params from ty
2159−lead value offset def = UnsafeWindowFunction $ "lag"
2160− <> parenthesized
2161− (commaSeparated ([renderSQL value, renderSQL offset, renderSQL def]))
2162−
2163−{- | returns value evaluated at the row that is the
2164−first row of the window frame
2165−-}
2166−firstValue
2167− :: Expression grp commons schemas params from ty
2168− -- ^ value
2169− -> WindowFunction grp commons schemas params from ty
2170−firstValue = unsafeWindowFunction1 "first_value"
2171−
2172−{- | returns value evaluated at the row that is the
2173−last row of the window frame
2174−-}
2175−lastValue
2176− :: Expression grp commons schemas params from ty
2177− -- ^ value
2178− -> WindowFunction grp commons schemas params from ty
2179−lastValue = unsafeWindowFunction1 "last_value"
2180−
2181−{- | returns value evaluated at the row that is the nth
2182−row of the window frame (counting from 1); null if no such row
2183−-}
2184−nthValue
2185− :: Expression grp commons schemas params from (nullity ty)
2186− -- ^ value
2187− -> Expression grp commons schemas params from ('NotNull 'PGint4)
2188− -- ^ nth
2189− -> WindowFunction grp commons schemas params from ('Null ty)
2190−nthValue value nth = UnsafeWindowFunction $ "nth_value"
2191− <> parenthesized (commaSeparated [renderSQL value, renderSQL nth])
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+180−188
@@ -18,6 +18,7 @@ Squeal data manipulation language.
1818 , MultiParamTypeClasses
1919 , OverloadedStrings
2020 , PatternSynonyms
21+ , QuantifiedConstraints
2122 , RankNTypes
2223 , ScopedTypeVariables
2324 , TypeApplications
@@ -29,19 +30,9 @@ Squeal data manipulation language.
2930
3031module Squeal.PostgreSQL.Manipulation
3132 ( -- * Manipulation
32− Manipulation (..)
33− , Manipulation_
33+ Manipulation_
34+ , Manipulation (..)
3435 , queryStatement
35− , QueryClause (..)
36− , pattern Values_
37− , DefaultAliasable (..)
38− , ColumnExpression (..)
39− , ReturningClause (..)
40− , pattern Returning_
41− , ConflictClause (..)
42− , ConflictTarget (..)
43− , ConflictAction (..)
44− , UsingClause (..)
4536 -- * Insert
4637 , insertInto
4738 , insertInto_
@@ -51,36 +42,95 @@ module Squeal.PostgreSQL.Manipulation
5142 -- * Delete
5243 , deleteFrom
5344 , deleteFrom_
54− , also
45+ -- * Clauses
46+ , Optional (..)
47+ , QueryClause (..)
48+ , pattern Values_
49+ , ReturningClause (..)
50+ , pattern Returning_
51+ , ConflictClause (..)
52+ , ConflictTarget (..)
53+ , ConflictAction (..)
54+ , UsingClause (..)
5555 ) where
5656
5757import Control.DeepSeq
5858import Data.ByteString hiding (foldr)
5959import Data.Kind (Type)
60−import GHC.TypeLits (KnownSymbol)
6160
6261import qualified Generics.SOP as SOP
6362import qualified GHC.Generics as GHC
6463
64+import Squeal.PostgreSQL.Alias
6565import Squeal.PostgreSQL.Expression
66+import Squeal.PostgreSQL.Expression.Logic
67+import Squeal.PostgreSQL.List
68+import Squeal.PostgreSQL.PG
6669import Squeal.PostgreSQL.Render
6770import Squeal.PostgreSQL.Query
6871import Squeal.PostgreSQL.Schema
6972
73+-- $setup
74+-- >>> import Squeal.PostgreSQL
75+-- >>> import Data.Int
76+-- >>> import Data.Time
77+
7078{- |
7179A `Manipulation` is a statement which may modify data in the database,
7280but does not alter its schemas. Examples are inserts, updates and deletes.
7381A `Query` is also considered a `Manipulation` even though it does not modify data.
7482
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+
75125simple insert:
76126
77127>>> type Columns = '["col1" ::: 'NoDef :=> 'Null 'PGint4, "col2" ::: 'Def :=> 'NotNull 'PGint4]
78128>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]
79129>>> :{
80130let
81− manipulation :: Manipulation '[] (Public Schema) '[] '[]
131+ manipulation :: Manipulation_ (Public Schema) () ()
82132 manipulation =
83− insertInto_ #tab (Values_ (2 `as` #col1 :* defaultAs #col2))
133+ insertInto_ #tab (Values_ (Set 2 `as` #col1 :* Default `as` #col2))
84134in printSQL manipulation
85135:}
86136INSERT INTO "tab" ("col1", "col2") VALUES (2, DEFAULT)
@@ -91,9 +141,9 @@ parameterized insert:
91141>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]
92142>>> :{
93143let
94− manipulation :: Manipulation '[] (Public Schema) '[ 'NotNull 'PGint4, 'NotNull 'PGint4 ] '[]
144+ manipulation :: Manipulation_ (Public Schema) (Int32, Int32) ()
95145 manipulation =
96− insertInto_ #tab (Values_ (param @1 `as` #col1 :* param @2 `as` #col2))
146+ insertInto_ #tab (Values_ (Set (param @1) `as` #col1 :* Set (param @2) `as` #col2))
97147in printSQL manipulation
98148:}
99149INSERT INTO "tab" ("col1", "col2") VALUES (($1 :: int4), ($2 :: int4))
@@ -102,9 +152,9 @@ returning insert:
102152
103153>>> :{
104154let
105− manipulation :: Manipulation '[] (Public Schema) '[] '["fromOnly" ::: 'NotNull 'PGint4]
155+ manipulation :: Manipulation_ (Public Schema) () (Only Int32)
106156 manipulation =
107− insertInto #tab (Values_ (2 `as` #col1 :* 3 `as` #col2))
157+ insertInto #tab (Values_ (Set 2 `as` #col1 :* Set 3 `as` #col2))
108158 OnConflictDoRaise (Returning (#col1 `as` #fromOnly))
109159in printSQL manipulation
110160:}
@@ -117,12 +167,12 @@ upsert:
117167>>> type CustomersSchema = '["customers" ::: 'Table (CustomersConstraints :=> CustomersColumns)]
118168>>> :{
119169let
120− manipulation :: Manipulation '[] (Public CustomersSchema) '[] '[]
170+ manipulation :: Manipulation_ (Public CustomersSchema) () ()
121171 manipulation =
122172 insertInto #customers
123− (Values_ ("John Smith" `as` #name :* "john@smith.com" `as` #email))
173+ (Values_ (Set "John Smith" `as` #name :* Set "john@smith.com" `as` #email))
124174 (OnConflict (OnConstraint #uq)
125− (DoUpdate (((#excluded ! #email) <> "; " <> (#customers ! #email)) `as` #email) []))
175+ (DoUpdate (Set (#excluded ! #email <> "; " <> #customers ! #email) `as` #email) []))
126176 (Returning_ Nil)
127177in printSQL manipulation
128178:}
@@ -132,7 +182,7 @@ query insert:
132182
133183>>> :{
134184let
135− manipulation :: Manipulation '[] (Public Schema) '[] '[]
185+ manipulation :: Manipulation_ (Public Schema) () ()
136186 manipulation = insertInto_ #tab (Subquery (select Star (from (table #tab))))
137187in printSQL manipulation
138188:}
@@ -142,8 +192,8 @@ update:
142192
143193>>> :{
144194let
145− manipulation :: Manipulation '[] (Public Schema) '[] '[]
146− manipulation = update_ #tab (2 `as` #col1) (#col1 ./= #col2)
195+ manipulation :: Manipulation_ (Public Schema) () ()
196+ manipulation = update_ #tab (Set 2 `as` #col1) (#col1 ./= #col2)
147197in printSQL manipulation
148198:}
149199UPDATE "tab" SET "col1" = 2 WHERE ("col1" <> "col2")
@@ -152,9 +202,7 @@ delete:
152202
153203>>> :{
154204let
155− manipulation :: Manipulation '[] (Public Schema) '[]
156− '[ "col1" ::: 'NotNull 'PGint4
157− , "col2" ::: 'NotNull 'PGint4 ]
205+ manipulation :: Manipulation_ (Public Schema) () (Row Int32 Int32)
158206 manipulation = deleteFrom #tab NoUsing (#col1 .== #col2) (Returning Star)
159207in printSQL manipulation
160208:}
@@ -165,17 +213,18 @@ delete and using clause:
165213>>> :{
166214type Schema3 =
167215 '[ "tab" ::: 'Table ('[] :=> Columns)
168− , "other_tab" ::: 'Table ('[] :=> Columns)
169− , "third_tab" ::: 'Table ('[] :=> Columns) ]
216+ , "other_tab" ::: 'Table ('[] :=> Columns)
217+ , "third_tab" ::: 'Table ('[] :=> Columns) ]
170218:}
171219
172220>>> :{
173221let
174− manipulation :: Manipulation '[] (Public Schema3) '[] '[]
222+ manipulation :: Manipulation_ (Public Schema3) () ()
175223 manipulation =
176− deleteFrom_ #tab (Using (table #other_tab & also (table #third_tab)))
224+ deleteFrom #tab (Using (table #other_tab & also (table #third_tab)))
177225 ( (#tab ! #col2 .== #other_tab ! #col2)
178226 .&& (#tab ! #col2 .== #third_tab ! #col2) )
227+ (Returning_ Nil)
179228in printSQL manipulation
180229:}
181230DELETE 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"))
@@ -186,7 +235,7 @@ with manipulation:
186235>>> type ProductsSchema = '["products" ::: 'Table ('[] :=> ProductsColumns), "products_deleted" ::: 'Table ('[] :=> ProductsColumns)]
187236>>> :{
188237let
189− manipulation :: Manipulation '[] (Public ProductsSchema) '[ 'NotNull 'PGdate] '[]
238+ manipulation :: Manipulation_ (Public ProductsSchema) (Only Day) ()
190239 manipulation = with
191240 (deleteFrom #products NoUsing (#date .< param @1) (Returning Star) `as` #del)
192241 (insertInto_ #products_deleted (Subquery (select Star (from (common #del)))))
@@ -194,28 +243,13 @@ in printSQL manipulation
194243:}
195244WITH "del" AS (DELETE FROM "products" WHERE ("date" < ($1 :: date)) RETURNING *) INSERT INTO "products_deleted" SELECT * FROM "del" AS "del"
196245-}
197−
198−newtype Manipulation
199− (commons :: FromType)
200− (schemas :: SchemasType)
201− (params :: [NullityType])
202− (columns :: RowType)
203− = UnsafeManipulation { renderManipulation :: ByteString }
204− deriving (GHC.Generic,Show,Eq,Ord,NFData)
205−instance RenderSQL (Manipulation commons schemas params columns) where
206− renderSQL = renderManipulation
207−instance With Manipulation where
208− with Done manip = manip
209− with (cte :>> ctes) manip = UnsafeManipulation $
210− "WITH" <+> renderCommonTableExpressions renderSQL cte ctes
211− <+> renderSQL manip
212−
213246type family Manipulation_ (schemas :: SchemasType) (params :: Type) (row :: Type) where
214247 Manipulation_ schemas params row = Manipulation '[] schemas (TuplePG params) (RowPG row)
215248
216249-- | Convert a `Query` into a `Manipulation`.
217250queryStatement
218− :: Query commons schemas params columns
251+ :: Query '[] commons schemas params columns
252+ -- ^ `Query` to embed as a `Manipulation`
219253 -> Manipulation commons schemas params columns
220254queryStatement q = UnsafeManipulation $ renderSQL q
221255
@@ -238,9 +272,13 @@ insertInto
238272 , SOP.SListI columns
239273 , SOP.SListI row1 )
240274 => QualifiedAlias sch tab
275+ -- ^ table
241276 -> QueryClause commons schemas params columns
277+ -- ^ what to insert
242278 -> ConflictClause tab commons schemas params table
279+ -- ^ what to do in case of conflict
243280 -> ReturningClause commons schemas params '[tab ::: row0] row1
281+ -- ^ what to return
244282 -> Manipulation commons schemas params row1
245283insertInto tab qry conflict ret = UnsafeManipulation $
246284 "INSERT" <+> "INTO" <+> renderSQL tab
@@ -248,6 +286,7 @@ insertInto tab qry conflict ret = UnsafeManipulation $
248286 <> renderSQL conflict
249287 <> renderSQL ret
250288
289+-- | Like `insertInto` but with `OnConflictDoRaise` and `no` `ReturningClause`.
251290insertInto_
252291 :: ( Has sch schemas schema
253292 , Has tab schema ('Table table)
@@ -255,25 +294,33 @@ insertInto_
255294 , row ~ TableToRow table
256295 , SOP.SListI columns )
257296 => QualifiedAlias sch tab
297+ -- ^ table
258298 -> QueryClause commons schemas params columns
299+ -- ^ what to insert
259300 -> Manipulation commons schemas params '[]
260301insertInto_ tab qry =
261302 insertInto tab qry OnConflictDoRaise (Returning_ Nil)
262303
304+-- | A `QueryClause` describes what to `insertInto` a table.
263305data QueryClause commons schemas params columns where
264306 Values
265307 :: SOP.SListI columns
266− => NP (ColumnExpression 'Ungrouped schemas params '[]) columns
267− -> [NP (ColumnExpression 'Ungrouped schemas params '[]) columns]
308+ => NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[]))) columns
309+ -- ^ row of values
310+ -> [NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[]))) columns]
311+ -- ^ additional rows of values
268312 -> QueryClause commons schemas params columns
269313 Select
270314 :: SOP.SListI columns
271− => NP (ColumnExpression grp schemas params from) columns
272− -> TableExpression grp commons schemas params from
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
273319 -> QueryClause commons schemas params columns
274320 Subquery
275321 :: ColumnsToRow columns ~ row
276− => Query commons schemas params row
322+ => Query '[] commons schemas params row
323+ -- ^ subquery to insert
277324 -> QueryClause commons schemas params columns
278325
279326instance RenderSQL (QueryClause commons schemas params columns) where
@@ -292,109 +339,41 @@ instance RenderSQL (QueryClause commons schemas params columns) where
292339 Subquery qry -> renderQuery qry
293340 where
294341 renderSQLPartMaybe, renderValuePartMaybe
295− :: ColumnExpression grp schemas params from column -> Maybe ByteString
342+ :: Aliased (Optional (Expression '[] commons grp schemas params from)) column
343+ -> Maybe ByteString
296344 renderSQLPartMaybe = \case
297− DefaultAs _ -> Nothing
298− Specific (_ `As` name) -> Just $ renderSQL name
345+ Default `As` _ -> Nothing
346+ Set _ `As` name -> Just $ renderSQL name
299347 renderValuePartMaybe = \case
300− DefaultAs _ -> Nothing
301− Specific (value `As` _) -> Just $ renderExpression value
348+ Default `As` _ -> Nothing
349+ Set value `As` _ -> Just $ renderExpression value
302350 renderSQLPart, renderValuePart
303− :: ColumnExpression grp schemas params from column -> ByteString
304− renderSQLPart = \case
305− DefaultAs name -> renderSQL name
306− Specific (_ `As` name) -> renderSQL name
307− renderValuePart = \case
308− DefaultAs _ -> "DEFAULT"
309− Specific (value `As` _) -> renderExpression value
351+ :: Aliased (Optional (Expression '[] commons grp schemas params from)) column
352+ -> ByteString
353+ renderSQLPart (_ `As` name) = renderSQL name
354+ renderValuePart (value `As` _) = renderSQL value
310355
356+-- | `Values_` describes a single `NP` list of `Aliased` `Optional` `Expression`s
357+-- whose `ColumnsType` must match the tables'.
311358pattern Values_
312359 :: SOP.SListI columns
313− => NP (ColumnExpression 'Ungrouped schemas params '[]) columns
360+ => NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[]))) columns
361+ -- ^ row of values
314362 -> QueryClause commons schemas params columns
315363pattern Values_ vals = Values vals []
316364
317−data ColumnExpression grp schemas params from column where
318− DefaultAs
319− :: KnownSymbol col
320− => Alias col
321− -> ColumnExpression grp schemas params from (col ::: 'Def :=> ty)
322− Specific
323− :: Aliased (Expression grp '[] schemas params from) (col ::: ty)
324− -> ColumnExpression grp schemas params from (col ::: defness :=> ty)
325−
326−instance (KnownSymbol col, column ~ (col ::: defness :=> ty))
327− => Aliasable col
328− (Expression grp '[] schemas params from ty)
329− (ColumnExpression grp schemas params from column) where
330− expression `as` col = Specific (expression `As` col)
331−instance (KnownSymbol col, columns ~ '[col ::: defness :=> ty])
332− => Aliasable col
333− (Expression grp '[] schemas params from ty)
334− (NP (ColumnExpression grp schemas params from) columns) where
335− expression `as` col = expression `as` col :* Nil
336−instance (KnownSymbol col, column ~ (col ::: 'Def :=> ty))
337− => DefaultAliasable col (ColumnExpression grp schemas params from column) where
338− defaultAs = DefaultAs
339−instance (KnownSymbol col, columns ~ '[col ::: 'Def :=> ty])
340− => DefaultAliasable col (NP (ColumnExpression grp schemas params from) columns) where
341− defaultAs col = defaultAs col :* Nil
342−
343−instance (HasUnique tab from row, Has col row ty, column ~ (col ::: defness :=> ty))
344− => IsLabel col (ColumnExpression 'Ungrouped schemas params from column) where
345− fromLabel = fromLabel @col `as` Alias
346−instance (HasUnique tab from row, Has col row ty, columns ~ '[col ::: defness :=> ty])
347− => IsLabel col
348− (NP (ColumnExpression 'Ungrouped schemas params from) columns) where
349− fromLabel = fromLabel @col `as` Alias
350−
351−instance (Has tab from row, Has col row ty, column ~ (col ::: defness :=> ty))
352− => IsQualified tab col (ColumnExpression 'Ungrouped schemas params from column) where
353− tab ! col = tab ! col `as` col
354−instance (Has tab from row, Has col row ty, columns ~ '[col ::: defness :=> ty])
355− => IsQualified tab col (NP (ColumnExpression 'Ungrouped schemas params from) columns) where
356− tab ! col = tab ! col `as` col
357−
358−instance
359− ( HasUnique tab from row
360− , Has col row ty
361− , GroupedBy tab col bys
362− , column ~ (col ::: defness :=> ty)
363− ) => IsLabel col
364− (ColumnExpression ('Grouped bys) schemas params from column) where
365− fromLabel = fromLabel @col `as` Alias
366−instance
367− ( HasUnique tab from row
368− , Has col row ty
369− , GroupedBy tab col bys
370− , columns ~ '[col ::: defness :=> ty]
371− ) => IsLabel col
372− (NP (ColumnExpression ('Grouped bys) schemas params from) columns) where
373− fromLabel = fromLabel @col `as` Alias
374−
375−instance
376− ( Has tab from row
377− , Has col row ty
378− , GroupedBy tab col bys
379− , column ~ (col ::: defness :=> ty)
380− ) => IsQualified tab col
381− (ColumnExpression ('Grouped bys) schemas params from column) where
382− tab ! col = tab ! col `as` col
383−instance
384− ( Has tab from row
385− , Has col row ty
386− , GroupedBy tab col bys
387− , columns ~ '[col ::: defness :=> ty]
388− ) => IsQualified tab col
389− (NP (ColumnExpression ('Grouped bys) schemas params from) columns) where
390− tab ! col = tab ! col :* Nil
391−
392−instance RenderSQL (ColumnExpression grp schemas params from column) where
365+-- | `Optional` is either `Default` or a value, parameterized by an appropriate
366+-- `ColumnConstraint`.
367+data Optional expr ty where
368+ -- | Use the `Default` value for a column.
369+ Default :: Optional expr ('Def :=> ty)
370+ -- | `Set` a value for a column.
371+ Set :: expr ty -> Optional expr (def :=> ty)
372+
373+instance (forall x. RenderSQL (expr x)) => RenderSQL (Optional expr ty) where
393374 renderSQL = \case
394− DefaultAs col ->
395− renderSQL col <+> "=" <+> "DEFAULT"
396− Specific (expression `As` col) ->
397− renderSQL col <+> "=" <+> renderSQL expression
375+ Default -> "DEFAULT"
376+ Set expr -> renderSQL expr
398377
399378-- | A `ReturningClause` computes and return value(s) based
400379-- on each row actually inserted, updated or deleted. This is primarily
@@ -402,34 +381,38 @@ instance RenderSQL (ColumnExpression grp schemas params from column) where
402381-- serial sequence number. However, any expression using the table's columns
403382-- is allowed. Only rows that were successfully inserted or updated or
404383-- deleted will be returned. For example, if a row was locked
405−-- but not updated because an `OnConflictDoUpdate` condition was not satisfied,
406−-- the row will not be returned. `ReturningStar` will return all columns
407−-- in the row. Use @Returning Nil@ in the common case where no return
384+-- but not updated because an `OnConflict` `DoUpdate` condition was not satisfied,
385+-- the row will not be returned. `Returning` `Star` will return all columns
386+-- in the row. Use `Returning` `Nil` in the common case where no return
408387-- values are desired.
409388newtype ReturningClause commons schemas params from row =
410− Returning (Selection 'Ungrouped commons schemas params from row)
389+ Returning (Selection '[] commons 'Ungrouped schemas params from row)
411390
412391instance RenderSQL (ReturningClause commons schemas params from row) where
413392 renderSQL = \case
414393 Returning (List Nil) -> ""
415394 Returning selection -> " RETURNING" <+> renderSQL selection
416395
396+-- | `Returning` a `List`
417397pattern Returning_
418398 :: SOP.SListI row
419− => NP (Aliased (Expression 'Ungrouped commons schemas params from)) row
399+ => NP (Aliased (Expression '[] commons 'Ungrouped schemas params from)) row
400+ -- ^ row of values
420401 -> ReturningClause commons schemas params from row
421402pattern Returning_ list = Returning (List list)
422403
423404-- | A `ConflictClause` specifies an action to perform upon a constraint
424405-- violation. `OnConflictDoRaise` will raise an error.
425−-- `OnConflictDoNothing` simply avoids inserting a row.
426−-- `OnConflictDoUpdate` updates the existing row that conflicts with the row
406+-- `OnConflict` `DoNothing` simply avoids inserting a row.
407+-- `OnConflict` `DoUpdate` updates the existing row that conflicts with the row
427408-- proposed for insertion.
428409data ConflictClause tab commons schemas params table where
429410 OnConflictDoRaise :: ConflictClause tab commons schemas params table
430411 OnConflict
431412 :: ConflictTarget constraints
413+ -- ^ conflict target
432414 -> ConflictAction tab commons schemas params columns
415+ -- ^ conflict action
433416 -> ConflictClause tab commons schemas params (constraints :=> columns)
434417
435418-- | Render a `ConflictClause`.
@@ -440,6 +423,17 @@ instance SOP.SListI (TableToColumns table)
440423 OnConflict target action -> " ON CONFLICT"
441424 <+> renderSQL target <+> renderSQL action
442425
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+-}
443437data ConflictAction tab commons schemas params columns where
444438 DoNothing :: ConflictAction tab commons schemas params columns
445439 DoUpdate
@@ -448,8 +442,9 @@ data ConflictAction tab commons schemas params columns where
448442 , columns ~ (col0 ': cols)
449443 , SOP.All (HasIn columns) subcolumns
450444 , AllUnique subcolumns )
451− => NP (ColumnExpression 'Ungrouped schemas params '[tab ::: row, "excluded" ::: row]) subcolumns
452− -> [Condition 'Ungrouped commons schemas params '[tab ::: row, "excluded" ::: row]]
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
453448 -> ConflictAction tab commons schemas params columns
454449
455450instance RenderSQL (ConflictAction tab commons schemas params columns) where
@@ -457,11 +452,17 @@ instance RenderSQL (ConflictAction tab commons schemas params columns) where
457452 DoNothing -> "DO NOTHING"
458453 DoUpdate updates whs'
459454 -> "DO UPDATE SET"
460− <+> renderCommaSeparated renderSQL updates
455+ <+> renderCommaSeparated renderUpdate updates
461456 <> case whs' of
462457 [] -> ""
463458 wh:whs -> " WHERE" <+> renderSQL (foldr (.&&) wh whs)
464459
460+renderUpdate
461+ :: (forall x. RenderSQL (expr x))
462+ => Aliased (Optional expr) ty
463+ -> ByteString
464+renderUpdate (expr `As` col) = renderSQL col <+> "=" <+> renderSQL expr
465+
465466-- | A `ConflictTarget` specifies the constraint violation that triggers a
466467-- `ConflictAction`.
467468data ConflictTarget constraints where
@@ -484,7 +485,6 @@ UPDATE statements
484485update
485486 :: ( SOP.SListI columns
486487 , SOP.SListI row1
487− , db ~ (commons :=> schemas)
488488 , Has sch schemas schema
489489 , Has tab schema ('Table table)
490490 , row0 ~ TableToRow table
@@ -492,9 +492,9 @@ update
492492 , SOP.All (HasIn columns) subcolumns
493493 , AllUnique subcolumns )
494494 => QualifiedAlias sch tab -- ^ table to update
495− -> NP (ColumnExpression 'Ungrouped schemas params '[tab ::: row0]) subcolumns
495+ -> NP (Aliased (Optional (Expression '[] '[] 'Ungrouped schemas params '[tab ::: row0]))) subcolumns
496496 -- ^ modified values to replace old values
497− -> Condition 'Ungrouped commons schemas params '[tab ::: row0]
497+ -> Condition '[] commons 'Ungrouped schemas params '[tab ::: row0]
498498 -- ^ condition under which to perform update on a row
499499 -> ReturningClause commons schemas params '[tab ::: row0] row1 -- ^ results to return
500500 -> Manipulation commons schemas params row1
@@ -502,14 +502,13 @@ update tab columns wh returning = UnsafeManipulation $
502502 "UPDATE"
503503 <+> renderSQL tab
504504 <+> "SET"
505− <+> renderCommaSeparated renderSQL columns
505+ <+> renderCommaSeparated renderUpdate columns
506506 <+> "WHERE" <+> renderSQL wh
507507 <> renderSQL returning
508508
509509-- | Update a row returning `Nil`.
510510update_
511511 :: ( SOP.SListI columns
512− , db ~ (commons :=> schemas)
513512 , Has sch schemas schema
514513 , Has tab schema ('Table table)
515514 , row ~ TableToRow table
@@ -517,9 +516,9 @@ update_
517516 , SOP.All (HasIn columns) subcolumns
518517 , AllUnique subcolumns )
519518 => QualifiedAlias sch tab -- ^ table to update
520− -> NP (ColumnExpression 'Ungrouped schemas params '[tab ::: row]) subcolumns
519+ -> NP (Aliased (Optional (Expression '[] '[] 'Ungrouped schemas params '[tab ::: row]))) subcolumns
521520 -- ^ modified values to replace old values
522− -> Condition 'Ungrouped commons schemas params '[tab ::: row]
521+ -> Condition '[] commons 'Ungrouped schemas params '[tab ::: row]
523522 -- ^ condition under which to perform update on a row
524523 -> Manipulation commons schemas params '[]
525524update_ tab columns wh = update tab columns wh (Returning_ Nil)
@@ -528,23 +527,32 @@ update_ tab columns wh = update tab columns wh (Returning_ Nil)
528527DELETE statements
529528-----------------------------------------}
530529
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.
531539data UsingClause commons schemas params from where
532540 NoUsing :: UsingClause commons schemas params '[]
533541 Using
534− :: FromClause commons schemas params from
542+ :: FromClause '[] commons schemas params from
543+ -- ^ what to use
535544 -> UsingClause commons schemas params from
536545
537546-- | Delete rows from a table.
538547deleteFrom
539548 :: ( SOP.SListI row1
540− , db ~ (commons :=> schemas)
541549 , Has sch schemas schema
542550 , Has tab schema ('Table table)
543551 , row0 ~ TableToRow table
544552 , columns ~ TableToColumns table )
545553 => QualifiedAlias sch tab -- ^ table to delete from
546554 -> UsingClause commons schemas params from
547− -> Condition 'Ungrouped commons schemas params (tab ::: row0 ': from)
555+ -> Condition '[] commons 'Ungrouped schemas params (tab ::: row0 ': from)
548556 -- ^ condition under which to delete a row
549557 -> ReturningClause commons schemas params '[tab ::: row0] row1 -- ^ results to return
550558 -> Manipulation commons schemas params row1
@@ -559,28 +567,12 @@ deleteFrom tab using wh returning = UnsafeManipulation $
559567
560568-- | Delete rows returning `Nil`.
561569deleteFrom_
562− :: ( db ~ (commons :=> schemas)
563− , Has sch schemas schema
570+ :: ( Has sch schemas schema
564571 , Has tab schema ('Table table)
565572 , row ~ TableToRow table
566573 , columns ~ TableToColumns table )
567574 => QualifiedAlias sch tab -- ^ table to delete from
568− -> UsingClause commons schemas params from
569− -> Condition 'Ungrouped commons schemas params (tab ::: row ': from)
575+ -> Condition '[] commons 'Ungrouped schemas params '[tab ::: row]
570576 -- ^ condition under which to delete a row
571577 -> Manipulation commons schemas params '[]
572−deleteFrom_ tab uses wh = deleteFrom tab uses wh (Returning_ Nil)
573−
574−-- | This has the behaviour of a cartesian product, taking all
575−-- possible combinations between @left@ and @right@ - exactly like a
576−-- CROSS JOIN. Used when no "CROSS JOIN" syntax is required but simply
577−-- a comma separated list of tables. Typical case is the `USING` clause
578−-- of a DELETE query.
579−also
580− :: FromClause commons schemas params right
581− -- ^ right
582− -> FromClause commons schemas params left
583− -- ^ left
584− -> FromClause commons schemas params (Join left right)
585−also right left = UnsafeFromClause $
586− renderSQL left <> "," <+> renderSQL right
578+deleteFrom_ tab wh = deleteFrom tab NoUsing wh (Returning_ Nil)
squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs+337−186
@@ -8,8 +8,13 @@ Stability: experimental
88This module defines a `Migration` type to safely
99change the schema of your database over time. Let's see an example!
1010
11+First turn on some extensions.
12+
1113>>> :set -XDataKinds -XOverloadedLabels
1214>>> :set -XOverloadedStrings -XFlexibleContexts -XTypeOperators
15+
16+Next, let's define our `TableType`s.
17+
1318>>> :{
1419type UsersTable =
1520 '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
@@ -20,7 +25,7 @@ type UsersTable =
2025
2126>>> :{
2227type EmailsTable =
23− '[ "pk_emails" ::: 'PrimaryKey '["id"]
28+ '[ "pk_emails" ::: 'PrimaryKey '["id"]
2429 , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
2530 ] :=>
2631 '[ "id" ::: 'Def :=> 'NotNull 'PGint4
@@ -29,227 +34,293 @@ type EmailsTable =
2934 ]
3035:}
3136
37+Now we can define some `Migration`s to make our tables.
38+
3239>>> :{
3340let
34− makeUsers :: Migration IO (Public '[]) '["public" ::: '["users" ::: 'Table UsersTable]]
41+ makeUsers :: Migration Definition (Public '[]) '["public" ::: '["users" ::: 'Table UsersTable]]
3542 makeUsers = Migration
3643 { name = "make users table"
37− , up = void . define $
38− createTable #users
44+ , up = createTable #users
3945 ( serial `as` #id :*
40− (text & notNullable) `as` #name )
46+ notNullable text `as` #name )
4147 ( primaryKey #id `as` #pk_users )
42− , down = void . define $ dropTable #users
48+ , down = dropTable #users
4349 }
4450:}
4551
4652>>> :{
4753let
48− makeEmails :: Migration IO '["public" ::: '["users" ::: 'Table UsersTable]]
54+ makeEmails :: Migration Definition '["public" ::: '["users" ::: 'Table UsersTable]]
4955 '["public" ::: '["users" ::: 'Table UsersTable, "emails" ::: 'Table EmailsTable]]
5056 makeEmails = Migration
5157 { name = "make emails table"
52− , up = void . define $
53− createTable #emails
58+ , up = createTable #emails
5459 ( serial `as` #id :*
55− (int & notNullable) `as` #user_id :*
56− (text & nullable) `as` #email )
60+ notNullable int `as` #user_id :*
61+ nullable text `as` #email )
5762 ( primaryKey #id `as` #pk_emails :*
5863 foreignKey #user_id #users #id
5964 OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
60− , down = void . define $ dropTable #emails
65+ , down = dropTable #emails
6166 }
6267:}
6368
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`.
6570
6671>>> let migrations = makeUsers :>> makeEmails :>> Done
6772
68−>>> :{
69−let
70− numMigrations
71− :: Has "migrations" schemas MigrationsSchema
72− => PQ schemas schemas IO ()
73− numMigrations = do
74− result <- runQuery (select Star (from (table (#migrations ! #schema_migrations `as` #m))))
75− num <- ntuples result
76− liftBase $ print num
77−:}
73+Now run the migrations.
7874
75+>>> import Control.Monad.IO.Class
7976>>> :{
8077withConnection "host=localhost port=5432 dbname=exampledb" $
8178 manipulate (UnsafeManipulation "SET client_min_messages TO WARNING;")
8279 -- suppress notices
80+ & pqThen (liftIO (putStrLn "Migrate"))
8381 & pqThen (migrateUp migrations)
84− & pqThen numMigrations
82+ & pqThen (liftIO (putStrLn "Rollback"))
8583 & pqThen (migrateDown migrations)
86− & pqThen numMigrations
8784:}
88−Row 2
89−Row 0
85+Migrate
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.
90122-}
91123
92124{-# LANGUAGE
93125 DataKinds
126+ , DeriveGeneric
127+ , FlexibleContexts
128+ , FlexibleInstances
94129 , GADTs
95130 , LambdaCase
96− , PolyKinds
97131 , OverloadedLabels
132+ , OverloadedStrings
133+ , PolyKinds
134+ , QuantifiedConstraints
135+ , RankNTypes
98136 , TypeApplications
99− , FlexibleContexts
100137 , TypeOperators
101138#-}
102139
103140module Squeal.PostgreSQL.Migration
104141 ( -- * Migration
105142 Migration (..)
106− , migrateUp
107− , migrateDown
108− -- * Migration table
143+ , Migratory (..)
144+ , Terminally (..)
145+ , terminally
146+ , pureMigration
109147 , MigrationsTable
110− , createMigrations
111− , insertMigration
112− , deleteMigration
113− , selectMigration
148+ , defaultMain
114149 ) where
115150
151+import Control.Category
116152import Control.Monad
117−import Control.Monad.Base
118−import Control.Monad.Trans.Control
119−import Generics.SOP (K(..))
153+import Data.ByteString (ByteString)
154+import Data.Foldable (traverse_)
120155import Data.Function ((&))
156+import Data.List ((\\))
121157import Data.Text (Text)
158+import Data.Time (UTCTime)
159+import Prelude hiding ((.), id)
160+import System.Environment
161+import UnliftIO (MonadIO (..))
122162
123−import Squeal.PostgreSQL
163+import qualified Data.Text.IO as Text (putStrLn)
164+import qualified Generics.SOP as SOP
165+import qualified GHC.Generics as GHC
124166
125−-- | A `Migration` should contain an inverse pair of
126−-- `up` and `down` instructions and a unique `name`.
127−data Migration io schemas0 schemas1 = Migration
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
182+
183+-- | A `Migration` is a named "isomorphism" over a given category.
184+-- It should contain an inverse pair of `up` and `down`
185+-- instructions and a unique `name`.
186+data Migration p schemas0 schemas1 = Migration
128187 { name :: Text -- ^ The `name` of a `Migration`.
129188 -- Each `name` in a `Migration` should be unique.
130− , up :: PQ schemas0 schemas1 io () -- ^ The `up` instruction of a `Migration`.
131− , down :: PQ schemas1 schemas0 io () -- ^ The `down` instruction of a `Migration`.
189+ , up :: p schemas0 schemas1 -- ^ The `up` 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
132260 }
133261
134−-- | Run `Migration`s by creating the `MigrationsTable`
135−-- if it does not exist and then in a transaction, for each each `Migration`
136−-- query to see if the `Migration` is executed. If not, then
137−-- execute the `Migration` and insert its row in the `MigrationsTable`.
138−migrateUp
139− :: MonadBaseControl IO io
140− => AlignedList (Migration io) schemas0 schemas1 -- ^ migrations to run
141− -> PQ
142− ("migrations" ::: MigrationsSchema ': schemas0)
143− ("migrations" ::: MigrationsSchema ': schemas1)
144− io ()
145−migrateUp migration =
146− define createMigrations
147− & pqBind okResult
148− & pqThen (transactionallySchema_ (upMigrations migration))
149− where
262+instance Migratory (Terminally PQ IO) where
150263
151− upMigrations
152− :: MonadBaseControl IO io
153− => AlignedList (Migration io) schemas0 schemas1
154− -> PQ
155− ("migrations" ::: MigrationsSchema ': schemas0)
156− ("migrations" ::: MigrationsSchema ': schemas1)
157− io ()
158− upMigrations = \case
159− Done -> return ()
160− step :>> steps -> upMigration step & pqThen (upMigrations steps)
161−
162− upMigration
163− :: MonadBase IO io
164− => Migration io schemas0 schemas1 -> PQ
165− ("migrations" ::: MigrationsSchema ': schemas0)
166− ("migrations" ::: MigrationsSchema ': schemas1)
167− io ()
168− upMigration step =
169− queryExecuted step
170− & pqBind (\ executed ->
171− if executed == 1 -- up step has already been executed
172− then PQ (\ _ -> return (K ())) -- unsafely switch schemas
173− else
174− pqEmbed (up step) -- safely switch schemas
175− & pqThen (manipulateParams insertMigration (Only (name step)))
176− -- insert execution record
177− & pqBind okResult)
178−
179− queryExecuted
180− :: MonadBase IO io
181− => Migration io schemas0 schemas1 -> PQ
182− ("migrations" ::: MigrationsSchema ': schemas0)
183− ("migrations" ::: MigrationsSchema ': schemas0)
184− io Row
185− queryExecuted step = do
186− result <- runQueryParams selectMigration (Only (name step))
187− okResult result
188− ntuples result
189−
190−-- | Rewind `Migration`s by creating the `MigrationsTable`
191−-- if it does not exist and then in a transaction, for each each `Migration`
192−-- query to see if the `Migration` is executed. If it is, then
193−-- rewind the `Migration` and delete its row in the `MigrationsTable`.
194−migrateDown
195− :: MonadBaseControl IO io
196− => AlignedList (Migration io) schemas0 schemas1 -- ^ migrations to rewind
197− -> PQ
198− ("migrations" ::: MigrationsSchema ': schemas1)
199− ("migrations" ::: MigrationsSchema ': schemas0)
200− io ()
201−migrateDown migrations =
202− define createMigrations
203− & pqBind okResult
204− & pqThen (transactionallySchema_ (downMigrations migrations))
205− where
264+ migrateUp migration = unsafePQ . transactionally_ $ do
265+ define createMigrations
266+ upMigrations migration
267+
268+ where
269+
270+ upMigrations
271+ :: Path (Migration (Terminally PQ IO)) schemas0 schemas1
272+ -> PQ MigrationsSchemas MigrationsSchemas IO ()
273+ upMigrations = \case
274+ Done -> return ()
275+ step :>> steps -> upMigration step >> upMigrations steps
276+
277+ upMigration
278+ :: Migration (Terminally PQ IO) schemas0 schemas1
279+ -> PQ MigrationsSchemas MigrationsSchemas IO ()
280+ upMigration step = do
281+ executed <- queryExecuted step
282+ unless (executed == 1) $ do
283+ unsafePQ . runTerminally $ up step
284+ manipulateParams_ insertMigration (Only (name step))
285+
286+ queryExecuted
287+ :: Migration (Terminally PQ IO) schemas0 schemas1
288+ -> PQ MigrationsSchemas MigrationsSchemas IO Row
289+ queryExecuted step = do
290+ result <- runQueryParams selectMigration (Only (name step))
291+ ntuples result
206292
207− downMigrations
208− :: MonadBaseControl IO io
209− => AlignedList (Migration io) schemas0 schemas1 -> PQ
210− ("migrations" ::: MigrationsSchema ': schemas1)
211− ("migrations" ::: MigrationsSchema ': schemas0)
212− io ()
213− downMigrations = \case
214− Done -> return ()
215− step :>> steps -> downMigrations steps & pqThen (downMigration step)
216−
217− downMigration
218− :: MonadBase IO io
219− => Migration io schemas0 schemas1 -> PQ
220− ("migrations" ::: MigrationsSchema ': schemas1)
221− ("migrations" ::: MigrationsSchema ': schemas0)
222− io ()
223− downMigration step =
224− queryExecuted step
225− & pqBind (\ executed ->
226− if executed == 0 -- up step has not been executed
227− then PQ (\ _ -> return (K ())) -- unsafely switch schemas
228− else
229− pqEmbed (down step) -- safely switch schemas
230− & pqThen (manipulateParams deleteMigration (Only (name step)))
231− -- delete execution record
232− & pqBind okResult)
233−
234− queryExecuted
235− :: MonadBase IO io
236− => Migration io schemas0 schemas1 -> PQ
237− ("migrations" ::: MigrationsSchema ': schemas1)
238− ("migrations" ::: MigrationsSchema ': schemas1)
239− io Row
240− queryExecuted step = do
241− result <- runQueryParams selectMigration (Only (name step))
242− okResult result
243− ntuples result
244−
245−okResult :: MonadBase IO io => K Result results -> PQ schema schema io ()
246−okResult result = do
247− status <- resultStatus result
248− when (not (status `elem` [CommandOk, TuplesOk])) $ do
249− errorMessageMaybe <- resultErrorMessage result
250− case errorMessageMaybe of
251− Nothing -> error "migrateDown: unknown error"
252− Just msg -> error ("migrationDown: " <> show msg)
293+ migrateDown migrations = unsafePQ . transactionally_ $ do
294+ define createMigrations
295+ downMigrations migrations
296+
297+ where
298+
299+ downMigrations
300+ :: Path (Migration (Terminally PQ IO)) schemas0 schemas1
301+ -> PQ MigrationsSchemas MigrationsSchemas IO ()
302+ downMigrations = \case
303+ Done -> return ()
304+ step :>> steps -> downMigrations steps >> downMigration step
305+
306+ downMigration
307+ :: Migration (Terminally PQ IO) schemas0 schemas1
308+ -> PQ MigrationsSchemas MigrationsSchemas IO ()
309+ downMigration step = do
310+ executed <- queryExecuted step
311+ unless (executed == 0) $ do
312+ unsafePQ . runTerminally $ down step
313+ manipulateParams_ deleteMigration (Only (name step))
314+
315+ queryExecuted
316+ :: Migration (Terminally PQ IO) schemas0 schemas1
317+ -> PQ MigrationsSchemas MigrationsSchemas IO Row
318+ queryExecuted step = do
319+ result <- runQueryParams selectMigration (Only (name step))
320+ ntuples result
321+
322+unsafePQ :: (Functor m) => PQ db0 db1 m x -> PQ db0' db1' m x
323+unsafePQ (PQ pq) = PQ $ fmap (SOP.K . SOP.unK) . pq . SOP.K . SOP.unK
253324
254325-- | The `TableType` for a Squeal migration.
255326type MigrationsTable =
@@ -258,40 +329,120 @@ type MigrationsTable =
258329 , "executed_at" ::: 'Def :=> 'NotNull 'PGtimestamptz
259330 ]
260331
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+
261340type MigrationsSchema = '["schema_migrations" ::: 'Table MigrationsTable]
341+type MigrationsSchemas = Public MigrationsSchema
262342
263343-- | Creates a `MigrationsTable` if it does not already exist.
264−createMigrations
265− :: Has "migrations" schemas MigrationsSchema
266− => Definition schemas schemas
344+createMigrations :: Definition MigrationsSchemas MigrationsSchemas
267345createMigrations =
268− createSchemaIfNotExists #migrations >>>
269− createTableIfNotExists (#migrations ! #schema_migrations)
346+ createTableIfNotExists #schema_migrations
270347 ( (text & notNullable) `as` #name :*
271348 (timestampWithTimeZone & notNullable & default_ currentTimestamp)
272349 `as` #executed_at )
273350 ( unique #name `as` #migrations_unique_name )
274351
275−-- | Inserts a `Migration` into the `MigrationsTable`
276−insertMigration
277− :: Has "migrations" schemas MigrationsSchema
278− => Manipulation '[] schemas '[ 'NotNull 'PGtext] '[]
279−insertMigration = insertInto_ (#migrations ! #schema_migrations) . Values_ $
280− (param @1) `as` #name :* defaultAs #executed_at
352+-- | Inserts a `Migration` into the `MigrationsTable`, returning
353+-- the time at which it was inserted.
354+insertMigration :: Manipulation_ MigrationsSchemas (Only Text) ()
355+insertMigration = insertInto_ #schema_migrations
356+ (Values_ (Set (param @1) `as` #name :* Default `as` #executed_at))
281357
282−-- | Deletes a `Migration` from the `MigrationsTable`
283−deleteMigration
284− :: Has "migrations" schemas MigrationsSchema
285− => Manipulation '[] schemas '[ 'NotNull 'PGtext ] '[]
286−deleteMigration = deleteFrom_ (#migrations ! #schema_migrations) NoUsing (#name .== param @1)
358+-- | Deletes a `Migration` from the `MigrationsTable`, returning
359+-- the time at which it was inserted.
360+deleteMigration :: Manipulation_ MigrationsSchemas (Only Text) ()
361+deleteMigration = deleteFrom_ #schema_migrations (#name .== param @1)
287362
288363-- | Selects a `Migration` from the `MigrationsTable`, returning
289−-- the time at which it was executed.
364+-- the time at which it was inserted.
290365selectMigration
291− :: Has "migrations" schemas MigrationsSchema
292− => Query '[] schemas '[ 'NotNull 'PGtext ]
293− '[ "executed_at" ::: 'NotNull 'PGtimestamptz ]
294−selectMigration = select_
295− (#executed_at `as` #executed_at)
296− ( from (table ((#migrations ! #schema_migrations) `as` #m))
297− & where_ (#name .== param @1))
366+ :: Query_ MigrationsSchemas (Only Text) (Only UTCTime)
367+selectMigration = select_ (#executed_at `as` #fromOnly)
368+ $ from (table (#schema_migrations))
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+159−119
@@ -6,7 +6,7 @@ Maintainer: eitan@morphism.tech
66Stability: experimental
77
88This 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
1010a `Definition` and `MonadPQ` for executing a `Manipulation` or `Query`,
1111and a `PQ` type with instances for them.
1212
@@ -24,6 +24,7 @@ of executing Squeal commands.
2424 , FunctionalDependencies
2525 , FlexibleContexts
2626 , FlexibleInstances
27+ , InstanceSigs
2728 , OverloadedStrings
2829 , RankNTypes
2930 , ScopedTypeVariables
@@ -48,8 +49,6 @@ module Squeal.PostgreSQL.PQ
4849 , evalPQ
4950 , IndexedMonadTransPQ (..)
5051 , MonadPQ (..)
51− , PQRun
52− , pqliftWith
5352 -- * Results
5453 , LibPQ.Result
5554 , LibPQ.Row
@@ -65,25 +64,30 @@ module Squeal.PostgreSQL.PQ
6564 , resultErrorCode
6665 -- * Exceptions
6766 , SquealException (..)
67+ , PQState (..)
68+ , okResult
6869 , catchSqueal
6970 , handleSqueal
71+ , trySqueal
7072 ) where
7173
72−import Control.Exception.Lifted
73−import Control.Monad.Base
74+import Control.Exception (Exception, throw)
7475import Control.Monad.Except
7576import Control.Monad.Morph
76−import Control.Monad.Trans.Control
77+import UnliftIO (MonadUnliftIO (..), bracket, catch, handle, try)
7778import Data.ByteString (ByteString)
7879import Data.Foldable
7980import Data.Function ((&))
81+import Data.Functor ((<&>))
8082import Data.Kind
8183import Data.Text (pack, Text)
8284import Data.Traversable
8385import Generics.SOP
8486import PostgreSQL.Binary.Encoding (encodingBytes)
8587
88+import qualified Control.Monad.Fail as Fail
8689import qualified Database.PostgreSQL.LibPQ as LibPQ
90+import qualified PostgreSQL.Binary.Encoding as Encoding
8791
8892import Squeal.PostgreSQL.Binary
8993import Squeal.PostgreSQL.Definition
@@ -104,6 +108,9 @@ import qualified Control.Monad.Trans.Writer.Strict as Strict
104108import qualified Control.Monad.Trans.RWS.Lazy as Lazy
105109import qualified Control.Monad.Trans.RWS.Strict as Strict
106110
111+-- $setup
112+-- >>> import Squeal.PostgreSQL
113+
107114{- | Makes a new connection to the database server.
108115
109116This function opens a new database connection using the parameters taken
@@ -131,19 +138,19 @@ with the wrong schema!
131138-}
132139connectdb
133140 :: forall schemas io
134− . MonadBase IO io
141+ . MonadIO io
135142 => ByteString -- ^ conninfo
136143 -> io (K LibPQ.Connection schemas)
137−connectdb = fmap K . liftBase . LibPQ.connectdb
144+connectdb = fmap K . liftIO . LibPQ.connectdb
138145
139146-- | Closes the connection to the server.
140−finish :: MonadBase IO io => K LibPQ.Connection schemas -> io ()
141−finish = liftBase . LibPQ.finish . unK
147+finish :: MonadIO io => K LibPQ.Connection schemas -> io ()
148+finish = liftIO . LibPQ.finish . unK
142149
143150-- | Do `connectdb` and `finish` before and after a computation.
144151withConnection
145152 :: forall schemas0 schemas1 io x
146− . MonadBaseControl IO io
153+ . MonadUnliftIO io
147154 => ByteString
148155 -> PQ schemas0 schemas1 io x
149156 -> io x
@@ -171,7 +178,7 @@ instance Monad m => Functor (PQ schemas0 schemas1 m) where
171178 K x <- pq conn
172179 return $ K (f x)
173180
174−-- | Run a `PQ` and keep the result and the `Connection`.
181+-- | Run a `PQ` and keep the result and the `LibPQ.Connection`.
175182runPQ
176183 :: Functor m
177184 => PQ schemas0 schemas1 m x
@@ -181,7 +188,7 @@ runPQ (PQ pq) conn = (\ x -> (unK x, K (unK conn))) <$> pq conn
181188 -- K x <- pq conn
182189 -- return (x, K (unK conn))
183190
184−-- | Execute a `PQ` and discard the result but keep the `Connection`.
191+-- | Execute a `PQ` and discard the result but keep the `LibPQ.Connection`.
185192execPQ
186193 :: Functor m
187194 => PQ schemas0 schemas1 m x
@@ -189,7 +196,7 @@ execPQ
189196 -> m (K LibPQ.Connection schemas1)
190197execPQ (PQ pq) conn = mapKK (\ _ -> unK conn) <$> pq conn
191198
192−-- | Evaluate a `PQ` and discard the `Connection` but keep the result.
199+-- | Evaluate a `PQ` and discard the `LibPQ.Connection` but keep the result.
193200evalPQ
194201 :: Functor m
195202 => PQ schemas0 schemas1 m x
@@ -201,8 +208,7 @@ evalPQ (PQ pq) conn = unK <$> pq conn
201208-- [enriched category](https://ncatlab.org/nlab/show/enriched+category).
202209-- An indexed monad transformer transforms a `Monad` into an indexed monad.
203210-- And, `IndexedMonadTransPQ` is a class for indexed monad transformers that
204−-- support running `Definition`s using `define` and embedding a computation
205−-- in a larger schema using `pqEmbed`.
211+-- support running `Definition`s using `define`.
206212class IndexedMonadTransPQ pq where
207213
208214 -- | indexed analog of `<*>`
@@ -242,19 +248,16 @@ class IndexedMonadTransPQ pq where
242248 -> x -> pq schemas0 schemas2 m z
243249 pqAndThen g f x = pqBind g (f x)
244250
245− -- | Safely embed a computation in a larger schema.
246− pqEmbed
247− :: Monad m
248− => pq schemas0 schemas1 m x
249− -> pq (schema ': schemas0) (schema : schemas1) m x
250−
251− -- | Run a `Definition` with `LibPQ.exec`, we expect that libpq obeys the law
251+ -- | Run a `Definition` with `LibPQ.exec`.
252+ --
253+ -- It should be functorial in effect.
252254 --
253− -- @define statement1 & pqThen (define statement2) = define (statement1 >>> statement2)@
255+ -- @define id = return ()@
256+ -- @define (statement1 >>> statement2) = define statement1 & pqThen (define statement2)@
254257 define
255− :: MonadBase IO io
258+ :: MonadIO io
256259 => Definition schemas0 schemas1
257− -> pq schemas0 schemas1 io (K LibPQ.Result '[])
260+ -> pq schemas0 schemas1 io ()
258261
259262instance IndexedMonadTransPQ PQ where
260263
@@ -267,26 +270,26 @@ instance IndexedMonadTransPQ PQ where
267270 K x' <- x conn
268271 unPQ (f x') (K (unK conn))
269272
270− pqEmbed (PQ pq) = PQ $ \ (K conn) -> do
271− K x <- pq (K conn)
272− return $ K x
273−
274273 define (UnsafeDefinition q) = PQ $ \ (K conn) -> do
275− resultMaybe <- liftBase $ LibPQ.exec conn q
274+ resultMaybe <- liftIO $ LibPQ.exec conn q
276275 case resultMaybe of
277276 Nothing -> throw $ ResultException
278277 "define: LibPQ.exec returned no results"
279− Just result -> return $ K (K result)
278+ Just result -> K <$> okResult_ result
280279
281−{- | `MonadPQ` is an `mtl` style constraint, similar to
282−`Control.Monad.State.Class.MonadState`, for using `LibPQ` to
280+{- | `MonadPQ` is an @mtl@ style constraint, similar to
281+`Control.Monad.State.Class.MonadState`, for using `Database.PostgreSQL.LibPQ` to
283282
284283* `manipulateParams` runs a `Manipulation` with params from a type
285284 with a `ToParams` constraint. It calls `LibPQ.execParams` and
286285 doesn't afraid of anything.
287286
287+* `manipulateParams_` is like `manipulateParams` for a returning-free statement.
288+
288289* `manipulate` is like `manipulateParams` for a parameter-free statement.
289290
291+* `manipulate_` is like `manipulate` for a returning-free statement.
292+
290293* `runQueryParams` is like `manipulateParams` for query statements.
291294
292295* `runQuery` is like `runQueryParams` for a parameter-free statement.
@@ -300,11 +303,11 @@ instance IndexedMonadTransPQ PQ where
300303* `forPrepared` is a flipped `traversePrepared`
301304
302305* `traversePrepared_` is like `traversePrepared` but works on `Foldable`
303− containers and returns unit.
306+ containers for a returning-free statement.
304307
305308* `forPrepared_` is a flipped `traversePrepared_`.
306309
307−* `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
308311 into your monad.
309312
310313To define an instance, you can minimally define only `manipulateParams`,
@@ -314,74 +317,84 @@ a default instance.
314317-}
315318class Monad pq => MonadPQ schemas pq | pq -> schemas where
316319 manipulateParams
317− :: ToParams x params
320+ :: (ToParams x params, All OidOfParam params)
318321 => Manipulation '[] schemas params ys
319− -- ^ `insertRows`, `update` or `deleteFrom`
322+ -- ^ `insertInto`, `update` or `deleteFrom`
320323 -> x -> pq (K LibPQ.Result ys)
321324 default manipulateParams
322325 :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)
323− => ToParams x params
326+ => (ToParams x params, All OidOfParam params)
324327 => Manipulation '[] schemas params ys
325− -- ^ `insertRows`, `update` or `deleteFrom`
328+ -- ^ `insertInto`, `update` or `deleteFrom`
326329 -> x -> pq (K LibPQ.Result ys)
327330 manipulateParams manipulation params = lift $
328331 manipulateParams manipulation params
329332
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+
330340 manipulate :: Manipulation '[] schemas '[] ys -> pq (K LibPQ.Result ys)
331341 manipulate statement = manipulateParams statement ()
332342
343+ manipulate_ :: Manipulation '[] schemas '[] '[] -> pq ()
344+ manipulate_ = void . manipulate
345+
333346 runQueryParams
334− :: ToParams x params
335− => Query '[] schemas params ys
347+ :: (ToParams x params, All OidOfParam params)
348+ => Query '[] '[] schemas params ys
336349 -- ^ `select` and friends
337350 -> x -> pq (K LibPQ.Result ys)
338351 runQueryParams = manipulateParams . queryStatement
339352
340353 runQuery
341− :: Query '[] schemas '[] ys
354+ :: Query '[] '[] schemas '[] ys
342355 -- ^ `select` and friends
343356 -> pq (K LibPQ.Result ys)
344357 runQuery q = runQueryParams q ()
345358
346359 traversePrepared
347− :: (ToParams x params, Traversable list)
360+ :: (ToParams x params, Traversable list, All OidOfParam params)
348361 => Manipulation '[] schemas params ys
349− -- ^ `insertRows`, `update`, or `deleteFrom`, and friends
362+ -- ^ `insertInto`, `update`, or `deleteFrom`, and friends
350363 -> list x -> pq (list (K LibPQ.Result ys))
351364 default traversePrepared
352365 :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)
353− => (ToParams x params, Traversable list)
366+ => (ToParams x params, Traversable list, All OidOfParam params)
354367 => Manipulation '[] schemas params ys -> list x -> pq (list (K LibPQ.Result ys))
355368 traversePrepared manipulation params = lift $
356369 traversePrepared manipulation params
357370
358371 forPrepared
359− :: (ToParams x params, Traversable list)
372+ :: (ToParams x params, Traversable list, All OidOfParam params)
360373 => list x
361374 -> Manipulation '[] schemas params ys
362− -- ^ `insertRows`, `update` or `deleteFrom`
375+ -- ^ `insertInto`, `update` or `deleteFrom`
363376 -> pq (list (K LibPQ.Result ys))
364377 forPrepared = flip traversePrepared
365378
366379 traversePrepared_
367− :: (ToParams x params, Foldable list)
380+ :: (ToParams x params, Foldable list, All OidOfParam params)
368381 => Manipulation '[] schemas params '[]
369− -- ^ `insertRows`, `update` or `deleteFrom`
382+ -- ^ `insertInto`, `update` or `deleteFrom`
370383 -> list x -> pq ()
371384 default traversePrepared_
372385 :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)
373− => (ToParams x params, Foldable list)
386+ => (ToParams x params, Foldable list, All OidOfParam params)
374387 => Manipulation '[] schemas params '[]
375− -- ^ `insertRows`, `update` or `deleteFrom`
388+ -- ^ `insertInto`, `update` or `deleteFrom`
376389 -> list x -> pq ()
377390 traversePrepared_ manipulation params = lift $
378391 traversePrepared_ manipulation params
379392
380393 forPrepared_
381− :: (ToParams x params, Foldable list)
394+ :: (ToParams x params, Foldable list, All OidOfParam params)
382395 => list x
383396 -> Manipulation '[] schemas params '[]
384− -- ^ `insertRows`, `update` or `deleteFrom`
397+ -- ^ `insertInto`, `update` or `deleteFrom`
385398 -> pq ()
386399 forPrepared_ = flip traversePrepared_
387400
@@ -391,61 +404,83 @@ class Monad pq => MonadPQ schemas pq | pq -> schemas where
391404 => (LibPQ.Connection -> IO a) -> pq a
392405 liftPQ = lift . liftPQ
393406
394−instance (MonadBase IO io, schemas0 ~ schemas, schemas1 ~ schemas)
407+instance (MonadIO io, schemas0 ~ schemas, schemas1 ~ schemas)
395408 => MonadPQ schemas (PQ schemas0 schemas1 io) where
396409
397410 manipulateParams
398411 (UnsafeManipulation q :: Manipulation '[] schemas ps ys) (params :: x) =
399412 PQ $ \ (K conn) -> do
400413 let
401− toParam' encoding =
402− (LibPQ.invalidOid, encodingBytes encoding, LibPQ.Binary)
403− params' = fmap (fmap toParam') (hcollapse (toParams @x @ps params))
414+ paramSet
415+ :: forall param. OidOfParam param
416+ => K (Maybe Encoding.Encoding) param
417+ -> K (Maybe (LibPQ.Oid, ByteString, LibPQ.Format)) param
418+ paramSet (K maybeEncoding) = K $
419+ maybeEncoding <&> \encoding ->
420+ (oidOfParam @param, encodingBytes encoding, LibPQ.Binary)
421+ params'
422+ = hcollapse
423+ . hcmap (Proxy @OidOfParam) paramSet
424+ $ toParams @x @ps params
404425 q' = q <> ";"
405− resultMaybe <- liftBase $ LibPQ.execParams conn q' params' LibPQ.Binary
426+ resultMaybe <- liftIO $ LibPQ.execParams conn q' params' LibPQ.Binary
406427 case resultMaybe of
407428 Nothing -> throw $ ResultException
408429 "manipulateParams: LibPQ.execParams returned no results"
409430 Just result -> do
410− tryResult result
431+ okResult_ result
411432 return $ K (K result)
412433
413434 traversePrepared
414435 (UnsafeManipulation q :: Manipulation '[] schemas xs ys) (list :: list x) =
415− PQ $ \ (K conn) -> liftBase $ do
416− let temp = "temporary_statement"
417− prepResultMaybe <- LibPQ.prepare conn temp q Nothing
436+ PQ $ \ (K conn) -> liftIO $ do
437+ let
438+ temp = "temporary_statement"
439+ paramOid :: forall p. OidOfParam p => K LibPQ.Oid p
440+ paramOid = K (oidOfParam @p)
441+ paramOids :: NP (K LibPQ.Oid) xs
442+ paramOids = hcpure (Proxy @OidOfParam) paramOid
443+ paramOids' :: [LibPQ.Oid]
444+ paramOids' = hcollapse paramOids
445+ prepResultMaybe <- LibPQ.prepare conn temp q (Just paramOids')
418446 case prepResultMaybe of
419447 Nothing -> throw $ ResultException
420448 "traversePrepared: LibPQ.prepare returned no results"
421− Just prepResult -> tryResult prepResult
449+ Just prepResult -> okResult_ prepResult
422450 results <- for list $ \ params -> do
423451 let
424− toParam' encoding = (encodingBytes encoding,LibPQ.Binary)
452+ toParam' encoding = (encodingBytes encoding, LibPQ.Binary)
425453 params' = fmap (fmap toParam') (hcollapse (toParams @x @xs params))
426454 resultMaybe <- LibPQ.execPrepared conn temp params' LibPQ.Binary
427455 case resultMaybe of
428456 Nothing -> throw $ ResultException
429457 "traversePrepared: LibPQ.execParams returned no results"
430458 Just result -> do
431− tryResult result
459+ okResult_ result
432460 return $ K result
433461 deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")
434462 case deallocResultMaybe of
435463 Nothing -> throw $ ResultException
436464 "traversePrepared: LibPQ.exec DEALLOCATE returned no results"
437− Just deallocResult -> tryResult deallocResult
465+ Just deallocResult -> okResult_ deallocResult
438466 return (K results)
439467
440468 traversePrepared_
441469 (UnsafeManipulation q :: Manipulation '[] schemas xs '[]) (list :: list x) =
442− PQ $ \ (K conn) -> liftBase $ do
443− let temp = "temporary_statement"
444− prepResultMaybe <- LibPQ.prepare conn temp q Nothing
470+ PQ $ \ (K conn) -> liftIO $ do
471+ let
472+ temp = "temporary_statement"
473+ paramOid :: forall p. OidOfParam p => K LibPQ.Oid p
474+ paramOid = K (oidOfParam @p)
475+ paramOids :: NP (K LibPQ.Oid) xs
476+ paramOids = hcpure (Proxy @OidOfParam) paramOid
477+ paramOids' :: [LibPQ.Oid]
478+ paramOids' = hcollapse paramOids
479+ prepResultMaybe <- LibPQ.prepare conn temp q (Just paramOids')
445480 case prepResultMaybe of
446481 Nothing -> throw $ ResultException
447482 "traversePrepared_: LibPQ.prepare returned no results"
448− Just prepResult -> tryResult prepResult
483+ Just prepResult -> okResult_ prepResult
449484 for_ list $ \ params -> do
450485 let
451486 toParam' encoding = (encodingBytes encoding, LibPQ.Binary)
@@ -454,16 +489,16 @@ instance (MonadBase IO io, schemas0 ~ schemas, schemas1 ~ schemas)
454489 case resultMaybe of
455490 Nothing -> throw $ ResultException
456491 "traversePrepared_: LibPQ.execParams returned no results"
457− Just result -> tryResult result
492+ Just result -> okResult_ result
458493 deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")
459494 case deallocResultMaybe of
460495 Nothing -> throw $ ResultException
461496 "traversePrepared: LibPQ.exec DEALLOCATE returned no results"
462− Just deallocResult -> tryResult deallocResult
497+ Just deallocResult -> okResult_ deallocResult
463498 return (K ())
464499
465500 liftPQ pq = PQ $ \ (K conn) -> do
466− y <- liftBase $ pq conn
501+ y <- liftIO $ pq conn
467502 return (K y)
468503
469504instance MonadPQ schemas m => MonadPQ schemas (IdentityT m)
@@ -488,6 +523,10 @@ instance (Monad m, schemas0 ~ schemas1)
488523 return = pure
489524 (>>=) = flip pqBind
490525
526+instance (Monad m, schemas0 ~ schemas1)
527+ => Fail.MonadFail (PQ schemas0 schemas1 m) where
528+ fail = Fail.fail
529+
491530instance schemas0 ~ schemas1 => MFunctor (PQ schemas0 schemas1) where
492531 hoist f (PQ pq) = PQ (f . pq)
493532
@@ -500,40 +539,29 @@ instance schemas0 ~ schemas1 => MMonad (PQ schemas0 schemas1) where
500539 embed f (PQ pq) = PQ $ \ conn -> do
501540 evalPQ (f (pq conn)) conn
502541
503−instance (MonadBase b m, schemas0 ~ schemas1)
504− => MonadBase b (PQ schemas0 schemas1 m) where
505− liftBase = lift . liftBase
506−
507542instance (MonadIO m, schema0 ~ schema1)
508543 => MonadIO (PQ schema0 schema1 m) where
509544 liftIO = lift . liftIO
510545
511−-- | A snapshot of the state of a `PQ` computation.
512−type PQRun schemas =
513− forall m x. Monad m => PQ schemas schemas m x -> m (K x schemas)
514−
515−-- | Helper function in defining `MonadBaseControl` instance for `PQ`.
516−pqliftWith :: Functor m => (PQRun schemas -> m a) -> PQ schemas schemas m a
517−pqliftWith f = PQ $ \ conn ->
518− fmap K (f $ \ pq -> unPQ pq conn)
519−
520−instance (MonadBaseControl b m, schemas0 ~ schemas1)
521− => MonadBaseControl b (PQ schemas0 schemas1 m) where
522− type StM (PQ schemas0 schemas1 m) x = StM m (K x schemas0)
523− liftBaseWith f =
524− pqliftWith $ \ run -> liftBaseWith $ \ runInBase -> f $ runInBase . run
525− restoreM = PQ . const . restoreM
546+instance (MonadUnliftIO m, schemas0 ~ schemas1)
547+ => MonadUnliftIO (PQ schemas0 schemas1 m) where
548+ withRunInIO
549+ :: ((forall a . PQ schemas0 schema1 m a -> IO a) -> IO b)
550+ -> PQ schemas0 schema1 m b
551+ withRunInIO inner = PQ $ \conn ->
552+ withRunInIO $ \(run :: (forall x . m x -> IO x)) ->
553+ K <$> inner (\pq -> run $ unK <$> unPQ pq conn)
526554
527555-- | Get a row corresponding to a given row number from a `LibPQ.Result`,
528556-- throwing an exception if the row number is out of bounds.
529557getRow
530− :: (FromRow columns y, MonadBase IO io)
558+ :: (FromRow columns y, MonadIO io)
531559 => LibPQ.Row
532560 -- ^ row number
533561 -> K LibPQ.Result columns
534562 -- ^ result
535563 -> io y
536−getRow r (K result :: K LibPQ.Result columns) = liftBase $ do
564+getRow r (K result :: K LibPQ.Result columns) = liftIO $ do
537565 numRows <- LibPQ.ntuples result
538566 when (numRows < r) $ throw $ ResultException $
539567 "getRow: expected at least " <> pack (show r) <> "rows but only saw "
@@ -551,13 +579,13 @@ getRow r (K result :: K LibPQ.Result columns) = liftBase $ do
551579-- and a `LibPQ.Result` and given a row number if it's too large returns `Nothing`,
552580-- otherwise returning the row along with the next row number.
553581nextRow
554− :: (FromRow columns y, MonadBase IO io)
582+ :: (FromRow columns y, MonadIO io)
555583 => LibPQ.Row -- ^ total number of rows
556584 -> K LibPQ.Result columns -- ^ result
557585 -> LibPQ.Row -- ^ row number
558586 -> io (Maybe (LibPQ.Row,y))
559587nextRow total (K result :: K LibPQ.Result columns) r
560− = liftBase $ if r >= total then return Nothing else do
588+ = liftIO $ if r >= total then return Nothing else do
561589 let len = fromIntegral (lengthSList (Proxy @columns))
562590 row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]
563591 case fromList row' of
@@ -568,10 +596,10 @@ nextRow total (K result :: K LibPQ.Result columns) r
568596
569597-- | Get all rows from a `LibPQ.Result`.
570598getRows
571− :: (FromRow columns y, MonadBase IO io)
599+ :: (FromRow columns y, MonadIO io)
572600 => K LibPQ.Result columns -- ^ result
573601 -> io [y]
574−getRows (K result :: K LibPQ.Result columns) = liftBase $ do
602+getRows (K result :: K LibPQ.Result columns) = liftIO $ do
575603 let len = fromIntegral (lengthSList (Proxy @columns))
576604 numRows <- LibPQ.ntuples result
577605 for [0 .. numRows - 1] $ \ r -> do
@@ -584,10 +612,10 @@ getRows (K result :: K LibPQ.Result columns) = liftBase $ do
584612
585613-- | Get the first row if possible from a `LibPQ.Result`.
586614firstRow
587− :: (FromRow columns y, MonadBase IO io)
615+ :: (FromRow columns y, MonadIO io)
588616 => K LibPQ.Result columns -- ^ result
589617 -> io (Maybe y)
590−firstRow (K result :: K LibPQ.Result columns) = liftBase $ do
618+firstRow (K result :: K LibPQ.Result columns) = liftIO $ do
591619 numRows <- LibPQ.ntuples result
592620 if numRows <= 0 then return Nothing else do
593621 let len = fromIntegral (lengthSList (Proxy @columns))
@@ -600,23 +628,23 @@ firstRow (K result :: K LibPQ.Result columns) = liftBase $ do
600628
601629-- | Lifts actions on results from @LibPQ@.
602630liftResult
603− :: MonadBase IO io
631+ :: MonadIO io
604632 => (LibPQ.Result -> IO x)
605633 -> K LibPQ.Result results -> io x
606−liftResult f (K result) = liftBase $ f result
634+liftResult f (K result) = liftIO $ f result
607635
608636-- | Returns the number of rows (tuples) in the query result.
609−ntuples :: MonadBase IO io => K LibPQ.Result columns -> io LibPQ.Row
637+ntuples :: MonadIO io => K LibPQ.Result columns -> io LibPQ.Row
610638ntuples = liftResult LibPQ.ntuples
611639
612640-- | Returns the result status of the command.
613−resultStatus :: MonadBase IO io => K LibPQ.Result results -> io LibPQ.ExecStatus
641+resultStatus :: MonadIO io => K LibPQ.Result results -> io LibPQ.ExecStatus
614642resultStatus = liftResult LibPQ.resultStatus
615643
616644-- | Returns the error message most recently generated by an operation
617645-- on the connection.
618646resultErrorMessage
619− :: MonadBase IO io => K LibPQ.Result results -> io (Maybe ByteString)
647+ :: MonadIO io => K LibPQ.Result results -> io (Maybe ByteString)
620648resultErrorMessage = liftResult LibPQ.resultErrorMessage
621649
622650-- | Returns the error code most recently generated by an operation
@@ -624,29 +652,29 @@ resultErrorMessage = liftResult LibPQ.resultErrorMessage
624652--
625653-- https://www.postgresql.org/docs/current/static/errcodes-appendix.html
626654resultErrorCode
627− :: MonadBase IO io
655+ :: MonadIO io
628656 => K LibPQ.Result results
629657 -> io (Maybe ByteString)
630658resultErrorCode = liftResult (flip LibPQ.resultErrorField LibPQ.DiagSqlstate)
631659
632−-- | `Exception`s that can be thrown by Squeal.
633−data SquealException
634− = PQException
660+-- | the state of LibPQ
661+data PQState = PQState
635662 { sqlExecStatus :: LibPQ.ExecStatus
636663 , sqlStateCode :: Maybe ByteString
637664 -- ^ https://www.postgresql.org/docs/current/static/errcodes-appendix.html
638665 , sqlErrorMessage :: Maybe ByteString
639− }
666+ } deriving (Eq, Show)
667+
668+-- | `Exception`s that can be thrown by Squeal.
669+data SquealException
670+ = PQException PQState
640671 | ResultException Text
641672 | ParseException Text
642673 deriving (Eq, Show)
643674instance Exception SquealException
644675
645−tryResult
646− :: MonadBase IO io
647− => LibPQ.Result
648− -> io ()
649−tryResult result = liftBase $ do
676+okResult_ :: MonadIO io => LibPQ.Result -> io ()
677+okResult_ result = liftIO $ do
650678 status <- LibPQ.resultStatus result
651679 case status of
652680 LibPQ.CommandOk -> return ()
@@ -654,11 +682,16 @@ tryResult result = liftBase $ do
654682 _ -> do
655683 stateCode <- LibPQ.resultErrorField result LibPQ.DiagSqlstate
656684 msg <- LibPQ.resultErrorMessage result
657− 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
658691
659692-- | Catch `SquealException`s.
660693catchSqueal
661− :: MonadBaseControl IO io
694+ :: MonadUnliftIO io
662695 => io a
663696 -> (SquealException -> io a) -- ^ handler
664697 -> io a
@@ -666,7 +699,14 @@ catchSqueal = catch
666699
667700-- | Handle `SquealException`s.
668701handleSqueal
669− :: MonadBaseControl IO io
702+ :: MonadUnliftIO io
670703 => (SquealException -> io a) -- ^ handler
671704 -> io a -> io a
672705handleSqueal = 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+72−103
@@ -1,17 +1,40 @@
11{-|
2−Module: Squeal.PostgreSQL.Definition
3−Description: Pooled connections
2+Module: Squeal.PostgreSQL.Pool
3+Description: Connection pools
44Copyright: (c) Eitan Chatav, 2017
55Maintainer: eitan@morphism.tech
66Stability: experimental
77
8−A `MonadPQ` for pooled connections.
8+Connection pools.
9+
10+Typical use case would be to create your pool using `createConnectionPool`
11+and run anything that requires the pool connection with `usingConnectionPool`.
12+
13+Here's a simplified example:
14+
15+>>> import Squeal.PostgreSQL
16+
17+>>> :{
18+do
19+ let
20+ query :: Query_ (Public '[]) () (Only Char)
21+ query = values_ (literal 'a' `as` #fromOnly)
22+ pool <- createConnectionPool "host=localhost port=5432 dbname=exampledb" 1 0.5 10
23+ chr <- usingConnectionPool pool $ do
24+ result <- runQuery query
25+ Just (Only a) <- firstRow result
26+ return a
27+ destroyConnectionPool pool
28+ putChar chr
29+:}
30+a
931-}
1032
1133{-# LANGUAGE
1234 DeriveFunctor
1335 , FlexibleContexts
1436 , FlexibleInstances
37+ , InstanceSigs
1538 , MultiParamTypeClasses
1639 , RankNTypes
1740 , ScopedTypeVariables
@@ -22,55 +45,24 @@ A `MonadPQ` for pooled connections.
2245
2346module Squeal.PostgreSQL.Pool
2447 ( -- * Pools
25− PoolPQ (..)
48+ Pool
2649 , createConnectionPool
27− , Pool
28− , destroyAllResources
29− , PoolPQRun
30− , poolpqliftWith
50+ , usingConnectionPool
51+ , destroyConnectionPool
3152 ) where
3253
33−import Control.Monad.Base
34−import Control.Monad.Trans
35−import Control.Monad.Trans.Control
3654import Data.ByteString
37−import Data.Pool
3855import 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)
4059
4160import Squeal.PostgreSQL.PQ
42−import Squeal.PostgreSQL.Schema
43−
44−{- | `PoolPQ` @schemas@ should be a drop-in replacement for `PQ` @schemas schemas@.
45−
46−Typical use case would be to create your pool using `createConnectionPool` and run anything that requires the pool connection with it.
47−
48−Here's a simplified example:
49−
50−> 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 (schemas :: SchemasType) m x =
67− PoolPQ { runPoolPQ :: Pool (K Connection schemas) -> m x }
68− deriving Functor
6961
7062-- | Create a striped pool of connections.
7163-- 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.
7264createConnectionPool
73− :: MonadBase IO io
65+ :: MonadUnliftIO io
7466 => ByteString
7567 -- ^ The passed string can be empty to use all default parameters, or it can
7668 -- contain one or more parameter settings separated by whitespace.
@@ -87,67 +79,44 @@ createConnectionPool
8779 -- ^ Maximum number of connections to keep open per stripe. The smallest acceptable value is 1.
8880 -- Requests for connections will block if this limit is reached on a single stripe, even if other stripes have idle connections available.
8981 -> io (Pool (K Connection schemas))
90−createConnectionPool conninfo stripes idle maxResrc = liftBase $
82+createConnectionPool conninfo stripes idle maxResrc =
9183 createPool (connectdb conninfo) finish stripes idle maxResrc
9284
93−-- | `Applicative` instance for `PoolPQ`.
94−instance Monad m => Applicative (PoolPQ schemas m) where
95− pure x = PoolPQ $ \ _ -> pure x
96− PoolPQ f <*> PoolPQ x = PoolPQ $ \ pool -> do
97− f' <- f pool
98− x' <- x pool
99− return $ f' x'
100−
101−-- | `Monad` instance for `PoolPQ`.
102−instance Monad m => Monad (PoolPQ schemas m) where
103− return = pure
104− PoolPQ x >>= f = PoolPQ $ \ pool -> do
105− x' <- x pool
106− runPoolPQ (f x') pool
107−
108−-- | `MonadTrans` instance for `PoolPQ`.
109−instance MonadTrans (PoolPQ schemas) where
110− lift m = PoolPQ $ \ _pool -> m
111−
112−-- | `MonadBase` instance for `PoolPQ`.
113−instance MonadBase b m => MonadBase b (PoolPQ schemas m) where
114− liftBase = lift . liftBase
115−
116−-- | `MonadPQ` instance for `PoolPQ`.
117−instance MonadBaseControl IO io => MonadPQ schemas (PoolPQ schemas io) where
118− manipulateParams manipulation params = PoolPQ $ \ pool -> do
119− withResource pool $ \ conn -> do
120− (K result :: K (K Result ys) schemas) <- flip unPQ conn $
121− manipulateParams manipulation params
122− return result
123− traversePrepared manipulation params = PoolPQ $ \ pool ->
124− withResource pool $ \ conn -> do
125− (K result :: K (list (K Result ys)) schemas) <- flip unPQ conn $
126− traversePrepared manipulation params
127− return result
128− traversePrepared_ manipulation params = PoolPQ $ \ pool -> do
129− withResource pool $ \ conn -> do
130− (_ :: K () schemas) <- flip unPQ conn $
131− traversePrepared_ manipulation params
132− return ()
133− liftPQ m = PoolPQ $ \ pool ->
134− withResource pool $ \ conn -> do
135− (K result :: K result schemas) <- flip unPQ conn $
136− liftPQ m
137− return result
138−
139−-- | A snapshot of the state of a `PoolPQ` computation.
140−type PoolPQRun schemas =
141− forall m x. Monad m => PoolPQ schemas m x -> m x
142−
143−-- | Helper function in defining `MonadBaseControl` instance for `PoolPQ`.
144−poolpqliftWith :: Functor m => (PoolPQRun schemas -> m a) -> PoolPQ schemas 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 schemas m) where
150− type StM (PoolPQ schemas m) x = StM m x
151− liftBaseWith f =
152− poolpqliftWith $ \ run -> liftBaseWith $ \ runInBase -> f $ runInBase . run
153− restoreM = PoolPQ . const . restoreM
85+{-|
86+Temporarily take a connection from a `Pool`, perform an action with it,
87+and return it to the pool afterwards.
88+
89+If the pool has an idle connection available, it is used immediately.
90+Otherwise, if the maximum number of connections has not yet been reached,
91+a new connection is created and used.
92+If the maximum number of connections has been reached, this function blocks
93+until a connection becomes available.
94+-}
95+usingConnectionPool
96+ :: MonadUnliftIO io
97+ => Pool (K Connection schemas) -- ^ pool
98+ -> PQ schemas schemas io x -- ^ session
99+ -> io x
100+usingConnectionPool pool (PQ session) = unK <$> withResource pool session
101+
102+{- |
103+Destroy all connections in all stripes in the pool.
104+Note that this will ignore any exceptions in the destroy function.
105+
106+This function is useful when you detect that all connections
107+in the pool are broken. For example after a database has been
108+restarted all connections opened before the restart will be broken.
109+In that case it's better to close those connections so that
110+`usingConnectionPool` won't take a broken connection from the pool
111+but will open a new connection instead.
112+
113+Another use-case for this function is that when you know you are done
114+with the pool you can destroy all idle connections immediately
115+instead of waiting on the garbage collector to destroy them,
116+thus freeing up those connections sooner.
117+-}
118+destroyConnectionPool
119+ :: MonadUnliftIO io
120+ => Pool (K Connection schemas) -- ^ pool
121+ -> io ()
122+destroyConnectionPool = destroyAllResources
squeal-postgresql/src/Squeal/PostgreSQL/Query.hs+401−686
@@ -1,7 +1,7 @@
11{-|
22Module: Squeal.PostgreSQL.Query
33Description: Squeal queries
4−Copyright: (c) Eitan Chatav, 2017
4+Copyright: (c) Eitan Chatav, 2019
55Maintainer: eitan@morphism.tech
66Stability: experimental
77
@@ -17,7 +17,9 @@ Squeal queries.
1717 , GeneralizedNewtypeDeriving
1818 , LambdaCase
1919 , MultiParamTypeClasses
20+ , OverloadedLabels
2021 , OverloadedStrings
22+ , QuantifiedConstraints
2123 , ScopedTypeVariables
2224 , StandaloneDeriving
2325 , TypeApplications
@@ -30,13 +32,15 @@ Squeal queries.
3032
3133module Squeal.PostgreSQL.Query
3234 ( -- * Queries
33− Query (..)
34− , Query_
35+ Query_
36+ , Query (..)
3537 -- ** Select
3638 , select
3739 , select_
3840 , selectDistinct
3941 , selectDistinct_
42+ , selectDistinctOn
43+ , selectDistinctOn_
4044 , Selection (..)
4145 -- ** Values
4246 , values
@@ -51,23 +55,7 @@ module Squeal.PostgreSQL.Query
5155 -- ** With
5256 , With (..)
5357 , CommonTableExpression (..)
54− , renderCommonTableExpression
55− , renderCommonTableExpressions
56− -- ** Json
57− , jsonEach
58− , jsonbEach
59− , jsonEachAsText
60− , jsonbEachAsText
61− , jsonObjectKeys
62− , jsonbObjectKeys
63− , jsonPopulateRecord
64− , jsonbPopulateRecord
65− , jsonPopulateRecordSet
66− , jsonbPopulateRecordSet
67− , jsonToRecord
68− , jsonbToRecord
69− , jsonToRecordSet
70− , jsonbToRecordSet
58+ , withRecursive
7159 -- * Table Expressions
7260 , TableExpression (..)
7361 , from
@@ -91,33 +79,6 @@ module Squeal.PostgreSQL.Query
9179 , By (..)
9280 , GroupByClause (..)
9381 , HavingClause (..)
94− -- * Subquery Expressions
95− , in_
96− , rowIn
97− , eqAll
98− , rowEqAll
99− , eqAny
100− , rowEqAny
101− , neqAll
102− , rowNeqAll
103− , neqAny
104− , rowNeqAny
105− , allLt
106− , rowLtAll
107− , ltAny
108− , rowLtAny
109− , lteAll
110− , rowLteAll
111− , lteAny
112− , rowLteAny
113− , gtAll
114− , rowGtAll
115− , gtAny
116− , rowGtAny
117− , gteAll
118− , rowGteAll
119− , gteAny
120− , rowGteAny
12182 ) where
12283
12384import Control.DeepSeq
@@ -130,13 +91,67 @@ import GHC.TypeLits
13091
13192import qualified GHC.Generics as GHC
13293
94+import Squeal.PostgreSQL.Alias
13395import 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
134101import Squeal.PostgreSQL.Render
135102import Squeal.PostgreSQL.Schema
136103
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+
137111{- |
138−The process of retrieving or the command to retrieve data from a database
139−is called a `Query`. Let's see some examples of queries.
112+The process of retrieving or the command to retrieve data from
113+a database is called a `Query`.
114+
115+The general `Query` type is parameterized by
116+
117+* @outer :: FromType@ - outer scope for a correlated subquery,
118+* @commons :: FromType@ - scope for all `common` table expressions,
119+* @schemas :: SchemasType@ - scope for all `table`s and `view`s,
120+* @params :: [NullityType]@ - scope for all `Squeal.Expression.Parameter.parameter`s,
121+* @row :: RowType@ - return type of the `Query`.
122+-}
123+newtype Query
124+ (outer :: FromType)
125+ (commons :: FromType)
126+ (schemas :: SchemasType)
127+ (params :: [NullityType])
128+ (row :: RowType)
129+ = UnsafeQuery { renderQuery :: ByteString }
130+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
131+instance RenderSQL (Query outer commons schemas params row) where renderSQL = renderQuery
132+
133+{- |
134+The top level `Query_` type is parameterized by a @schemas@ `SchemasType`,
135+against which the query is type-checked, an input @parameters@ Haskell `Type`,
136+and an ouput row Haskell `Type`.
137+
138+A top-level query can be run
139+using `Squeal.PostgreSQL.PQ.runQueryParams`, or if @parameters = ()@
140+using `Squeal.PostgreSQL.PQ.runQuery`.
141+
142+Generally, @parameters@ will be a Haskell tuple or record whose entries
143+may be referenced using positional
144+`Squeal.PostgreSQL.Expression.Parameter.parameter`s and @row@ will be a
145+Haskell record, whose entries will be targeted using overloaded labels.
146+
147+Let's see some examples of queries.
148+
149+>>> :set -XDeriveAnyClass -XDerivingStrategies
150+>>> :{
151+data Row a b = Row { col1 :: a, col2 :: b }
152+ deriving stock (GHC.Generic)
153+ deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
154+:}
140155
141156simple query:
142157
@@ -144,7 +159,7 @@ simple query:
144159>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]
145160>>> :{
146161let
147− query :: Query '[] (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]
162+ query :: Query_ (Public Schema) () (Row Int32 Int32)
148163 query = select Star (from (table #tab))
149164in printSQL query
150165:}
@@ -154,21 +169,21 @@ restricted query:
154169
155170>>> :{
156171let
157− query :: Query '[] (Public Schema) '[] '["sum" ::: 'NotNull 'PGint4, "col1" ::: 'NotNull 'PGint4]
172+ query :: Query_ (Public Schema) () (Row Int32 Int32)
158173 query =
159− select_ ((#col1 + #col2) `as` #sum :* #col1)
174+ select_ ((#col1 + #col2) `as` #col1 :* #col1 `as` #col2)
160175 ( from (table #tab)
161176 & where_ (#col1 .> #col2)
162177 & where_ (#col2 .> 0) )
163178in printSQL query
164179:}
165−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))
166181
167182subquery:
168183
169184>>> :{
170185let
171− query :: Query '[] (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]
186+ query :: Query_ (Public Schema) () (Row Int32 Int32)
172187 query = select Star (from (subquery (select Star (from (table #tab)) `as` #sub)))
173188in printSQL query
174189:}
@@ -178,7 +193,7 @@ limits and offsets:
178193
179194>>> :{
180195let
181− query :: Query '[] (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]
196+ query :: Query_ (Public Schema) () (Row Int32 Int32)
182197 query = select Star (from (table #tab) & limit 100 & offset 2 & limit 50 & offset 2)
183198in printSQL query
184199:}
@@ -188,7 +203,7 @@ parameterized query:
188203
189204>>> :{
190205let
191− query :: Query '[] (Public Schema) '[ 'NotNull 'PGint4] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]
206+ query :: Query_ (Public Schema) (Only Int32) (Row Int32 Int32)
192207 query = select Star (from (table #tab) & where_ (#col1 .> param @1))
193208in printSQL query
194209:}
@@ -198,21 +213,21 @@ aggregation query:
198213
199214>>> :{
200215let
201− query :: Query '[] (Public Schema) '[] '["sum" ::: 'NotNull 'PGint4, "col1" ::: 'NotNull 'PGint4 ]
216+ query :: Query_ (Public Schema) () (Row Int64 Int32)
202217 query =
203− select_ (sum_ (All #col2) `as` #sum :* #col1)
218+ select_ ((fromNull 0 (sum_ (All #col2))) `as` #col1 :* #col1 `as` #col2)
204219 ( from (table (#tab `as` #table1))
205220 & groupBy #col1
206− & having (#col1 + sum_ (Distinct #col2) .> 1) )
221+ & having (sum_ (Distinct #col2) .> 1) )
207222in printSQL query
208223:}
209−SELECT sum(ALL "col2") AS "sum", "col1" AS "col1" FROM "tab" AS "table1" GROUP BY "col1" HAVING (("col1" + sum(DISTINCT "col2")) > 1)
224+SELECT COALESCE(sum(ALL "col2"), 0) AS "col1", "col1" AS "col2" FROM "tab" AS "table1" GROUP BY "col1" HAVING (sum(DISTINCT "col2") > 1)
210225
211226sorted query:
212227
213228>>> :{
214229let
215− query :: Query '[] (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]
230+ query :: Query_ (Public Schema) () (Row Int32 Int32)
216231 query = select Star (from (table #tab) & orderBy [#col1 & Asc])
217232in printSQL query
218233:}
@@ -220,14 +235,12 @@ SELECT * FROM "tab" AS "tab" ORDER BY "col1" ASC
220235
221236joins:
222237
223−>>> :set -XFlexibleContexts
224238>>> :{
225239type OrdersColumns =
226240 '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4
227− , "price" ::: 'NoDef :=> 'NotNull 'PGfloat4
228− , "customer_id" ::: 'NoDef :=> 'NotNull 'PGint4
229− , "shipper_id" ::: 'NoDef :=> 'NotNull 'PGint4
230− ]
241+ , "price" ::: 'NoDef :=> 'NotNull 'PGfloat4
242+ , "customer_id" ::: 'NoDef :=> 'NotNull 'PGint4
243+ , "shipper_id" ::: 'NoDef :=> 'NotNull 'PGint4 ]
231244:}
232245
233246>>> :{
@@ -243,22 +256,27 @@ type OrdersConstraints =
243256>>> :{
244257type OrdersSchema =
245258 '[ "orders" ::: 'Table (OrdersConstraints :=> OrdersColumns)
246− , "customers" ::: 'Table (CustomersConstraints :=> NamesColumns)
247− , "shippers" ::: 'Table (ShippersConstraints :=> NamesColumns) ]
259+ , "customers" ::: 'Table (CustomersConstraints :=> NamesColumns)
260+ , "shippers" ::: 'Table (ShippersConstraints :=> NamesColumns) ]
261+:}
262+
263+>>> :{
264+data Order = Order
265+ { price :: Float
266+ , customerName :: Text
267+ , shipperName :: Text
268+ } deriving GHC.Generic
269+instance SOP.Generic Order
270+instance SOP.HasDatatypeInfo Order
248271:}
249272
250273>>> :{
251274let
252− query :: Query '[] (Public OrdersSchema)
253− '[]
254− '[ "order_price" ::: 'NotNull 'PGfloat4
255− , "customer_name" ::: 'NotNull 'PGtext
256− , "shipper_name" ::: 'NotNull 'PGtext
257− ]
275+ query :: Query_ (Public OrdersSchema) () Order
258276 query = select_
259− ( #o ! #price `as` #order_price :*
260− #c ! #name `as` #customer_name :*
261− #s ! #name `as` #shipper_name )
277+ ( #o ! #price `as` #price :*
278+ #c ! #name `as` #customerName :*
279+ #s ! #name `as` #shipperName )
262280 ( from (table (#orders `as` #o)
263281 & innerJoin (table (#customers `as` #c))
264282 (#o ! #customer_id .== #c ! #id)
@@ -266,14 +284,16 @@ let
266284 (#o ! #shipper_id .== #s ! #id)) )
267285in printSQL query
268286:}
269−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")
270288
271289self-join:
272290
273291>>> :{
274292let
275− query :: Query '[] (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]
276− query = select (#t1 & DotStar) (from (table (#tab `as` #t1) & crossJoin (table (#tab `as` #t2))))
293+ query :: Query_ (Public Schema) () (Row Int32 Int32)
294+ query = select
295+ (#t1 & DotStar)
296+ (from (table (#tab `as` #t1) & crossJoin (table (#tab `as` #t2))))
277297in printSQL query
278298:}
279299SELECT "t1".* FROM "tab" AS "t1" CROSS JOIN "tab" AS "t2"
@@ -282,17 +302,19 @@ value queries:
282302
283303>>> :{
284304let
285− query :: Query commons schemas '[] '["foo" ::: 'NotNull 'PGint2, "bar" ::: 'NotNull 'PGbool]
286− query = values (1 `as` #foo :* true `as` #bar) [2 `as` #foo :* false `as` #bar]
305+ query :: Query_ schemas () (Row String Bool)
306+ query = values
307+ ("true" `as` #col1 :* true `as` #col2)
308+ ["false" `as` #col1 :* false `as` #col2]
287309in printSQL query
288310:}
289−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")
290312
291313set operations:
292314
293315>>> :{
294316let
295− query :: Query '[] (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]
317+ query :: Query_ (Public Schema) () (Row Int32 Int32)
296318 query = select Star (from (table #tab)) `unionAll` select Star (from (table #tab))
297319in printSQL query
298320:}
@@ -302,7 +324,7 @@ with queries:
302324
303325>>> :{
304326let
305− query :: Query '[] (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]
327+ query :: Query_ (Public Schema) () (Row Int32 Int32)
306328 query = with (
307329 select Star (from (table #tab)) `as` #cte1 :>>
308330 select Star (from (common #cte1)) `as` #cte2
@@ -315,32 +337,42 @@ window function queries
315337
316338>>> :{
317339let
318− query :: Query '[] (Public Schema) '[] ["col1" ::: 'NotNull 'PGint4, "rank" ::: 'NotNull 'PGint8]
340+ query :: Query_ (Public Schema) () (Row Int32 Int64)
319341 query = select
320− (#col1 & Also (rank `as` #rank `Over` (partitionBy #col1 & orderBy [#col2 & Asc])))
342+ (#col1 & Also (rank `as` #col2 `Over` (partitionBy #col1 & orderBy [#col2 & Asc])))
321343 (from (table #tab))
322344in printSQL query
323345:}
324−SELECT "col1" AS "col1", rank() OVER (PARTITION BY "col1" ORDER BY "col2" ASC) AS "rank" FROM "tab" AS "tab"
346+SELECT "col1" AS "col1", rank() OVER (PARTITION BY "col1" ORDER BY "col2" ASC) AS "col2" FROM "tab" AS "tab"
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)))))
358+in printSQL query
359+:}
360+SELECT "col1" AS "fromOnly" FROM "tab" AS "t1" WHERE EXISTS (SELECT * FROM "tab" AS "t2" WHERE ("t2"."col2" = "t1"."col1"))
361+
325362-}
326−newtype Query
327− (commons :: FromType)
363+type family Query_
328364 (schemas :: SchemasType)
329− (params :: [NullityType])
330− (row :: RowType)
331− = UnsafeQuery { renderQuery :: ByteString }
332− deriving (GHC.Generic,Show,Eq,Ord,NFData)
333−instance RenderSQL (Query commons schemas params row) where renderSQL = renderQuery
334−
335−type family Query_ (schemas :: SchemasType) (params :: Type) (row :: Type) where
336− Query_ schemas params row = Query '[] schemas (TuplePG params) (RowPG row)
365+ (parameters :: Type)
366+ (row :: Type) where
367+ Query_ schemas params row =
368+ Query '[] '[] schemas (TuplePG params) (RowPG row)
337369
338370-- | The results of two queries can be combined using the set operation
339371-- `union`. Duplicate rows are eliminated.
340372union
341− :: Query commons schemas params columns
342− -> Query commons schemas params columns
343− -> Query commons schemas params columns
373+ :: Query outer commons schemas params columns
374+ -> Query outer commons schemas params columns
375+ -> Query outer commons schemas params columns
344376q1 `union` q2 = UnsafeQuery $
345377 parenthesized (renderSQL q1)
346378 <+> "UNION"
@@ -349,9 +381,9 @@ q1 `union` q2 = UnsafeQuery $
349381-- | The results of two queries can be combined using the set operation
350382-- `unionAll`, the disjoint union. Duplicate rows are retained.
351383unionAll
352− :: Query commons schemas params columns
353− -> Query commons schemas params columns
354− -> Query commons schemas params columns
384+ :: Query outer commons schemas params columns
385+ -> Query outer commons schemas params columns
386+ -> Query outer commons schemas params columns
355387q1 `unionAll` q2 = UnsafeQuery $
356388 parenthesized (renderSQL q1)
357389 <+> "UNION" <+> "ALL"
@@ -360,9 +392,9 @@ q1 `unionAll` q2 = UnsafeQuery $
360392-- | The results of two queries can be combined using the set operation
361393-- `intersect`, the intersection. Duplicate rows are eliminated.
362394intersect
363− :: Query commons schemas params columns
364− -> Query commons schemas params columns
365− -> Query commons schemas params columns
395+ :: Query outer commons schemas params columns
396+ -> Query outer commons schemas params columns
397+ -> Query outer commons schemas params columns
366398q1 `intersect` q2 = UnsafeQuery $
367399 parenthesized (renderSQL q1)
368400 <+> "INTERSECT"
@@ -371,9 +403,9 @@ q1 `intersect` q2 = UnsafeQuery $
371403-- | The results of two queries can be combined using the set operation
372404-- `intersectAll`, the intersection. Duplicate rows are retained.
373405intersectAll
374− :: Query commons schemas params columns
375− -> Query commons schemas params columns
376− -> Query commons schemas params columns
406+ :: Query outer commons schemas params columns
407+ -> Query outer commons schemas params columns
408+ -> Query outer commons schemas params columns
377409q1 `intersectAll` q2 = UnsafeQuery $
378410 parenthesized (renderSQL q1)
379411 <+> "INTERSECT" <+> "ALL"
@@ -382,9 +414,9 @@ q1 `intersectAll` q2 = UnsafeQuery $
382414-- | The results of two queries can be combined using the set operation
383415-- `except`, the set difference. Duplicate rows are eliminated.
384416except
385− :: Query commons schemas params columns
386− -> Query commons schemas params columns
387− -> Query commons schemas params columns
417+ :: Query outer commons schemas params columns
418+ -> Query outer commons schemas params columns
419+ -> Query outer commons schemas params columns
388420q1 `except` q2 = UnsafeQuery $
389421 parenthesized (renderSQL q1)
390422 <+> "EXCEPT"
@@ -393,9 +425,9 @@ q1 `except` q2 = UnsafeQuery $
393425-- | The results of two queries can be combined using the set operation
394426-- `exceptAll`, the set difference. Duplicate rows are retained.
395427exceptAll
396− :: Query commons schemas params columns
397− -> Query commons schemas params columns
398− -> Query commons schemas params columns
428+ :: Query outer commons schemas params columns
429+ -> Query outer commons schemas params columns
430+ -> Query outer commons schemas params columns
399431q1 `exceptAll` q2 = UnsafeQuery $
400432 parenthesized (renderSQL q1)
401433 <+> "EXCEPT" <+> "ALL"
@@ -405,54 +437,71 @@ q1 `exceptAll` q2 = UnsafeQuery $
405437SELECT queries
406438-----------------------------------------}
407439
408−data Selection grp commons schemas params from row where
409− List
410− :: SListI row
411− => NP (Aliased (Expression grp commons schemas params from)) row
412− -> Selection grp commons schemas params from row
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
413447 Star
414448 :: HasUnique tab from row
415− => Selection 'Ungrouped commons schemas params from row
449+ => Selection outer commons 'Ungrouped schemas params from row
450+ -- ^ `HasUnique` table in the `FromClause`
416451 DotStar
417452 :: Has tab from row
418453 => Alias tab
419− -> Selection 'Ungrouped commons schemas params from row
420− Also
421− :: Selection grp commons schemas params from right
422− -> Selection grp commons schemas params from left
423− -> Selection grp commons schemas params from (Join left right)
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
424461 Over
425462 :: SListI row
426− => NP (Aliased (WindowFunction grp commons schemas params from)) row
427− -> WindowDefinition grp commons schemas params from
428− -> Selection grp commons schemas params from 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
429474instance (KnownSymbol col, row ~ '[col ::: ty])
430475 => Aliasable col
431− (Expression grp commons schemas params from ty)
432− (Selection grp commons schemas params from row) where
476+ (Expression outer commons grp schemas params from ty)
477+ (Selection outer commons grp schemas params from row) where
433478 expr `as` col = List (expr `as` col)
434−instance (Has tab from row0, Has col row0 ty, row1 ~ '[col ::: ty])
435− => IsQualified tab col (Selection 'Ungrouped commons schemas params from row1) where
436− tab ! col = tab ! col `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
437483instance
438− ( Has tab from row0
484+ ( Has tab (Join outer from) row0
439485 , Has col row0 ty
440486 , row1 ~ '[col ::: ty]
441487 , GroupedBy tab col bys )
442− => IsQualified tab col (Selection ('Grouped bys) commons schemas params from row1) where
443− tab ! col = tab ! col `as` col
444−instance (HasUnique tab from row0, Has col row0 ty, row1 ~ '[col ::: ty])
445− => IsLabel col (Selection 'Ungrouped commons schemas params from row1) where
446− fromLabel = fromLabel @col `as` Alias
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
447495instance
448− ( HasUnique tab from row0
496+ ( HasUnique tab (Join outer from) row0
449497 , Has col row0 ty
450498 , row1 ~ '[col ::: ty]
451499 , GroupedBy tab col bys )
452− => IsLabel col (Selection ('Grouped bys) commons schemas params from row1) where
453− fromLabel = fromLabel @col `as` Alias
500+ => IsLabel col
501+ (Selection outer commons ('Grouped bys) schemas params from row1) where
502+ fromLabel = fromLabel @col `as` Alias
454503
455−instance RenderSQL (Selection grp commons schemas params from row) where
504+instance RenderSQL (Selection outer commons grp schemas params from row) where
456505 renderSQL = \case
457506 List list -> renderCommaSeparated (renderAliased renderSQL) list
458507 Star -> "*"
@@ -461,7 +510,7 @@ instance RenderSQL (Selection grp commons schemas params from row) where
461510 Over winFns winDef ->
462511 let
463512 renderOver
464− :: Aliased (WindowFunction grp commons schemas params from) field
513+ :: Aliased (WindowFunction outer commons grp schemas params from) field
465514 -> ByteString
466515 renderOver (winFn `As` col) = renderSQL winFn
467516 <+> "OVER" <+> parenthesized (renderSQL winDef)
@@ -469,6 +518,10 @@ instance RenderSQL (Selection grp commons schemas params from row) where
469518 in
470519 renderCommaSeparated renderOver winFns
471520
521+instance IsString
522+ (Selection outer commons grp schemas params from '["fromOnly" ::: 'NotNull 'PGtext]) where
523+ fromString str = fromString str `as` Alias
524+
472525-- | the `TableExpression` in the `select` command constructs an intermediate
473526-- virtual table by possibly combining tables, views, eliminating rows,
474527-- grouping, etc. This table is finally passed on to processing by
@@ -476,45 +529,100 @@ instance RenderSQL (Selection grp commons schemas params from row) where
476529-- the intermediate table are actually output.
477530select
478531 :: (SListI row, row ~ (x ': xs))
479− => Selection grp commons schemas params from row
480− -- ^ select list
481− -> TableExpression grp commons schemas params from
532+ => Selection outer commons grp schemas params from row
533+ -- ^ selection
534+ -> TableExpression outer commons grp schemas params from
482535 -- ^ intermediate virtual table
483− -> Query commons schemas params row
536+ -> Query outer commons schemas params row
484537select selection tabexpr = UnsafeQuery $
485538 "SELECT"
486539 <+> renderSQL selection
487540 <+> renderSQL tabexpr
488541
542+-- | Like `select` but takes an `NP` list of `Expression`s instead
543+-- of a general `Selection`.
489544select_
490545 :: (SListI row, row ~ (x ': xs))
491− => NP (Aliased (Expression grp commons schemas params from)) row
492− -> TableExpression grp commons schemas params from
493− -> Query commons schemas params row
494−select_ list = select (List list)
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
495552
496553-- | After the select list has been processed, the result table can
497554-- be subject to the elimination of duplicate rows using `selectDistinct`.
498555selectDistinct
499556 :: (SListI columns, columns ~ (col ': cols))
500− => Selection 'Ungrouped commons schemas params from columns
501− -- ^ select list
502− -> TableExpression 'Ungrouped commons schemas params from
557+ => Selection outer commons grp schemas params from columns
558+ -- ^ selection
559+ -> TableExpression outer commons grp schemas params from
503560 -- ^ intermediate virtual table
504− -> Query commons schemas params columns
561+ -> Query outer commons schemas params columns
505562selectDistinct selection tabexpr = UnsafeQuery $
506563 "SELECT DISTINCT"
507564 <+> renderSQL selection
508565 <+> renderSQL tabexpr
509566
567+-- | Like `selectDistinct` but takes an `NP` list of `Expression`s instead
568+-- of a general `Selection`.
510569selectDistinct_
511570 :: (SListI columns, columns ~ (col ': cols))
512− => NP (Aliased (Expression 'Ungrouped commons schemas params from)) columns
571+ => NP (Aliased (Expression outer commons grp schemas params from)) columns
513572 -- ^ select list
514− -> TableExpression 'Ungrouped commons schemas params from
573+ -> TableExpression outer commons grp schemas params from
574+ -- ^ intermediate virtual table
575+ -> Query outer commons schemas params columns
576+selectDistinct_ = selectDistinct . List
577+
578+{-|
579+`selectDistinctOn` keeps only the first row of each set of rows where
580+the given expressions evaluate to equal. The DISTINCT ON expressions are
581+interpreted using the same rules as for ORDER BY. ORDER BY is used to
582+ensure that the desired row appears first.
583+
584+The DISTINCT ON expression(s) must match the leftmost ORDER BY expression(s).
585+The ORDER BY clause will normally contain additional expression(s) that
586+determine the desired precedence of rows within each DISTINCT ON group.
587+
588+In order to guarantee they match and reduce redundancy, this function
589+will prepend the The DISTINCT ON expressions to the ORDER BY clause.
590+-}
591+selectDistinctOn
592+ :: (SListI columns, columns ~ (col ': cols))
593+ => [SortExpression outer commons grp schemas params from]
594+ -- ^ DISTINCT ON expression(s) and prepended to ORDER BY clause
595+ -> Selection outer commons grp schemas params from columns
596+ -- ^ selection
597+ -> TableExpression outer commons grp schemas params from
598+ -- ^ intermediate virtual table
599+ -> Query outer commons schemas params columns
600+selectDistinctOn distincts selection tab = UnsafeQuery $
601+ "SELECT DISTINCT ON"
602+ <+> parenthesized (commaSeparated (renderDistinctOn <$> distincts))
603+ <+> renderSQL selection
604+ <+> renderSQL (tab {orderByClause = distincts <> orderByClause tab})
605+ where
606+ renderDistinctOn = \case
607+ Asc expression -> renderSQL expression
608+ Desc expression -> renderSQL expression
609+ AscNullsFirst expression -> renderSQL expression
610+ DescNullsFirst expression -> renderSQL expression
611+ AscNullsLast expression -> renderSQL expression
612+ DescNullsLast expression -> renderSQL expression
613+
614+-- | Like `selectDistinctOn` but takes an `NP` list of `Expression`s instead
615+-- of a general `Selection`.
616+selectDistinctOn_
617+ :: (SListI columns, columns ~ (col ': cols))
618+ => [SortExpression outer commons grp schemas params from]
619+ -- ^ distinct on and return the first row in ordering
620+ -> NP (Aliased (Expression outer commons grp schemas params from)) columns
621+ -- ^ selection
622+ -> TableExpression outer commons grp schemas params from
515623 -- ^ intermediate virtual table
516− -> Query commons schemas params columns
517−selectDistinct_ list = select (List list)
624+ -> Query outer commons schemas params columns
625+selectDistinctOn_ distincts = selectDistinctOn distincts . List
518626
519627-- | `values` computes a row value or set of row values
520628-- specified by value expressions. It is most commonly used
@@ -522,16 +630,16 @@ selectDistinct_ list = select (List list)
522630-- but it can be used on its own.
523631--
524632-- >>> type Row = '["a" ::: 'NotNull 'PGint4, "b" ::: 'NotNull 'PGtext]
525−-- >>> let query = values (1 `as` #a :* "one" `as` #b) [] :: Query commons schemas '[] Row
633+-- >>> let query = values (1 `as` #a :* "one" `as` #b) [] :: Query outer commons schemas '[] Row
526634-- >>> printSQL query
527635-- SELECT * FROM (VALUES (1, E'one')) AS t ("a", "b")
528636values
529637 :: SListI cols
530− => NP (Aliased (Expression 'Ungrouped commons schemas params '[] )) cols
531− -> [NP (Aliased (Expression 'Ungrouped commons schemas params '[] )) cols]
638+ => NP (Aliased (Expression outer commons 'Ungrouped schemas params '[] )) cols
639+ -> [NP (Aliased (Expression outer commons 'Ungrouped schemas params '[] )) cols]
532640 -- ^ When more than one row is specified, all the rows must
533641 -- must have the same number of elements
534− -> Query commons schemas params cols
642+ -> Query outer commons schemas params cols
535643values rw rws = UnsafeQuery $ "SELECT * FROM"
536644 <+> parenthesized (
537645 "VALUES"
@@ -542,7 +650,7 @@ values rw rws = UnsafeQuery $ "SELECT * FROM"
542650 <+> parenthesized (renderCommaSeparated renderAliasPart rw)
543651 where
544652 renderAliasPart, renderValuePart
545− :: Aliased (Expression 'Ungrouped commons schemas params '[] ) ty -> ByteString
653+ :: Aliased (Expression outer commons 'Ungrouped schemas params '[] ) ty -> ByteString
546654 renderAliasPart (_ `As` name) = renderSQL name
547655 renderValuePart (value `As` _) = renderSQL value
548656
@@ -550,9 +658,9 @@ values rw rws = UnsafeQuery $ "SELECT * FROM"
550658-- specified by value expressions.
551659values_
552660 :: SListI cols
553− => NP (Aliased (Expression 'Ungrouped commons schemas params '[] )) cols
661+ => NP (Aliased (Expression outer commons 'Ungrouped schemas params '[] )) cols
554662 -- ^ one row of values
555− -> Query commons schemas params cols
663+ -> Query outer commons schemas params cols
556664values_ rw = values rw []
557665
558666{-----------------------------------------
@@ -566,16 +674,17 @@ Table Expressions
566674-- to a table on disk, a so-called base table, but more complex expressions
567675-- can be used to modify or combine base tables in various ways.
568676data TableExpression
569− (grp :: Grouping)
677+ (outer :: FromType)
570678 (commons :: FromType)
679+ (grp :: Grouping)
571680 (schemas :: SchemasType)
572681 (params :: [NullityType])
573682 (from :: FromType)
574683 = TableExpression
575− { fromClause :: FromClause commons schemas params from
684+ { fromClause :: FromClause outer commons schemas params from
576685 -- ^ A table reference that can be a table name, or a derived table such
577686 -- as a subquery, a @JOIN@ construct, or complex combinations of these.
578− , whereClause :: [Condition 'Ungrouped commons schemas params from]
687+ , whereClause :: [Condition outer commons 'Ungrouped schemas params from]
579688 -- ^ optional search coditions, combined with `.&&`. After the processing
580689 -- of the `fromClause` is done, each row of the derived virtual table
581690 -- is checked against the search condition. If the result of the
@@ -591,13 +700,13 @@ data TableExpression
591700 -- set of rows having common values into one group row that represents all
592701 -- rows in the group. This is done to eliminate redundancy in the output
593702 -- and/or compute aggregates that apply to these groups.
594− , havingClause :: HavingClause grp commons schemas params from
703+ , havingClause :: HavingClause outer commons grp schemas params from
595704 -- ^ If a table has been grouped using `groupBy`, but only certain groups
596705 -- are of interest, the `havingClause` can be used, much like a
597706 -- `whereClause`, to eliminate groups from the result. Expressions in the
598707 -- `havingClause` can refer both to grouped expressions and to ungrouped
599708 -- expressions (which necessarily involve an aggregate function).
600− , orderByClause :: [SortExpression grp commons schemas params from]
709+ , orderByClause :: [SortExpression outer commons grp schemas params from]
601710 -- ^ The `orderByClause` is for optional sorting. When more than one
602711 -- `SortExpression` is specified, the later (right) values are used to sort
603712 -- rows that are equal according to the earlier (left) values.
@@ -607,14 +716,14 @@ data TableExpression
607716 -- will be returned (but possibly fewer, if the query itself yields
608717 -- fewer rows).
609718 , offsetClause :: [Word64]
610− -- ^ The `offsetClause` is combined with `+` to give an offset count
719+ -- ^ The `offsetClause` is combined with `Prelude.+` to give an offset count
611720 -- if nonempty. The offset count says to skip that many rows before
612721 -- beginning to return rows. The rows are skipped before the limit count
613722 -- is applied.
614− }
723+ } deriving (GHC.Generic)
615724
616725-- | Render a `TableExpression`
617−instance RenderSQL (TableExpression grp commons schemas params from) where
726+instance RenderSQL (TableExpression outer commons grp schemas params from) where
618727 renderSQL
619728 (TableExpression frm' whs' grps' hvs' srts' lims' offs') = mconcat
620729 [ "FROM ", renderSQL frm'
@@ -623,8 +732,7 @@ instance RenderSQL (TableExpression grp commons schemas params from) where
623732 , renderSQL hvs'
624733 , renderOrderByClause srts'
625734 , renderLimits lims'
626− , renderOffsets offs'
627− ]
735+ , renderOffsets offs' ]
628736 where
629737 renderWheres = \case
630738 [] -> ""
@@ -644,33 +752,33 @@ instance RenderSQL (TableExpression grp commons schemas params from) where
644752-- | A `from` generates a `TableExpression` from a table reference that can be
645753-- a table name, or a derived table such as a subquery, a JOIN construct,
646754-- or complex combinations of these. A `from` may be transformed by `where_`,
647−-- `group`, `having`, `orderBy`, `limit` and `offset`, using the `&` operator
755+-- `groupBy`, `having`, `orderBy`, `limit` and `offset`, using the `&` operator
648756-- to match the left-to-right sequencing of their placement in SQL.
649757from
650− :: FromClause commons schemas params from -- ^ table reference
651− -> TableExpression 'Ungrouped commons schemas params from
652−from rels = TableExpression rels [] NoGroups NoHaving [] [] []
758+ :: FromClause outer commons schemas params from -- ^ table reference
759+ -> TableExpression outer commons 'Ungrouped schemas params from
760+from tab = TableExpression tab [] noGroups NoHaving [] [] []
653761
654762-- | A `where_` is an endomorphism of `TableExpression`s which adds a
655763-- search condition to the `whereClause`.
656764where_
657− :: Condition 'Ungrouped commons schemas params from -- ^ filtering condition
658− -> TableExpression grp commons schemas params from
659− -> TableExpression grp commons schemas params from
765+ :: Condition outer commons 'Ungrouped schemas params from -- ^ filtering condition
766+ -> TableExpression outer commons grp schemas params from
767+ -> TableExpression outer commons grp schemas params from
660768where_ wh rels = rels {whereClause = wh : whereClause rels}
661769
662770-- | A `groupBy` is a transformation of `TableExpression`s which switches
663−-- its `Grouping` from `Ungrouped` to `Grouped`. Use @group Nil@ to perform
771+-- its `Grouping` from `Ungrouped` to `Grouped`. Use @groupBy Nil@ to perform
664772-- a "grand total" aggregation query.
665773groupBy
666774 :: SListI bys
667775 => NP (By from) bys -- ^ grouped columns
668− -> TableExpression 'Ungrouped commons schemas params from
669− -> TableExpression ('Grouped bys) commons schemas params from
776+ -> TableExpression outer commons 'Ungrouped schemas params from
777+ -> TableExpression outer commons ('Grouped bys) schemas params from
670778groupBy bys rels = TableExpression
671779 { fromClause = fromClause rels
672780 , whereClause = whereClause rels
673− , groupByClause = Group bys
781+ , groupByClause = group bys
674782 , havingClause = Having []
675783 , orderByClause = []
676784 , limitClause = limitClause rels
@@ -680,9 +788,9 @@ groupBy bys rels = TableExpression
680788-- | A `having` is an endomorphism of `TableExpression`s which adds a
681789-- search condition to the `havingClause`.
682790having
683− :: Condition ('Grouped bys) commons schemas params from -- ^ having condition
684− -> TableExpression ('Grouped bys) commons schemas params from
685− -> TableExpression ('Grouped bys) commons schemas params from
791+ :: Condition outer commons ('Grouped bys) schemas params from -- ^ having condition
792+ -> TableExpression outer commons ('Grouped bys) schemas params from
793+ -> TableExpression outer commons ('Grouped bys) schemas params from
686794having hv rels = rels
687795 { havingClause = case havingClause rels of Having hvs -> Having (hv:hvs) }
688796
@@ -693,159 +801,18 @@ instance OrderBy TableExpression where
693801-- `limitClause`.
694802limit
695803 :: Word64 -- ^ limit parameter
696− -> TableExpression grp commons schemas params from
697− -> TableExpression grp commons schemas params from
804+ -> TableExpression outer commons grp schemas params from
805+ -> TableExpression outer commons grp schemas params from
698806limit lim rels = rels {limitClause = lim : limitClause rels}
699807
700808-- | An `offset` is an endomorphism of `TableExpression`s which adds to the
701809-- `offsetClause`.
702810offset
703811 :: Word64 -- ^ offset parameter
704− -> TableExpression grp commons schemas params from
705− -> TableExpression grp commons schemas params from
812+ -> TableExpression outer commons grp schemas params from
813+ -> TableExpression outer commons grp schemas params from
706814offset off rels = rels {offsetClause = off : offsetClause rels}
707815
708−{-----------------------------------------
709−JSON stuff
710−-----------------------------------------}
711−
712−unsafeSetOfFunction
713− :: ByteString
714− -> Expression 'Ungrouped commons schemas params '[] ty
715− -> Query commons schemas params row
716−unsafeSetOfFunction fun expr = UnsafeQuery $
717− "SELECT * FROM " <> fun <> "(" <> renderSQL expr <> ")"
718−
719−-- | Expands the outermost JSON object into a set of key/value pairs.
720−jsonEach
721− :: Expression 'Ungrouped commons schemas params '[] (nullity 'PGjson) -- ^ json object
722− -> Query commons schemas 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 'Ungrouped commons schemas params '[] (nullity 'PGjsonb) -- ^ jsonb object
729− -> Query commons schemas 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 'Ungrouped commons schemas params '[] (nullity 'PGjson) -- ^ json object
736− -> Query commons schemas 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 'Ungrouped commons schemas params '[] (nullity 'PGjsonb) -- ^ jsonb object
743− -> Query commons schemas 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 'Ungrouped commons schemas params '[] (nullity 'PGjson) -- ^ json object
750− -> Query commons schemas 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 'Ungrouped commons schemas params '[] (nullity 'PGjsonb) -- ^ jsonb object
756− -> Query commons schemas params '["jsonb_object_keys" ::: 'NotNull 'PGtext]
757−jsonbObjectKeys = unsafeSetOfFunction "jsonb_object_keys"
758−
759−unsafePopulateFunction
760− :: ByteString
761− -> TypeExpression schemas (nullity ('PGcomposite row))
762− -> Expression 'Ungrouped commons schemas params '[] ty
763− -> Query commons schemas params row
764−unsafePopulateFunction fun ty expr = UnsafeQuery $
765− "SELECT * FROM " <> fun <> "("
766− <> "null::" <> renderSQL ty <> ", "
767− <> renderSQL 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 schemas (nullity ('PGcomposite row)) -- ^ row type
773− -> Expression 'Ungrouped commons schemas params '[] (nullity 'PGjson) -- ^ json object
774− -> Query commons schemas 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 schemas (nullity ('PGcomposite row)) -- ^ row type
781− -> Expression 'Ungrouped commons schemas params '[] (nullity 'PGjsonb) -- ^ jsonb object
782− -> Query commons schemas 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 schemas (nullity ('PGcomposite row)) -- ^ row type
789− -> Expression 'Ungrouped commons schemas params '[] (nullity 'PGjson) -- ^ json array
790− -> Query commons schemas 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 schemas (nullity ('PGcomposite row)) -- ^ row type
798− -> Expression 'Ungrouped commons schemas params '[] (nullity 'PGjsonb) -- ^ jsonb array
799− -> Query commons schemas params row
800−jsonbPopulateRecordSet = unsafePopulateFunction "jsonb_populate_record_set"
801−
802−unsafeRecordFunction
803− :: (SListI record, json `In` PGJsonType)
804− => ByteString
805− -> Expression 'Ungrouped commons schemas params '[] (nullity json)
806− -> NP (Aliased (TypeExpression schemas)) record
807− -> Query commons schemas params record
808−unsafeRecordFunction fun expr types = UnsafeQuery $
809− "SELECT * FROM " <> fun <> "("
810− <> renderSQL expr <> ")"
811− <+> "AS" <+> "x" <> parenthesized (renderCommaSeparated renderTy types)
812− where
813− renderTy :: Aliased (TypeExpression schemas) ty -> ByteString
814− renderTy (ty `As` alias) =
815− renderSQL alias <+> renderSQL ty
816−
817−-- | Builds an arbitrary record from a JSON object.
818−jsonToRecord
819− :: SListI record
820− => Expression 'Ungrouped commons schemas params '[] (nullity 'PGjson) -- ^ json object
821− -> NP (Aliased (TypeExpression schemas)) record -- ^ record types
822− -> Query commons schemas 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 'Ungrouped commons schemas params '[] (nullity 'PGjsonb) -- ^ jsonb object
829− -> NP (Aliased (TypeExpression schemas)) record -- ^ record types
830− -> Query commons schemas 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 'Ungrouped commons schemas params '[] (nullity 'PGjson) -- ^ json array
837− -> NP (Aliased (TypeExpression schemas)) record -- ^ record types
838− -> Query commons schemas 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 'Ungrouped commons schemas params '[] (nullity 'PGjsonb) -- ^ jsonb array
845− -> NP (Aliased (TypeExpression schemas)) record -- ^ record types
846− -> Query commons schemas params record
847−jsonbToRecordSet = unsafeRecordFunction "jsonb_to_record_set"
848−
849816{-----------------------------------------
850817FROM clauses
851818-----------------------------------------}
@@ -854,53 +821,59 @@ FROM clauses
854821A `FromClause` can be a table name, or a derived table such
855822as a subquery, a @JOIN@ construct, or complex combinations of these.
856823-}
857−newtype FromClause commons schemas params from
824+newtype FromClause outer commons schemas params from
858825 = UnsafeFromClause { renderFromClause :: ByteString }
859826 deriving (GHC.Generic,Show,Eq,Ord,NFData)
860−instance RenderSQL (FromClause commons schemas params from) where
827+instance RenderSQL (FromClause outer commons schemas params from) where
861828 renderSQL = renderFromClause
862829
863830-- | A real `table` is a table from the database.
864831table
865832 :: (Has sch schemas schema, Has tab schema ('Table table))
866833 => Aliased (QualifiedAlias sch) (alias ::: tab)
867− -> FromClause commons schemas params '[alias ::: TableToRow table]
834+ -> FromClause outer commons schemas params '[alias ::: TableToRow table]
868835table (tab `As` alias) = UnsafeFromClause $
869836 renderSQL tab <+> "AS" <+> renderSQL alias
870837
871838-- | `subquery` derives a table from a `Query`.
872839subquery
873− :: Aliased (Query commons schemas params) query
874− -> FromClause commons schemas params '[query]
875−subquery = UnsafeFromClause . renderAliased (parenthesized . renderQuery)
840+ :: Aliased (Query outer commons schemas params) query
841+ -> FromClause outer commons schemas params '[query]
842+subquery = UnsafeFromClause . renderAliased (parenthesized . renderSQL)
876843
877844-- | `view` derives a table from a `View`.
878845view
879846 :: (Has sch schemas schema, Has vw schema ('View view))
880847 => Aliased (QualifiedAlias sch) (alias ::: vw)
881− -> FromClause commons schemas params '[alias ::: view]
848+ -> FromClause outer commons schemas params '[alias ::: view]
882849view (vw `As` alias) = UnsafeFromClause $
883850 renderSQL vw <+> "AS" <+> renderSQL alias
884851
852+-- | `common` derives a table from a common table expression.
885853common
886854 :: Has cte commons common
887855 => Aliased Alias (alias ::: cte)
888− -> FromClause commons schemas params '[alias ::: common]
856+ -> FromClause outer commons schemas params '[alias ::: common]
889857common (cte `As` alias) = UnsafeFromClause $
890858 renderSQL cte <+> "AS" <+> renderSQL alias
891859
892−{- | @left & crossJoin right@. For every possible combination of rows from
893− @left@ and @right@ (i.e., a Cartesian product), the joined table will contain
894− a row consisting of all columns in @left@ followed by all columns in @right@.
895− If the tables have @n@ and @m@ rows respectively, the joined table will
896− have @n * m@ rows.
860+instance Additional (FromClause outer commons schemas params) where
861+ also right left = UnsafeFromClause $
862+ renderSQL left <> ", " <> renderSQL right
863+
864+{- |
865+@left & crossJoin right@. For every possible combination of rows from
866+@left@ and @right@ (i.e., a Cartesian product), the joined table will contain
867+a row consisting of all columns in @left@ followed by all columns in @right@.
868+If the tables have @n@ and @m@ rows respectively, the joined table will
869+have @n * m@ rows.
897870-}
898871crossJoin
899− :: FromClause commons schemas params right
872+ :: FromClause outer commons schemas params right
900873 -- ^ right
901− -> FromClause commons schemas params left
874+ -> FromClause outer commons schemas params left
902875 -- ^ left
903− -> FromClause commons schemas params (Join left right)
876+ -> FromClause outer commons schemas params (Join left right)
904877crossJoin right left = UnsafeFromClause $
905878 renderSQL left <+> "CROSS JOIN" <+> renderSQL right
906879
@@ -908,13 +881,13 @@ crossJoin right left = UnsafeFromClause $
908881the @on@ condition.
909882-}
910883innerJoin
911− :: FromClause commons schemas params right
884+ :: FromClause outer commons schemas params right
912885 -- ^ right
913− -> Condition 'Ungrouped commons schemas params (Join left right)
886+ -> Condition outer commons 'Ungrouped schemas params (Join left right)
914887 -- ^ @on@ condition
915− -> FromClause commons schemas params left
888+ -> FromClause outer commons schemas params left
916889 -- ^ left
917− -> FromClause commons schemas params (Join left right)
890+ -> FromClause outer commons schemas params (Join left right)
918891innerJoin right on left = UnsafeFromClause $
919892 renderSQL left <+> "INNER JOIN" <+> renderSQL right
920893 <+> "ON" <+> renderSQL on
@@ -925,13 +898,13 @@ innerJoin right on left = UnsafeFromClause $
925898 Thus, the joined table always has at least one row for each row in @left@.
926899-}
927900leftOuterJoin
928− :: FromClause commons schemas params right
901+ :: FromClause outer commons schemas params right
929902 -- ^ right
930− -> Condition 'Ungrouped commons schemas params (Join left right)
903+ -> Condition outer commons 'Ungrouped schemas params (Join left right)
931904 -- ^ @on@ condition
932− -> FromClause commons schemas params left
905+ -> FromClause outer commons schemas params left
933906 -- ^ left
934− -> FromClause commons schemas params (Join left (NullifyFrom right))
907+ -> FromClause outer commons schemas params (Join left (NullifyFrom right))
935908leftOuterJoin right on left = UnsafeFromClause $
936909 renderSQL left <+> "LEFT OUTER JOIN" <+> renderSQL right
937910 <+> "ON" <+> renderSQL on
@@ -943,13 +916,13 @@ leftOuterJoin right on left = UnsafeFromClause $
943916 have a row for each row in @right@.
944917-}
945918rightOuterJoin
946− :: FromClause commons schemas params right
919+ :: FromClause outer commons schemas params right
947920 -- ^ right
948− -> Condition 'Ungrouped commons schemas params (Join left right)
921+ -> Condition outer commons 'Ungrouped schemas params (Join left right)
949922 -- ^ @on@ condition
950− -> FromClause commons schemas params left
923+ -> FromClause outer commons schemas params left
951924 -- ^ left
952− -> FromClause commons schemas params (Join (NullifyFrom left) right)
925+ -> FromClause outer commons schemas params (Join (NullifyFrom left) right)
953926rightOuterJoin right on left = UnsafeFromClause $
954927 renderSQL left <+> "RIGHT OUTER JOIN" <+> renderSQL right
955928 <+> "ON" <+> renderSQL on
@@ -962,13 +935,13 @@ rightOuterJoin right on left = UnsafeFromClause $
962935 is added.
963936-}
964937fullOuterJoin
965− :: FromClause commons schemas params right
938+ :: FromClause outer commons schemas params right
966939 -- ^ right
967− -> Condition 'Ungrouped commons schemas params (Join left right)
940+ -> Condition outer commons 'Ungrouped schemas params (Join left right)
968941 -- ^ @on@ condition
969− -> FromClause commons schemas params left
942+ -> FromClause outer commons schemas params left
970943 -- ^ left
971− -> FromClause commons schemas params
944+ -> FromClause outer commons schemas params
972945 (Join (NullifyFrom left) (NullifyFrom right))
973946fullOuterJoin right on left = UnsafeFromClause $
974947 renderSQL left <+> "FULL OUTER JOIN" <+> renderSQL right
@@ -978,7 +951,7 @@ fullOuterJoin right on left = UnsafeFromClause $
978951Grouping
979952-----------------------------------------}
980953
981−-- | `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
982955-- used to group together those rows in a table that have the same values
983956-- in all the columns listed. @By \#col@ will reference an unambiguous
984957-- column @col@; otherwise @By2 (\#tab \! \#col)@ will reference a table
@@ -1019,309 +992,42 @@ instance (Has rel rels cols, Has col cols ty, bys ~ '[ '(rel, col)])
1019992-- done on @NoGroups@ while all output `Expression`s must be aggregated
1020993-- in @Group Nil@. In general, all output `Expression`s in the
1021994-- complement of @bys@ must be aggregated in @Group bys@.
1022−data GroupByClause grp from where
1023− NoGroups :: GroupByClause 'Ungrouped from
1024− Group
1025− :: SListI bys
1026− => NP (By from) bys
1027− -> GroupByClause ('Grouped bys) from
1028−
1029−-- | Renders a `GroupByClause`.
995+newtype GroupByClause grp from = UnsafeGroupByClause
996+ { renderGroupByClause :: ByteString }
997+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
1030998instance RenderSQL (GroupByClause grp from) where
1031− renderSQL = \case
1032− NoGroups -> ""
1033− Group Nil -> ""
1034− Group bys -> " GROUP BY" <+> renderCommaSeparated renderSQL bys
999+ renderSQL = renderGroupByClause
1000+noGroups :: GroupByClause 'Ungrouped from
1001+noGroups = UnsafeGroupByClause ""
1002+group
1003+ :: SListI bys
1004+ => NP (By from) bys
1005+ -> GroupByClause ('Grouped bys) from
1006+group bys = UnsafeGroupByClause $ case bys of
1007+ Nil -> ""
1008+ bys' -> " GROUP BY" <+> renderCommaSeparated renderSQL bys'
10351009
10361010-- | A `HavingClause` is used to eliminate groups that are not of interest.
10371011-- An `Ungrouped` `TableExpression` may only use `NoHaving` while a `Grouped`
10381012-- `TableExpression` must use `Having` whose conditions are combined with
10391013-- `.&&`.
1040−data HavingClause grp commons schemas params from where
1041− NoHaving :: HavingClause 'Ungrouped commons schemas params from
1014+data HavingClause outer commons grp schemas params from where
1015+ NoHaving :: HavingClause outer commons 'Ungrouped schemas params from
10421016 Having
1043− :: [Condition ('Grouped bys) commons schemas params from]
1044− -> HavingClause ('Grouped bys) commons schemas params from
1045−deriving instance Show (HavingClause grp commons schemas params from)
1046−deriving instance Eq (HavingClause grp commons schemas params from)
1047−deriving instance Ord (HavingClause grp commons schemas params from)
1017+ :: [Condition outer commons ('Grouped bys) schemas params from]
1018+ -> HavingClause outer commons ('Grouped bys) schemas params from
1019+deriving instance Show (HavingClause outer commons grp schemas params from)
1020+deriving instance Eq (HavingClause outer commons grp schemas params from)
1021+deriving instance Ord (HavingClause outer commons grp schemas params from)
10481022
10491023-- | Render a `HavingClause`.
1050−instance RenderSQL (HavingClause grp commons schemas params from) where
1024+instance RenderSQL (HavingClause outer commons grp schemas params from) where
10511025 renderSQL = \case
10521026 NoHaving -> ""
10531027 Having [] -> ""
10541028 Having conditions ->
10551029 " HAVING" <+> commaSeparated (renderSQL <$> conditions)
10561030
1057−unsafeSubqueryExpression
1058− :: ByteString
1059− -> Expression grp commons schemas params from ty
1060− -> Query commons schemas params '[alias ::: ty]
1061− -> Expression grp commons schemas params from (nullity 'PGbool)
1062−unsafeSubqueryExpression op x q = UnsafeExpression $
1063− renderSQL x <+> op <+> parenthesized (renderSQL q)
1064−
1065−unsafeRowSubqueryExpression
1066− :: SListI row
1067− => ByteString
1068− -> NP (Aliased (Expression grp commons schemas params from)) row
1069− -> Query commons schemas params row
1070− -> Expression grp commons schemas params from (nullity 'PGbool)
1071−unsafeRowSubqueryExpression op xs q = UnsafeExpression $
1072− renderSQL (row xs) <+> op <+> parenthesized (renderSQL q)
1073−
1074−-- | The right-hand side is a sub`Query`, which must return exactly one column.
1075−-- The left-hand expression is evaluated and compared to each row of the
1076−-- sub`Query` result. The result of `in_` is `true` if any equal subquery row is found.
1077−-- The result is `false` if no equal row is found
1078−-- (including the case where the subquery returns no rows).
1079−--
1080−-- >>> printSQL $ true `in_` values_ (true `as` #foo)
1081−-- TRUE IN (SELECT * FROM (VALUES (TRUE)) AS t ("foo"))
1082−in_
1083− :: Expression grp commons schemas params from ty -- ^ expression
1084− -> Query commons schemas params '[alias ::: ty] -- ^ subquery
1085− -> Expression grp commons schemas params from (nullity 'PGbool)
1086−in_ = unsafeSubqueryExpression "IN"
1087−
1088−{- | The left-hand side of this form of `rowIn` is a row constructor.
1089−The right-hand side is a sub`Query`,
1090−which must return exactly as many columns as
1091−there are expressions in the left-hand row.
1092−The left-hand expressions are evaluated and compared row-wise to each row
1093−of the subquery result. The result of `rowIn`
1094−is `true` if any equal subquery row is found.
1095−The result is `false` if no equal row is found
1096−(including the case where the subquery returns no rows).
1097−
1098−>>> let myRow = 1 `as` #foo :* false `as` #bar :: NP (Aliased (Expression grp commons schemas params from)) '["foo" ::: 'NotNull 'PGint2, "bar" ::: 'NotNull 'PGbool]
1099−>>> printSQL $ myRow `rowIn` values_ myRow
1100−ROW(1, FALSE) IN (SELECT * FROM (VALUES (1, FALSE)) AS t ("foo", "bar"))
1101−-}
1102−rowIn
1103− :: SListI row
1104− => NP (Aliased (Expression grp commons schemas params from)) row -- ^ row constructor
1105− -> Query commons schemas params row -- ^ subquery
1106− -> Expression grp commons schemas params from (nullity 'PGbool)
1107−rowIn = unsafeRowSubqueryExpression "IN"
1108−
1109−-- | >>> printSQL $ true `eqAll` values_ (true `as` #foo)
1110−-- TRUE = ALL (SELECT * FROM (VALUES (TRUE)) AS t ("foo"))
1111−eqAll
1112− :: Expression grp commons schemas params from ty -- ^ expression
1113− -> Query commons schemas params '[alias ::: ty] -- ^ subquery
1114− -> Expression grp commons schemas params from (nullity 'PGbool)
1115−eqAll = unsafeSubqueryExpression "= ALL"
1116−
1117−-- | >>> let myRow = 1 `as` #foo :* false `as` #bar :: NP (Aliased (Expression grp commons schemas params from)) '["foo" ::: 'NotNull 'PGint2, "bar" ::: 'NotNull 'PGbool]
1118−-- >>> printSQL $ myRow `rowEqAll` values_ myRow
1119−-- ROW(1, FALSE) = ALL (SELECT * FROM (VALUES (1, FALSE)) AS t ("foo", "bar"))
1120−rowEqAll
1121− :: SListI row
1122− => NP (Aliased (Expression grp commons schemas params from)) row -- ^ row constructor
1123− -> Query commons schemas params row -- ^ subquery
1124− -> Expression grp commons schemas params from (nullity 'PGbool)
1125−rowEqAll = unsafeRowSubqueryExpression "= ALL"
1126−
1127−-- | >>> printSQL $ true `eqAny` values_ (true `as` #foo)
1128−-- TRUE = ANY (SELECT * FROM (VALUES (TRUE)) AS t ("foo"))
1129−eqAny
1130− :: Expression grp commons schemas params from ty -- ^ expression
1131− -> Query commons schemas params '[alias ::: ty] -- ^ subquery
1132− -> Expression grp commons schemas params from (nullity 'PGbool)
1133−eqAny = unsafeSubqueryExpression "= ANY"
1134−
1135−-- | >>> let myRow = 1 `as` #foo :* false `as` #bar :: NP (Aliased (Expression grp commons schemas params from)) '["foo" ::: 'NotNull 'PGint2, "bar" ::: 'NotNull 'PGbool]
1136−-- >>> printSQL $ myRow `rowEqAny` values_ myRow
1137−-- ROW(1, FALSE) = ANY (SELECT * FROM (VALUES (1, FALSE)) AS t ("foo", "bar"))
1138−rowEqAny
1139− :: SListI row
1140− => NP (Aliased (Expression grp commons schemas params from)) row -- ^ row constructor
1141− -> Query commons schemas params row -- ^ subquery
1142− -> Expression grp commons schemas params from (nullity 'PGbool)
1143−rowEqAny = unsafeRowSubqueryExpression "= ANY"
1144−
1145−-- | >>> printSQL $ true `neqAll` values_ (true `as` #foo)
1146−-- TRUE <> ALL (SELECT * FROM (VALUES (TRUE)) AS t ("foo"))
1147−neqAll
1148− :: Expression grp commons schemas params from ty -- ^ expression
1149− -> Query commons schemas params '[alias ::: ty] -- ^ subquery
1150− -> Expression grp commons schemas params from (nullity 'PGbool)
1151−neqAll = unsafeSubqueryExpression "<> ALL"
1152−
1153−-- | >>> let myRow = 1 `as` #foo :* false `as` #bar :: NP (Aliased (Expression grp commons schemas params from)) '["foo" ::: 'NotNull 'PGint2, "bar" ::: 'NotNull 'PGbool]
1154−-- >>> printSQL $ myRow `rowNeqAll` values_ myRow
1155−-- ROW(1, FALSE) <> ALL (SELECT * FROM (VALUES (1, FALSE)) AS t ("foo", "bar"))
1156−rowNeqAll
1157− :: SListI row
1158− => NP (Aliased (Expression grp commons schemas params from)) row -- ^ row constructor
1159− -> Query commons schemas params row -- ^ subquery
1160− -> Expression grp commons schemas params from (nullity 'PGbool)
1161−rowNeqAll = unsafeRowSubqueryExpression "<> ALL"
1162−
1163−-- | >>> printSQL $ true `neqAny` values_ (true `as` #foo)
1164−-- TRUE <> ANY (SELECT * FROM (VALUES (TRUE)) AS t ("foo"))
1165−neqAny
1166− :: Expression grp commons schemas params from ty -- ^ expression
1167− -> Query commons schemas params '[alias ::: ty] -- ^ subquery
1168− -> Expression grp commons schemas params from (nullity 'PGbool)
1169−neqAny = unsafeSubqueryExpression "<> ANY"
1170−
1171−-- | >>> let myRow = 1 `as` #foo :* false `as` #bar :: NP (Aliased (Expression grp commons schemas params from)) '["foo" ::: 'NotNull 'PGint2, "bar" ::: 'NotNull 'PGbool]
1172−-- >>> printSQL $ myRow `rowNeqAny` values_ myRow
1173−-- ROW(1, FALSE) <> ANY (SELECT * FROM (VALUES (1, FALSE)) AS t ("foo", "bar"))
1174−rowNeqAny
1175− :: SListI row
1176− => NP (Aliased (Expression grp commons schemas params from)) row -- ^ row constructor
1177− -> Query commons schemas params row -- ^ subquery
1178− -> Expression grp commons schemas params from (nullity 'PGbool)
1179−rowNeqAny = unsafeRowSubqueryExpression "<> ANY"
1180−
1181−-- | >>> printSQL $ true `allLt` values_ (true `as` #foo)
1182−-- TRUE ALL < (SELECT * FROM (VALUES (TRUE)) AS t ("foo"))
1183−allLt
1184− :: Expression grp commons schemas params from ty -- ^ expression
1185− -> Query commons schemas params '[alias ::: ty] -- ^ subquery
1186− -> Expression grp commons schemas params from (nullity 'PGbool)
1187−allLt = unsafeSubqueryExpression "ALL <"
1188−
1189−-- | >>> let myRow = 1 `as` #foo :* false `as` #bar :: NP (Aliased (Expression grp commons schemas params from)) '["foo" ::: 'NotNull 'PGint2, "bar" ::: 'NotNull 'PGbool]
1190−-- >>> printSQL $ myRow `rowLtAll` values_ myRow
1191−-- ROW(1, FALSE) ALL < (SELECT * FROM (VALUES (1, FALSE)) AS t ("foo", "bar"))
1192−rowLtAll
1193− :: SListI row
1194− => NP (Aliased (Expression grp commons schemas params from)) row -- ^ row constructor
1195− -> Query commons schemas params row -- ^ subquery
1196− -> Expression grp commons schemas params from (nullity 'PGbool)
1197−rowLtAll = unsafeRowSubqueryExpression "ALL <"
1198−
1199−-- | >>> printSQL $ true `ltAny` values_ (true `as` #foo)
1200−-- TRUE ANY < (SELECT * FROM (VALUES (TRUE)) AS t ("foo"))
1201−ltAny
1202− :: Expression grp commons schemas params from ty -- ^ expression
1203− -> Query commons schemas params '[alias ::: ty] -- ^ subquery
1204− -> Expression grp commons schemas params from (nullity 'PGbool)
1205−ltAny = unsafeSubqueryExpression "ANY <"
1206−
1207−-- | >>> let myRow = 1 `as` #foo :* false `as` #bar :: NP (Aliased (Expression grp commons schemas params from)) '["foo" ::: 'NotNull 'PGint2, "bar" ::: 'NotNull 'PGbool]
1208−-- >>> printSQL $ myRow `rowLtAll` values_ myRow
1209−-- ROW(1, FALSE) ALL < (SELECT * FROM (VALUES (1, FALSE)) AS t ("foo", "bar"))
1210−rowLtAny
1211− :: SListI row
1212− => NP (Aliased (Expression grp commons schemas params from)) row -- ^ row constructor
1213− -> Query commons schemas params row -- ^ subquery
1214− -> Expression grp commons schemas params from (nullity 'PGbool)
1215−rowLtAny = unsafeRowSubqueryExpression "ANY <"
1216−
1217−-- | >>> printSQL $ true `lteAll` values_ (true `as` #foo)
1218−-- TRUE <= ALL (SELECT * FROM (VALUES (TRUE)) AS t ("foo"))
1219−lteAll
1220− :: Expression grp commons schemas params from ty -- ^ expression
1221− -> Query commons schemas params '[alias ::: ty] -- ^ subquery
1222− -> Expression grp commons schemas params from (nullity 'PGbool)
1223−lteAll = unsafeSubqueryExpression "<= ALL"
1224−
1225−-- | >>> let myRow = 1 `as` #foo :* false `as` #bar :: NP (Aliased (Expression grp commons schemas params from)) '["foo" ::: 'NotNull 'PGint2, "bar" ::: 'NotNull 'PGbool]
1226−-- >>> printSQL $ myRow `rowLteAll` values_ myRow
1227−-- ROW(1, FALSE) <= ALL (SELECT * FROM (VALUES (1, FALSE)) AS t ("foo", "bar"))
1228−rowLteAll
1229− :: SListI row
1230− => NP (Aliased (Expression grp commons schemas params from)) row -- ^ row constructor
1231− -> Query commons schemas params row -- ^ subquery
1232− -> Expression grp commons schemas params from (nullity 'PGbool)
1233−rowLteAll = unsafeRowSubqueryExpression "<= ALL"
1234−
1235−-- | >>> printSQL $ true `lteAny` values_ (true `as` #foo)
1236−-- TRUE <= ANY (SELECT * FROM (VALUES (TRUE)) AS t ("foo"))
1237−lteAny
1238− :: Expression grp commons schemas params from ty -- ^ expression
1239− -> Query commons schemas params '[alias ::: ty] -- ^ subquery
1240− -> Expression grp commons schemas params from (nullity 'PGbool)
1241−lteAny = unsafeSubqueryExpression "<= ANY"
1242−
1243−-- | >>> let myRow = 1 `as` #foo :* false `as` #bar :: NP (Aliased (Expression grp commons schemas params from)) '["foo" ::: 'NotNull 'PGint2, "bar" ::: 'NotNull 'PGbool]
1244−-- >>> printSQL $ myRow `rowLteAny` values_ myRow
1245−-- ROW(1, FALSE) <= ANY (SELECT * FROM (VALUES (1, FALSE)) AS t ("foo", "bar"))
1246−rowLteAny
1247− :: SListI row
1248− => NP (Aliased (Expression grp commons schemas params from)) row -- ^ row constructor
1249− -> Query commons schemas params row -- ^ subquery
1250− -> Expression grp commons schemas params from (nullity 'PGbool)
1251−rowLteAny = unsafeRowSubqueryExpression "<= ANY"
1252−
1253−-- | >>> printSQL $ true `gtAll` values_ (true `as` #foo)
1254−-- TRUE > ALL (SELECT * FROM (VALUES (TRUE)) AS t ("foo"))
1255−gtAll
1256− :: Expression grp commons schemas params from ty -- ^ expression
1257− -> Query commons schemas params '[alias ::: ty] -- ^ subquery
1258− -> Expression grp commons schemas params from (nullity 'PGbool)
1259−gtAll = unsafeSubqueryExpression "> ALL"
1260−
1261−-- | >>> let myRow = 1 `as` #foo :* false `as` #bar :: NP (Aliased (Expression grp commons schemas params from)) '["foo" ::: 'NotNull 'PGint2, "bar" ::: 'NotNull 'PGbool]
1262−-- >>> printSQL $ myRow `rowGtAll` values_ myRow
1263−-- ROW(1, FALSE) > ALL (SELECT * FROM (VALUES (1, FALSE)) AS t ("foo", "bar"))
1264−rowGtAll
1265− :: SListI row
1266− => NP (Aliased (Expression grp commons schemas params from)) row -- ^ row constructor
1267− -> Query commons schemas params row -- ^ subquery
1268− -> Expression grp commons schemas params from (nullity 'PGbool)
1269−rowGtAll = unsafeRowSubqueryExpression "> ALL"
1270−
1271−-- | >>> printSQL $ true `gtAny` values_ (true `as` #foo)
1272−-- TRUE > ANY (SELECT * FROM (VALUES (TRUE)) AS t ("foo"))
1273−gtAny
1274− :: Expression grp commons schemas params from ty -- ^ expression
1275− -> Query commons schemas params '[alias ::: ty] -- ^ subquery
1276− -> Expression grp commons schemas params from (nullity 'PGbool)
1277−gtAny = unsafeSubqueryExpression "> ANY"
1278−
1279−-- | >>> let myRow = 1 `as` #foo :* false `as` #bar :: NP (Aliased (Expression grp commons schemas params from)) '["foo" ::: 'NotNull 'PGint2, "bar" ::: 'NotNull 'PGbool]
1280−-- >>> printSQL $ myRow `rowGtAny` values_ myRow
1281−-- ROW(1, FALSE) > ANY (SELECT * FROM (VALUES (1, FALSE)) AS t ("foo", "bar"))
1282−rowGtAny
1283− :: SListI row
1284− => NP (Aliased (Expression grp commons schemas params from)) row -- ^ row constructor
1285− -> Query commons schemas params row -- ^ subquery
1286− -> Expression grp commons schemas params from (nullity 'PGbool)
1287−rowGtAny = unsafeRowSubqueryExpression "> ANY"
1288−
1289−-- | >>> printSQL $ true `gteAll` values_ (true `as` #foo)
1290−-- TRUE >= ALL (SELECT * FROM (VALUES (TRUE)) AS t ("foo"))
1291−gteAll
1292− :: Expression grp commons schemas params from ty -- ^ expression
1293− -> Query commons schemas params '[alias ::: ty] -- ^ subquery
1294− -> Expression grp commons schemas params from (nullity 'PGbool)
1295−gteAll = unsafeSubqueryExpression ">= ALL"
1296−
1297−-- | >>> let myRow = 1 `as` #foo :* false `as` #bar :: NP (Aliased (Expression grp commons schemas params from)) '["foo" ::: 'NotNull 'PGint2, "bar" ::: 'NotNull 'PGbool]
1298−-- >>> printSQL $ myRow `rowGteAll` values_ myRow
1299−-- ROW(1, FALSE) >= ALL (SELECT * FROM (VALUES (1, FALSE)) AS t ("foo", "bar"))
1300−rowGteAll
1301− :: SListI row
1302− => NP (Aliased (Expression grp commons schemas params from)) row -- ^ row constructor
1303− -> Query commons schemas params row -- ^ subquery
1304− -> Expression grp commons schemas params from (nullity 'PGbool)
1305−rowGteAll = unsafeRowSubqueryExpression ">= ALL"
1306−
1307−-- | >>> printSQL $ true `gteAny` values_ (true `as` #foo)
1308−-- TRUE >= ANY (SELECT * FROM (VALUES (TRUE)) AS t ("foo"))
1309−gteAny
1310− :: Expression grp commons schemas params from ty -- ^ expression
1311− -> Query commons schemas params '[alias ::: ty] -- ^ subquery
1312− -> Expression grp commons schemas params from (nullity 'PGbool)
1313−gteAny = unsafeSubqueryExpression ">= ANY"
1314−
1315−-- | >>> let myRow = 1 `as` #foo :* false `as` #bar :: NP (Aliased (Expression grp commons schemas params from)) '["foo" ::: 'NotNull 'PGint2, "bar" ::: 'NotNull 'PGbool]
1316−-- >>> printSQL $ myRow `rowGteAny` values_ myRow
1317−-- ROW(1, FALSE) >= ANY (SELECT * FROM (VALUES (1, FALSE)) AS t ("foo", "bar"))
1318−rowGteAny
1319− :: SListI row
1320− => NP (Aliased (Expression grp commons schemas params from)) row -- ^ row constructor
1321− -> Query commons schemas params row -- ^ subquery
1322− -> Expression grp commons schemas params from (nullity 'PGbool)
1323−rowGteAny = unsafeRowSubqueryExpression ">= ANY"
1324−
13251031-- | A `CommonTableExpression` is an auxiliary statement in a `with` clause.
13261032data CommonTableExpression statement
13271033 (schemas :: SchemasType)
@@ -1343,41 +1049,50 @@ instance
13431049 , commons1 ~ (cte ::: common ': commons)
13441050 ) => Aliasable cte
13451051 (statement commons schemas params common)
1346− (AlignedList (CommonTableExpression statement schemas params) commons commons1) where
1347− statement `as` cte = single (statement `as` cte)
1348−
1349−-- | render a `CommonTableExpression`.
1350−renderCommonTableExpression
1351− :: (forall cs ss ps row. statement cs ss ps row -> ByteString) -- ^ render statement
1352− -> CommonTableExpression statement schemas params commons0 commons1 -> ByteString
1353−renderCommonTableExpression renderStatement
1354− (CommonTableExpression (statement `As` alias)) =
1355− renderSQL alias <+> "AS" <+> parenthesized (renderStatement statement)
1356−
1357−-- | render a non-empty `AlignedList` of `CommonTableExpression`s.
1358−renderCommonTableExpressions
1359− :: (forall cs ss ps row. statement cs ss ps row -> ByteString) -- ^ render statement
1360− -> CommonTableExpression statement schemas params commons0 commons1
1361− -> AlignedList (CommonTableExpression statement schemas params) commons1 commons2
1362− -> ByteString
1363−renderCommonTableExpressions renderStatement cte ctes =
1364− renderCommonTableExpression renderStatement cte <> case ctes of
1365− Done -> ""
1366− cte' :>> ctes' -> "," <+>
1367− renderCommonTableExpressions renderStatement cte' ctes'
1052+ (Path (CommonTableExpression statement schemas params) commons commons1) where
1053+ statement `as` cte = csingleton (statement `as` cte)
1054+
1055+instance (forall c s p r. RenderSQL (statement c s p r)) => RenderSQL
1056+ (CommonTableExpression statement schemas params commons0 commons1) where
1057+ renderSQL (CommonTableExpression (statement `As` cte)) =
1058+ renderSQL cte <+> "AS" <+> parenthesized (renderSQL statement)
13681059
13691060-- | `with` provides a way to write auxiliary statements for use in a larger query.
13701061-- These statements, referred to as `CommonTableExpression`s, can be thought of as
13711062-- defining temporary tables that exist just for one query.
13721063class With statement where
13731064 with
1374− :: AlignedList (CommonTableExpression statement schemas params) commons0 commons1
1065+ :: Path (CommonTableExpression statement schemas params) commons0 commons1
13751066 -- ^ common table expressions
13761067 -> statement commons1 schemas params row
13771068 -- ^ larger query
13781069 -> statement commons0 schemas params row
1379−instance With Query where
1070+instance With (Query outer) where
13801071 with Done query = query
1381− with (cte :>> ctes) query = UnsafeQuery $
1382− "WITH" <+> renderCommonTableExpressions renderSQL cte ctes
1383− <+> renderSQL query
1072+ with ctes query = UnsafeQuery $
1073+ "WITH" <+> commaSeparated (ctoList renderSQL ctes) <+> renderSQL query
1074+
1075+{- |
1076+>>> import Data.Monoid (Sum (..))
1077+>>> import Data.Int (Int64)
1078+>>> :{
1079+ let
1080+ query :: Query_ schema () (Sum Int64)
1081+ query = withRecursive
1082+ ( values_ ((1 & astype int) `as` #n)
1083+ `unionAll`
1084+ select_ ((#n + 1) `as` #n)
1085+ (from (common #t) & where_ (#n .< 100)) `as` #t )
1086+ ( select_ (fromNull 0 (sum_ (All #n)) `as` #getSum) (from (common #t) & groupBy Nil))
1087+ in printSQL query
1088+:}
1089+WITH RECURSIVE "t" AS ((SELECT * FROM (VALUES ((1 :: int))) AS t ("n")) UNION ALL (SELECT ("n" + 1) AS "n" FROM "t" AS "t" WHERE ("n" < 100))) SELECT COALESCE(sum(ALL "n"), 0) AS "getSum" FROM "t" AS "t"
1090+-}
1091+withRecursive
1092+ :: Aliased (Query outer (recursive ': commons) schemas params) recursive
1093+ -> Query outer (recursive ': commons) schemas params row
1094+ -> Query outer commons schemas params row
1095+withRecursive (recursive `As` cte) query = UnsafeQuery $
1096+ "WITH RECURSIVE" <+> renderSQL cte
1097+ <+> "AS" <+> parenthesized (renderSQL recursive)
1098+ <+> renderSQL query
squeal-postgresql/src/Squeal/PostgreSQL/Render.hs+46−11
@@ -10,40 +10,47 @@ Rendering helper functions.
1010
1111{-# LANGUAGE
1212 AllowAmbiguousTypes
13+ , ConstraintKinds
1314 , FlexibleContexts
15+ , LambdaCase
1416 , MagicHash
1517 , OverloadedStrings
1618 , PolyKinds
1719 , RankNTypes
1820 , ScopedTypeVariables
21+ , TypeApplications
1922#-}
2023
2124module Squeal.PostgreSQL.Render
2225 ( -- * Render
23− parenthesized
26+ RenderSQL (..)
27+ , printSQL
28+ , escape
29+ , parenthesized
30+ , bracketed
2431 , (<+>)
2532 , commaSeparated
2633 , doubleQuoted
2734 , singleQuotedText
2835 , singleQuotedUtf8
2936 , renderCommaSeparated
37+ , renderCommaSeparatedConstraint
3038 , renderCommaSeparatedMaybe
3139 , renderNat
3240 , renderSymbol
33− , RenderSQL (..)
34− , printSQL
3541 ) where
3642
37−import Control.Monad.Base
43+import Control.Monad.IO.Class (MonadIO (..))
3844import Data.ByteString (ByteString)
3945import Data.Maybe (catMaybes)
4046import Data.Monoid ((<>))
4147import Data.Text (Text)
4248import Generics.SOP
4349import GHC.Exts
44−import GHC.TypeLits
45−import qualified Data.Text as T
46−import qualified Data.Text.Encoding as T
50+import GHC.TypeLits hiding (Text)
51+
52+import qualified Data.Text as Text
53+import qualified Data.Text.Encoding as Text
4754import qualified Data.ByteString as ByteString
4855import qualified Data.ByteString.Char8 as Char8
4956
@@ -51,6 +58,10 @@ import qualified Data.ByteString.Char8 as Char8
5158parenthesized :: ByteString -> ByteString
5259parenthesized str = "(" <> str <> ")"
5360
61+-- | Square bracket a `ByteString`
62+bracketed :: ByteString -> ByteString
63+bracketed str = "[" <> str <> "]"
64+
5465-- | Concatenate two `ByteString`s with a space between.
5566(<+>) :: ByteString -> ByteString -> ByteString
5667infixr 7 <+>
@@ -66,11 +77,12 @@ doubleQuoted str = "\"" <> str <> "\""
6677
6778-- | Add single quotes around a `Text` and escape single quotes within it.
6879singleQuotedText :: Text -> ByteString
69−singleQuotedText str = "'" <> T.encodeUtf8 (T.replace "'" "''" str) <> "'"
80+singleQuotedText str =
81+ "'" <> Text.encodeUtf8 (Text.replace "'" "''" str) <> "'"
7082
7183-- | Add single quotes around a `ByteString` and escape single quotes within it.
7284singleQuotedUtf8 :: ByteString -> ByteString
73−singleQuotedUtf8 = singleQuotedText . T.decodeUtf8
85+singleQuotedUtf8 = singleQuotedText . Text.decodeUtf8
7486
7587-- | Comma separate the renderings of a heterogeneous list.
7688renderCommaSeparated
@@ -82,6 +94,16 @@ renderCommaSeparated render
8294 . hcollapse
8395 . hmap (K . render)
8496
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+
85107-- | Comma separate the `Maybe` renderings of a heterogeneous list, dropping
86108-- `Nothing`s.
87109renderCommaSeparatedMaybe
@@ -106,5 +128,18 @@ renderSymbol = fromString (symbolVal' (proxy# :: Proxy# s))
106128class RenderSQL sql where renderSQL :: sql -> ByteString
107129
108130-- | Print SQL.
109−printSQL :: (RenderSQL sql, MonadBase IO io) => sql -> io ()
110−printSQL = liftBase . Char8.putStrLn . renderSQL
131+printSQL :: (RenderSQL sql, MonadIO io) => sql -> io ()
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+207−484
@@ -1,16 +1,15 @@
11{-|
22Module: Squeal.PostgreSQL.Schema
33Description: Embedding of PostgreSQL type and alias system
4−Copyright: (c) Eitan Chatav, 2017
4+Copyright: (c) Eitan Chatav, 2019
55Maintainer: eitan@morphism.tech
66Stability: experimental
77
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,
99tables, schema, constraints, aliases, enumerated labels, and groupings.
1010It also defines useful type families to operate on these. Finally,
1111it defines an embedding of Haskell types into Postgres types.
1212-}
13−{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
1413{-# LANGUAGE
1514 AllowAmbiguousTypes
1615 , ConstraintKinds
@@ -22,6 +21,7 @@ it defines an embedding of Haskell types into Postgres types.
2221 , GADTs
2322 , LambdaCase
2423 , OverloadedStrings
24+ , QuantifiedConstraints
2525 , RankNTypes
2626 , ScopedTypeVariables
2727 , StandaloneDeriving
@@ -39,16 +39,15 @@ module Squeal.PostgreSQL.Schema
3939 , NullityType (..)
4040 , RowType
4141 , FromType
42− -- * Haskell to Postgres Types
43− , PG
44− , NullPG
45− , TuplePG
46− , RowPG
4742 -- * Schema Types
4843 , ColumnType
4944 , ColumnsType
5045 , TableType
5146 , SchemumType (..)
47+ , IndexType (..)
48+ , FunctionType
49+ , OperatorType (..)
50+ , ReturnsType (..)
5251 , SchemaType
5352 , SchemasType
5453 , Public
@@ -58,52 +57,30 @@ module Squeal.PostgreSQL.Schema
5857 , TableConstraint (..)
5958 , TableConstraints
6059 , Uniquely
61− -- * Aliases
62− , (:::)
63− , Alias (..)
64− , IsLabel (..)
65− , Aliased (As)
66− , Aliasable (as)
67− , renderAliased
68− , Has
69− , HasUnique
70− , HasAll
71− , QualifiedAlias (..)
72− , IsQualified (..)
73− , HasIn
74− , IsNotElem
75− , AllUnique
76− , DefaultAliasable (..)
7760 -- * Enumerated Labels
7861 , IsPGlabel (..)
7962 , PGlabel (..)
80− , LabelsPG
81− -- * Grouping
82− , Grouping (..)
83− , GroupedBy
84− -- * Aligned lists
85− , AlignedList (..)
86− , single
8763 -- * Data Definitions
8864 , Create
65+ , CreateIfNotExists
66+ , CreateOrReplace
8967 , Drop
68+ , DropSchemum
69+ , DropIfExists
70+ , DropSchemumIfExists
9071 , Alter
72+ , AlterIfExists
9173 , Rename
74+ , RenameIfExists
75+ , ConstraintInvolves
9276 , DropIfConstraintsInvolve
93− -- * Lists
94− , Join
95− , Elem
96− , In
97− , Length
77+ , IsNotElem
78+ , AllUnique
9879 -- * Type Classifications
99− , HasOid (..)
10080 , PGNum
10181 , PGIntegral
10282 , PGFloating
10383 , PGTypeOf
104− , PGArrayOf
105− , PGArray
106− , PGTextArray
10784 , PGJsonType
10885 , PGJsonKey
10986 , SamePGType
@@ -120,36 +97,22 @@ module Squeal.PostgreSQL.Schema
12097 ) where
12198
12299import Control.Category
123−import Control.DeepSeq
124−import Data.Aeson (Value)
125−import Data.ByteString (ByteString)
126−import Data.Int (Int16, Int32, Int64)
127100import Data.Kind
128101import Data.Monoid hiding (All)
129−import Data.Scientific (Scientific)
130−import Data.String
131−import Data.Text (Text)
132−import Data.Time
133−import Data.Word (Word16, Word32, Word64)
134102import Data.Type.Bool
135−import Data.UUID.Types (UUID)
136103import Generics.SOP
137−import Generics.SOP.Record
138−import GHC.OverloadedLabels
139104import GHC.TypeLits
140−import Network.IP.Addr
141105import Prelude hiding (id, (.))
142106
143−import qualified Data.ByteString.Lazy as Lazy
144−import qualified Data.Text.Lazy as Lazy
145−import qualified GHC.Generics as GHC
146−import qualified Generics.SOP.Type.Metadata as Type
147−
107+import Squeal.PostgreSQL.Alias
108+import Squeal.PostgreSQL.List
148109import Squeal.PostgreSQL.Render
149110
111+-- $setup
112+-- >>> import Squeal.PostgreSQL
113+
150114-- | `PGType` is the promoted datakind of PostgreSQL types.
151115--
152−-- >>> import Squeal.PostgreSQL.Schema
153116-- >>> :kind 'PGbool
154117-- 'PGbool :: PGType
155118data PGType
@@ -160,6 +123,7 @@ data PGType
160123 | PGnumeric -- ^ arbitrary precision numeric type
161124 | PGfloat4 -- ^ single precision floating-point number (4 bytes)
162125 | PGfloat8 -- ^ double precision floating-point number (8 bytes)
126+ | PGmoney -- ^ currency amount
163127 | PGchar Nat -- ^ fixed-length character string
164128 | PGvarchar Nat -- ^ variable-length character string
165129 | PGtext -- ^ variable-length character string
@@ -178,36 +142,12 @@ data PGType
178142 | PGfixarray [Nat] NullityType -- ^ fixed length array
179143 | PGenum [Symbol] -- ^ enumerated (enum) types are data types that comprise a static, ordered set of values.
180144 | 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).
181149 | UnsafePGType Symbol -- ^ an escape hatch for unsupported PostgreSQL types
182150
183−-- | The object identifier of a `PGType`.
184−--
185−-- >>> :set -XTypeApplications
186−-- >>> oid @'PGbool
187−-- 16
188−class HasOid (ty :: PGType) where oid :: Word32
189−instance HasOid 'PGbool where oid = 16
190−instance HasOid 'PGint2 where oid = 21
191−instance HasOid 'PGint4 where oid = 23
192−instance HasOid 'PGint8 where oid = 20
193−instance HasOid 'PGnumeric where oid = 1700
194−instance HasOid 'PGfloat4 where oid = 700
195−instance HasOid 'PGfloat8 where oid = 701
196−instance HasOid ('PGchar n) where oid = 18
197−instance HasOid ('PGvarchar n) where oid = 1043
198−instance HasOid 'PGtext where oid = 25
199−instance HasOid 'PGbytea where oid = 17
200−instance HasOid 'PGtimestamp where oid = 1114
201−instance HasOid 'PGtimestamptz where oid = 1184
202−instance HasOid 'PGdate where oid = 1082
203−instance HasOid 'PGtime where oid = 1083
204−instance HasOid 'PGtimetz where oid = 1266
205−instance HasOid 'PGinterval where oid = 1186
206−instance HasOid 'PGuuid where oid = 2950
207−instance HasOid 'PGinet where oid = 869
208−instance HasOid 'PGjson where oid = 114
209−instance HasOid 'PGjsonb where oid = 3802
210−
211151-- | `NullityType` encodes the potential presence or definite absence of a
212152-- @NULL@ allowing operations which are sensitive to such to be well typed.
213153--
@@ -226,11 +166,6 @@ data NullityType
226166type (:=>) constraint ty = '(constraint,ty)
227167infixr 7 :=>
228168
229−-- | The alias operator `:::` is like a promoted version of `As`,
230−-- a type level pair between an alias and some type.
231−type (:::) (alias :: Symbol) ty = '(alias,ty)
232−infixr 6 :::
233−
234169-- | `ColumnConstraint` encodes the availability of @DEFAULT@ for inserts and updates.
235170-- A column can be assigned a default value.
236171-- A data `Squeal.PostgreSQL.Manipulations.Manipulation` command can also
@@ -272,7 +207,13 @@ data TableConstraint
272207 | PrimaryKey [Symbol]
273208 | ForeignKey [Symbol] Symbol [Symbol]
274209
275−-- | 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+-}
276217type TableConstraints = [(Symbol,TableConstraint)]
277218
278219-- | A `ForeignKey` must reference columns that either are
@@ -298,7 +239,7 @@ type family Uniquely
298239type TableType = (TableConstraints,ColumnsType)
299240
300241{- | A `RowType` is a row of `NullityType`. They correspond to Haskell
301−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.
302243
303244>>> :{
304245type family PersonRow :: RowType where
@@ -319,9 +260,19 @@ type FromType = [(Symbol,RowType)]
319260
320261-- | `ColumnsToRow` removes column constraints.
321262type family ColumnsToRow (columns :: ColumnsType) :: RowType where
322− ColumnsToRow '[] = '[]
323− ColumnsToRow (column ::: constraint :=> ty ': columns) =
263+ ColumnsToRow (column ::: _ :=> ty ': column1 ::: _ :=> ty1 ': column2 ::: _ :=> ty2 ': column3 ::: _ :=> ty3 ': column4 ::: _ :=> ty4 ': column5 ::: _ :=> ty5 ': columns) =
264+ column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': column3 ::: ty3 ': column4 ::: ty4 ': column5 ::: ty5 ': ColumnsToRow columns
265+ ColumnsToRow (column ::: _ :=> ty ': column1 ::: _ :=> ty1 ': column2 ::: _ :=> ty2 ': column3 ::: _ :=> ty3 ': column4 ::: _ :=> ty4 ': columns) =
266+ column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': column3 ::: ty3 ': column4 ::: ty4 ': ColumnsToRow columns
267+ ColumnsToRow (column ::: _ :=> ty ': column1 ::: _ :=> ty1 ': column2 ::: _ :=> ty2 ': column3 ::: _ :=> ty3 ': columns) =
268+ column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': column3 ::: ty3 ': ColumnsToRow columns
269+ ColumnsToRow (column ::: _ :=> ty ': column1 ::: _ :=> ty1 ': column2 ::: _ :=> ty2 ': columns) =
270+ column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': ColumnsToRow columns
271+ ColumnsToRow (column ::: _ :=> ty ': column1 ::: _ :=> ty1 ': columns) =
272+ column ::: ty ': column1 ::: ty1 ': ColumnsToRow columns
273+ ColumnsToRow (column ::: _ :=> ty ': columns) =
324274 column ::: ty ': ColumnsToRow columns
275+ ColumnsToRow '[] = '[]
325276
326277-- | `TableToColumns` removes table constraints.
327278type family TableToColumns (table :: TableType) :: ColumnsType where
@@ -331,188 +282,6 @@ type family TableToColumns (table :: TableType) :: ColumnsType where
331282type family TableToRow (table :: TableType) :: RowType where
332283 TableToRow tab = ColumnsToRow (TableToColumns tab)
333284
334−-- | `Grouping` is an auxiliary namespace, created by
335−-- @GROUP BY@ clauses (`Squeal.PostgreSQL.Query.group`), and used
336−-- for typesafe aggregation
337−data Grouping
338− = Ungrouped -- ^ no aggregation permitted
339− | Grouped [(Symbol,Symbol)] -- ^ aggregation required for any column which is not grouped
340−
341−{- | A `GroupedBy` constraint indicates that a table qualified column is
342−a member of the auxiliary namespace created by @GROUP BY@ clauses and thus,
343−may be called in an output `Squeal.PostgreSQL.Expression.Expression` without aggregating.
344−-}
345−class (KnownSymbol table, KnownSymbol column)
346− => GroupedBy table column bys where
347−instance {-# OVERLAPPING #-} (KnownSymbol table, KnownSymbol column)
348− => GroupedBy table column ('(table,column) ': bys)
349−instance {-# OVERLAPPABLE #-}
350− ( KnownSymbol table
351− , KnownSymbol column
352− , GroupedBy table column bys
353− ) => GroupedBy table column (tabcol ': bys)
354−
355−-- | `Alias`es are proxies for a type level string or `Symbol`
356−-- and have an `IsLabel` instance so that with @-XOverloadedLabels@
357−--
358−-- >>> :set -XOverloadedLabels
359−-- >>> #foobar :: Alias "foobar"
360−-- Alias
361−data Alias (alias :: Symbol) = Alias
362− deriving (Eq,GHC.Generic,Ord,Show,NFData)
363−instance alias1 ~ alias2 => IsLabel alias1 (Alias alias2) where
364− fromLabel = Alias
365−instance aliases ~ '[alias] => IsLabel alias (NP Alias aliases) where
366− fromLabel = fromLabel :* Nil
367−-- | >>> printSQL (#jimbob :: Alias "jimbob")
368−-- "jimbob"
369−instance KnownSymbol alias => RenderSQL (Alias alias) where
370− renderSQL = doubleQuoted . fromString . symbolVal
371−
372−-- | >>> import Generics.SOP (NP(..))
373−-- >>> printSQL (#jimbob :* #kandi :: NP Alias '["jimbob", "kandi"])
374−-- "jimbob", "kandi"
375−instance All KnownSymbol aliases => RenderSQL (NP Alias aliases) where
376− renderSQL
377− = commaSeparated
378− . hcollapse
379− . hcmap (Proxy @KnownSymbol) (K . renderSQL)
380−
381−-- | The `As` operator is used to name an expression. `As` is like a demoted
382−-- version of `:::`.
383−--
384−-- >>> Just "hello" `As` #hi :: Aliased Maybe ("hi" ::: String)
385−-- As (Just "hello") Alias
386−data Aliased expression aliased where
387− As
388− :: KnownSymbol alias
389− => expression ty
390− -> Alias alias
391− -> Aliased expression (alias ::: ty)
392−deriving instance Show (expression ty)
393− => Show (Aliased expression (alias ::: ty))
394−deriving instance Eq (expression ty)
395− => Eq (Aliased expression (alias ::: ty))
396−deriving instance Ord (expression ty)
397− => Ord (Aliased expression (alias ::: ty))
398−instance (alias0 ~ alias1, alias0 ~ alias2, KnownSymbol alias2)
399− => IsLabel alias0 (Aliased Alias (alias1 ::: alias2)) where
400− fromLabel = fromLabel @alias2 `As` fromLabel @alias1
401−
402−-- | The `Aliasable` class provides a way to scrap your `Nil`s
403−-- in an `NP` list of `Aliased` expressions.
404−class KnownSymbol alias => Aliasable alias expression aliased
405− | aliased -> expression
406− , aliased -> alias
407− where as :: expression -> Alias alias -> aliased
408−instance (KnownSymbol alias, aliased ~ (alias ::: ty)) => Aliasable alias
409− (expression ty)
410− (Aliased expression aliased)
411− where
412− as = As
413−instance (KnownSymbol alias, tys ~ '[alias ::: ty]) => Aliasable alias
414− (expression ty)
415− (NP (Aliased expression) tys)
416− where
417− expression `as` alias = expression `As` alias :* Nil
418−
419−-- | >>> let renderMaybe = fromString . maybe "Nothing" (const "Just")
420−-- >>> renderAliased renderMaybe (Just (3::Int) `As` #an_int)
421−-- "Just AS \"an_int\""
422−renderAliased
423− :: (forall ty. expression ty -> ByteString)
424− -> Aliased expression aliased
425− -> ByteString
426−renderAliased render (expression `As` alias) =
427− render expression <> " AS " <> renderSQL alias
428−
429−-- | @HasUnique alias fields field@ is a constraint that proves that
430−-- @fields@ is a singleton of @alias ::: field@.
431−type HasUnique alias fields field = fields ~ '[alias ::: field]
432−
433−-- | @Has alias fields field@ is a constraint that proves that
434−-- @fields@ has a field of @alias ::: field@, inferring @field@
435−-- from @alias@ and @fields@.
436−class KnownSymbol alias =>
437− Has (alias :: Symbol) (fields :: [(Symbol,kind)]) (field :: kind)
438− | alias fields -> field where
439−instance {-# OVERLAPPING #-} KnownSymbol alias
440− => Has alias (alias ::: field ': fields) field
441−instance {-# OVERLAPPABLE #-} (KnownSymbol alias, Has alias fields field)
442− => Has alias (field' ': fields) field
443−
444−class HasIn fields (x :: (Symbol, a)) where
445−instance (Has alias fields field) => HasIn fields '(alias, field) where
446−
447−-- | Utility class for `AllUnique` to provide nicer error messages.
448−class IsNotElem x isElem where
449−instance IsNotElem x 'False where
450−instance (TypeError ( 'Text "Cannot assign to "
451− ':<>: 'ShowType alias
452− ':<>: 'Text " more than once"))
453− => IsNotElem '(alias, a) 'True where
454− -- | No elem of @xs@ appears more than once, in the context of assignment.
455−class AllUnique (xs :: [(Symbol, a)]) where
456−instance AllUnique '[] where
457−instance (IsNotElem x (Elem x xs), AllUnique xs) => AllUnique (x ': xs) where
458−
459−class KnownSymbol alias
460− => DefaultAliasable alias aliased | aliased -> alias where
461− defaultAs :: Alias alias -> aliased
462−
463−-- | `HasAll` extends `Has` to take lists of @aliases@ and @fields@ and infer
464−-- a list of @subfields@.
465−class
466− ( All KnownSymbol aliases
467− ) => HasAll
468− (aliases :: [Symbol])
469− (fields :: [(Symbol,kind)])
470− (subfields :: [(Symbol,kind)])
471− | aliases fields -> subfields where
472−instance {-# OVERLAPPING #-} HasAll '[] fields '[]
473−instance {-# OVERLAPPABLE #-}
474− (Has alias fields field, HasAll aliases fields subfields)
475− => HasAll (alias ': aliases) fields (alias ::: field ': subfields)
476−
477−-- | Analagous to `IsLabel`, the constraint
478−-- `IsQualified` defines `!` for a column alias qualified
479−-- by a table alias.
480−class IsQualified table column expression where
481− (!) :: Alias table -> Alias column -> expression
482− infixl 9 !
483−instance IsQualified table column (Alias table, Alias column) where (!) = (,)
484−
485−data QualifiedAlias (qualifier :: Symbol) (alias :: Symbol) = QualifiedAlias
486− deriving (Eq,GHC.Generic,Ord,Show,NFData)
487−instance (q ~ q', a ~ a') => IsQualified q a (QualifiedAlias q' a') where
488− _!_ = QualifiedAlias
489−instance (q' ~ "public", a ~ a') => IsLabel a (QualifiedAlias q' a') where
490− fromLabel = QualifiedAlias
491−instance (q0 ~ q1, a0 ~ a1, a1 ~ a2, KnownSymbol a2) =>
492− IsQualified q0 a0 (Aliased (QualifiedAlias q1) (a1 ::: a2)) where
493− _!_ = QualifiedAlias `As` Alias
494−instance (q ~ "public", a0 ~ a1, a1 ~ a2, KnownSymbol a2) =>
495− IsLabel a0 (Aliased (QualifiedAlias q) (a1 ::: a2)) where
496− fromLabel = QualifiedAlias `As` Alias
497−
498−instance (KnownSymbol q, KnownSymbol a)
499− => RenderSQL (QualifiedAlias q a) where
500− renderSQL _ =
501− let
502− qualifier = renderSQL (Alias @q)
503− alias = renderSQL (Alias @a)
504− in
505− if qualifier == "\"public\"" then alias else qualifier <> "." <> alias
506−
507−-- | @Elem@ is a promoted `Data.List.elem`.
508−type family Elem x xs where
509− Elem x '[] = 'False
510− Elem x (x ': xs) = 'True
511− Elem x (_ ': xs) = Elem x xs
512−
513−-- | @In x xs@ is a constraint that proves that @x@ is in @xs@.
514−type family In x xs :: Constraint where In x xs = Elem x xs ~ 'True
515−
516285-- | Numeric Postgres types.
517286type PGNum =
518287 '[ 'PGint2, 'PGint4, 'PGint8, 'PGnumeric, 'PGfloat4, 'PGfloat8]
@@ -523,37 +292,6 @@ type PGFloating = '[ 'PGfloat4, 'PGfloat8, 'PGnumeric]
523292-- | Integral Postgres types.
524293type PGIntegral = '[ 'PGint2, 'PGint4, 'PGint8]
525294
526−-- | Error message helper for displaying unavailable\/unknown\/placeholder type
527−-- variables whose kind is known.
528−type Placeholder k = 'Text "(_::" :<>: 'ShowType k :<>: 'Text ")"
529−
530−type ErrArrayOf arr ty = arr :<>: 'Text " " :<>: ty
531−type ErrPGfixarrayOf t = ErrArrayOf ('ShowType 'PGfixarray :<>: 'Text " " :<>: Placeholder Nat) t
532−type ErrPGvararrayOf t = ErrArrayOf ('ShowType 'PGvararray) t
533−
534−-- | Ensure a type is a valid array type.
535−type family PGArray name arr :: Constraint where
536− PGArray name ('PGvararray x) = ()
537− PGArray name ('PGfixarray n x) = ()
538− PGArray name val = TypeError
539− ('Text name :<>: 'Text ": Unsatisfied PGArray constraint. Expected either: "
540− :$$: 'Text " • " :<>: ErrPGvararrayOf (Placeholder PGType)
541− :$$: 'Text " • " :<>: ErrPGfixarrayOf (Placeholder PGType)
542− :$$: 'Text "But got: " :<>: 'ShowType val)
543−
544−-- | Ensure a type is a valid array type with a specific element type.
545−type family PGArrayOf name arr ty :: Constraint where
546− PGArrayOf name ('PGvararray x) ty = x ~ ty
547− PGArrayOf name ('PGfixarray n x) ty = x ~ ty
548− PGArrayOf name val ty = TypeError
549− ( 'Text name :<>: 'Text "Unsatisfied PGArrayOf constraint. Expected either: "
550− :$$: 'Text " • " :<>: ErrPGvararrayOf ( 'ShowType ty )
551− :$$: 'Text " • " :<>: ErrPGfixarrayOf ( 'ShowType ty )
552− :$$: 'Text "But got: " :<>: 'ShowType val)
553−
554−-- | Ensure a type is a valid array type whose elements are text.
555−type PGTextArray name arr = PGArrayOf name arr ('NotNull 'PGtext)
556−
557295-- | `PGTypeOf` forgets about @NULL@ and any column constraints.
558296type family PGTypeOf (ty :: NullityType) :: PGType where
559297 PGTypeOf (nullity pg) = pg
@@ -567,14 +305,24 @@ instance ty0 ~ ty1 => SamePGType
567305
568306-- | `AllNotNull` is a constraint that proves a `ColumnsType` has no @NULL@s.
569307type 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
570314 AllNotNull '[] = ()
571− AllNotNull (column ::: def :=> 'NotNull ty ': columns) = AllNotNull columns
572315
573316-- | `NotAllNull` is a constraint that proves a `ColumnsType` has some
574317-- @NOT NULL@.
575318type family NotAllNull (columns :: ColumnsType) :: Constraint where
576− NotAllNull (column ::: def :=> 'NotNull ty ': columns) = ()
577− NotAllNull (column ::: def :=> 'Null ty ': columns) = NotAllNull columns
319+ NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()
320+ NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()
321+ NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()
322+ NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()
323+ NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()
324+ NotAllNull (_ ::: _ :=> 'NotNull _ ': _) = ()
325+ NotAllNull (_ ::: _ :=> 'Null _ ': columns) = NotAllNull columns
578326
579327-- | `NullifyType` is an idempotent that nullifies a `NullityType`.
580328type family NullifyType (ty :: NullityType) :: NullityType where
@@ -583,23 +331,37 @@ type family NullifyType (ty :: NullityType) :: NullityType where
583331
584332-- | `NullifyRow` is an idempotent that nullifies a `RowType`.
585333type family NullifyRow (columns :: RowType) :: RowType where
586− 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
587344 NullifyRow (column ::: ty ': columns) =
588345 column ::: NullifyType ty ': NullifyRow columns
346+ NullifyRow '[] = '[]
589347
590348-- | `NullifyFrom` is an idempotent that nullifies a `FromType`
591349-- used to nullify the left or right hand side of an outer join
592350-- in a `Squeal.PostgreSQL.Query.FromClause`.
593351type family NullifyFrom (tables :: FromType) :: FromType where
594− 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
595362 NullifyFrom (table ::: columns ': tables) =
596363 table ::: NullifyRow columns ': NullifyFrom tables
597−
598−-- | `Join` is simply promoted `++` and is used in @JOIN@s in
599−-- `Squeal.PostgreSQL.Query.FromClause`s.
600−type family Join xs ys where
601− Join '[] ys = ys
602− Join (x ': xs) ys = x ': Join xs ys
364+ NullifyFrom '[] = '[]
603365
604366-- | @Create alias x xs@ adds @alias ::: x@ to the end of @xs@ and is used in
605367-- `Squeal.PostgreSQL.Definition.createTable` statements and in @ALTER TABLE@
@@ -609,30 +371,101 @@ type family Create alias x xs where
609371 Create alias x (alias ::: y ': xs) = TypeError
610372 ('Text "Create: alias "
611373 ':<>: 'ShowType alias
612− ':<>: 'Text "already in use")
374+ ':<>: 'Text "already exists")
613375 Create alias y (x ': xs) = x ': Create alias y xs
614376
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+
615394-- | @Drop alias xs@ removes the type associated with @alias@ in @xs@
616395-- and is used in `Squeal.PostgreSQL.Definition.dropTable` statements
617396-- and in @ALTER TABLE@ `Squeal.PostgreSQL.Definition.dropColumn` statements.
618397type family Drop alias xs where
619− Drop alias ((alias ::: x) ': xs) = xs
398+ Drop alias '[] = TypeError
399+ ('Text "Drop: alias "
400+ ':<>: 'ShowType alias
401+ ':<>: 'Text " does not exist" )
402+ Drop alias (alias ::: x ': xs) = xs
620403 Drop alias (x ': xs) = x ': Drop alias xs
621404
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+
622437-- | @Alter alias x xs@ replaces the type associated with an @alias@ in @xs@
623−-- 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`
624439-- and `Squeal.PostgreSQL.Definition.alterColumn`.
625440type family Alter alias x xs where
441+ Alter alias x '[] = TypeError
442+ ('Text "Alter: alias "
443+ ':<>: 'ShowType alias
444+ ':<>: 'Text " does not exist" )
626445 Alter alias x1 (alias ::: x0 ': xs) = alias ::: x1 ': xs
627446 Alter alias x1 (x0 ': xs) = x0 ': Alter alias x1 xs
628447
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+
629453-- | @Rename alias0 alias1 xs@ replaces the alias @alias0@ by @alias1@ in @xs@
630454-- and is used in `Squeal.PostgreSQL.Definition.alterTableRename` and
631455-- `Squeal.PostgreSQL.Definition.renameColumn`.
632456type family Rename alias0 alias1 xs where
457+ Rename alias0 alias1 '[] = TypeError
458+ ('Text "Rename: alias "
459+ ':<>: 'ShowType alias0
460+ ':<>: 'Text " does not exist" )
633461 Rename alias0 alias1 ((alias0 ::: x0) ': xs) = (alias1 ::: x0) ': xs
634462 Rename alias0 alias1 (x ': xs) = x ': Rename alias0 alias1 xs
635463
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+
636469-- | Check if a `TableConstraint` involves a column
637470type family ConstraintInvolves column constraint where
638471 ConstraintInvolves column ('Check columns) = column `Elem` columns
@@ -649,22 +482,35 @@ type family DropIfConstraintsInvolve column constraints where
649482 (DropIfConstraintsInvolve column constraints)
650483 (alias ::: constraint ': DropIfConstraintsInvolve column constraints)
651484
652−{- | Calculate the `Length` of a type level list
653−
654−>>> :kind! Length '[Char,String,Bool,Double]
655−Length '[Char,String,Bool,Double] :: Nat
656−= 4
657−-}
658−type family Length (xs :: [k]) :: Nat where
659− Length (x : xs) = 1 + Length xs
660− Length '[] = 0
661−
662485-- | A `SchemumType` is a user-defined type, either a `Table`,
663486-- `View` or `Typedef`.
664487data SchemumType
665488 = Table TableType
666489 | View RowType
667490 | 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
668514
669515{- | The schema of a database consists of a list of aliased,
670516user-defined `SchemumType`s.
@@ -690,8 +536,24 @@ type family Schema :: SchemaType where
690536-}
691537type SchemaType = [(Symbol,SchemumType)]
692538
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+-}
693554type SchemasType = [(Symbol,SchemaType)]
694555
556+-- | A type family to use for a single schema database.
695557type family Public (schema :: SchemaType) :: SchemasType
696558 where Public schema = '["public" ::: schema]
697559
@@ -714,160 +576,21 @@ instance All KnownSymbol labels => RenderSQL (NP PGlabel labels) where
714576 . hcollapse
715577 . hcmap (Proxy @KnownSymbol) (K . renderSQL)
716578
717−{- | The `PG` type family embeds a subset of Haskell types
718−as Postgres types. As an open type family, `PG` is extensible.
719−
720−>>> :kind! PG LocalTime
721−PG LocalTime :: PGType
722−= 'PGtimestamp
723−
724−>>> newtype MyDouble = My Double
725−>>> type instance PG MyDouble = 'PGfloat8
726−-}
727−type family PG (hask :: Type) :: PGType
728−type instance PG Bool = 'PGbool
729−type instance PG Int16 = 'PGint2
730−type instance PG Int32 = 'PGint4
731−type instance PG Int64 = 'PGint8
732−type instance PG Word16 = 'PGint2
733−type instance PG Word32 = 'PGint4
734−type instance PG Word64 = 'PGint8
735−type instance PG Scientific = 'PGnumeric
736−type instance PG Float = 'PGfloat4
737−type instance PG Double = 'PGfloat8
738−type instance PG Char = 'PGchar 1
739−type instance PG Text = 'PGtext
740−type instance PG Lazy.Text = 'PGtext
741−type instance PG String = 'PGtext
742−type instance PG ByteString = 'PGbytea
743−type instance PG Lazy.ByteString = 'PGbytea
744−type instance PG LocalTime = 'PGtimestamp
745−type instance PG UTCTime = 'PGtimestamptz
746−type instance PG Day = 'PGdate
747−type instance PG TimeOfDay = 'PGtime
748−type instance PG (TimeOfDay, TimeZone) = 'PGtimetz
749−type instance PG DiffTime = 'PGinterval
750−type instance PG UUID = 'PGuuid
751−type instance PG (NetAddr IP) = 'PGinet
752−type instance PG Value = 'PGjson
753−
754−{-| The `LabelsPG` type family calculates the constructors of a
755−Haskell enum type.
756−
757−>>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic
758−>>> instance Generic Schwarma
759−>>> instance HasDatatypeInfo Schwarma
760−>>> :kind! LabelsPG Schwarma
761−LabelsPG Schwarma :: [Type.ConstructorName]
762−= '["Beef", "Lamb", "Chicken"]
763−-}
764−type family LabelsPG (hask :: Type) :: [Type.ConstructorName] where
765− LabelsPG hask =
766− ConstructorNamesOf (ConstructorsOf (DatatypeInfoOf hask))
767−
768−{- | `RowPG` turns a Haskell record type into a `RowType`.
769−
770−>>> data Person = Person { name :: Text, age :: Int32 } deriving GHC.Generic
771−>>> instance Generic Person
772−>>> instance HasDatatypeInfo Person
773−>>> :kind! RowPG Person
774−RowPG Person :: [(Symbol, NullityType)]
775−= '["name" ::: 'NotNull 'PGtext, "age" ::: 'NotNull 'PGint4]
776−-}
777−type family RowPG (hask :: Type) :: RowType where
778− RowPG hask = RowOf (RecordCodeOf hask)
779−
780−type family RowOf (fields :: [(Symbol, Type)]) :: RowType where
781− RowOf '[] = '[]
782− RowOf (field ': fields) = FieldPG field ': RowOf fields
783−
784−type family FieldPG (field :: (Symbol, Type)) :: (Symbol, NullityType) where
785− FieldPG (field ::: hask) = field ::: NullPG hask
786−
787−{- | `NullPG` turns a Haskell type into a `NullityType`.
788−
789−>>> :kind! NullPG Double
790−NullPG Double :: NullityType
791−= 'NotNull 'PGfloat8
792−>>> :kind! NullPG (Maybe Double)
793−NullPG (Maybe Double) :: NullityType
794−= 'Null 'PGfloat8
795−-}
796−type family NullPG (hask :: Type) :: NullityType where
797− NullPG (Maybe hask) = 'Null (PG hask)
798− NullPG hask = 'NotNull (PG hask)
799−
800−{- | `TuplePG` turns a Haskell tuple type (including record types) into
801−the corresponding list of `NullityType`s.
802−
803−>>> :kind! TuplePG (Double, Maybe Char)
804−TuplePG (Double, Maybe Char) :: [NullityType]
805−= '['NotNull 'PGfloat8, 'Null ('PGchar 1)]
806−-}
807−type family TuplePG (hask :: Type) :: [NullityType] where
808− TuplePG hask = TupleOf (TupleCodeOf hask (Code hask))
809−
810−type family TupleOf (tuple :: [Type]) :: [NullityType] where
811− TupleOf '[] = '[]
812− TupleOf (hask ': tuple) = NullPG hask ': TupleOf tuple
813−
814−type family TupleCodeOf (hask :: Type) (code :: [[Type]]) :: [Type] where
815− TupleCodeOf hask '[tuple] = tuple
816− TupleCodeOf hask '[] =
817− TypeError
818− ( 'Text "The type `" :<>: 'ShowType hask :<>: 'Text "' is not a tuple type."
819− :$$: 'Text "It is a void type with no constructors."
820− )
821− TupleCodeOf hask (_ ': _ ': _) =
822− TypeError
823− ( 'Text "The type `" :<>: 'ShowType hask :<>: 'Text "' is not a tuple type."
824− :$$: 'Text "It is a sum type with more than one constructor."
825− )
826−
827−-- | Calculates constructors of a datatype.
828−type family ConstructorsOf (datatype :: Type.DatatypeInfo)
829− :: [Type.ConstructorInfo] where
830− ConstructorsOf ('Type.ADT _module _datatype constructors) =
831− constructors
832− ConstructorsOf ('Type.Newtype _module _datatype constructor) =
833− '[constructor]
834−
835−-- | Calculates the name of a nullary constructor, otherwise
836−-- generates a type error.
837−type family ConstructorNameOf (constructors :: Type.ConstructorInfo)
838− :: Type.ConstructorName where
839− ConstructorNameOf ('Type.Constructor name) = name
840− ConstructorNameOf ('Type.Infix name _assoc _fix) = TypeError
841− ('Text "ConstructorNameOf error: non-nullary constructor "
842− ':<>: 'Text name)
843− ConstructorNameOf ('Type.Record name _fields) = TypeError
844− ('Text "ConstructorNameOf error: non-nullary constructor "
845− ':<>: 'Text name)
846−
847−-- | Calculate the names of nullary constructors.
848−type family ConstructorNamesOf (constructors :: [Type.ConstructorInfo])
849− :: [Type.ConstructorName] where
850− ConstructorNamesOf '[] = '[]
851− ConstructorNamesOf (constructor ': constructors) =
852− ConstructorNameOf constructor ': ConstructorNamesOf constructors
853−
854579-- | Is a type a valid JSON key?
855580type PGJsonKey = '[ 'PGint2, 'PGint4, 'PGtext ]
856581
857582-- | Is a type a valid JSON type?
858583type PGJsonType = '[ 'PGjson, 'PGjsonb ]
859584
860−-- | An `AlignedList` is a type-aligned list or free category.
861−data AlignedList p x0 x1 where
862− Done :: AlignedList p x x
863− (:>>) :: p x0 x1 -> AlignedList p x1 x2 -> AlignedList p x0 x2
864−infixr 7 :>>
865−instance Category (AlignedList p) where
866− id = Done
867− (.) list = \case
868− Done -> list
869− step :>> steps -> step :>> (steps >>> list)
870−
871−-- | A `single` step.
872−single :: p x0 x1 -> AlignedList p x0 x1
873−single step = step :>> Done
585+-- | Utility class for `AllUnique` to provide nicer error messages.
586+class IsNotElem x isElem where
587+instance IsNotElem x 'False where
588+instance (TypeError ( 'Text "Cannot assign to "
589+ ':<>: 'ShowType alias
590+ ':<>: 'Text " more than once"))
591+ => IsNotElem '(alias, a) 'True where
592+
593+-- | No elem of @xs@ appears more than once, in the context of assignment.
594+class AllUnique (xs :: [(Symbol, a)]) where
595+instance AllUnique '[] where
596+instance (IsNotElem x (Elem x xs), AllUnique xs) => AllUnique (x ': xs) where
squeal-postgresql/src/Squeal/PostgreSQL/Transaction.hs+78−48
@@ -1,7 +1,7 @@
11{-|
22Module: Squeal.PostgreSQL.Transaction
33Description: Squeal transaction control language
4−Copyright: (c) Eitan Chatav, 2017
4+Copyright: (c) Eitan Chatav, 2019
55Maintainer: eitan@morphism.tech
66Stability: experimental
77
@@ -20,11 +20,12 @@ module Squeal.PostgreSQL.Transaction
2020 ( -- * Transaction
2121 transactionally
2222 , transactionally_
23+ , transactionallyRetry
24+ , ephemerally
25+ , ephemerally_
2326 , begin
2427 , commit
2528 , rollback
26− , transactionallySchema
27− , transactionallySchema_
2829 -- * Transaction Mode
2930 , TransactionMode (..)
3031 , defaultMode
@@ -34,70 +35,99 @@ module Squeal.PostgreSQL.Transaction
3435 , DeferrableMode (..)
3536 ) where
3637
37−import Control.Exception.Lifted
38−import Control.Monad.Base
39−import Control.Monad.Trans.Control
40−import Generics.SOP
41−
42−import qualified Database.PostgreSQL.LibPQ as LibPQ
38+import UnliftIO
4339
4440import Squeal.PostgreSQL.Manipulation
4541import Squeal.PostgreSQL.Render
4642import Squeal.PostgreSQL.PQ
47−import Squeal.PostgreSQL.Schema
4843
49−-- | 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+-}
5050transactionally
51− :: (MonadBaseControl IO tx, MonadPQ schemas tx)
51+ :: (MonadUnliftIO tx, MonadPQ schemas tx)
5252 => TransactionMode
5353 -> tx x -- ^ run inside a transaction
5454 -> tx x
5555transactionally mode tx = mask $ \restore -> do
56− _ <- begin mode
57− result <- restore tx `onException` rollback
58− _ <- commit
56+ manipulate_ $ begin mode
57+ result <- restore tx `onException` (manipulate_ rollback)
58+ manipulate_ commit
5959 return result
6060
61−-- | Run a schema invariant computation `transactionally_` in `defaultMode`.
61+-- | Run a computation `transactionally_`, in `defaultMode`.
6262transactionally_
63− :: (MonadBaseControl IO tx, MonadPQ schemas tx)
63+ :: (MonadUnliftIO tx, MonadPQ schemas tx)
6464 => tx x -- ^ run inside a transaction
6565 -> tx x
6666transactionally_ = transactionally defaultMode
6767
68−-- | @BEGIN@ a transaction.
69−begin :: MonadPQ schemas tx => TransactionMode -> tx (K Result ('[] :: RowType))
70−begin mode = manipulate . UnsafeManipulation $
71− "BEGIN" <+> renderSQL mode <> ";"
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)
79+ => TransactionMode
80+ -> tx x -- ^ run inside a transaction
81+ -> tx x
82+transactionallyRetry mode tx = mask $ \restore ->
83+ loop . try $ do
84+ x <- restore tx
85+ manipulate_ commit
86+ return x
87+ where
88+ loop attempt = do
89+ manipulate_ $ begin mode
90+ attempt >>= \case
91+ Left (PQException (PQState _ (Just "40001") _)) -> do
92+ manipulate_ rollback
93+ loop attempt
94+ Left err -> do
95+ manipulate_ rollback
96+ throwIO err
97+ Right x -> return x
98+
99+{- | Run a computation `ephemerally`;
100+Like `transactionally` but always `rollback`, useful in testing.
101+-}
102+ephemerally
103+ :: (MonadUnliftIO tx, MonadPQ schemas tx)
104+ => TransactionMode
105+ -> tx x -- ^ run inside an ephemeral transaction
106+ -> tx x
107+ephemerally mode tx = mask $ \restore -> do
108+ manipulate_ $ begin mode
109+ result <- restore tx `onException` (manipulate_ rollback)
110+ manipulate_ rollback
111+ return result
72112
73−-- | @COMMIT@ a schema invariant transaction.
74−commit :: MonadPQ schemas tx => tx (K Result ('[] :: RowType))
75−commit = manipulate $ UnsafeManipulation "COMMIT;"
113+{- | Run a computation `ephemerally` in `defaultMode`. -}
114+ephemerally_
115+ :: (MonadUnliftIO tx, MonadPQ schemas tx)
116+ => tx x -- ^ run inside an ephemeral transaction
117+ -> tx x
118+ephemerally_ = ephemerally defaultMode
119+
120+-- | @BEGIN@ a transaction.
121+begin :: TransactionMode -> Manipulation_ schemas () ()
122+begin mode = UnsafeManipulation $ "BEGIN" <+> renderSQL mode
76123
77−-- | @ROLLBACK@ a schema invariant transaction.
78−rollback :: MonadPQ schemas tx => tx (K Result ('[] :: RowType))
79−rollback = manipulate $ UnsafeManipulation "ROLLBACK;"
124+-- | @COMMIT@ a transaction.
125+commit :: Manipulation_ schemas () ()
126+commit = UnsafeManipulation "COMMIT"
80127
81−-- | Run a schema changing computation `transactionallySchema`.
82−transactionallySchema
83− :: MonadBaseControl IO io
84− => TransactionMode
85− -> PQ schemas0 schemas1 io x
86− -> PQ schemas0 schemas1 io x
87−transactionallySchema mode u = PQ $ \ conn -> mask $ \ restore -> do
88− _ <- liftBase . LibPQ.exec (unK conn) $
89− "BEGIN" <+> renderSQL mode <> ";"
90− x <- restore (unPQ u conn)
91− `onException` (liftBase (LibPQ.exec (unK conn) "ROLLBACK"))
92− _ <- liftBase $ LibPQ.exec (unK conn) "COMMIT"
93− return x
94−
95−-- | Run a schema changing computation `transactionallySchema_` in `DefaultMode`.
96−transactionallySchema_
97− :: MonadBaseControl IO io
98− => PQ schemas0 schemas1 io x
99− -> PQ schemas0 schemas1 io x
100−transactionallySchema_ = transactionallySchema defaultMode
128+-- | @ROLLBACK@ a transaction.
129+rollback :: Manipulation_ schemas () ()
130+rollback = UnsafeManipulation "ROLLBACK"
101131
102132-- | The available transaction characteristics are the transaction `IsolationLevel`,
103133-- the transaction `AccessMode` (`ReadWrite` or `ReadOnly`), and the `DeferrableMode`.
@@ -110,7 +140,7 @@ data TransactionMode = TransactionMode
110140-- | `TransactionMode` with a `Serializable` `IsolationLevel`,
111141-- `ReadWrite` `AccessMode` and `NotDeferrable` `DeferrableMode`.
112142defaultMode :: TransactionMode
113−defaultMode = TransactionMode Serializable ReadWrite NotDeferrable
143+defaultMode = TransactionMode ReadCommitted ReadWrite NotDeferrable
114144
115145-- | `TransactionMode` with a `Serializable` `IsolationLevel`,
116146-- `ReadOnly` `AccessMode` and `Deferrable` `DeferrableMode`.
squeal-postgresql/test/Doc.hsnew file+6
@@ -0,0 +1,6 @@
1+module Main (main) where
2+
3+import Test.DocTest
4+
5+main :: IO ()
6+main = doctest [ "-isrc", "src" ]
squeal-postgresql/test/DocTest.hsdeleted−18
@@ -1,18 +0,0 @@
1−module Main (main) where
2−
3−import Test.DocTest
4−
5−main :: IO ()
6−main = doctest
7− [ "-isrc"
8− , "src/Squeal/PostgreSQL.hs"
9− , "src/Squeal/PostgreSQL/Binary.hs"
10− , "src/Squeal/PostgreSQL/Definition.hs"
11− , "src/Squeal/PostgreSQL/Manipulation.hs"
12− , "src/Squeal/PostgreSQL/Query.hs"
13− , "src/Squeal/PostgreSQL/Expression.hs"
14− , "src/Squeal/PostgreSQL/PQ.hs"
15− , "src/Squeal/PostgreSQL/Migration.hs"
16− , "src/Squeal/PostgreSQL/Transaction.hs"
17− , "src/Squeal/PostgreSQL/Pool.hs"
18− ]
squeal-postgresql/test/Property.hsnew file+166
@@ -0,0 +1,166 @@
1+{-# LANGUAGE
2+ DataKinds
3+ , GADTs
4+ , LambdaCase
5+ , OverloadedLabels
6+ , OverloadedStrings
7+ , TypeApplications
8+ , TypeOperators
9+#-}
10+
11+module Main (main) where
12+
13+import Control.Monad.Trans
14+import Data.ByteString (ByteString)
15+import Data.ByteString.Char8 (unpack)
16+import Data.Scientific (fromFloatDigits)
17+import Data.Fixed (Fixed(MkFixed), Micro, Pico)
18+import Data.String (IsString(fromString))
19+import Data.Time
20+import Squeal.PostgreSQL hiding (check, defaultMain, Group)
21+import Hedgehog hiding (Range)
22+import qualified Hedgehog.Gen as Gen
23+import qualified Hedgehog.Main as Main
24+import qualified Hedgehog.Range as Range
25+
26+main :: IO ()
27+main = Main.defaultMain [checkSequential roundtrips]
28+
29+roundtrips :: Group
30+roundtrips = Group "roundtrips"
31+ [ roundtrip int2 genInt16
32+ , roundtrip int4 genInt32
33+ , roundtrip int8 genInt64
34+ , roundtrip bool Gen.bool
35+ , roundtrip numeric genScientific
36+ , roundtrip float4 genFloat
37+ , roundtrip float8 genDouble
38+ , roundtripOn normalizeTimeOfDay time genTimeOfDay
39+ -- , roundtrip timetz genTimeWithZone normalizeTimeWithZone
40+ , roundtripOn normalizeLocalTime timestamp genLocalTime
41+ , roundtrip timestamptz genUTCTime
42+ , roundtrip date genDay
43+ , roundtrip interval genDiffTime
44+ , roundtripOn normalizeIntRange int4range (genRange genInt32)
45+ , roundtripOn normalizeIntRange int8range (genRange genInt64)
46+ , roundtrip numrange (genRange genScientific)
47+ , roundtripOn (fmap normalizeLocalTime) tsrange (genRange genLocalTime)
48+ , roundtrip tstzrange (genRange genUTCTime)
49+ , roundtripOn normalizeIntRange daterange (genRange genDay)
50+ ]
51+ where
52+ genInt16 = Gen.int16 Range.exponentialBounded
53+ genInt32 = Gen.int32 Range.exponentialBounded
54+ genInt64 = Gen.int64 Range.exponentialBounded
55+ genScientific = fromFloatDigits <$> genFloat
56+ genPosFloat = Gen.float
57+ (Range.exponentialFloatFrom 1 minPosFloat maxPosFloat)
58+ genFloat = Gen.prune $ Gen.choice
59+ [ genPosFloat
60+ , negate <$> genPosFloat
61+ , Gen.element [0,1/0] ]
62+ genPosDouble = Gen.double
63+ (Range.exponentialFloatFrom 1 minPosFloat maxPosFloat)
64+ genDouble = Gen.prune $ Gen.choice
65+ [ genPosDouble
66+ , negate <$> genPosDouble
67+ , Gen.element [0,1/0] ]
68+ genRange gen = do
69+ lb <- gen
70+ ub <- Gen.filter (lb <) gen
71+ Gen.element
72+ [ Empty, singleton lb, whole
73+ , lb <=..<= ub , lb <=..< ub, lb <..<= ub, lb <..< ub
74+ , atLeast lb, moreThan lb, atMost ub, lessThan ub ]
75+ genDay = do
76+ y <- toInteger <$> Gen.int (Range.constant 2000 2019)
77+ m <- Gen.int (Range.constant 1 12)
78+ d <- Gen.int (Range.constant 1 28)
79+ return $ fromGregorian y m d
80+ genDiffTime = secondsToDiffTime . toInteger <$>
81+ Gen.int (Range.constant 0 86401)
82+ genUTCTime = UTCTime <$> genDay <*> genDiffTime
83+ genTimeOfDay = do
84+ h <- Gen.int (Range.constant 0 23)
85+ m <- Gen.int (Range.constant 0 59)
86+ s <- MkFixed . toInteger <$> Gen.int (Range.constant 0 59)
87+ return $ TimeOfDay h m s
88+ genLocalTime = LocalTime <$> genDay <*> genTimeOfDay
89+ -- genTimeZone = Gen.element $ map (read @TimeZone)
90+ -- [ "UTC", "UT", "GMT", "EST", "EDT", "CST"
91+ -- , "CDT", "MST", "MDT", "PST", "PDT" ]
92+ -- genTimeWithZone = (,) <$> genTimeOfDay <*> genTimeZone
93+
94+roundtrip
95+ :: (OidOf ty, ToParam x ty, FromValue ty x, Show x, Eq x)
96+ => TypeExpression schemas ('NotNull ty)
97+ -> Gen x
98+ -> (PropertyName, Property)
99+roundtrip = roundtripOn id
100+
101+roundtripOn
102+ :: (OidOf ty, ToParam x ty, FromValue ty x, Show x, Eq x)
103+ => (x -> x)
104+ -> TypeExpression schemas ('NotNull ty)
105+ -> Gen x
106+ -> (PropertyName, Property)
107+roundtripOn norm ty gen = propertyWithName $ do
108+ x <- forAll gen
109+ Just (Only y) <- lift . withConnection connectionString $
110+ firstRow =<< runQueryParams
111+ (values_ (parameter @1 ty `as` #fromOnly)) (Only x)
112+ norm x === y
113+ where
114+ propertyWithName prop =
115+ (fromString (unpack (renderSQL ty)), property prop)
116+
117+maxPosFloat :: RealFloat a => a
118+maxPosFloat = x
119+ where
120+ n = floatDigits x
121+ b = floatRadix x
122+ (_, u) = floatRange x
123+ x = encodeFloat (b^n - 1) (u - n)
124+
125+minPosFloat :: RealFloat a => a
126+minPosFloat = x
127+ where
128+ n = floatDigits x
129+ b = floatRadix x
130+ (l, _) = floatRange x
131+ x = encodeFloat (b^n - 1) (l - n - 1)
132+
133+connectionString :: ByteString
134+connectionString = "host=localhost port=5432 dbname=exampledb"
135+
136+normalizeIntRange :: (Enum int, Ord int) => Range int -> Range int
137+normalizeIntRange = \case
138+ Empty -> Empty
139+ NonEmpty l u ->
140+ let
141+ l' = normalizeL l
142+ u' = normalizeU u
143+ in if emptyNormalized l' u' then Empty else NonEmpty l' u'
144+ where
145+ normalizeL = \case
146+ Open l -> Closed (succ l)
147+ normalized -> normalized
148+ normalizeU = \case
149+ Closed u -> Open (succ u)
150+ normalized -> normalized
151+ emptyNormalized (Closed l) (Open u) = l >= u
152+ emptyNormalized _ _ = False
153+
154+normalizeTimeOfDay :: TimeOfDay -> TimeOfDay
155+normalizeTimeOfDay (TimeOfDay h m s) = TimeOfDay h m
156+ . fromRational @Pico
157+ . toRational @Micro
158+ . fromRational @Micro
159+ . toRational @Pico
160+ $ s
161+
162+normalizeLocalTime :: LocalTime -> LocalTime
163+normalizeLocalTime (LocalTime d t) = LocalTime d (normalizeTimeOfDay t)
164+
165+-- normalizeTimeWithZone :: (TimeOfDay, TimeZone) -> (TimeOfDay, TimeZone)
166+-- normalizeTimeWithZone (t, z) = (normalizeTimeOfDay t, z)
squeal-postgresql/test/Spec.hsnew file+136
@@ -0,0 +1,136 @@
1+{-# LANGUAGE
2+ DataKinds
3+ , DeriveAnyClass
4+ , DeriveGeneric
5+ , DerivingStrategies
6+ , DuplicateRecordFields
7+ , FlexibleContexts
8+ , OverloadedLabels
9+ , OverloadedLists
10+ , OverloadedStrings
11+ , TypeApplications
12+ , TypeFamilies
13+ , TypeInType
14+ , TypeOperators
15+#-}
16+
17+module Main (main) where
18+
19+import Control.Concurrent.Async (replicateConcurrently)
20+import Data.ByteString (ByteString)
21+import Data.Int (Int32)
22+import Data.Text (Text)
23+import Test.Hspec
24+
25+import qualified Generics.SOP as SOP
26+import qualified GHC.Generics as GHC
27+
28+import Squeal.PostgreSQL
29+
30+main :: IO ()
31+main = hspec spec
32+
33+type Schemas = Public
34+ '[ "users" ::: 'Table (
35+ '[ "pk_users" ::: 'PrimaryKey '["id"]
36+ , "unique_names" ::: 'Unique '["name"]
37+ ] :=>
38+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
39+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext ] ) ]
40+
41+data User = User
42+ { userName :: Text
43+ } deriving stock (Eq, Show, GHC.Generic)
44+ deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
45+
46+insertUser :: Manipulation_ Schemas User ()
47+insertUser = insertInto_ #users
48+ (Values_ (Default `as` #id :* Set (param @1) `as` #name))
49+
50+setup :: Definition (Public '[]) Schemas
51+setup =
52+ createTable #users
53+ ( serial `as` #id :*
54+ notNullable text `as` #name )
55+ ( primaryKey #id `as` #pk_users :*
56+ unique #name `as` #unique_names )
57+
58+teardown :: Definition Schemas (Public '[])
59+teardown = dropTable #users
60+
61+silence :: MonadPQ schemas pq => pq ()
62+silence = manipulate_ $
63+ UnsafeManipulation "SET client_min_messages TO WARNING;"
64+
65+setupDB :: IO ()
66+setupDB = withConnection connectionString $
67+ silence & pqThen (define setup)
68+
69+dropDB :: IO ()
70+dropDB = withConnection connectionString $
71+ silence & pqThen (define teardown)
72+
73+connectionString :: ByteString
74+connectionString = "host=localhost port=5432 dbname=exampledb"
75+
76+spec :: Spec
77+spec = before_ setupDB . after_ dropDB $ do
78+
79+ describe "Exceptions" $ do
80+
81+ let
82+ testUser = User "TestUser"
83+ newUser = manipulateParams_ insertUser
84+ insertUserTwice = newUser testUser >> newUser testUser
85+ err23505 = PQException $ PQState FatalError (Just "23505")
86+ (Just "ERROR: duplicate key value violates unique constraint \"unique_names\"\nDETAIL: Key (name)=(TestUser) already exists.\n")
87+
88+ it "should be thrown for constraint violation" $
89+ withConnection connectionString insertUserTwice
90+ `shouldThrow` (== err23505)
91+
92+ it "should be rethrown for constraint violation in a transaction" $
93+ withConnection connectionString (transactionally_ insertUserTwice)
94+ `shouldThrow` (== err23505)
95+
96+ describe "Pools" $
97+
98+ it "should manage concurrent transactions" $ do
99+ pool <- createConnectionPool
100+ "host=localhost port=5432 dbname=exampledb" 1 0.5 10
101+ let
102+ query :: Query_ (Public '[]) () (Only Char)
103+ query = values_ (literal 'a' `as` #fromOnly)
104+ session = usingConnectionPool pool . transactionally_ $ do
105+ result <- runQuery query
106+ Just (Only chr) <- firstRow result
107+ return chr
108+ chrs <- replicateConcurrently 10 session
109+ chrs `shouldSatisfy` all (== 'a')
110+
111+ describe "Ranges" $
112+
113+ it "should correctly decode ranges" $ do
114+
115+ rangesOut <- withConnection connectionString $ do
116+ let
117+ query :: Query_ (Public '[]) () (Only (Range Int32))
118+ query = values
119+ ( range int4range (atLeast 3) `as` #fromOnly )
120+ [ range int4range (3 <=..< 5) `as` #fromOnly
121+ , range int4range Empty `as` #fromOnly
122+ , range int4range whole `as` #fromOnly ]
123+ getRows =<< runQuery query
124+ (fromOnly <$> rangesOut :: [Range Int32]) `shouldBe`
125+ [ atLeast 3, 3 <=..< 5, Empty, whole ]
126+
127+ describe "Parameters" $ do
128+
129+ it "should run queries that don't reference all their parameters" $ do
130+
131+ out <- withConnection connectionString $ do
132+ let
133+ query :: Query_ (Public '[]) (Char,Int32) (Only Int32)
134+ query = values_ (param @2 `as` #fromOnly)
135+ firstRow =<< runQueryParams query ('a', 3 :: Int32)
136+ (fromOnly <$> out :: Maybe Int32) `shouldBe` Just 3
squeal-postgresql/test/Specs/ExceptionHandling.hsdeleted−126
@@ -1,126 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE DeriveGeneric #-}
3−{-# LANGUAGE DuplicateRecordFields #-}
4−{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE OverloadedLabels #-}
6−{-# LANGUAGE OverloadedLists #-}
7−{-# LANGUAGE OverloadedStrings #-}
8−{-# LANGUAGE TypeApplications #-}
9−{-# LANGUAGE TypeFamilies #-}
10−{-# LANGUAGE TypeInType #-}
11−{-# LANGUAGE TypeOperators #-}
12−module ExceptionHandling
13− ( specs
14− , User (..)
15− )
16−where
17−
18−import Control.Monad (void)
19−import Control.Monad.Base (MonadBase)
20−import qualified Data.ByteString.Char8 as Char8
21−import Data.Int (Int16)
22−import Data.Text (Text)
23−import Data.Vector (Vector)
24−import qualified Generics.SOP as SOP
25−import qualified GHC.Generics as GHC
26−import Squeal.PostgreSQL
27−import Squeal.PostgreSQL.Migration
28−import Test.Hspec
29−
30−type Schema =
31− '[ "users" ::: 'Table (
32− '[ "pk_users" ::: 'PrimaryKey '["id"]
33− , "unique_names" ::: 'Unique '["name"]
34− ] :=>
35− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
36− , "name" ::: 'NoDef :=> 'NotNull 'PGtext
37− , "vec" ::: 'NoDef :=> 'NotNull ('PGvararray ('Null 'PGint2))
38− ])
39− , "emails" ::: 'Table (
40− '[ "pk_emails" ::: 'PrimaryKey '["id"]
41− , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
42− ] :=>
43− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
44− , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
45− , "email" ::: 'NoDef :=> 'Null 'PGtext
46− ])
47− ]
48−
49−type Schemas = Public Schema
50−
51−data User =
52− User { userName :: Text
53− , userEmail :: Maybe Text
54− , userVec :: VarArray (Vector (Maybe Int16)) }
55− deriving (Show, GHC.Generic)
56−instance SOP.Generic User
57−instance SOP.HasDatatypeInfo User
58−
59−insertUser :: Manipulation '[] Schemas '[ 'NotNull 'PGtext, 'NotNull ('PGvararray ('Null 'PGint2))]
60− '[ "fromOnly" ::: 'NotNull 'PGint4 ]
61−insertUser = insertInto #users
62− (Values_ (defaultAs #id :* param @1 `as` #name :* param @2 `as` #vec))
63− OnConflictDoRaise (Returning (#id `as` #fromOnly))
64−
65−setup :: Definition (Public '[]) Schemas
66−setup =
67− createTable #users
68− ( serial `as` #id :*
69− (text & notNullable) `as` #name :*
70− (vararray int2 & notNullable) `as` #vec )
71− ( primaryKey #id `as` #pk_users
72− :* unique #name `as` #unique_names )
73− >>>
74− createTable #emails
75− ( serial `as` #id :*
76− (int & notNullable) `as` #user_id :*
77− (text & nullable) `as` #email )
78− ( primaryKey #id `as` #pk_emails :*
79− foreignKey #user_id #users #id
80− OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
81−
82−teardown :: Definition Schemas (Public '[])
83−teardown = dropTable #emails >>> dropTable #users
84−
85−migration :: Migration IO (Public '[]) Schemas
86−migration = Migration { name = "test"
87− , up = void $ define setup
88− , down = void $ define teardown }
89−
90−setupDB :: IO ()
91−setupDB = void . withConnection connectionString $
92− manipulate (UnsafeManipulation "SET client_min_messages TO WARNING;")
93− & pqThen (migrateUp (single migration))
94−
95−dropDB :: IO ()
96−dropDB = void . withConnection connectionString $
97− manipulate (UnsafeManipulation "SET client_min_messages TO WARNING;")
98− & pqThen (migrateDown (single migration))
99−
100−connectionString :: Char8.ByteString
101−connectionString = "host=localhost port=5432 dbname=exampledb"
102−
103−testUser :: User
104−testUser = User "TestUser" Nothing (VarArray [])
105−
106−newUser :: (MonadBase IO m, MonadPQ Schemas m) => User -> m ()
107−newUser u = void $ manipulateParams insertUser (userName u, userVec u)
108−
109−insertUserTwice :: (MonadBase IO m, MonadPQ Schemas m) => m ()
110−insertUserTwice = newUser testUser >> newUser testUser
111−
112−specs :: SpecWith ()
113−specs = before_ setupDB $ after_ dropDB $
114− describe "Exceptions" $ do
115−
116− let
117− dupKeyErr = PQException FatalError (Just "23505")
118− (Just "ERROR: duplicate key value violates unique constraint \"unique_names\"\nDETAIL: Key (name)=(TestUser) already exists.\n")
119−
120− it "should be thrown for unique constraint violation in a manipulation" $
121− withConnection connectionString insertUserTwice
122− `shouldThrow` (== dupKeyErr)
123−
124− it "should be rethrown for unique constraint violation in a manipulation by a transaction" $
125− withConnection connectionString (transactionally_ insertUserTwice)
126− `shouldThrow` (== dupKeyErr)
squeal-postgresql/test/Specs/Specs.hsdeleted−7
@@ -1,7 +0,0 @@
1−module Specs where
2−
3−import Test.Hspec
4−import qualified ExceptionHandling
5−
6−main :: IO ()
7−main = hspec ExceptionHandling.specs
stack.yaml+6−1
@@ -1,3 +1,8 @@
1−resolver: nightly-2018-09-03
1+resolver: nightly-2019-07-14
22packages:
33- squeal-postgresql
4+
5+extra-deps:
6+- unliftio-pool-0.2.1.0
7+- github: morphismtech/free-categories
8+ commit: c0e555fbefb5c21619e532264c4dfeac556d0630