on dev help sign in
53 files changed+4880−2555
since splitsnapshots
unifiedsplit
.circleci/config.yml+1−1 README.md+59−70 RELEASE NOTES.md+400 squeal-postgresql/exe/Example.hs+9−7 squeal-postgresql/squeal-postgresql.cabal+38−12 squeal-postgresql/src/Squeal/PostgreSQL.hs+63−82 squeal-postgresql/src/Squeal/PostgreSQL/Alias.hs−9 squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs+213−71 squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs+12−1016 squeal-postgresql/src/Squeal/PostgreSQL/Definition/Function.hs+238 squeal-postgresql/src/Squeal/PostgreSQL/Definition/Index.hs+159 squeal-postgresql/src/Squeal/PostgreSQL/Definition/Schema.hs+96 squeal-postgresql/src/Squeal/PostgreSQL/Definition/Table.hs+500 squeal-postgresql/src/Squeal/PostgreSQL/Definition/Table/Constraint.hs+339 squeal-postgresql/src/Squeal/PostgreSQL/Definition/Type.hs+229 squeal-postgresql/src/Squeal/PostgreSQL/Definition/View.hs+104 squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs+100−64 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Aggregate.hs+30−5 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Collection.hs+16−6 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Comparison.hs+35−20 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Json.hs+150−212 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Literal.hs+87 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Logic.hs+13−3 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Math.hs+14−7 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Null.hs+14−4 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Parameter.hs+10 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Range.hs+230 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Set.hs+139 squeal-postgresql/src/Squeal/PostgreSQL/Expression/SetOf.hs−69 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Sort.hs+24−14 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Subquery.hs+15−5 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Text.hs+13−4 squeal-postgresql/src/Squeal/PostgreSQL/Expression/TextSearch.hs+71−21 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Time.hs+18−12 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Type.hs+180−5 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Window.hs+44−6 squeal-postgresql/src/Squeal/PostgreSQL/List.hs+21−50 squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs+155−153 squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs+53−57 squeal-postgresql/src/Squeal/PostgreSQL/PG.hs+42−43 squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs+96−40 squeal-postgresql/src/Squeal/PostgreSQL/Pool.hs+67−99 squeal-postgresql/src/Squeal/PostgreSQL/Query.hs+235−93 squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs+161−60 squeal-postgresql/src/Squeal/PostgreSQL/Transaction.hs+76−44 squeal-postgresql/src/Squeal/PostgreSQL/Tutorial.hs−39 squeal-postgresql/test/Doc.hs+6 squeal-postgresql/test/DocTest.hs−18 squeal-postgresql/test/Property.hs+166 squeal-postgresql/test/Spec.hs+136 squeal-postgresql/test/Specs/ExceptionHandling.hs−126 squeal-postgresql/test/Specs/Specs.hs−7 stack.yaml+3−1
.circleci/config.yml+1−1
@@ -2,7 +2,7 @@ version: 2
22jobs:
33 build:
44 docker:
5− - image: haskell:8.6.3
5+ - image: haskell:8.6.5
66 - image: circleci/postgres:latest
77 environment:
88 POSTGRES_USER: root
README.md+59−70
@@ -46,7 +46,11 @@ composable and cover a large portion of SQL.
4646* transactions
4747* views
4848* array, composite and enumerated types
49−* json operations
49+* json functions and operations
50+* multischema support
51+* correlated subqueries
52+* window functions
53+* text search
5054
5155## installation
5256
@@ -72,19 +76,17 @@ First, we need some language extensions because Squeal uses modern GHC
7276features.
7377
7478```Haskell
75−>>> :set -XDataKinds -XDeriveGeneric -XOverloadedLabels
76−>>> :set -XOverloadedStrings -XTypeApplications -XTypeOperators
79+>>> :set -XDataKinds -XDeriveGeneric -XOverloadedLabels -XFlexibleContexts
80+>>> :set -XOverloadedStrings -XTypeApplications -XTypeOperators -XGADTs
7781```
7882
7983We'll need some imports.
8084
8185```Haskell
82−>>> import Control.Monad (void)
8386>>> import Control.Monad.IO.Class (liftIO)
8487>>> import Data.Int (Int32)
8588>>> import Data.Text (Text)
8689>>> import Squeal.PostgreSQL
87−>>> import Squeal.PostgreSQL.Render
8890```
8991
9092We'll use generics to easily convert between Haskell and PostgreSQL values.
@@ -99,27 +101,27 @@ we use `DataKinds` and `TypeOperators`.
99101
100102```Haskell
101103>>> :{
104+type UsersColumns =
105+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
106+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext ]
107+type UsersConstraints = '[ "pk_users" ::: 'PrimaryKey '["id"] ]
108+type EmailsColumns =
109+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
110+ , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
111+ , "email" ::: 'NoDef :=> 'Null 'PGtext ]
112+type EmailsConstraints =
113+ '[ "pk_emails" ::: 'PrimaryKey '["id"]
114+ , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"] ]
102115type Schema =
103− '[ "users" ::: 'Table (
104− '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
105− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
106− , "name" ::: 'NoDef :=> 'NotNull 'PGtext
107− ])
108− , "emails" ::: 'Table (
109− '[ "pk_emails" ::: 'PrimaryKey '["id"]
110− , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
111− ] :=>
112− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
113− , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
114− , "email" ::: 'NoDef :=> 'Null 'PGtext
115− ])
116− ]
116+ '[ "users" ::: 'Table (UsersConstraints :=> UsersColumns)
117+ , "emails" ::: 'Table (EmailsConstraints :=> EmailsColumns) ]
118+type Schemas = Public Schema
117119:}
118120```
119121
120122Notice the use of type operators.
121123
122−`:::` is used to pair an alias `GHC.TypeLits.Symbol` with a `SchemumType`,
124+`:::` is used to pair an alias `Symbol` with a `SchemumType`,
123125a `TableConstraint` or a `ColumnType`. It is intended to connote Haskell's `::`
124126operator.
125127
@@ -137,7 +139,7 @@ labels to refer to named tables and columns in our schema.
137139```Haskell
138140>>> :{
139141let
140− setup :: Definition '[] Schema
142+ setup :: Definition (Public '[]) Schemas
141143 setup =
142144 createTable #users
143145 ( serial `as` #id :*
@@ -169,7 +171,7 @@ primary and foreign keys, making them somewhat complex. Our `teardown`
169171```Haskell
170172>>> :{
171173let
172− teardown :: Definition Schema '[]
174+ teardown :: Definition Schemas (Public '[])
173175 teardown = dropTable #emails >>> dropTable #users
174176:}
175177
@@ -178,54 +180,54 @@ DROP TABLE "emails";
178180DROP TABLE "users";
179181```
180182
181−Next, we'll write `Manipulation`s to insert data into our two tables.
182−A `Manipulation` like `insertRow`, `update` or `deleteFrom`
183−has three type parameters, the schema it refers to, a list of parameters
184−it can take as input, and a list of columns it produces as output. When
183+We'll need a Haskell type for `User`s. We give the type `SOP.Generic` and
184+`SOP.HasDatatypeInfo` instances so that we can encode and decode `User`s.
185+
186+```Haskell
187+>>> data User = User { userName :: Text, userEmail :: Maybe Text } deriving (Show, GHC.Generic)
188+>>> instance SOP.Generic User
189+>>> instance SOP.HasDatatypeInfo User
190+```
191+
192+Next, we'll write `Manipulation_`s to insert `User`s into our two tables.
193+A `Manipulation_` like `insertInto`, `update` or `deleteFrom`
194+has three type parameters, the schemas it refers to, input parameters
195+and an output row. When
185196we insert into the users table, we will need a parameter for the `name`
186197field but not for the `id` field. Since it's serial, we can use a default
187198value. However, since the emails table refers to the users table, we will
188199need to retrieve the user id that the insert generates and insert it into
189−the emails table. Take a careful look at the type and definition of both
190−of our inserts.
200+the emails table. We can do this in a single `Manipulation_` by using a
201+`with` statement.
191202
192203```Haskell
193204>>> :{
194205let
195− insertUser :: Manipulation Schema '[ 'NotNull 'PGtext ] '[ "fromOnly" ::: 'NotNull 'PGint4 ]
196− insertUser = insertRow #users
197− (Default `as` #id :* Set (param @1) `as` #name)
198− OnConflictDoNothing (Returning (#id `as` #fromOnly))
199−:}
200−
201−>>> :{
202−let
203− insertEmail :: Manipulation Schema '[ 'NotNull 'PGint4, 'Null 'PGtext] '[]
204− insertEmail = insertRow #emails
205− ( Default `as` #id :*
206− Set (param @1) `as` #user_id :*
207− Set (param @2) `as` #email )
208− OnConflictDoNothing (Returning Nil)
206+ insertUser :: Manipulation_ Schemas User ()
207+ insertUser = with (u `as` #u) e
208+ where
209+ u = insertInto #users
210+ (Values_ (Default `as` #id :* Set (param @1) `as` #name))
211+ OnConflictDoRaise (Returning_ (#id :* param @2 `as` #email))
212+ e = insertInto_ #emails $ Select
213+ (Default `as` #id :* Set (#u ! #id) `as` #user_id :* Set (#u ! #email) `as` #email)
214+ (from (common #u))
209215:}
210216
211217>>> printSQL insertUser
212−INSERT INTO "users" ("id", "name") VALUES (DEFAULT, ($1 :: text)) ON CONFLICT DO NOTHING RETURNING "id" AS "fromOnly"
213−>>> printSQL insertEmail
214−INSERT INTO "emails" ("id", "user_id", "email") VALUES (DEFAULT, ($1 :: int4), ($2 :: text)) ON CONFLICT DO NOTHING
218+WITH "u" AS (INSERT INTO "users" ("id", "name") VALUES (DEFAULT, ($1 :: text)) RETURNING "id" AS "id", ($2 :: text) AS "email") INSERT INTO "emails" ("user_id", "email") SELECT "u"."id", "u"."email" FROM "u" AS "u"
215219```
216220
217−Next we write a `Query` to retrieve users from the database. We're not
221+Next we write a `Query_` to retrieve users from the database. We're not
218222interested in the ids here, just the usernames and email addresses. We
219−need to use an inner join to get the right result. A `Query` is like a
220−`Manipulation` with the same kind of type parameters.
223+need to use an `innerJoin` to get the right result. A `Query_` is like a
224+`Manipulation_` with the same kind of type parameters.
221225
222226```Haskell
223227>>> :{
224228let
225− getUsers :: Query Schema '[]
226− '[ "userName" ::: 'NotNull 'PGtext
227− , "userEmail" ::: 'Null 'PGtext ]
228− getUsers = select
229+ getUsers :: Query_ Schemas () User
230+ getUsers = select_
229231 (#u ! #name `as` #userName :* #e ! #email `as` #userEmail)
230232 ( from (table (#users `as` #u)
231233 & innerJoin (table (#emails `as` #e))
@@ -236,19 +238,7 @@ let
236238SELECT "u"."name" AS "userName", "e"."email" AS "userEmail" FROM "users" AS "u" INNER JOIN "emails" AS "e" ON ("u"."id" = "e"."user_id")
237239```
238240
239−Now that we've defined the SQL side of things, we'll need a Haskell type
240−for users. We give the type `Generics.SOP.Generic` and
241−`Generics.SOP.HasDatatypeInfo` instances so that we can decode the rows
242−we receive when we run `getUsers`. Notice that the record fields of the
243−`User` type match the column names of `getUsers`.
244−
245−```Haskell
246−>>> data User = User { userName :: Text, userEmail :: Maybe Text } deriving (Show, GHC.Generic)
247−>>> instance SOP.Generic User
248−>>> instance SOP.HasDatatypeInfo User
249−```
250−
251−Let's also create some users to add to the database.
241+Let's create some users to add to the database.
252242
253243```Haskell
254244>>> :{
@@ -273,19 +263,18 @@ transformer and when the schema doesn't change we can use `Monad` and
273263```Haskell
274264>>> :{
275265let
276− session :: PQ Schema Schema IO ()
266+ session :: PQ Schemas Schemas IO ()
277267 session = do
278− idResults <- traversePrepared insertUser (Only . userName <$> users)
279− ids <- traverse (fmap fromOnly . getRow 0) idResults
280− traversePrepared_ insertEmail (zip (ids :: [Int32]) (userEmail <$> users))
268+ _ <- traversePrepared_ insertUser users
281269 usersResult <- runQuery getUsers
282270 usersRows <- getRows usersResult
283271 liftIO $ print (usersRows :: [User])
284272in
285− void . withConnection "host=localhost port=5432 dbname=exampledb" $
273+ withConnection "host=localhost port=5432 dbname=exampledb" $
286274 define setup
287275 & pqThen session
288276 & pqThen (define teardown)
289277:}
290278[User {userName = "Alice", userEmail = Just "alice@gmail.com"},User {userName = "Bob", userEmail = Nothing},User {userName = "Carole", userEmail = Just "carole@hotmail.com"}]
279+-}
291280```
RELEASE NOTES.md+400
@@ -1,5 +1,405 @@
11## RELEASE NOTES
22
3+### Version 0.5
4+
5+Version 0.5 makes a number of large changes and additions to Squeal.
6+I want to thank folks who contributed issues and pull requests;
7+Raveline, rimmington, ilyakooo0, chshersh, reygoch, and more.
8+
9+**Multi-schema support**
10+
11+Previous versions of Squeal only supported definitions in the "public"
12+schema. Squeal 0.5 adds support for multiple schemas with the new kind
13+
14+```Haskell
15+type SchemasType = [(Symbol,SchemaType)]
16+```
17+
18+In order to upgrade your queries, manipulations and definitions from
19+Squeal 0.4, you will have to apply the `Public` type family, which indicates
20+that your only schema is the "public" schema.
21+
22+```Haskell
23+-- Squeal 0.4
24+setup :: Definition '[] Schema
25+
26+-- Squeal 0.5
27+setup :: Definition (Public '[]) (Public Schema)
28+```
29+
30+You can create non-public schemas using `createSchema` and inversely
31+remove them using `dropSchema`. There is also an idempotent
32+`createSchemaIfNotExists`.
33+
34+In order to handle aliases which may refer to non-public schemas, Squeal 0.5
35+introduces `QualifiedAlias`es. A `QualifiedAlias` can be referred to using
36+the `(!)` operator from the `IsQualified` typeclass; but if you want to refer
37+to an alias from the "public" schema, you can continue to use a single
38+overloaded label, no need to write `#public ! #tab`, just write `#tab`.
39+
40+**Top-level statements**
41+
42+As a consequence of multi-schema support, common table expressions that
43+a `Query` or `Manipulation` may refer to had to be broken into a new parameter.
44+Additionally, `Query` gained another new parameter for its outer scope which
45+will be discussed in the next section.
46+
47+To simplify type signatures that you have to write for top-level queries
48+and manipulations, Squeal 0.5 introduces the `Query_` and `Manipulation_`
49+type families.
50+
51+```
52+type family Query_
53+ (schemas :: SchemasType)
54+ (parameters :: Type)
55+ (row :: Type) where
56+ Query_ schemas params row =
57+ Query '[] '[] schemas (TuplePG params) (RowPG row)
58+```
59+
60+As you see, a top-level `Query_` has no outer scope and no common
61+table expressions in scope, they are empty `'[]`. Moreover,
62+its parameters and row parameters are now `Type`s, which are
63+converted to corresponding Postgres types using the `TuplePG`
64+and `RowPG` type families. This means you can write the type signatures
65+for your top-level statements using the Haskell types that you
66+intend to input and retrieve when running the statements. Similar
67+to `Query_`, there is a `Manipulation_` type, the only difference
68+being that a general `Manipulation` doesn't have an outer scope,
69+only a scope for common table expressions.
70+
71+**Subquery expressions**
72+
73+Previous versions of Squeal offered subquery expression support
74+but there were issues. The common use case of using the `IN` operator
75+from SQL was overly complex. There was a proliferation of subquery
76+functions to handle different comparison operators, each with two versions
77+for comparing `ALL` or `ANY` of the query rows. And, most confoundedly,
78+there was no way to support the `EXISTS` subquery because the "outer scope"
79+for a query was not available.
80+
81+Squeal adds an outer scope to the `Query` type.
82+
83+```Haskell
84+newtype Query
85+ (outer :: FromType)
86+ (commons :: FromType)
87+ (schemas :: SchemasType)
88+ (params :: [NullityType])
89+ (row :: RowType)
90+ = UnsafeQuery { renderQuery :: ByteString }
91+```
92+
93+This enables a well-typed `exists` function.
94+
95+```Haskell
96+exists
97+ :: Query (Join outer from) commons schemas params row
98+ -> Condition outer commons grp schemas params from
99+```
100+
101+The `in_` and `notIn` functions were simplified to handle the most
102+common use case of comparing to a list of values.
103+
104+```Haskell
105+in_
106+ :: Expression outer commons grp schemas params from ty -- ^ expression
107+ -> [Expression outer commons grp schemas params from ty]
108+ -> Condition outer commons grp schemas params from
109+```
110+
111+Finally, general subquery comparisons were abstracted to work with
112+any comparison operators, using the `Operator` type which will be discussed in
113+the next section.
114+
115+```Haskell
116+subAll
117+ :: Expression outer commons grp schemas params from ty1
118+ -> Operator ty1 ty2 ('Null 'PGbool)
119+ -> Query (Join outer from) commons schemas params '[col ::: ty2]
120+ -> Condition outer commons grp schemas params from
121+
122+subAny
123+ :: Expression outer commons grp schemas params from ty1
124+ -> Operator ty1 ty2 ('Null 'PGbool)
125+ -> Query (Join outer from) commons schemas params '[col ::: ty2]
126+ -> Condition outer commons grp schemas params from
127+```
128+
129+**Expression RankNTypes**
130+
131+Squeal 0.5 introduces RankNType type synonyms for common expression patterns.
132+The simplest example is the `Expr` type, a type for "closed" expressions
133+that cannot reference any aliases or parameters.
134+
135+```Haskell
136+type Expr x
137+ = forall outer commons grp schemas params from
138+ . Expression outer commons grp schemas params from x
139+```
140+
141+There is also a function type `(-->)`, which is a subtype of the usual Haskell function
142+type `(->)`.
143+
144+```Haskell
145+type (-->) x y
146+ = forall outer commons grp schemas params from
147+ . Expression outer commons grp schemas params from x
148+ -> Expression outer commons grp schemas params from y
149+```
150+
151+We saw in the subquery section that there is an `Operator` type.
152+
153+```Haskell
154+type Operator x1 x2 y
155+ = forall outer commons grp schemas params from
156+ . Expression outer commons grp schemas params from x1
157+ -> Expression outer commons grp schemas params from x2
158+ -> Expression outer commons grp schemas params from y
159+```
160+
161+There are also types `FunctionN` and `FunctionVar` for n-ary functions
162+and variadic functions.
163+
164+```
165+type FunctionN xs y
166+ = forall outer commons grp schemas params from
167+ . NP (Expression outer commons grp schemas params from) xs
168+ -> Expression outer commons grp schemas params from y
169+```
170+
171+An n-ary function takes an `NP` list of `Expression`s as its argument.
172+Squeal 0.5 adds a helpful operator `(*:)`, to help scrap your `Nil`s.
173+You can construct an `NP` list now by using the operator `(:*)`,
174+until your last element, using `(*:)` there. For instance, the function
175+`atan2_` takes two arguments, `atan2_ (pi *: 2)`.
176+
177+**Selections**
178+
179+Previously, Squeal provided a couple versions of `SELECT` depending
180+on whether you wanted to select all columns of a unique table
181+in the from clause, i.e. `*`, all columns of a particular table
182+in the from clause, i.e. `.*`, or a list of columns from the from clause.
183+
184+Squeal 0.5 refactors this pattern into a `Selection` GADT type, allowing
185+for abstraction and combinations that were not possible before.
186+
187+```Haskell
188+data Selection outer commons grp schemas params from row where
189+ Star
190+ :: HasUnique tab from row
191+ => Selection outer commons 'Ungrouped schemas params from row
192+ DotStar
193+ :: Has tab from row
194+ => Alias tab
195+ -> Selection outer commons 'Ungrouped schemas params from row
196+ List
197+ :: SListI row
198+ => NP (Aliased (Expression outer commons grp schemas params from)) row
199+ -> Selection outer commons grp schemas params from row
200+ Over
201+ :: SListI row
202+ => NP (Aliased (WindowFunction outer commons grp schemas params from)) row
203+ -> WindowDefinition outer commons grp schemas params from
204+ -> Selection outer commons grp schemas params from row
205+ Also
206+ :: Selection outer commons grp schemas params from right
207+ -> Selection outer commons grp schemas params from left
208+ -> Selection outer commons grp schemas params from (Join left right)
209+```
210+
211+In addition to the `Star`, `DotStar` and `List` constructors, there is an
212+`Also` constructor combinator, which enables users to combine `Selection`s.
213+Additionally, there is an `Over` constructor that is used to enable
214+window functions, described in the next section.
215+
216+To upgrade from Squeal 0.4, you will replace `selectStar` with `select Star`,
217+replace `selectDotStar #tab` with `select (DotStar #tab)`. The `List`
218+selection is such a common use case that there is a function `select_` which
219+automatically applies it, so to upgrade from Squeal 0.4, replace `select`
220+with `select_`. There are also independent `selectDistinct` and `selectDistinct_`
221+functions to filter out duplicate rows.
222+
223+**Query clauses**
224+
225+Previously, Squeal provided a couple versions of `INSERT` depending
226+on whether you wanted to insert `VALUES` or a query.
227+
228+Squeal 0.5 refactors this pattern into a `QueryClause` GADT.
229+
230+```
231+-- Squeal 0.4
232+insertRow_ #tab (Set 2 `as` #col1 :* Default `as` #col2)
233+insertQuery_ #tab (selectStar (from (table #other_tab)))
234+
235+-- Squeal 0.5
236+insertInto_ #tab (Values_ (Set 2 `as` #col1 :* Default `as` #col2))
237+insertInto_ #tab (Subquery (select Star (from (table #other_tab))))
238+```
239+
240+**Window functions and aggregation**
241+
242+Previous versions of Squeal provided no support for window functions.
243+Squeal 0.5 adds support for window functions. We saw `Over` in the
244+previous section.
245+
246+```Haskell
247+Over
248+ :: SListI row
249+ => NP (Aliased (WindowFunction outer commons grp schemas params from)) row
250+ -> WindowDefinition outer commons grp schemas params from
251+ -> Selection outer commons grp schemas params from row
252+```
253+
254+`Over` combines window functions with window definitions. A `WindowDefinition`
255+is constructed using the `partitionBy` function, optionally with an `orderBy`
256+clause. For example,
257+
258+```Haskell
259+query :: Query_ (Public Schema) () (Row Int32 Int32)
260+query = select
261+ (#col1 & Also (rank `as` #col2 `Over` (partitionBy #col1 & orderBy [#col2 & Asc])))
262+ (from (table #tab))
263+```
264+
265+Here the `rank` function is a `WindowFunction`
266+
267+```Haskell
268+rank :: WinFun0 ('NotNull 'PGint8)
269+rank = UnsafeWindowFunction "rank()"
270+```
271+
272+`WinFun0` is a RankNType, like `Expr` was, used for no argument window functions.
273+Similarly, there are also `WinFun1` and `WinFunN` types for
274+window functions and n-ary window functions.
275+
276+In order to use the same syntax for certain window functions and aggregate functions,
277+a new typeclass `Aggregate` was introduced. So for instance, `sum_` can be
278+either a `Distinction` `Expression` or a `WindowFunction`, used either with
279+a `groupBy` or with a `partitionBy` in the appropriate way.
280+
281+```
282+data Distinction (expr :: kind -> Type) (ty :: kind)
283+ = All (expr ty)
284+ | Distinct (expr ty)
285+```
286+
287+Aggregate functions can be run over all rows or only over distinct rows,
288+while window functions bear no such distinction.
289+
290+**Migrations**
291+
292+Thanks to [https://github.com/Raveline](Raveline) Squeal 0.5 introduces
293+a function `defaultMain` to easily create a command line program to
294+run or rewind your migrations.
295+
296+Previously, Squeal's migrations were impure, allowing in addition to
297+running `Definition`s to run arbitrary `IO` operations, such as inserting
298+data into the database or printing out status messages. In order to
299+provide compatibility with other migration systems, Squeal 0.5 introduces
300+pure migrations, that is migrations that are only `Definition`s.
301+
302+```Haskell
303+data Migration p schemas0 schemas1 = Migration
304+ { name :: Text -- ^ The `name` of a `Migration`.
305+ -- Each `name` in a `Migration` should be unique.
306+ , up :: p schemas0 schemas1 -- ^ The `up` instruction of a `Migration`.
307+ , down :: p schemas1 schemas0 -- ^ The `down` instruction of a `Migration`.
308+ } deriving (GHC.Generic)
309+```
310+
311+A pure migration is a `Migration Definition`, a pair of inverse
312+`Definition`s with a unique name. To recover impure migrations, Squeal 0.5
313+introduces the `Terminally` type.
314+
315+```Haskell
316+newtype Terminally trans monad x0 x1 = Terminally
317+ { runTerminally :: trans x0 x1 monad () }
318+```
319+
320+`Terminally` applies the indexed monad transformer and the monad it transforms
321+to the unit type `()`, thereby turning an indexed monad into a `Category`. An
322+impure migration is a `Migration (Terminally PQ IO)`. You can always cast
323+a pure migration into an impure migration with the functor, `pureMigration`.
324+
325+```Haskell
326+pureMigration
327+ :: Migration Definition schemas0 schemas1
328+ -> Migration (Terminally PQ IO) schemas0 schemas1
329+```
330+
331+To run either pure or impure migrations, Squeal 0.5 introduces
332+a typeclass, `Migratory`.
333+
334+```
335+class Category p => Migratory p where
336+
337+ migrateUp
338+ :: AlignedList (Migration p) schemas0 schemas1
339+ -> PQ schemas0 schemas1 IO ()
340+
341+ migrateDown
342+ :: AlignedList (Migration p) schemas0 schemas1
343+ -> PQ schemas1 schemas0 IO ()
344+```
345+
346+The signatures of `migrateUp` and `migrateDown` have been changed
347+to make them easier to compose with other `PQ` actions.
348+
349+**Transactions**
350+
351+You can now run transactions `ephemerally`, guaranteed to roll back,
352+but return the result or throw the exception that the transaction
353+would have generated. This is useful for testing. You can also
354+`transactionallyRetry` computations, retrying the transaction if
355+a [serialization failure](https://www.postgresql.org/docs/11/transaction-iso.html#XACT-REPEATABLE-READ) occurs.
356+
357+**Types**
358+
359+Squeal now supports money via a `Money` Haskell `Type` and a `'PGmoney`
360+`PGType`. Squeal 0.5 also adds support for creating domain types
361+with `createDomain`.
362+
363+**Time**
364+
365+Squeal 0.5 adds support for new functions; `now`, `makeDate`, `makeTime`,
366+, `makeTimestamp`, and `makeTimestamptz`, a function `interval_` for
367+constructing time intervals out multiples of `TimeUnit`s, and a new
368+`TimeOp` class, defining affine space operators for time types and their
369+differences.
370+
371+**Literals**
372+
373+Squeal allows you to include Haskell values in your statements using
374+out of line `parameter`s, but often you want to include them inline,
375+as a SQL `literal`. Squeal 0.5 enables this using the `Literal` class.
376+
377+**Set returning functions**
378+
379+Squeal 0.5 adds support for set returning functions such as `unnest`,
380+with the `RankNType` `SetOfFunction`, which can be used as as a `FromClause`.
381+
382+**Text search**
383+
384+Squeal 0.5 adds extensive support for text search types, functions and operators.
385+
386+**Much more**
387+
388+Lots more changes went into and under the hood of the new version.
389+The `Expression` module was split into coherent submodules since it
390+had grown to immense proportions. New modules `Alias`, `PG` and `List`
391+were added to relieve some of the burden that the `Schema` module
392+had been carrying. Rendering has been better unified with a new
393+`RenderSQL` typeclass. Type level list concatenation with the `Additional`
394+typeclass has been added. `Manipulation`s `update` and `delete`
395+were upgraded, so you can leave out fields you don't want to update and
396+use `USING` clauses in deletes. Upserts which were previously broken
397+now work. The `IO` typeclass hierarchy was changed from `MonadBase`
398+and `MonadBaseControl` to `MonadIO` and `MonadUnliftIO`. A new
399+`withRecursive` `Manipulation` was added. `SquealException`s were
400+refactored and a `trySqueal` function added. Arrays were refactored.
401+And there was probably more I've forgotten.
402+
3403### Version 0.4
4404
5405Version 0.4 strengthens Squeal's type system, adds
squeal-postgresql/exe/Example.hs+9−7
@@ -11,7 +11,6 @@
1111
1212module Main (main, main2) where
1313
14−import Control.Monad (void)
1514import Control.Monad.IO.Class (MonadIO (..))
1615import Data.Int (Int16, Int32)
1716import Data.Monoid ((<>))
@@ -39,6 +38,7 @@ type Schema =
3938 , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
4039 , "email" ::: 'NoDef :=> 'Null 'PGtext
4140 ])
41+ , "positive" ::: 'Typedef 'PGfloat4
4242 ]
4343
4444type Schemas = Public Schema
@@ -53,23 +53,25 @@ setup =
5353 >>>
5454 createTable #emails
5555 ( serial `as` #id :*
56− (int & notNullable) `as` #user_id :*
57− (text & nullable) `as` #email )
56+ hask @Int32 `as` #user_id :*
57+ hask @(Maybe Text) `as` #email )
5858 ( primaryKey #id `as` #pk_emails :*
5959 foreignKey #user_id #users #id
6060 OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
61+ >>>
62+ createDomain #positive real (#value .> 0 .&& (#value & isNotNull))
6163
6264teardown :: Definition Schemas (Public '[])
63−teardown = dropTable #emails >>> dropTable #users
65+teardown = dropType #positive >>> dropTable #emails >>> dropTable #users
6466
6567insertUser :: Manipulation_ Schemas (Text, VarArray (Vector (Maybe Int16))) (Only Int32)
6668insertUser = insertInto #users
67− (Values_ (defaultAs #id :* param @1 `as` #name :* param @2 `as` #vec))
69+ (Values_ (Default `as` #id :* Set (param @1) `as` #name :* Set (param @2) `as` #vec))
6870 (OnConflict (OnConstraint #pk_users) DoNothing) (Returning_ (#id `as` #fromOnly))
6971
7072insertEmail :: Manipulation_ Schemas (Int32, Maybe Text) ()
7173insertEmail = insertInto_ #emails
72− (Values_ (defaultAs #id :* param @1 `as` #user_id :* param @2 `as` #email))
74+ (Values_ (Default `as` #id :* Set (param @1) `as` #user_id :* Set (param @2) `as` #email))
7375
7476getUsers :: Query_ Schemas () User
7577getUsers = select_
@@ -117,7 +119,7 @@ main = do
117119
118120main2 :: IO ()
119121main2 =
120− void . withConnection "host=localhost port=5432 dbname=exampledb" $
122+ withConnection "host=localhost port=5432 dbname=exampledb" $
121123 define setup
122124 & pqThen session
123125 & pqThen (define teardown)
squeal-postgresql/squeal-postgresql.cabal+38−12
@@ -1,5 +1,5 @@
11name: squeal-postgresql
2−version: 0.4.9.0
2+version: 0.5.1.0
33synopsis: Squeal PostgreSQL Library
44description: Squeal is a type-safe embedding of PostgreSQL in Haskell
55homepage: https://github.com/morphismtech/squeal
@@ -25,16 +25,25 @@ library
2525 Squeal.PostgreSQL.Alias
2626 Squeal.PostgreSQL.Binary
2727 Squeal.PostgreSQL.Definition
28+ Squeal.PostgreSQL.Definition.Function
29+ Squeal.PostgreSQL.Definition.Index
30+ Squeal.PostgreSQL.Definition.Table
31+ Squeal.PostgreSQL.Definition.Table.Constraint
32+ Squeal.PostgreSQL.Definition.Type
33+ Squeal.PostgreSQL.Definition.Schema
34+ Squeal.PostgreSQL.Definition.View
2835 Squeal.PostgreSQL.Expression
2936 Squeal.PostgreSQL.Expression.Aggregate
3037 Squeal.PostgreSQL.Expression.Collection
3138 Squeal.PostgreSQL.Expression.Comparison
3239 Squeal.PostgreSQL.Expression.Json
40+ Squeal.PostgreSQL.Expression.Literal
3341 Squeal.PostgreSQL.Expression.Logic
3442 Squeal.PostgreSQL.Expression.Math
3543 Squeal.PostgreSQL.Expression.Null
3644 Squeal.PostgreSQL.Expression.Parameter
37− Squeal.PostgreSQL.Expression.SetOf
45+ Squeal.PostgreSQL.Expression.Range
46+ Squeal.PostgreSQL.Expression.Set
3847 Squeal.PostgreSQL.Expression.Sort
3948 Squeal.PostgreSQL.Expression.Subquery
4049 Squeal.PostgreSQL.Expression.Text
@@ -61,7 +70,8 @@ library
6170 , bytestring >= 0.10.8.2
6271 , bytestring-strict-builder >= 0.4.5
6372 , deepseq >= 1.4.3.0
64− , generics-sop >= 0.3.2.0
73+ , free-categories >= 0.1.0.0
74+ , generics-sop >= 0.3.2.0 && < 0.5.0.0
6575 , mmorph >= 1.1.1
6676 , mtl >= 2.2.2
6777 , network-ip >= 0.3.0.2
@@ -78,34 +88,50 @@ library
7888 , uuid-types >= 1.0.3
7989 , vector >= 0.12.0.1
8090
81−test-suite squeal-postgresql-doctest
91+test-suite doctest
8292 default-language: Haskell2010
8393 type: exitcode-stdio-1.0
8494 hs-source-dirs: test
8595 ghc-options: -Wall
86− main-is: DocTest.hs
96+ main-is: Doc.hs
8797 build-depends:
8898 base >= 4.10.0.0
8999 , doctest >= 0.11.4
100+ , squeal-postgresql
90101
91−test-suite squeal-postgresql-specs
102+test-suite properties
92103 default-language: Haskell2010
93104 type: exitcode-stdio-1.0
94− hs-source-dirs: test/Specs
95− ghc-options: -Wall -main-is Specs
96− main-is: Specs.hs
97− other-modules: ExceptionHandling
105+ hs-source-dirs: test
106+ ghc-options: -Wall
107+ main-is: Property.hs
98108 build-depends:
99109 base >= 4.10.0.0
100110 , 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
101127 , generics-sop >= 0.3.1.0
102128 , hspec >= 2.4.8
129+ , mtl >= 2.2.2
103130 , squeal-postgresql
104131 , text >= 1.2.2.2
105− , transformers >= 0.5.2.0
106132 , vector >= 0.12.0.1
107133
108−executable squeal-postgresql-example
134+executable example
109135 default-language: Haskell2010
110136 hs-source-dirs: exe
111137 ghc-options: -Wall
squeal-postgresql/src/Squeal/PostgreSQL.hs+63−82
@@ -11,17 +11,15 @@ Let's see an example!
1111First, we need some language extensions because Squeal uses modern GHC
1212features.
1313
14−>>> :set -XDataKinds -XDeriveGeneric -XOverloadedLabels
14+>>> :set -XDataKinds -XDeriveGeneric -XOverloadedLabels -XFlexibleContexts
1515>>> :set -XOverloadedStrings -XTypeApplications -XTypeOperators -XGADTs
1616
1717We'll need some imports.
1818
19−>>> import Control.Monad (void)
2019>>> import Control.Monad.IO.Class (liftIO)
2120>>> import Data.Int (Int32)
2221>>> import Data.Text (Text)
2322>>> import Squeal.PostgreSQL
24−>>> import Squeal.PostgreSQL.Render
2523
2624We'll use generics to easily convert between Haskell and PostgreSQL values.
2725
@@ -104,45 +102,44 @@ let
104102DROP TABLE "emails";
105103DROP TABLE "users";
106104
107−Next, we'll write `Manipulation`s to insert data into our two tables.
108−A `Manipulation` like `insertInto`, `update` or `deleteFrom`
109−has three type parameters, the schema it refers to, a list of parameters
110−it can take as input, and a list of columns it produces as output. When
111−we insert into the users table, we will need a parameter for the @name@
112−field but not for the @id@ field. Since it's serial, we can use a default
113−value. However, since the emails table refers to the users table, we will
114−need to retrieve the user id that the insert generates and insert it into
115−the emails table. Take a careful look at the type and definition of both
116−of our inserts.
117−
118−We'll need a Haskell type for users. We give the type `Generics.SOP.Generic` and
119−`Generics.SOP.HasDatatypeInfo` instances so that we can decode the rows
120−we receive when we run @getUsers@. Notice that the record fields of the
121−@User@ type match the column names of @getUsers@.
105+We'll need a Haskell type for @User@s. We give the type `Generics.SOP.Generic` and
106+`Generics.SOP.HasDatatypeInfo` instances so that we can encode and decode @User@s.
122107
123108>>> data User = User { userName :: Text, userEmail :: Maybe Text } deriving (Show, GHC.Generic)
124109>>> instance SOP.Generic User
125110>>> instance SOP.HasDatatypeInfo User
126111
112+Next, we'll write `Manipulation_`s to insert @User@s into our two tables.
113+A `Manipulation_` like `insertInto`, `update` or `deleteFrom`
114+has three type parameters, the schemas it refers to, input parameters
115+and an output row. When
116+we insert into the users table, we will need a parameter for the @name@
117+field but not for the @id@ field. Since it's serial, we can use a default
118+value. However, since the emails table refers to the users table, we will
119+need to retrieve the user id that the insert generates and insert it into
120+the emails table. We can do this in a single `Manipulation_` by using a
121+`with` statement.
122+
127123>>> :{
128124let
129125 insertUser :: Manipulation_ Schemas User ()
130126 insertUser = with (u `as` #u) e
131127 where
132128 u = insertInto #users
133− (Values_ (defaultAs #id :* param @1 `as` #name))
129+ (Values_ (Default `as` #id :* Set (param @1) `as` #name))
134130 OnConflictDoRaise (Returning_ (#id :* param @2 `as` #email))
135− e = insertInto_ #emails
136− (Select (defaultAs #id :* #u ! #id `as` #user_id :* #u ! #email) (from (common #u)))
131+ e = insertInto_ #emails $ Select
132+ (Default `as` #id :* Set (#u ! #id) `as` #user_id :* Set (#u ! #email) `as` #email)
133+ (from (common #u))
137134:}
138135
139136>>> printSQL insertUser
140137WITH "u" AS (INSERT INTO "users" ("id", "name") VALUES (DEFAULT, ($1 :: text)) RETURNING "id" AS "id", ($2 :: text) AS "email") INSERT INTO "emails" ("user_id", "email") SELECT "u"."id", "u"."email" FROM "u" AS "u"
141138
142−Next we write a `Query` to retrieve users from the database. We're not
139+Next we write a `Query_` to retrieve users from the database. We're not
143140interested in the ids here, just the usernames and email addresses. We
144−need to use an inner join to get the right result. A `Query` is like a
145−`Manipulation` with the same kind of type parameters.
141+need to use an `innerJoin` to get the right result. A `Query_` is like a
142+`Manipulation_` with the same kind of type parameters.
146143
147144>>> :{
148145let
@@ -186,67 +183,51 @@ let
186183 usersRows <- getRows usersResult
187184 liftIO $ print (usersRows :: [User])
188185in
189− void . withConnection "host=localhost port=5432 dbname=exampledb" $
186+ withConnection "host=localhost port=5432 dbname=exampledb" $
190187 define setup
191188 & pqThen session
192189 & pqThen (define teardown)
193190:}
194191[User {userName = "Alice", userEmail = Just "alice@gmail.com"},User {userName = "Bob", userEmail = Nothing},User {userName = "Carole", userEmail = Just "carole@hotmail.com"}]
195192-}
196−module Squeal.PostgreSQL
197− ( module Squeal.PostgreSQL.Alias
198− , module Squeal.PostgreSQL.Binary
199− , module Squeal.PostgreSQL.Definition
200− , module Squeal.PostgreSQL.Expression
201− , module Squeal.PostgreSQL.Expression.Aggregate
202− , module Squeal.PostgreSQL.Expression.Collection
203− , module Squeal.PostgreSQL.Expression.Comparison
204− , module Squeal.PostgreSQL.Expression.Json
205− , module Squeal.PostgreSQL.Expression.Logic
206− , module Squeal.PostgreSQL.Expression.Math
207− , module Squeal.PostgreSQL.Expression.Null
208− , module Squeal.PostgreSQL.Expression.Parameter
209− , module Squeal.PostgreSQL.Expression.SetOf
210− , module Squeal.PostgreSQL.Expression.Sort
211− , module Squeal.PostgreSQL.Expression.Subquery
212− , module Squeal.PostgreSQL.Expression.Text
213− , module Squeal.PostgreSQL.Expression.TextSearch
214− , module Squeal.PostgreSQL.Expression.Time
215− , module Squeal.PostgreSQL.Expression.Type
216− , module Squeal.PostgreSQL.Expression.Window
217− , module Squeal.PostgreSQL.List
218− , module Squeal.PostgreSQL.Manipulation
219− , module Squeal.PostgreSQL.PG
220− , module Squeal.PostgreSQL.PQ
221− , module Squeal.PostgreSQL.Query
222− , module Squeal.PostgreSQL.Schema
223− , module Squeal.PostgreSQL.Transaction
224− ) where
225−
226−import Squeal.PostgreSQL.Alias
227−import Squeal.PostgreSQL.Binary
228−import Squeal.PostgreSQL.Definition
229−import Squeal.PostgreSQL.Expression
230−import Squeal.PostgreSQL.Expression.Aggregate
231−import Squeal.PostgreSQL.Expression.Collection
232−import Squeal.PostgreSQL.Expression.Comparison
233−import Squeal.PostgreSQL.Expression.Json
234−import Squeal.PostgreSQL.Expression.Logic
235−import Squeal.PostgreSQL.Expression.Math
236−import Squeal.PostgreSQL.Expression.Null
237−import Squeal.PostgreSQL.Expression.Parameter
238−import Squeal.PostgreSQL.Expression.SetOf
239−import Squeal.PostgreSQL.Expression.Sort
240−import Squeal.PostgreSQL.Expression.Subquery
241−import Squeal.PostgreSQL.Expression.Text
242−import Squeal.PostgreSQL.Expression.TextSearch
243−import Squeal.PostgreSQL.Expression.Time
244−import Squeal.PostgreSQL.Expression.Type
245−import Squeal.PostgreSQL.Expression.Window
246−import Squeal.PostgreSQL.List
247−import Squeal.PostgreSQL.Manipulation
248−import Squeal.PostgreSQL.PG
249−import Squeal.PostgreSQL.PQ
250−import Squeal.PostgreSQL.Query
251−import Squeal.PostgreSQL.Schema
252−import Squeal.PostgreSQL.Transaction
193+module Squeal.PostgreSQL (module X, RenderSQL(..), printSQL) where
194+
195+import Squeal.PostgreSQL.Alias as X
196+import Squeal.PostgreSQL.Binary as X
197+import Squeal.PostgreSQL.Definition as X
198+import Squeal.PostgreSQL.Definition.Function as X
199+import Squeal.PostgreSQL.Definition.Index as X
200+import Squeal.PostgreSQL.Definition.Schema as X
201+import Squeal.PostgreSQL.Definition.Table as X
202+import Squeal.PostgreSQL.Definition.Table.Constraint as X
203+import Squeal.PostgreSQL.Definition.Type as X
204+import Squeal.PostgreSQL.Definition.View as X
205+import Squeal.PostgreSQL.Expression as X
206+import Squeal.PostgreSQL.Expression.Aggregate as X
207+import Squeal.PostgreSQL.Expression.Collection as X
208+import Squeal.PostgreSQL.Expression.Comparison as X
209+import Squeal.PostgreSQL.Expression.Json as X
210+import Squeal.PostgreSQL.Expression.Literal as X
211+import Squeal.PostgreSQL.Expression.Logic as X
212+import Squeal.PostgreSQL.Expression.Math as X
213+import Squeal.PostgreSQL.Expression.Null as X
214+import Squeal.PostgreSQL.Expression.Parameter as X
215+import Squeal.PostgreSQL.Expression.Range as X
216+import Squeal.PostgreSQL.Expression.Set as X
217+import Squeal.PostgreSQL.Expression.Sort as X
218+import Squeal.PostgreSQL.Expression.Subquery as X
219+import Squeal.PostgreSQL.Expression.Text as X
220+import Squeal.PostgreSQL.Expression.TextSearch as X
221+import Squeal.PostgreSQL.Expression.Time as X
222+import Squeal.PostgreSQL.Expression.Type as X
223+import Squeal.PostgreSQL.Expression.Window as X
224+import Squeal.PostgreSQL.List as X
225+import Squeal.PostgreSQL.Manipulation as X
226+import Squeal.PostgreSQL.Migration as X
227+import Squeal.PostgreSQL.PG as X
228+import Squeal.PostgreSQL.Pool as X
229+import Squeal.PostgreSQL.PQ as X
230+import Squeal.PostgreSQL.Query as X
231+import Squeal.PostgreSQL.Render (RenderSQL(..), printSQL)
232+import Squeal.PostgreSQL.Schema as X
233+import Squeal.PostgreSQL.Transaction as X
squeal-postgresql/src/Squeal/PostgreSQL/Alias.hs−9
@@ -46,7 +46,6 @@ module Squeal.PostgreSQL.Alias
4646 , HasIn
4747 , QualifiedAlias (..)
4848 , IsQualified (..)
49− , DefaultAliasable (..)
5049 -- * Grouping
5150 , Grouping (..)
5251 , GroupedBy
@@ -189,14 +188,6 @@ choose which subfields to update.
189188class HasIn fields field where
190189instance (Has alias fields field) => HasIn fields (alias ::: field) where
191190
192−{- |
193−The `DefaultAliasable` class is intended to help with Scrap your Nils
194−for default inserts and updates.
195−-}
196−class KnownSymbol alias
197− => DefaultAliasable alias aliased | aliased -> alias where
198− defaultAs :: Alias alias -> aliased
199−
200191-- | `HasAll` extends `Has` to take lists of @aliases@ and @fields@ and infer
201192-- a list of @subfields@.
202193class
squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs+213−71
@@ -39,7 +39,7 @@ the input and output should be equal.
3939
4040>>> let input = Row 2 "hi" (Just True)
4141>>> :{
42−void . withConnection "host=localhost port=5432 dbname=exampledb" $ do
42+withConnection "host=localhost port=5432 dbname=exampledb" $ do
4343 result <- runQueryParams roundTrip input
4444 Just output <- firstRow result
4545 liftIO . print $ input == output
@@ -78,7 +78,7 @@ let
7878>>> :set -XOverloadedLists
7979>>> let input = Row (VarArray [1,2]) (FixArray (Just 1,Nothing)) (FixArray ((1,2),(3,4),(5,6)))
8080>>> :{
81−void . withConnection "host=localhost port=5432 dbname=exampledb" $ do
81+withConnection "host=localhost port=5432 dbname=exampledb" $ do
8282 result <- runQueryParams roundTrip input
8383 Just output <- firstRow result
8484 liftIO . print $ input == output
@@ -170,7 +170,7 @@ let
170170 Just output <- firstRow result
171171 liftIO . print $ input == output
172172in
173− void . withConnection "host=localhost port=5432 dbname=exampledb" $
173+ withConnection "host=localhost port=5432 dbname=exampledb" $
174174 define setup
175175 & pqThen session
176176 & pqThen (define teardown)
@@ -205,14 +205,20 @@ module Squeal.PostgreSQL.Binary
205205 ( -- * Encoding
206206 ToParam (..)
207207 , ToParams (..)
208− , ToNullityParam
209− , ToField
210− , ToFixArray
208+ , ToNullityParam (..)
209+ , ToField (..)
210+ , ToFixArray (..)
211211 -- * Decoding
212212 , FromValue (..)
213213 , FromRow (..)
214+ , FromField (..)
215+ , FromFixArray (..)
214216 -- * Only
215217 , Only (..)
218+ -- * Oid
219+ , OidOf (..)
220+ , OidOfParam (..)
221+ , OidOfField (..)
216222 ) where
217223
218224import BinaryParser
@@ -226,6 +232,7 @@ import Data.Time
226232import Data.UUID.Types
227233import Data.Vector (Vector)
228234import Data.Word
235+import Foreign.C.Types (CUInt(CUInt))
229236import Generics.SOP
230237import Generics.SOP.Record
231238import GHC.TypeLits
@@ -239,6 +246,7 @@ import qualified Data.Text.Lazy as Lazy (Text)
239246import qualified Data.Text as Strict (Text)
240247import qualified Data.Text as Strict.Text
241248import qualified Data.Vector as Vector
249+import qualified Database.PostgreSQL.LibPQ as LibPQ
242250import qualified GHC.Generics as GHC
243251import qualified PostgreSQL.Binary.Decoding as Decoding
244252import qualified PostgreSQL.Binary.Encoding as Encoding
@@ -269,11 +277,9 @@ class ToParam (x :: Type) (pg :: PGType) where
269277 toParam :: x -> K Encoding.Encoding pg
270278instance ToParam Bool 'PGbool where toParam = K . Encoding.bool
271279instance ToParam Int16 'PGint2 where toParam = K . Encoding.int2_int16
272−instance ToParam Word16 'PGint2 where toParam = K . Encoding.int2_word16
273280instance ToParam Int32 'PGint4 where toParam = K . Encoding.int4_int32
274−instance ToParam Word32 'PGint4 where toParam = K . Encoding.int4_word32
275281instance ToParam Int64 'PGint8 where toParam = K . Encoding.int8_int64
276−instance ToParam Word64 'PGint8 where toParam = K . Encoding.int8_word64
282+instance ToParam Oid 'PGoid where toParam = K . Encoding.int4_word32 . getOid
277283instance ToParam Float 'PGfloat4 where toParam = K . Encoding.float4
278284instance ToParam Double 'PGfloat8 where toParam = K . Encoding.float8
279285instance ToParam Scientific 'PGnumeric where toParam = K . Encoding.numeric
@@ -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
@@ -451,6 +582,7 @@ 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,6 +721,10 @@ instance FromValue pg y
589721 K (Just bytestring) -> P . Just <$>
590722 Decoding.valueParser (fromValue @pg) bytestring
591723
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.
592728class FromFixArray (dims :: [Nat]) (ty :: NullityType) (y :: Type) where
593729 fromFixArray :: Decoding.Array y
594730instance FromValue pg y => FromFixArray '[] ('NotNull pg) y where
@@ -633,50 +769,53 @@ instance
633769 = fmap fromRecord
634770 . hsequence'
635771 . htrans (Proxy @FromField) fromField
636−instance (FromField (col ::: pg) (col ::: hask))
637− => FromRow '[col ::: pg] (P (col ::: hask)) where
638− fromRow (pg :* Nil) = (unComp . fromField) pg
639−instance
640− ( row ~ Join row1 row2
641− , FromRow row1 hask1
642− , FromRow row2 hask2
643− , SListI row
644− ) => FromRow row (hask1, hask2) where
645− fromRow row = case disjoin @row1 @row2 row of
646− (row1, row2) -> (,) <$> fromRow row1 <*> fromRow row2
647−instance
648− ( row ~ Join row1 row23
649− , FromRow row1 hask1
650− , FromRow row23 (hask2, hask3)
651− , SListI row
652− ) => FromRow row (hask1, hask2, hask3) where
653− fromRow row = case disjoin @row1 @row23 row of
654− (row1, row23) -> do
655− hask1 <- fromRow row1
656− (hask2, hask3) <- fromRow row23
657− return (hask1, hask2, hask3)
658−instance
659− ( row ~ Join row1 row234
660− , FromRow row1 hask1
661− , FromRow row234 (hask2, hask3, hask4)
662− , SListI row
663− ) => FromRow row (hask1, hask2, hask3, hask4) where
664− fromRow row = case disjoin @row1 @row234 row of
665− (row1, row234) -> do
666− hask1 <- fromRow row1
667− (hask2, hask3, hask4) <- fromRow row234
668− return (hask1, hask2, hask3, hask4)
669−instance
670− ( row ~ Join row1 row2345
671− , FromRow row1 hask1
672− , FromRow row2345 (hask2, hask3, hask4, hask5)
673− , SListI row
674− ) => FromRow row (hask1, hask2, hask3, hask4, hask5) where
675− fromRow row = case disjoin @row1 @row2345 row of
676− (row1, row2345) -> do
677− hask1 <- fromRow row1
678− (hask2, hask3, hask4, hask5) <- fromRow row2345
679− return (hask1, hask2, hask3, hask4, hask5)
772+------------------------------------------------------
773+-- P records
774+------------------------------------------------------
775+-- instance (FromField (col ::: pg) (col ::: hask))
776+-- => FromRow '[col ::: pg] (P (col ::: hask)) where
777+-- fromRow (pg :* Nil) = (unComp . fromField) pg
778+-- instance
779+-- ( row ~ Join row1 row2
780+-- , FromRow row1 hask1
781+-- , FromRow row2 hask2
782+-- , SListI row
783+-- ) => FromRow row (hask1, hask2) where
784+-- fromRow row = case disjoin @row1 @row2 row of
785+-- (row1, row2) -> (,) <$> fromRow row1 <*> fromRow row2
786+-- instance
787+-- ( row ~ Join row1 row23
788+-- , FromRow row1 hask1
789+-- , FromRow row23 (hask2, hask3)
790+-- , SListI row
791+-- ) => FromRow row (hask1, hask2, hask3) where
792+-- fromRow row = case disjoin @row1 @row23 row of
793+-- (row1, row23) -> do
794+-- hask1 <- fromRow row1
795+-- (hask2, hask3) <- fromRow row23
796+-- return (hask1, hask2, hask3)
797+-- instance
798+-- ( row ~ Join row1 row234
799+-- , FromRow row1 hask1
800+-- , FromRow row234 (hask2, hask3, hask4)
801+-- , SListI row
802+-- ) => FromRow row (hask1, hask2, hask3, hask4) where
803+-- fromRow row = case disjoin @row1 @row234 row of
804+-- (row1, row234) -> do
805+-- hask1 <- fromRow row1
806+-- (hask2, hask3, hask4) <- fromRow row234
807+-- return (hask1, hask2, hask3, hask4)
808+-- instance
809+-- ( row ~ Join row1 row2345
810+-- , FromRow row1 hask1
811+-- , FromRow row2345 (hask2, hask3, hask4, hask5)
812+-- , SListI row
813+-- ) => FromRow row (hask1, hask2, hask3, hask4, hask5) where
814+-- fromRow row = case disjoin @row1 @row2345 row of
815+-- (row1, row2345) -> do
816+-- hask1 <- fromRow row1
817+-- (hask2, hask3, hask4, hask5) <- fromRow row2345
818+-- return (hask1, hask2, hask3, hask4, hask5)
680819
681820-- | `Only` is a 1-tuple type, useful for encoding a single parameter with
682821-- `toParams` or decoding a single value with `fromRow`.
@@ -704,3 +843,6 @@ replicateMN
704843 => m x -> m (NP I xs)
705844replicateMN mx = hsequence' $
706845 hcpure (Proxy :: Proxy ((~) x)) (Comp (I <$> mx))
846+
847+getOid :: LibPQ.Oid -> Word32
848+getOid (LibPQ.Oid (CUInt oid)) = oid
squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs+12−1016
@@ -11,13 +11,15 @@ Squeal data definition language.
1111{-# LANGUAGE
1212 AllowAmbiguousTypes
1313 , ConstraintKinds
14+ , DeriveAnyClass
1415 , DeriveGeneric
16+ , DerivingStrategies
1517 , FlexibleContexts
1618 , FlexibleInstances
1719 , GADTs
18− , GeneralizedNewtypeDeriving
1920 , LambdaCase
2021 , MultiParamTypeClasses
22+ , OverloadedLabels
2123 , OverloadedStrings
2224 , RankNTypes
2325 , ScopedTypeVariables
@@ -25,83 +27,25 @@ Squeal data definition language.
2527 , TypeInType
2628 , TypeOperators
2729 , UndecidableSuperClasses
30+ , UndecidableInstances
2831#-}
2932
3033module Squeal.PostgreSQL.Definition
3134 ( -- * Definition
3235 Definition (..)
3336 , (>>>)
34− -- * Tables
35− -- ** Create
36− , createSchema
37− , createSchemaIfNotExists
38− , createTable
39− , createTableIfNotExists
40− , createView
41− , createTypeEnum
42− , createTypeEnumFrom
43− , createTypeComposite
44− , createTypeCompositeFrom
45− , createDomain
46− , TableConstraintExpression (..)
47− , check
48− , unique
49− , primaryKey
50− , foreignKey
51− , ForeignKeyed
52− , OnDeleteClause (..)
53− , OnUpdateClause (..)
54− -- ** Drop
55− , dropSchema
56− , dropTable
57− , dropView
58− , dropType
59− -- ** Alter
60− , alterTable
61− , alterTableRename
62− , AlterTable (..)
63− , addConstraint
64− , dropConstraint
65− , AddColumn (..)
66− , dropColumn
67− , renameColumn
68− , alterColumn
69− , AlterColumn (..)
70− , setDefault
71− , dropDefault
72− , setNotNull
73− , dropNotNull
74− , alterType
75− -- * Columns
76− , ColumnTypeExpression (..)
77− , nullable
78− , notNullable
79− , default_
80− , serial2
81− , smallserial
82− , serial4
83− , serial
84− , serial8
85− , bigserial
37+ , manipDefinition
8638 ) where
8739
8840import Control.Category
8941import Control.DeepSeq
9042import Data.ByteString
9143import Data.Monoid
92−import GHC.TypeLits
9344import Prelude hiding ((.), id)
9445
95−import qualified Generics.SOP as SOP
9646import qualified GHC.Generics as GHC
9747
98−import Squeal.PostgreSQL.Alias
99−import Squeal.PostgreSQL.Expression
100−import Squeal.PostgreSQL.Expression.Logic
101−import Squeal.PostgreSQL.Expression.Type
102−import Squeal.PostgreSQL.List
103−import Squeal.PostgreSQL.PG
104−import Squeal.PostgreSQL.Query
48+import Squeal.PostgreSQL.Manipulation
10549import Squeal.PostgreSQL.Render
10650import Squeal.PostgreSQL.Schema
10751
@@ -129,958 +73,10 @@ instance Category Definition where
12973 ddl1 . ddl0 = UnsafeDefinition $
13074 renderSQL ddl0 <> "\n" <> renderSQL ddl1
13175
132−{-----------------------------------------
133−CREATE statements
134−-----------------------------------------}
135−
136−createSchema
137− :: KnownSymbol sch
138− => Alias sch
139− -> Definition schemas (Create sch '[] schemas)
140−createSchema sch = UnsafeDefinition $
141− "CREATE" <+> "SCHEMA" <+> renderSQL sch <> ";"
142−
143−createSchemaIfNotExists
144− :: (KnownSymbol sch, Has sch schemas schema)
145− => Alias sch
76+-- | A `Manipulation` without input or output can be run as a statement
77+-- along with other `Definition`s, by embedding it using `manipDefinition`.
78+manipDefinition
79+ :: Manipulation '[] schemas '[] '[]
80+ -- ^ no input or output
14681 -> Definition schemas schemas
147−createSchemaIfNotExists sch = UnsafeDefinition $
148− "CREATE" <+> "SCHEMA" <+> "IF" <+> "NOT" <+> "EXISTS"
149− <+> renderSQL sch <> ";"
150−
151−{- | `createTable` adds a table to the schema.
152−
153−>>> :set -XOverloadedLabels
154−>>> :{
155−type Table = '[] :=>
156− '[ "a" ::: 'NoDef :=> 'Null 'PGint4
157− , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]
158−:}
159−
160−>>> :{
161−let
162− setup :: Definition (Public '[]) (Public '["tab" ::: 'Table Table])
163− setup = createTable #tab
164− (nullable int `as` #a :* nullable real `as` #b) Nil
165−in printSQL setup
166−:}
167−CREATE TABLE "tab" ("a" int NULL, "b" real NULL);
168−-}
169−createTable
170− :: ( KnownSymbol sch
171− , KnownSymbol tab
172− , columns ~ (col ': cols)
173− , SOP.SListI columns
174− , SOP.SListI constraints
175− , Has sch schemas0 schema0
176− , schemas1 ~ Alter sch (Create tab ('Table (constraints :=> columns)) schema0) schemas0 )
177− => QualifiedAlias sch tab -- ^ the name of the table to add
178− -> NP (Aliased (ColumnTypeExpression schemas0)) columns
179− -- ^ the names and datatype of each column
180− -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints
181− -- ^ constraints that must hold for the table
182− -> Definition schemas0 schemas1
183−createTable tab columns constraints = UnsafeDefinition $
184− "CREATE TABLE" <+> renderCreation tab columns constraints
185−
186−{-| `createTableIfNotExists` creates a table if it doesn't exist, but does not add it to the schema.
187−Instead, the schema already has the table so if the table did not yet exist, the schema was wrong.
188−`createTableIfNotExists` fixes this. Interestingly, this property makes it an idempotent in
189−the `Category` of `Definition`s.
190−
191−>>> :set -XOverloadedLabels -XTypeApplications
192−>>> :{
193−type Table = '[] :=>
194− '[ "a" ::: 'NoDef :=> 'Null 'PGint4
195− , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]
196−:}
197−
198−>>> type Schemas = Public '["tab" ::: 'Table Table]
199−
200−>>> :{
201−let
202− setup :: Definition Schemas Schemas
203− setup = createTableIfNotExists #tab
204− (nullable int `as` #a :* nullable real `as` #b) Nil
205−in printSQL setup
206−:}
207−CREATE TABLE IF NOT EXISTS "tab" ("a" int NULL, "b" real NULL);
208−-}
209−createTableIfNotExists
210− :: ( Has sch schemas schema
211− , Has tab schema ('Table (constraints :=> columns))
212− , SOP.SListI columns
213− , SOP.SListI constraints )
214− => QualifiedAlias sch tab -- ^ the name of the table to add
215− -> NP (Aliased (ColumnTypeExpression schemas)) columns
216− -- ^ the names and datatype of each column
217− -> NP (Aliased (TableConstraintExpression sch tab schemas)) constraints
218− -- ^ constraints that must hold for the table
219− -> Definition schemas schemas
220−createTableIfNotExists tab columns constraints = UnsafeDefinition $
221− "CREATE TABLE IF NOT EXISTS"
222− <+> renderCreation tab columns constraints
223−
224−-- helper function for `createTable` and `createTableIfNotExists`
225−renderCreation
226− :: ( KnownSymbol sch
227− , KnownSymbol tab
228− , SOP.SListI columns
229− , SOP.SListI constraints )
230− => QualifiedAlias sch tab -- ^ the name of the table to add
231− -> NP (Aliased (ColumnTypeExpression schemas0)) columns
232− -- ^ the names and datatype of each column
233− -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints
234− -- ^ constraints that must hold for the table
235− -> ByteString
236−renderCreation tab columns constraints = renderSQL tab
237− <+> parenthesized
238− ( renderCommaSeparated renderColumnDef columns
239− <> ( case constraints of
240− Nil -> ""
241− _ -> ", " <>
242− renderCommaSeparated renderConstraint constraints ) )
243− <> ";"
244− where
245− renderColumnDef :: Aliased (ColumnTypeExpression schemas) x -> ByteString
246− renderColumnDef (ty `As` column) =
247− renderSQL column <+> renderColumnTypeExpression ty
248− renderConstraint
249− :: Aliased (TableConstraintExpression sch tab schemas) constraint
250− -> ByteString
251− renderConstraint (constraint `As` alias) =
252− "CONSTRAINT" <+> renderSQL alias <+> renderSQL constraint
253−
254−-- | Data types are a way to limit the kind of data that can be stored in a
255−-- table. For many applications, however, the constraint they provide is
256−-- too coarse. For example, a column containing a product price should
257−-- probably only accept positive values. But there is no standard data type
258−-- that accepts only positive numbers. Another issue is that you might want
259−-- to constrain column data with respect to other columns or rows.
260−-- For example, in a table containing product information,
261−-- there should be only one row for each product number.
262−-- `TableConstraint`s give you as much control over the data in your tables
263−-- as you wish. If a user attempts to store data in a column that would
264−-- violate a constraint, an error is raised. This applies
265−-- even if the value came from the default value definition.
266−newtype TableConstraintExpression
267− (sch :: Symbol)
268− (tab :: Symbol)
269− (schemas :: SchemasType)
270− (constraint :: TableConstraint)
271− = UnsafeTableConstraintExpression
272− { renderTableConstraintExpression :: ByteString }
273− deriving (GHC.Generic,Show,Eq,Ord,NFData)
274−instance RenderSQL
275− (TableConstraintExpression sch tab schemas constraint) where
276− renderSQL = renderTableConstraintExpression
277−
278−{-| A `check` constraint is the most generic `TableConstraint` type.
279−It allows you to specify that the value in a certain column must satisfy
280−a Boolean (truth-value) expression.
281−
282−>>> :{
283−type Schema = '[
284− "tab" ::: 'Table ('[ "inequality" ::: 'Check '["a","b"]] :=> '[
285− "a" ::: 'NoDef :=> 'NotNull 'PGint4,
286− "b" ::: 'NoDef :=> 'NotNull 'PGint4
287− ])]
288−:}
289−
290−>>> :{
291−let
292− definition :: Definition (Public '[]) (Public Schema)
293− definition = createTable #tab
294− ( (int & notNullable) `as` #a :*
295− (int & notNullable) `as` #b )
296− ( check (#a :* #b) (#a .> #b) `as` #inequality )
297−:}
298−
299−>>> printSQL definition
300−CREATE TABLE "tab" ("a" int NOT NULL, "b" int NOT NULL, CONSTRAINT "inequality" CHECK (("a" > "b")));
301−-}
302−check
303− :: ( Has sch schemas schema
304− , Has tab schema ('Table table)
305− , HasAll aliases (TableToRow table) subcolumns )
306− => NP Alias aliases
307− -- ^ specify the subcolumns which are getting checked
308− -> (forall t. Condition '[] '[] 'Ungrouped schemas '[] '[t ::: subcolumns])
309− -- ^ a closed `Condition` on those subcolumns
310− -> TableConstraintExpression sch tab schemas ('Check aliases)
311−check _cols condition = UnsafeTableConstraintExpression $
312− "CHECK" <+> parenthesized (renderSQL condition)
313−
314−{-| A `unique` constraint ensure that the data contained in a column,
315−or a group of columns, is unique among all the rows in the table.
316−
317−>>> :{
318−type Schema = '[
319− "tab" ::: 'Table( '[ "uq_a_b" ::: 'Unique '["a","b"]] :=> '[
320− "a" ::: 'NoDef :=> 'Null 'PGint4,
321− "b" ::: 'NoDef :=> 'Null 'PGint4
322− ])]
323−:}
324−
325−>>> :{
326−let
327− definition :: Definition (Public '[]) (Public Schema)
328− definition = createTable #tab
329− ( (int & nullable) `as` #a :*
330− (int & nullable) `as` #b )
331− ( unique (#a :* #b) `as` #uq_a_b )
332−:}
333−
334−>>> printSQL definition
335−CREATE TABLE "tab" ("a" int NULL, "b" int NULL, CONSTRAINT "uq_a_b" UNIQUE ("a", "b"));
336−-}
337−unique
338− :: ( Has sch schemas schema
339− , Has tab schema('Table table)
340− , HasAll aliases (TableToRow table) subcolumns )
341− => NP Alias aliases
342− -- ^ specify subcolumns which together are unique for each row
343− -> TableConstraintExpression sch tab schemas ('Unique aliases)
344−unique columns = UnsafeTableConstraintExpression $
345− "UNIQUE" <+> parenthesized (renderSQL columns)
346−
347−{-| A `primaryKey` constraint indicates that a column, or group of columns,
348−can be used as a unique identifier for rows in the table.
349−This requires that the values be both unique and not null.
350−
351−>>> :{
352−type Schema = '[
353− "tab" ::: 'Table ('[ "pk_id" ::: 'PrimaryKey '["id"]] :=> '[
354− "id" ::: 'Def :=> 'NotNull 'PGint4,
355− "name" ::: 'NoDef :=> 'NotNull 'PGtext
356− ])]
357−:}
358−
359−>>> :{
360−let
361− definition :: Definition (Public '[]) (Public Schema)
362− definition = createTable #tab
363− ( serial `as` #id :*
364− (text & notNullable) `as` #name )
365− ( primaryKey #id `as` #pk_id )
366−:}
367−
368−>>> printSQL definition
369−CREATE TABLE "tab" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_id" PRIMARY KEY ("id"));
370−-}
371−primaryKey
372− :: ( Has sch schemas schema
373− , Has tab schema ('Table table)
374− , HasAll aliases (TableToColumns table) subcolumns
375− , AllNotNull subcolumns )
376− => NP Alias aliases
377− -- ^ specify the subcolumns which together form a primary key.
378− -> TableConstraintExpression sch tab schemas ('PrimaryKey aliases)
379−primaryKey columns = UnsafeTableConstraintExpression $
380− "PRIMARY KEY" <+> parenthesized (renderSQL columns)
381−
382−{-| A `foreignKey` specifies that the values in a column
383−(or a group of columns) must match the values appearing in some row of
384−another table. We say this maintains the referential integrity
385−between two related tables.
386−
387−>>> :{
388−type Schema =
389− '[ "users" ::: 'Table (
390− '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
391− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
392− , "name" ::: 'NoDef :=> 'NotNull 'PGtext
393− ])
394− , "emails" ::: 'Table (
395− '[ "pk_emails" ::: 'PrimaryKey '["id"]
396− , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
397− ] :=>
398− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
399− , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
400− , "email" ::: 'NoDef :=> 'Null 'PGtext
401− ])
402− ]
403−:}
404−
405−>>> :{
406−let
407− setup :: Definition (Public '[]) (Public Schema)
408− setup =
409− createTable #users
410− ( serial `as` #id :*
411− (text & notNullable) `as` #name )
412− ( primaryKey #id `as` #pk_users ) >>>
413− createTable #emails
414− ( serial `as` #id :*
415− (int & notNullable) `as` #user_id :*
416− (text & nullable) `as` #email )
417− ( primaryKey #id `as` #pk_emails :*
418− foreignKey #user_id #users #id
419− OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
420−in printSQL setup
421−:}
422−CREATE TABLE "users" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_users" PRIMARY KEY ("id"));
423−CREATE TABLE "emails" ("id" serial, "user_id" int NOT NULL, "email" text NULL, CONSTRAINT "pk_emails" PRIMARY KEY ("id"), CONSTRAINT "fk_user_id" FOREIGN KEY ("user_id") REFERENCES "users" ("id") ON DELETE CASCADE ON UPDATE CASCADE);
424−
425−A `foreignKey` can even be a table self-reference.
426−
427−>>> :{
428−type Schema =
429− '[ "employees" ::: 'Table (
430− '[ "employees_pk" ::: 'PrimaryKey '["id"]
431− , "employees_employer_fk" ::: 'ForeignKey '["employer_id"] "employees" '["id"]
432− ] :=>
433− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
434− , "name" ::: 'NoDef :=> 'NotNull 'PGtext
435− , "employer_id" ::: 'NoDef :=> 'Null 'PGint4
436− ])
437− ]
438−:}
439−
440−>>> :{
441−let
442− setup :: Definition (Public '[]) (Public Schema)
443− setup =
444− createTable #employees
445− ( serial `as` #id :*
446− (text & notNullable) `as` #name :*
447− (integer & nullable) `as` #employer_id )
448− ( primaryKey #id `as` #employees_pk :*
449− foreignKey #employer_id #employees #id
450− OnDeleteCascade OnUpdateCascade `as` #employees_employer_fk )
451−in printSQL setup
452−:}
453−CREATE TABLE "employees" ("id" serial, "name" text NOT NULL, "employer_id" integer NULL, CONSTRAINT "employees_pk" PRIMARY KEY ("id"), CONSTRAINT "employees_employer_fk" FOREIGN KEY ("employer_id") REFERENCES "employees" ("id") ON DELETE CASCADE ON UPDATE CASCADE);
454−-}
455−foreignKey
456− :: (ForeignKeyed schemas sch schema child parent
457− table reftable
458− columns refcolumns
459− constraints cols
460− reftys tys )
461− => NP Alias columns
462− -- ^ column or columns in the table
463− -> Alias parent
464− -- ^ reference table
465− -> NP Alias refcolumns
466− -- ^ reference column or columns in the reference table
467− -> OnDeleteClause
468− -- ^ what to do when reference is deleted
469− -> OnUpdateClause
470− -- ^ what to do when reference is updated
471− -> TableConstraintExpression sch child schemas
472− ('ForeignKey columns parent refcolumns)
473−foreignKey keys parent refs ondel onupd = UnsafeTableConstraintExpression $
474− "FOREIGN KEY" <+> parenthesized (renderSQL keys)
475− <+> "REFERENCES" <+> renderSQL parent
476− <+> parenthesized (renderSQL refs)
477− <+> renderSQL ondel
478− <+> renderSQL onupd
479−
480−-- | A constraint synonym between types involved in a foreign key constraint.
481−type ForeignKeyed schemas
482− sch
483− schema
484− child parent
485− table reftable
486− columns refcolumns
487− constraints cols
488− reftys tys =
489− ( Has sch schemas schema
490− , Has child schema ('Table table)
491− , Has parent schema ('Table reftable)
492− , HasAll columns (TableToColumns table) tys
493− , reftable ~ (constraints :=> cols)
494− , HasAll refcolumns cols reftys
495− , SOP.AllZip SamePGType tys reftys
496− , Uniquely refcolumns constraints )
497−
498−-- | `OnDeleteClause` indicates what to do with rows that reference a deleted row.
499−data OnDeleteClause
500− = OnDeleteNoAction
501− -- ^ if any referencing rows still exist when the constraint is checked,
502− -- an error is raised
503− | OnDeleteRestrict -- ^ prevents deletion of a referenced row
504− | OnDeleteCascade
505− -- ^ specifies that when a referenced row is deleted,
506− -- row(s) referencing it should be automatically deleted as well
507− deriving (GHC.Generic,Show,Eq,Ord)
508−instance NFData OnDeleteClause
509−-- | Render `OnDeleteClause`.
510−instance RenderSQL OnDeleteClause where
511− renderSQL = \case
512− OnDeleteNoAction -> "ON DELETE NO ACTION"
513− OnDeleteRestrict -> "ON DELETE RESTRICT"
514− OnDeleteCascade -> "ON DELETE CASCADE"
515−
516−-- | Analagous to `OnDeleteClause` there is also `OnUpdateClause` which is invoked
517−-- when a referenced column is changed (updated).
518−data OnUpdateClause
519− = OnUpdateNoAction
520− -- ^ if any referencing rows has not changed when the constraint is checked,
521− -- an error is raised
522− | OnUpdateRestrict -- ^ prevents update of a referenced row
523− | OnUpdateCascade
524− -- ^ the updated values of the referenced column(s) should be copied
525− -- into the referencing row(s)
526− deriving (GHC.Generic,Show,Eq,Ord)
527−instance NFData OnUpdateClause
528−
529−-- | Render `OnUpdateClause`.
530−instance RenderSQL OnUpdateClause where
531− renderSQL = \case
532− OnUpdateNoAction -> "ON UPDATE NO ACTION"
533− OnUpdateRestrict -> "ON UPDATE RESTRICT"
534− OnUpdateCascade -> "ON UPDATE CASCADE"
535−
536−{-----------------------------------------
537−DROP statements
538−-----------------------------------------}
539−
540−-- >>> :{
541−-- let
542−-- definition :: Definition '["muh_schema" ::: schema, "public" ::: public] '["public" ::: public]
543−-- definition = dropSchema #muh_schema
544−-- :}
545−--
546−-- >>> printSQL definition
547−-- DROP SCHEMA "muh_schema";
548−dropSchema
549− :: Has sch schemas schema
550− => Alias sch
551− -> Definition schemas (Drop sch schemas)
552−dropSchema sch = UnsafeDefinition $ "DROP SCHEMA" <+> renderSQL sch <> ";"
553−
554−-- | `dropTable` removes a table from the schema.
555−--
556−-- >>> :{
557−-- let
558−-- definition :: Definition '["public" ::: '["muh_table" ::: 'Table t]] (Public '[])
559−-- definition = dropTable #muh_table
560−-- :}
561−--
562−-- >>> printSQL definition
563−-- DROP TABLE "muh_table";
564−dropTable
565− :: ( Has sch schemas schema
566− , Has tab schema ('Table table))
567− => QualifiedAlias sch tab -- ^ table to remove
568− -> Definition schemas (Alter sch (Drop tab schema) schemas)
569−dropTable tab = UnsafeDefinition $ "DROP TABLE" <+> renderSQL tab <> ";"
570−
571−{-----------------------------------------
572−ALTER statements
573−-----------------------------------------}
574−
575−-- | `alterTable` changes the definition of a table from the schema.
576−alterTable
577− :: (Has sch schemas schema, Has tab schema ('Table table0))
578− => QualifiedAlias sch tab -- ^ table to alter
579− -> AlterTable sch tab schemas table1 -- ^ alteration to perform
580− -> Definition schemas (Alter sch (Alter tab ('Table table1) schema) schemas)
581−alterTable tab alteration = UnsafeDefinition $
582− "ALTER TABLE"
583− <+> renderSQL tab
584− <+> renderAlterTable alteration
585− <> ";"
586−
587−-- | `alterTableRename` changes the name of a table from the schema.
588−--
589−-- >>> printSQL $ alterTableRename #foo #bar
590−-- ALTER TABLE "foo" RENAME TO "bar";
591−alterTableRename
592− :: (KnownSymbol table0, KnownSymbol table1)
593− => Alias table0 -- ^ table to rename
594− -> Alias table1 -- ^ what to rename it
595− -> Definition schema (Rename table0 table1 schema)
596−alterTableRename table0 table1 = UnsafeDefinition $
597− "ALTER TABLE" <+> renderSQL table0
598− <+> "RENAME TO" <+> renderSQL table1 <> ";"
599−
600−-- | An `AlterTable` describes the alteration to perform on the columns
601−-- of a table.
602−newtype AlterTable
603− (sch :: Symbol)
604− (tab :: Symbol)
605− (schemas :: SchemasType)
606− (table :: TableType) =
607− UnsafeAlterTable {renderAlterTable :: ByteString}
608− deriving (GHC.Generic,Show,Eq,Ord,NFData)
609−
610−-- | An `addConstraint` adds a table constraint.
611−--
612−-- >>> :{
613−-- let
614−-- definition :: Definition
615−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
616−-- '["public" ::: '["tab" ::: 'Table ('["positive" ::: 'Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
617−-- definition = alterTable #tab (addConstraint #positive (check #col (#col .> 0)))
618−-- in printSQL definition
619−-- :}
620−-- ALTER TABLE "tab" ADD CONSTRAINT "positive" CHECK (("col" > 0));
621−addConstraint
622− :: ( KnownSymbol alias
623− , Has sch schemas schema
624− , Has tab schema ('Table table0)
625− , table0 ~ (constraints :=> columns)
626− , table1 ~ (Create alias constraint constraints :=> columns) )
627− => Alias alias
628− -> TableConstraintExpression sch tab schemas constraint
629− -- ^ constraint to add
630− -> AlterTable sch tab schemas table1
631−addConstraint alias constraint = UnsafeAlterTable $
632− "ADD" <+> "CONSTRAINT" <+> renderSQL alias
633− <+> renderSQL constraint
634−
635−-- | A `dropConstraint` drops a table constraint.
636−--
637−-- >>> :{
638−-- let
639−-- definition :: Definition
640−-- '["public" ::: '["tab" ::: 'Table ('["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
641−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
642−-- definition = alterTable #tab (dropConstraint #positive)
643−-- in printSQL definition
644−-- :}
645−-- ALTER TABLE "tab" DROP CONSTRAINT "positive";
646−dropConstraint
647− :: ( KnownSymbol constraint
648− , Has sch schemas schema
649− , Has tab schema ('Table table0)
650− , table0 ~ (constraints :=> columns)
651− , table1 ~ (Drop constraint constraints :=> columns) )
652− => Alias constraint
653− -- ^ constraint to drop
654− -> AlterTable sch tab schemas table1
655−dropConstraint constraint = UnsafeAlterTable $
656− "DROP" <+> "CONSTRAINT" <+> renderSQL constraint
657−
658−-- | An `AddColumn` is either @NULL@ or has @DEFAULT@.
659−class AddColumn ty where
660− -- | `addColumn` adds a new column, initially filled with whatever
661− -- default value is given or with @NULL@.
662− --
663− -- >>> :{
664− -- let
665− -- definition :: Definition
666− -- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]
667− -- '["public" ::: '["tab" ::: 'Table ('[] :=>
668− -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
669− -- , "col2" ::: 'Def :=> 'Null 'PGtext ])]]
670− -- definition = alterTable #tab (addColumn #col2 (text & nullable & default_ "foo"))
671− -- in printSQL definition
672− -- :}
673− -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL DEFAULT E'foo';
674− --
675− -- >>> :{
676− -- let
677− -- definition :: Definition
678− -- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]
679− -- '["public" ::: '["tab" ::: 'Table ('[] :=>
680− -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
681− -- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]]
682− -- definition = alterTable #tab (addColumn #col2 (text & nullable))
683− -- in printSQL definition
684− -- :}
685− -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL;
686− addColumn
687− :: ( KnownSymbol column
688− , Has sch schemas schema
689− , Has tab schema ('Table table0)
690− , table0 ~ (constraints :=> columns) )
691− => Alias column -- ^ column to add
692− -> ColumnTypeExpression schemas ty -- ^ type of the new column
693− -> AlterTable sch tab schemas (constraints :=> Create column ty columns)
694− addColumn column ty = UnsafeAlterTable $
695− "ADD COLUMN" <+> renderSQL column <+> renderColumnTypeExpression ty
696−instance {-# OVERLAPPING #-} AddColumn ('Def :=> ty)
697−instance {-# OVERLAPPABLE #-} AddColumn ('NoDef :=> 'Null ty)
698−
699−-- | A `dropColumn` removes a column. Whatever data was in the column
700−-- disappears. Table constraints involving the column are dropped, too.
701−-- However, if the column is referenced by a foreign key constraint of
702−-- another table, PostgreSQL will not silently drop that constraint.
703−--
704−-- >>> :{
705−-- let
706−-- definition :: Definition
707−-- '["public" ::: '["tab" ::: 'Table ('[] :=>
708−-- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
709−-- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]]
710−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]
711−-- definition = alterTable #tab (dropColumn #col2)
712−-- in printSQL definition
713−-- :}
714−-- ALTER TABLE "tab" DROP COLUMN "col2";
715−dropColumn
716− :: ( KnownSymbol column
717− , Has sch schemas schema
718− , Has tab schema ('Table table0)
719− , table0 ~ (constraints :=> columns)
720− , table1 ~ (constraints :=> Drop column columns) )
721− => Alias column -- ^ column to remove
722− -> AlterTable sch tab schemas table1
723−dropColumn column = UnsafeAlterTable $
724− "DROP COLUMN" <+> renderSQL column
725−
726−-- | A `renameColumn` renames a column.
727−--
728−-- >>> :{
729−-- let
730−-- definition :: Definition
731−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["foo" ::: 'NoDef :=> 'Null 'PGint4])]]
732−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["bar" ::: 'NoDef :=> 'Null 'PGint4])]]
733−-- definition = alterTable #tab (renameColumn #foo #bar)
734−-- in printSQL definition
735−-- :}
736−-- ALTER TABLE "tab" RENAME COLUMN "foo" TO "bar";
737−renameColumn
738− :: ( KnownSymbol column0
739− , KnownSymbol column1
740− , Has sch schemas schema
741− , Has tab schema ('Table table0)
742− , table0 ~ (constraints :=> columns)
743− , table1 ~ (constraints :=> Rename column0 column1 columns) )
744− => Alias column0 -- ^ column to rename
745− -> Alias column1 -- ^ what to rename the column
746− -> AlterTable sch tab schemas table1
747−renameColumn column0 column1 = UnsafeAlterTable $
748− "RENAME COLUMN" <+> renderSQL column0 <+> "TO" <+> renderSQL column1
749−
750−-- | An `alterColumn` alters a single column.
751−alterColumn
752− :: ( KnownSymbol column
753− , Has sch schemas schema
754− , Has tab schema ('Table table0)
755− , table0 ~ (constraints :=> columns)
756− , Has column columns ty0
757− , table1 ~ (constraints :=> Alter column ty1 columns))
758− => Alias column -- ^ column to alter
759− -> AlterColumn schemas ty0 ty1 -- ^ alteration to perform
760− -> AlterTable sch tab schemas table1
761−alterColumn column alteration = UnsafeAlterTable $
762− "ALTER COLUMN" <+> renderSQL column <+> renderAlterColumn alteration
763−
764−-- | An `AlterColumn` describes the alteration to perform on a single column.
765−newtype AlterColumn (schemas :: SchemasType) (ty0 :: ColumnType) (ty1 :: ColumnType) =
766− UnsafeAlterColumn {renderAlterColumn :: ByteString}
767− deriving (GHC.Generic,Show,Eq,Ord,NFData)
768−
769−-- | A `setDefault` sets a new default for a column. Note that this doesn't
770−-- affect any existing rows in the table, it just changes the default for
771−-- future insert and update commands.
772−--
773−-- >>> :{
774−-- let
775−-- definition :: Definition
776−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
777−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]]
778−-- definition = alterTable #tab (alterColumn #col (setDefault 5))
779−-- in printSQL definition
780−-- :}
781−-- ALTER TABLE "tab" ALTER COLUMN "col" SET DEFAULT 5;
782−setDefault
783− :: Expression '[] '[] 'Ungrouped schemas '[] '[] ty -- ^ default value to set
784− -> AlterColumn schemas (constraint :=> ty) ('Def :=> ty)
785−setDefault expression = UnsafeAlterColumn $
786− "SET DEFAULT" <+> renderExpression expression
787−
788−-- | A `dropDefault` removes any default value for a column.
789−--
790−-- >>> :{
791−-- let
792−-- definition :: Definition
793−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]]
794−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
795−-- definition = alterTable #tab (alterColumn #col dropDefault)
796−-- in printSQL definition
797−-- :}
798−-- ALTER TABLE "tab" ALTER COLUMN "col" DROP DEFAULT;
799−dropDefault :: AlterColumn schemas ('Def :=> ty) ('NoDef :=> ty)
800−dropDefault = UnsafeAlterColumn $ "DROP DEFAULT"
801−
802−-- | A `setNotNull` adds a @NOT NULL@ constraint to a column.
803−-- The constraint will be checked immediately, so the table data must satisfy
804−-- the constraint before it can be added.
805−--
806−-- >>> :{
807−-- let
808−-- definition :: Definition
809−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
810−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
811−-- definition = alterTable #tab (alterColumn #col setNotNull)
812−-- in printSQL definition
813−-- :}
814−-- ALTER TABLE "tab" ALTER COLUMN "col" SET NOT NULL;
815−setNotNull
816− :: AlterColumn schemas (constraint :=> 'Null ty) (constraint :=> 'NotNull ty)
817−setNotNull = UnsafeAlterColumn $ "SET NOT NULL"
818−
819−-- | A `dropNotNull` drops a @NOT NULL@ constraint from a column.
820−--
821−-- >>> :{
822−-- let
823−-- definition :: Definition
824−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
825−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
826−-- definition = alterTable #tab (alterColumn #col dropNotNull)
827−-- in printSQL definition
828−-- :}
829−-- ALTER TABLE "tab" ALTER COLUMN "col" DROP NOT NULL;
830−dropNotNull
831− :: AlterColumn schemas (constraint :=> 'NotNull ty) (constraint :=> 'Null ty)
832−dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL"
833−
834−-- | An `alterType` converts a column to a different data type.
835−-- This will succeed only if each existing entry in the column can be
836−-- converted to the new type by an implicit cast.
837−--
838−-- >>> :{
839−-- let
840−-- definition :: Definition
841−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
842−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGnumeric])]]
843−-- definition =
844−-- alterTable #tab (alterColumn #col (alterType (numeric & notNullable)))
845−-- in printSQL definition
846−-- :}
847−-- ALTER TABLE "tab" ALTER COLUMN "col" TYPE numeric NOT NULL;
848−alterType :: ColumnTypeExpression schemas ty -> AlterColumn schemas ty0 ty
849−alterType ty = UnsafeAlterColumn $ "TYPE" <+> renderColumnTypeExpression ty
850−
851−{- | Create a view.
852−>>> type ABC = '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4]
853−>>> type BC = '["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4]
854−>>> :{
855−let
856− definition :: Definition
857− '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC)]]
858− '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC), "bc" ::: 'View BC]]
859− definition =
860− createView #bc (select_ (#b :* #c) (from (table #abc)))
861−in printSQL definition
862−:}
863−CREATE VIEW "bc" AS SELECT "b" AS "b", "c" AS "c" FROM "abc" AS "abc";
864−-}
865−createView
866− :: (KnownSymbol sch, KnownSymbol vw, Has sch schemas schema)
867− => QualifiedAlias sch vw -- ^ the name of the view to add
868− -> Query '[] '[] schemas '[] view -- ^ query
869− -> Definition schemas (Alter sch (Create vw ('View view) schema) schemas)
870−createView alias query = UnsafeDefinition $
871− "CREATE" <+> "VIEW" <+> renderSQL alias <+> "AS"
872− <+> renderQuery query <> ";"
873−
874−-- | Drop a view.
875−--
876−-- >>> :{
877−-- let
878−-- definition :: Definition
879−-- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])
880−-- , "bc" ::: 'View ('["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4])]]
881−-- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])]]
882−-- definition = dropView #bc
883−-- in printSQL definition
884−-- :}
885−-- DROP VIEW "bc";
886−dropView
887− :: (Has sch schemas schema, Has vw schema ('View view))
888− => QualifiedAlias sch vw -- ^ view to remove
889− -> Definition schemas (Alter sch (Drop vw schema) schemas)
890−dropView vw = UnsafeDefinition $ "DROP VIEW" <+> renderSQL vw <> ";"
891−
892−-- | Enumerated types are created using the `createTypeEnum` command, for example
893−--
894−-- >>> printSQL $ (createTypeEnum #mood (label @"sad" :* label @"ok" :* label @"happy") :: Definition (Public '[]) '["public" ::: '["mood" ::: 'Typedef ('PGenum '["sad","ok","happy"])]])
895−-- CREATE TYPE "mood" AS ENUM ('sad', 'ok', 'happy');
896−createTypeEnum
897− :: (KnownSymbol enum, Has sch schemas schema, SOP.All KnownSymbol labels)
898− => QualifiedAlias sch enum
899− -- ^ name of the user defined enumerated type
900− -> NP PGlabel labels
901− -- ^ labels of the enumerated type
902− -> Definition schemas (Alter sch (Create enum ('Typedef ('PGenum labels)) schema) schemas)
903−createTypeEnum enum labels = UnsafeDefinition $
904− "CREATE" <+> "TYPE" <+> renderSQL enum <+> "AS" <+> "ENUM" <+>
905− parenthesized (renderSQL labels) <> ";"
906−
907−-- | Enumerated types can also be generated from a Haskell type, for example
908−--
909−-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic
910−-- >>> instance SOP.Generic Schwarma
911−-- >>> instance SOP.HasDatatypeInfo Schwarma
912−-- >>> :{
913−-- let
914−-- createSchwarma :: Definition (Public '[]) '["public" ::: '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))]]
915−-- createSchwarma = createTypeEnumFrom @Schwarma #schwarma
916−-- in
917−-- printSQL createSchwarma
918−-- :}
919−-- CREATE TYPE "schwarma" AS ENUM ('Beef', 'Lamb', 'Chicken');
920−createTypeEnumFrom
921− :: forall hask sch enum schemas schema.
922− ( SOP.Generic hask
923− , SOP.All KnownSymbol (LabelsPG hask)
924− , KnownSymbol enum
925− , Has sch schemas schema )
926− => QualifiedAlias sch enum
927− -- ^ name of the user defined enumerated type
928− -> Definition schemas (Alter sch (Create enum ('Typedef (PG (Enumerated hask))) schema) schemas)
929−createTypeEnumFrom enum = createTypeEnum enum
930− (SOP.hpure label :: NP PGlabel (LabelsPG hask))
931−
932−{- | `createTypeComposite` creates a composite type. The composite type is
933−specified by a list of attribute names and data types.
934−
935−>>> :{
936−type PGcomplex = 'PGcomposite
937− '[ "real" ::: 'NotNull 'PGfloat8
938− , "imaginary" ::: 'NotNull 'PGfloat8 ]
939−:}
940−
941−>>> :{
942−let
943− setup :: Definition (Public '[]) '["public" ::: '["complex" ::: 'Typedef PGcomplex]]
944− setup = createTypeComposite #complex
945− (float8 `as` #real :* float8 `as` #imaginary)
946−in printSQL setup
947−:}
948−CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);
949−-}
950−createTypeComposite
951− :: (KnownSymbol ty, Has sch schemas schema, SOP.SListI fields)
952− => QualifiedAlias sch ty
953− -- ^ name of the user defined composite type
954− -> NP (Aliased (TypeExpression schemas)) fields
955− -- ^ list of attribute names and data types
956− -> Definition schemas (Alter sch (Create ty ('Typedef ('PGcomposite fields)) schema) schemas)
957−createTypeComposite ty fields = UnsafeDefinition $
958− "CREATE" <+> "TYPE" <+> renderSQL ty <+> "AS" <+> parenthesized
959− (renderCommaSeparated renderField fields) <> ";"
960− where
961− renderField :: Aliased (TypeExpression schemas) x -> ByteString
962− renderField (typ `As` alias) =
963− renderSQL alias <+> renderSQL typ
964−
965−-- | Composite types can also be generated from a Haskell type, for example
966−--
967−-- >>> data Complex = Complex {real :: Double, imaginary :: Double} deriving GHC.Generic
968−-- >>> instance SOP.Generic Complex
969−-- >>> instance SOP.HasDatatypeInfo Complex
970−-- >>> type Schema = '["complex" ::: 'Typedef (PG (Composite Complex))]
971−-- >>> :{
972−-- let
973−-- createComplex :: Definition (Public '[]) (Public Schema)
974−-- createComplex = createTypeCompositeFrom @Complex #complex
975−-- in
976−-- printSQL createComplex
977−-- :}
978−-- CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);
979−createTypeCompositeFrom
980− :: forall hask sch ty schemas schema.
981− ( SOP.All (FieldTyped schemas) (RowPG hask)
982− , KnownSymbol ty
983− , Has sch schemas schema )
984− => QualifiedAlias sch ty
985− -- ^ name of the user defined composite type
986− -> Definition schemas (Alter sch (Create ty ( 'Typedef (PG (Composite hask))) schema) schemas)
987−createTypeCompositeFrom ty = createTypeComposite ty
988− (SOP.hcpure (SOP.Proxy :: SOP.Proxy (FieldTyped schemas)) fieldtype
989− :: NP (Aliased (TypeExpression schemas)) (RowPG hask))
990−
991−{-|
992−`createDomain` creates a new domain. A domain is essentially a data type
993−with constraints (restrictions on the allowed set of values).
994−
995−Domains are useful for abstracting common constraints on fields
996−into a single location for maintenance. For example, several tables might
997−contain email address columns, all requiring the same `check` constraint
998−to verify the address syntax. Define a domain rather than setting up
999−each table's constraint individually.
1000−
1001−>>> :{
1002−let
1003− createPositive :: Definition (Public '[]) (Public '["positive" ::: 'Typedef 'PGfloat4])
1004− createPositive = createDomain #positive real (#value .> 0 .&& (#value & isNotNull))
1005−in printSQL createPositive
1006−:}
1007−CREATE DOMAIN "positive" AS real CHECK ((("value" > 0) AND "value" IS NOT NULL));
1008−-}
1009−createDomain
1010− :: (Has sch schemas schema, KnownSymbol dom)
1011− => QualifiedAlias sch dom
1012− -> (forall nullity. TypeExpression schemas (nullity ty))
1013− -> (forall tab. Condition '[] '[] 'Ungrouped schemas '[] '[tab ::: '["value" ::: 'Null ty]])
1014− -> Definition schemas (Alter sch (Create alias ('Typedef ty) schema) schemas)
1015−createDomain dom ty condition =
1016− UnsafeDefinition $ "CREATE DOMAIN" <+> renderSQL dom
1017− <+> "AS" <+> renderTypeExpression ty
1018− <+> "CHECK" <+> parenthesized (renderSQL condition) <> ";"
1019−
1020−class FieldTyped schemas ty where
1021− fieldtype :: Aliased (TypeExpression schemas) ty
1022−instance (KnownSymbol alias, PGTyped schemas ty)
1023− => FieldTyped schemas (alias ::: ty) where
1024− fieldtype = pgtype `As` Alias
1025−
1026−-- | Drop a type.
1027−--
1028−-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic
1029−-- >>> instance SOP.Generic Schwarma
1030−-- >>> instance SOP.HasDatatypeInfo Schwarma
1031−-- >>> printSQL (dropType #schwarma :: Definition '["public" ::: '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))]] (Public '[]))
1032−-- DROP TYPE "schwarma";
1033−dropType
1034− :: (Has sch schemas schema, Has td schema ('Typedef ty))
1035− => QualifiedAlias sch td
1036− -- ^ name of the user defined type
1037− -> Definition schemas (Alter sch (Drop td schema) schemas)
1038−dropType tydef = UnsafeDefinition $ "DROP" <+> "TYPE" <+> renderSQL tydef <> ";"
1039−
1040−-- | `ColumnTypeExpression`s are used in `createTable` commands.
1041−newtype ColumnTypeExpression (schemas :: SchemasType) (ty :: ColumnType)
1042− = UnsafeColumnTypeExpression { renderColumnTypeExpression :: ByteString }
1043− deriving (GHC.Generic,Show,Eq,Ord,NFData)
1044−instance RenderSQL (ColumnTypeExpression schemas ty) where
1045− renderSQL = renderColumnTypeExpression
1046−
1047−-- | used in `createTable` commands as a column constraint to note that
1048−-- @NULL@ may be present in a column
1049−nullable
1050− :: TypeExpression schemas (nullity ty)
1051− -> ColumnTypeExpression schemas ('NoDef :=> 'Null ty)
1052−nullable ty = UnsafeColumnTypeExpression $ renderSQL ty <+> "NULL"
1053−
1054−-- | used in `createTable` commands as a column constraint to ensure
1055−-- @NULL@ is not present in a column
1056−notNullable
1057− :: TypeExpression schemas (nullity ty)
1058− -> ColumnTypeExpression schemas ('NoDef :=> 'NotNull ty)
1059−notNullable ty = UnsafeColumnTypeExpression $ renderSQL ty <+> "NOT NULL"
1060−
1061−-- | used in `createTable` commands as a column constraint to give a default
1062−default_
1063− :: Expression '[] '[] 'Ungrouped schemas '[] '[] ty
1064− -> ColumnTypeExpression schemas ('NoDef :=> ty)
1065− -> ColumnTypeExpression schemas ('Def :=> ty)
1066−default_ x ty = UnsafeColumnTypeExpression $
1067− renderSQL ty <+> "DEFAULT" <+> renderExpression x
1068−
1069−-- | not a true type, but merely a notational convenience for creating
1070−-- unique identifier columns with type `PGint2`
1071−serial2, smallserial
1072− :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint2)
1073−serial2 = UnsafeColumnTypeExpression "serial2"
1074−smallserial = UnsafeColumnTypeExpression "smallserial"
1075−-- | not a true type, but merely a notational convenience for creating
1076−-- unique identifier columns with type `PGint4`
1077−serial4, serial
1078− :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint4)
1079−serial4 = UnsafeColumnTypeExpression "serial4"
1080−serial = UnsafeColumnTypeExpression "serial"
1081−-- | not a true type, but merely a notational convenience for creating
1082−-- unique identifier columns with type `PGint8`
1083−serial8, bigserial
1084− :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint8)
1085−serial8 = UnsafeColumnTypeExpression "serial8"
1086−bigserial = UnsafeColumnTypeExpression "bigserial"
82+manipDefinition = UnsafeDefinition . (<> ";") . renderSQL
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Function.hsnew file+238
@@ -0,0 +1,238 @@
1+{-|
2+Module: Squeal.PostgreSQL.Definition.Function
3+Description: Create and drop function and operator definitions
4+Copyright: (c) Eitan Chatav, 2017
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Create and drop function and operator definitions.
9+-}
10+
11+{-# LANGUAGE
12+ AllowAmbiguousTypes
13+ , ConstraintKinds
14+ , DeriveAnyClass
15+ , DeriveGeneric
16+ , DerivingStrategies
17+ , FlexibleContexts
18+ , FlexibleInstances
19+ , GADTs
20+ , LambdaCase
21+ , MultiParamTypeClasses
22+ , OverloadedLabels
23+ , OverloadedStrings
24+ , RankNTypes
25+ , ScopedTypeVariables
26+ , TypeApplications
27+ , TypeInType
28+ , TypeOperators
29+ , UndecidableSuperClasses
30+#-}
31+
32+module Squeal.PostgreSQL.Definition.Function
33+ ( createFunction
34+ , createOrReplaceFunction
35+ , createSetFunction
36+ , createOrReplaceSetFunction
37+ , createBinaryOp
38+ , createLeftOp
39+ , createRightOp
40+ , dropFunction
41+ , dropFunctionIfExists
42+ , dropOperator
43+ , dropOperatorIfExists
44+ , FunctionDefinition(..)
45+ , languageSqlExpr
46+ , languageSqlQuery
47+ ) where
48+
49+import Control.DeepSeq
50+import Data.ByteString
51+import GHC.TypeLits
52+
53+import qualified Generics.SOP as SOP
54+import qualified GHC.Generics as GHC
55+
56+import Squeal.PostgreSQL.Alias
57+import Squeal.PostgreSQL.Definition
58+import Squeal.PostgreSQL.Expression
59+import Squeal.PostgreSQL.Expression.Type
60+import Squeal.PostgreSQL.List
61+import Squeal.PostgreSQL.Query
62+import Squeal.PostgreSQL.Render
63+import Squeal.PostgreSQL.Schema
64+
65+-- $setup
66+-- >>> import Squeal.PostgreSQL
67+
68+createFunction
69+ :: ( Has sch schemas schema
70+ , KnownSymbol fun
71+ , SOP.SListI args )
72+ => QualifiedAlias sch fun
73+ -> NP (TypeExpression schemas) args
74+ -> TypeExpression schemas ret
75+ -> FunctionDefinition schemas args ('Returns ret)
76+ -> Definition schemas (Alter sch (Create fun ('Function (args :=> 'Returns ret)) schema) schemas)
77+createFunction fun args ret fundef = UnsafeDefinition $
78+ "CREATE" <+> "FUNCTION" <+> renderSQL fun
79+ <+> parenthesized (renderCommaSeparated renderSQL args)
80+ <+> "RETURNS" <+> renderSQL ret <+> renderSQL fundef <> ";"
81+
82+createOrReplaceFunction
83+ :: ( Has sch schemas schema
84+ , KnownSymbol fun
85+ , SOP.SListI args )
86+ => QualifiedAlias sch fun
87+ -> NP (TypeExpression schemas) args
88+ -> TypeExpression schemas ret
89+ -> FunctionDefinition schemas args ('Returns ret)
90+ -> Definition schemas (Alter sch (CreateOrReplace fun ('Function (args :=> 'Returns ret)) schema) schemas)
91+createOrReplaceFunction fun args ret fundef = UnsafeDefinition $
92+ "CREATE" <+> "OR" <+> "REPLACE" <+> "FUNCTION" <+> renderSQL fun
93+ <+> parenthesized (renderCommaSeparated renderSQL args)
94+ <+> "RETURNS" <+> renderSQL ret <+> renderSQL fundef <> ";"
95+
96+languageSqlExpr
97+ :: Expression '[] '[] 'Ungrouped schemas args '[] ret
98+ -> FunctionDefinition schemas args ('Returns ret)
99+languageSqlExpr expr = UnsafeFunctionDefinition $
100+ "language sql as"
101+ <+> "$$" <+> renderSQL (values_ (expr `as` #ret)) <+> "$$"
102+
103+languageSqlQuery
104+ :: Query '[] '[] schemas args rets
105+ -> FunctionDefinition schemas args ('ReturnsTable rets)
106+languageSqlQuery qry = UnsafeFunctionDefinition $
107+ "language sql as" <+> "$$" <+> renderSQL qry <+> "$$"
108+
109+createSetFunction
110+ :: ( Has sch schemas schema
111+ , KnownSymbol fun
112+ , SOP.SListI args
113+ , SOP.SListI rets )
114+ => QualifiedAlias sch fun
115+ -> NP (TypeExpression schemas) args
116+ -> NP (Aliased (TypeExpression schemas)) rets
117+ -> FunctionDefinition schemas args ('ReturnsTable rets)
118+ -> Definition schemas (Alter sch (Create fun ('Function (args :=> 'ReturnsTable rets)) schema) schemas)
119+createSetFunction fun args rets fundef = UnsafeDefinition $
120+ "CREATE" <+> "FUNCTION" <+> renderSQL fun
121+ <+> parenthesized (renderCommaSeparated renderSQL args)
122+ <+> "RETURNS" <+> "TABLE"
123+ <+> parenthesized (renderCommaSeparated renderRet rets)
124+ <+> renderSQL fundef <> ";"
125+ where
126+ renderRet :: Aliased (TypeExpression s) r -> ByteString
127+ renderRet (ty `As` col) = renderSQL col <+> renderSQL ty
128+
129+createOrReplaceSetFunction
130+ :: ( Has sch schemas schema
131+ , KnownSymbol fun
132+ , SOP.SListI args
133+ , SOP.SListI rets )
134+ => QualifiedAlias sch fun
135+ -> NP (TypeExpression schemas) args
136+ -> NP (Aliased (TypeExpression schemas)) rets
137+ -> FunctionDefinition schemas args ('ReturnsTable rets)
138+ -> Definition schemas (Alter sch (CreateOrReplace fun ('Function (args :=> 'ReturnsTable rets)) schema) schemas)
139+createOrReplaceSetFunction fun args rets fundef = UnsafeDefinition $
140+ "CREATE" <+> "OR" <+> "REPLACE" <+> "FUNCTION" <+> renderSQL fun
141+ <+> parenthesized (renderCommaSeparated renderSQL args)
142+ <+> "RETURNS" <+> "TABLE"
143+ <+> parenthesized (renderCommaSeparated renderRet rets)
144+ <+> renderSQL fundef <> ";"
145+ where
146+ renderRet :: Aliased (TypeExpression s) r -> ByteString
147+ renderRet (ty `As` col) = renderSQL col <+> renderSQL ty
148+
149+createBinaryOp
150+ :: forall op fun sch schemas schema x y z.
151+ ( Has sch schemas schema
152+ , Has fun schema ('Function ('[x,y] :=> 'Returns z))
153+ , KnownSymbol op )
154+ => QualifiedAlias sch fun
155+ -> TypeExpression schemas x
156+ -> TypeExpression schemas y
157+ -> Definition schemas
158+ (Alter sch (Create op ('Operator ('BinaryOp x y z)) schema) schemas)
159+createBinaryOp fun x y = UnsafeDefinition $
160+ "CREATE" <+> "OPERATOR" <+> renderSymbol @op
161+ <+> parenthesized (commaSeparated opdef)
162+ where
163+ opdef =
164+ [ "FUNCTION" <+> "=" <+> renderSQL fun
165+ , "LEFTARG" <+> "=" <+> renderSQL x
166+ , "RIGHTARG" <+> "=" <+> renderSQL y ]
167+
168+createLeftOp
169+ :: forall op fun sch schemas schema x y.
170+ ( Has sch schemas schema
171+ , Has fun schema ('Function ('[x] :=> 'Returns y))
172+ , KnownSymbol op )
173+ => QualifiedAlias sch fun
174+ -> TypeExpression schemas x
175+ -> Definition schemas
176+ (Alter sch (Create op ('Operator ('LeftOp x y)) schema) schemas)
177+createLeftOp fun x = UnsafeDefinition $
178+ "CREATE" <+> "OPERATOR" <+> renderSymbol @op
179+ <+> parenthesized (commaSeparated opdef)
180+ where
181+ opdef =
182+ [ "FUNCTION" <+> "=" <+> renderSQL fun
183+ , "RIGHTARG" <+> "=" <+> renderSQL x ]
184+
185+createRightOp
186+ :: forall op fun sch schemas schema x y.
187+ ( Has sch schemas schema
188+ , Has fun schema ('Function ('[x] :=> 'Returns y))
189+ , KnownSymbol op )
190+ => QualifiedAlias sch fun
191+ -> TypeExpression schemas x
192+ -> Definition schemas
193+ (Alter sch (Create op ('Operator ('RightOp x y)) schema) schemas)
194+createRightOp fun x = UnsafeDefinition $
195+ "CREATE" <+> "OPERATOR" <+> renderSymbol @op
196+ <+> parenthesized (commaSeparated opdef)
197+ where
198+ opdef =
199+ [ "FUNCTION" <+> "=" <+> renderSQL fun
200+ , "LEFTARG" <+> "=" <+> renderSQL x ]
201+
202+dropFunction
203+ :: (Has sch schemas schema, KnownSymbol fun)
204+ => QualifiedAlias sch fun
205+ -- ^ name of the user defined function
206+ -> Definition schemas (Alter sch (DropSchemum fun 'Function schema) schemas)
207+dropFunction fun = UnsafeDefinition $
208+ "DROP" <+> "FUNCTION" <+> renderSQL fun <> ";"
209+
210+dropFunctionIfExists
211+ :: (Has sch schemas schema, KnownSymbol fun)
212+ => QualifiedAlias sch fun
213+ -- ^ name of the user defined function
214+ -> Definition schemas (Alter sch (DropSchemumIfExists fun 'Function schema) schemas)
215+dropFunctionIfExists fun = UnsafeDefinition $
216+ "DROP FUNCTION IF EXISTS" <+> renderSQL fun <> ";"
217+
218+dropOperator
219+ :: (Has sch schemas schema, KnownSymbol op)
220+ => QualifiedAlias sch op
221+ -- ^ name of the user defined operator
222+ -> Definition schemas (Alter sch (DropSchemum op 'Operator schema) schemas)
223+dropOperator op = UnsafeDefinition $
224+ "DROP" <+> "OPERATOR" <+> renderSQL op <> ";"
225+
226+dropOperatorIfExists
227+ :: (Has sch schemas schema, KnownSymbol op)
228+ => QualifiedAlias sch op
229+ -- ^ name of the user defined operator
230+ -> Definition schemas (Alter sch (DropSchemumIfExists op 'Operator schema) schemas)
231+dropOperatorIfExists op = UnsafeDefinition $
232+ "DROP OPERATOR IF EXISTS" <+> renderSQL op <> ";"
233+
234+newtype FunctionDefinition schemas args ret = UnsafeFunctionDefinition
235+ { renderFunctionDefinition :: ByteString }
236+ deriving (Eq,Show,GHC.Generic,NFData)
237+instance RenderSQL (FunctionDefinition schemas args ret) where
238+ renderSQL = renderFunctionDefinition
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Index.hsnew file+159
@@ -0,0 +1,159 @@
1+{-|
2+Module: Squeal.PostgreSQL.Definition.Index
3+Description: Create and drop index definitions
4+Copyright: (c) Eitan Chatav, 2017
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Create and drop index definitions.
9+-}
10+
11+{-# LANGUAGE
12+ AllowAmbiguousTypes
13+ , ConstraintKinds
14+ , DeriveAnyClass
15+ , DeriveGeneric
16+ , DerivingStrategies
17+ , FlexibleContexts
18+ , FlexibleInstances
19+ , GADTs
20+ , LambdaCase
21+ , MultiParamTypeClasses
22+ , OverloadedLabels
23+ , OverloadedStrings
24+ , RankNTypes
25+ , ScopedTypeVariables
26+ , TypeApplications
27+ , TypeInType
28+ , TypeOperators
29+ , UndecidableSuperClasses
30+#-}
31+
32+module Squeal.PostgreSQL.Definition.Index
33+ ( createIndex
34+ , createIndexIfNotExists
35+ , dropIndex
36+ , dropIndexIfExists
37+ , IndexMethod (..)
38+ , btree
39+ , hash
40+ , gist
41+ , spgist
42+ , gin
43+ , brin
44+ ) where
45+
46+import Data.ByteString
47+import GHC.TypeLits
48+
49+import qualified GHC.Generics as GHC
50+
51+import Squeal.PostgreSQL.Alias
52+import Squeal.PostgreSQL.Definition
53+import Squeal.PostgreSQL.Expression.Sort
54+import Squeal.PostgreSQL.Render
55+import Squeal.PostgreSQL.Schema
56+
57+-- $setup
58+-- >>> import Squeal.PostgreSQL
59+
60+{- |
61+>>> :{
62+type Table = '[] :=>
63+ '[ "a" ::: 'NoDef :=> 'Null 'PGint4
64+ , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]
65+:}
66+
67+>>> :{
68+let
69+ setup :: Definition (Public '[]) (Public '["tab" ::: 'Table Table, "ix" ::: 'Index 'Btree])
70+ setup =
71+ createTable #tab (nullable int `as` #a :* nullable real `as` #b) Nil >>>
72+ createIndex #ix #tab btree [#a & AscNullsFirst, #b & AscNullsLast]
73+in printSQL setup
74+:}
75+CREATE TABLE "tab" ("a" int NULL, "b" real NULL);
76+CREATE INDEX "ix" ON "tab" USING btree (("a") ASC NULLS FIRST, ("b") ASC NULLS LAST);
77+-}
78+createIndex
79+ :: (Has sch schemas schema, Has tab schema ('Table table), KnownSymbol ix)
80+ => Alias ix
81+ -> QualifiedAlias sch tab
82+ -> IndexMethod method
83+ -> [SortExpression '[] '[] 'Ungrouped schemas '[] '[tab ::: TableToRow table]]
84+ -> Definition schemas (Alter sch (Create ix ('Index method) schema) schemas)
85+createIndex ix tab method cols = UnsafeDefinition $
86+ "CREATE" <+> "INDEX" <+> renderSQL ix <+> "ON" <+> renderSQL tab
87+ <+> "USING" <+> renderSQL method
88+ <+> parenthesized (commaSeparated (renderIndex <$> cols))
89+ <> ";"
90+ where
91+ renderIndex = \case
92+ Asc expression -> parenthesized (renderSQL expression) <+> "ASC"
93+ Desc expression -> parenthesized (renderSQL expression) <+> "DESC"
94+ AscNullsFirst expression -> parenthesized (renderSQL expression)
95+ <+> "ASC NULLS FIRST"
96+ DescNullsFirst expression -> parenthesized (renderSQL expression)
97+ <+> "DESC NULLS FIRST"
98+ AscNullsLast expression -> parenthesized (renderSQL expression)
99+ <+> "ASC NULLS LAST"
100+ DescNullsLast expression -> parenthesized (renderSQL expression)
101+ <+> "DESC NULLS LAST"
102+
103+createIndexIfNotExists
104+ :: (Has sch schemas schema, Has tab schema ('Table table), KnownSymbol ix)
105+ => Alias ix
106+ -> QualifiedAlias sch tab
107+ -> IndexMethod method
108+ -> [SortExpression '[] '[] 'Ungrouped schemas '[] '[tab ::: TableToRow table]]
109+ -> Definition schemas (Alter sch (CreateIfNotExists ix ('Index method) schema) schemas)
110+createIndexIfNotExists ix tab method cols = UnsafeDefinition $
111+ "CREATE INDEX IF NOT EXISTS" <+> renderSQL ix <+> "ON" <+> renderSQL tab
112+ <+> "USING" <+> renderSQL method
113+ <+> parenthesized (commaSeparated (renderIndex <$> cols))
114+ <> ";"
115+ where
116+ renderIndex = \case
117+ Asc expression -> parenthesized (renderSQL expression) <+> "ASC"
118+ Desc expression -> parenthesized (renderSQL expression) <+> "DESC"
119+ AscNullsFirst expression -> parenthesized (renderSQL expression)
120+ <+> "ASC NULLS FIRST"
121+ DescNullsFirst expression -> parenthesized (renderSQL expression)
122+ <+> "DESC NULLS FIRST"
123+ AscNullsLast expression -> parenthesized (renderSQL expression)
124+ <+> "ASC NULLS LAST"
125+ DescNullsLast expression -> parenthesized (renderSQL expression)
126+ <+> "DESC NULLS LAST"
127+
128+newtype IndexMethod ty = UnsafeIndexMethod {renderIndexMethod :: ByteString}
129+ deriving stock (Eq, Ord, Show, GHC.Generic)
130+instance RenderSQL (IndexMethod ty) where renderSQL = renderIndexMethod
131+btree :: IndexMethod 'Btree
132+btree = UnsafeIndexMethod "btree"
133+hash :: IndexMethod 'Hash
134+hash = UnsafeIndexMethod "hash"
135+gist :: IndexMethod 'Gist
136+gist = UnsafeIndexMethod "gist"
137+spgist :: IndexMethod 'Spgist
138+spgist = UnsafeIndexMethod "spgist"
139+gin :: IndexMethod 'Gin
140+gin = UnsafeIndexMethod "gin"
141+brin :: IndexMethod 'Brin
142+brin = UnsafeIndexMethod "brin"
143+
144+-- |
145+-- >>> printSQL (dropIndex #ix :: Definition (Public '["ix" ::: 'Index 'Btree]) (Public '[]))
146+-- DROP INDEX "ix";
147+dropIndex
148+ :: (Has sch schemas schema, KnownSymbol ix)
149+ => QualifiedAlias sch ix
150+ -- ^ name of the user defined index
151+ -> Definition schemas (Alter sch (DropSchemum ix 'Index schema) schemas)
152+dropIndex ix = UnsafeDefinition $ "DROP" <+> "INDEX" <+> renderSQL ix <> ";"
153+
154+dropIndexIfExists
155+ :: (Has sch schemas schema, KnownSymbol ix)
156+ => QualifiedAlias sch ix
157+ -- ^ name of the user defined index
158+ -> Definition schemas (Alter sch (DropSchemumIfExists ix 'Index schema) schemas)
159+dropIndexIfExists ix = UnsafeDefinition $ "DROP INDEX IF EXISTS" <+> renderSQL ix <> ";"
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Schema.hsnew file+96
@@ -0,0 +1,96 @@
1+{-|
2+Module: Squeal.PostgreSQL.Definition.Schema
3+Description: Create and drop schema definitions
4+Copyright: (c) Eitan Chatav, 2017
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Create and drop schema definitions.
9+-}
10+
11+{-# LANGUAGE
12+ AllowAmbiguousTypes
13+ , ConstraintKinds
14+ , DeriveAnyClass
15+ , DeriveGeneric
16+ , DerivingStrategies
17+ , FlexibleContexts
18+ , FlexibleInstances
19+ , GADTs
20+ , LambdaCase
21+ , MultiParamTypeClasses
22+ , OverloadedLabels
23+ , OverloadedStrings
24+ , RankNTypes
25+ , ScopedTypeVariables
26+ , TypeApplications
27+ , TypeInType
28+ , TypeOperators
29+ , UndecidableSuperClasses
30+#-}
31+
32+module Squeal.PostgreSQL.Definition.Schema
33+ ( createSchema
34+ , createSchemaIfNotExists
35+ , dropSchema
36+ , dropSchemaIfExists
37+ ) where
38+
39+import GHC.TypeLits
40+
41+import Squeal.PostgreSQL.Alias
42+import Squeal.PostgreSQL.Definition
43+import Squeal.PostgreSQL.Render
44+import Squeal.PostgreSQL.Schema
45+
46+-- $setup
47+-- >>> import Squeal.PostgreSQL
48+
49+{- |
50+`createSchema` enters a new schema into the current database.
51+The schema name must be distinct from the name of any existing schema
52+in the current database.
53+
54+A schema is essentially a namespace: it contains named objects
55+(tables, data types, functions, and operators) whose names
56+can duplicate those of other objects existing in other schemas.
57+Named objects are accessed by `QualifiedAlias`es with the schema
58+name as a prefix.
59+-}
60+createSchema
61+ :: KnownSymbol sch
62+ => Alias sch
63+ -> Definition schemas (Create sch '[] schemas)
64+createSchema sch = UnsafeDefinition $
65+ "CREATE" <+> "SCHEMA" <+> renderSQL sch <> ";"
66+
67+{- | Idempotent version of `createSchema`. -}
68+createSchemaIfNotExists
69+ :: (KnownSymbol sch, Has sch schemas schema)
70+ => Alias sch
71+ -> Definition schemas (CreateIfNotExists sch '[] schemas)
72+createSchemaIfNotExists sch = UnsafeDefinition $
73+ "CREATE" <+> "SCHEMA" <+> "IF" <+> "NOT" <+> "EXISTS"
74+ <+> renderSQL sch <> ";"
75+
76+-- | >>> :{
77+-- let
78+-- definition :: Definition '["muh_schema" ::: schema, "public" ::: public] '["public" ::: public]
79+-- definition = dropSchema #muh_schema
80+-- :}
81+--
82+-- >>> printSQL definition
83+-- DROP SCHEMA "muh_schema";
84+dropSchema
85+ :: KnownSymbol sch
86+ => Alias sch
87+ -- ^ user defined schema
88+ -> Definition schemas (Drop sch schemas)
89+dropSchema sch = UnsafeDefinition $ "DROP SCHEMA" <+> renderSQL sch <> ";"
90+
91+dropSchemaIfExists
92+ :: KnownSymbol sch
93+ => Alias sch
94+ -- ^ user defined schema
95+ -> Definition schemas (DropIfExists sch schemas)
96+dropSchemaIfExists sch = UnsafeDefinition $ "DROP SCHEMA" <+> renderSQL sch <> ";"
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Table.hsnew file+500
@@ -0,0 +1,500 @@
1+{-|
2+Module: Squeal.PostgreSQL.Definition.Table
3+Description: Create, drop and alter table definitions
4+Copyright: (c) Eitan Chatav, 2017
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Create, drop and alter table definitions.
9+-}
10+
11+{-# LANGUAGE
12+ AllowAmbiguousTypes
13+ , ConstraintKinds
14+ , DeriveAnyClass
15+ , DeriveGeneric
16+ , DerivingStrategies
17+ , FlexibleContexts
18+ , FlexibleInstances
19+ , GADTs
20+ , LambdaCase
21+ , MultiParamTypeClasses
22+ , OverloadedLabels
23+ , OverloadedStrings
24+ , RankNTypes
25+ , ScopedTypeVariables
26+ , TypeApplications
27+ , TypeInType
28+ , TypeOperators
29+ , UndecidableSuperClasses
30+#-}
31+
32+module Squeal.PostgreSQL.Definition.Table
33+ ( createTable
34+ , createTableIfNotExists
35+ , dropTable
36+ , dropTableIfExists
37+ , alterTable
38+ , alterTableIfExists
39+ , alterTableRename
40+ , alterTableIfExistsRename
41+ , AlterTable (..)
42+ , addConstraint
43+ , dropConstraint
44+ , AddColumn (..)
45+ , dropColumn
46+ , renameColumn
47+ , alterColumn
48+ , AlterColumn (..)
49+ , setDefault
50+ , dropDefault
51+ , setNotNull
52+ , dropNotNull
53+ , alterType
54+ ) where
55+
56+import Control.DeepSeq
57+import Data.ByteString
58+import GHC.TypeLits
59+
60+import qualified Generics.SOP as SOP
61+import qualified GHC.Generics as GHC
62+
63+import Squeal.PostgreSQL.Alias
64+import Squeal.PostgreSQL.Definition
65+import Squeal.PostgreSQL.Definition.Table.Constraint
66+import Squeal.PostgreSQL.Expression
67+import Squeal.PostgreSQL.Expression.Type
68+import Squeal.PostgreSQL.List
69+import Squeal.PostgreSQL.Render
70+import Squeal.PostgreSQL.Schema
71+
72+-- $setup
73+-- >>> import Squeal.PostgreSQL
74+
75+{- | `createTable` adds a table to the schema.
76+
77+>>> :set -XOverloadedLabels
78+>>> :{
79+type Table = '[] :=>
80+ '[ "a" ::: 'NoDef :=> 'Null 'PGint4
81+ , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]
82+:}
83+
84+>>> :{
85+let
86+ setup :: Definition (Public '[]) (Public '["tab" ::: 'Table Table])
87+ setup = createTable #tab
88+ (nullable int `as` #a :* nullable real `as` #b) Nil
89+in printSQL setup
90+:}
91+CREATE TABLE "tab" ("a" int NULL, "b" real NULL);
92+-}
93+createTable
94+ :: ( KnownSymbol sch
95+ , KnownSymbol tab
96+ , columns ~ (col ': cols)
97+ , SOP.SListI columns
98+ , SOP.SListI constraints
99+ , Has sch schemas0 schema0
100+ , schemas1 ~ Alter sch (Create tab ('Table (constraints :=> columns)) schema0) schemas0 )
101+ => QualifiedAlias sch tab -- ^ the name of the table to add
102+ -> NP (Aliased (ColumnTypeExpression schemas0)) columns
103+ -- ^ the names and datatype of each column
104+ -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints
105+ -- ^ constraints that must hold for the table
106+ -> Definition schemas0 schemas1
107+createTable tab columns constraints = UnsafeDefinition $
108+ "CREATE TABLE" <+> renderCreation tab columns constraints
109+
110+{-| `createTableIfNotExists` creates a table if it doesn't exist, but does not add it to the schema.
111+Instead, the schema already has the table so if the table did not yet exist, the schema was wrong.
112+`createTableIfNotExists` fixes this. Interestingly, this property makes it an idempotent in
113+the `Category` of `Definition`s.
114+
115+>>> :set -XOverloadedLabels -XTypeApplications
116+>>> :{
117+type Table = '[] :=>
118+ '[ "a" ::: 'NoDef :=> 'Null 'PGint4
119+ , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]
120+:}
121+
122+>>> type Schemas = Public '["tab" ::: 'Table Table]
123+
124+>>> :{
125+let
126+ setup :: Definition Schemas Schemas
127+ setup = createTableIfNotExists #tab
128+ (nullable int `as` #a :* nullable real `as` #b) Nil
129+in printSQL setup
130+:}
131+CREATE TABLE IF NOT EXISTS "tab" ("a" int NULL, "b" real NULL);
132+-}
133+createTableIfNotExists
134+ :: ( KnownSymbol sch
135+ , KnownSymbol tab
136+ , columns ~ (col ': cols)
137+ , SOP.SListI columns
138+ , SOP.SListI constraints
139+ , Has sch schemas0 schema0
140+ , schemas1 ~ Alter sch (CreateIfNotExists tab ('Table (constraints :=> columns)) schema0) schemas0 )
141+ => QualifiedAlias sch tab -- ^ the name of the table to add
142+ -> NP (Aliased (ColumnTypeExpression schemas0)) columns
143+ -- ^ the names and datatype of each column
144+ -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints
145+ -- ^ constraints that must hold for the table
146+ -> Definition schemas0 schemas1
147+createTableIfNotExists tab columns constraints = UnsafeDefinition $
148+ "CREATE TABLE IF NOT EXISTS"
149+ <+> renderCreation tab columns constraints
150+
151+-- helper function for `createTable` and `createTableIfNotExists`
152+renderCreation
153+ :: ( KnownSymbol sch
154+ , KnownSymbol tab
155+ , SOP.SListI columns
156+ , SOP.SListI constraints )
157+ => QualifiedAlias sch tab -- ^ the name of the table to add
158+ -> NP (Aliased (ColumnTypeExpression schemas0)) columns
159+ -- ^ the names and datatype of each column
160+ -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints
161+ -- ^ constraints that must hold for the table
162+ -> ByteString
163+renderCreation tab columns constraints = renderSQL tab
164+ <+> parenthesized
165+ ( renderCommaSeparated renderColumnDef columns
166+ <> ( case constraints of
167+ Nil -> ""
168+ _ -> ", " <>
169+ renderCommaSeparated renderConstraint constraints ) )
170+ <> ";"
171+ where
172+ renderColumnDef :: Aliased (ColumnTypeExpression schemas) x -> ByteString
173+ renderColumnDef (ty `As` column) =
174+ renderSQL column <+> renderColumnTypeExpression ty
175+ renderConstraint
176+ :: Aliased (TableConstraintExpression sch tab schemas) constraint
177+ -> ByteString
178+ renderConstraint (constraint `As` alias) =
179+ "CONSTRAINT" <+> renderSQL alias <+> renderSQL constraint
180+
181+-- | `dropTable` removes a table from the schema.
182+--
183+-- >>> :{
184+-- let
185+-- definition :: Definition '["public" ::: '["muh_table" ::: 'Table t]] (Public '[])
186+-- definition = dropTable #muh_table
187+-- :}
188+--
189+-- >>> printSQL definition
190+-- DROP TABLE "muh_table";
191+dropTable
192+ :: ( Has sch schemas schema
193+ , KnownSymbol tab )
194+ => QualifiedAlias sch tab -- ^ table to remove
195+ -> Definition schemas (Alter sch (DropSchemum tab 'Table schema) schemas)
196+dropTable tab = UnsafeDefinition $ "DROP TABLE" <+> renderSQL tab <> ";"
197+
198+dropTableIfExists
199+ :: ( Has sch schemas schema
200+ , KnownSymbol tab)
201+ => QualifiedAlias sch tab -- ^ table to remove
202+ -> Definition schemas (Alter sch (DropSchemumIfExists tab 'Table schema) schemas)
203+dropTableIfExists tab = UnsafeDefinition $ "DROP TABLE IF EXISTS" <+> renderSQL tab <> ";"
204+
205+-- | `alterTable` changes the definition of a table from the schema.
206+alterTable
207+ :: (Has sch schemas schema, KnownSymbol tab)
208+ => QualifiedAlias sch tab -- ^ table to alter
209+ -> AlterTable sch tab schemas table -- ^ alteration to perform
210+ -> Definition schemas (Alter sch (Alter tab ('Table table) schema) schemas)
211+alterTable tab alteration = UnsafeDefinition $
212+ "ALTER TABLE"
213+ <+> renderSQL tab
214+ <+> renderAlterTable alteration
215+ <> ";"
216+
217+-- | `alterTable` changes the definition of a table from the schema.
218+alterTableIfExists
219+ :: (Has sch schemas schema, KnownSymbol tab)
220+ => QualifiedAlias sch tab -- ^ table to alter
221+ -> AlterTable sch tab schemas table -- ^ alteration to perform
222+ -> Definition schemas (Alter sch (AlterIfExists tab ('Table table) schema) schemas)
223+alterTableIfExists tab alteration = UnsafeDefinition $
224+ "ALTER TABLE IF EXISTS"
225+ <+> renderSQL tab
226+ <+> renderAlterTable alteration
227+ <> ";"
228+
229+-- | `alterTableRename` changes the name of a table from the schema.
230+--
231+-- >>> printSQL $ alterTableRename #foo #bar
232+-- ALTER TABLE "foo" RENAME TO "bar";
233+alterTableRename
234+ :: (KnownSymbol tab0, KnownSymbol tab1)
235+ => Alias tab0 -- ^ table to rename
236+ -> Alias tab1 -- ^ what to rename it
237+ -> Definition schema (Rename tab0 tab1 schema)
238+alterTableRename tab0 tab1 = UnsafeDefinition $
239+ "ALTER TABLE" <+> renderSQL tab0
240+ <+> "RENAME TO" <+> renderSQL tab1 <> ";"
241+
242+alterTableIfExistsRename
243+ :: (KnownSymbol tab0, KnownSymbol tab1)
244+ => Alias tab0 -- ^ table to rename
245+ -> Alias tab1 -- ^ what to rename it
246+ -> Definition schema (RenameIfExists tab0 tab1 schema)
247+alterTableIfExistsRename tab0 tab1 = UnsafeDefinition $
248+ "ALTER TABLE IF EXISTS" <+> renderSQL tab0
249+ <+> "RENAME TO" <+> renderSQL tab1 <> ";"
250+
251+-- | An `AlterTable` describes the alteration to perform on the columns
252+-- of a table.
253+newtype AlterTable
254+ (sch :: Symbol)
255+ (tab :: Symbol)
256+ (schemas :: SchemasType)
257+ (table :: TableType) =
258+ UnsafeAlterTable {renderAlterTable :: ByteString}
259+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
260+
261+-- | An `addConstraint` adds a table constraint.
262+--
263+-- >>> :{
264+-- let
265+-- definition :: Definition
266+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
267+-- '["public" ::: '["tab" ::: 'Table ('["positive" ::: 'Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
268+-- definition = alterTable #tab (addConstraint #positive (check #col (#col .> 0)))
269+-- in printSQL definition
270+-- :}
271+-- ALTER TABLE "tab" ADD CONSTRAINT "positive" CHECK (("col" > 0));
272+addConstraint
273+ :: ( KnownSymbol alias
274+ , Has sch schemas schema
275+ , Has tab schema ('Table table0)
276+ , table0 ~ (constraints :=> columns)
277+ , table1 ~ (Create alias constraint constraints :=> columns) )
278+ => Alias alias
279+ -> TableConstraintExpression sch tab schemas constraint
280+ -- ^ constraint to add
281+ -> AlterTable sch tab schemas table1
282+addConstraint alias constraint = UnsafeAlterTable $
283+ "ADD" <+> "CONSTRAINT" <+> renderSQL alias
284+ <+> renderSQL constraint
285+
286+-- | A `dropConstraint` drops a table constraint.
287+--
288+-- >>> :{
289+-- let
290+-- definition :: Definition
291+-- '["public" ::: '["tab" ::: 'Table ('["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
292+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
293+-- definition = alterTable #tab (dropConstraint #positive)
294+-- in printSQL definition
295+-- :}
296+-- ALTER TABLE "tab" DROP CONSTRAINT "positive";
297+dropConstraint
298+ :: ( KnownSymbol constraint
299+ , Has sch schemas schema
300+ , Has tab schema ('Table table0)
301+ , table0 ~ (constraints :=> columns)
302+ , table1 ~ (Drop constraint constraints :=> columns) )
303+ => Alias constraint
304+ -- ^ constraint to drop
305+ -> AlterTable sch tab schemas table1
306+dropConstraint constraint = UnsafeAlterTable $
307+ "DROP" <+> "CONSTRAINT" <+> renderSQL constraint
308+
309+-- | An `AddColumn` is either @NULL@ or has @DEFAULT@.
310+class AddColumn ty where
311+ -- | `addColumn` adds a new column, initially filled with whatever
312+ -- default value is given or with @NULL@.
313+ --
314+ -- >>> :{
315+ -- let
316+ -- definition :: Definition
317+ -- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]
318+ -- '["public" ::: '["tab" ::: 'Table ('[] :=>
319+ -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
320+ -- , "col2" ::: 'Def :=> 'Null 'PGtext ])]]
321+ -- definition = alterTable #tab (addColumn #col2 (text & nullable & default_ "foo"))
322+ -- in printSQL definition
323+ -- :}
324+ -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL DEFAULT E'foo';
325+ --
326+ -- >>> :{
327+ -- let
328+ -- definition :: Definition
329+ -- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]
330+ -- '["public" ::: '["tab" ::: 'Table ('[] :=>
331+ -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
332+ -- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]]
333+ -- definition = alterTable #tab (addColumn #col2 (text & nullable))
334+ -- in printSQL definition
335+ -- :}
336+ -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL;
337+ addColumn
338+ :: ( KnownSymbol column
339+ , Has sch schemas schema
340+ , Has tab schema ('Table table0)
341+ , table0 ~ (constraints :=> columns) )
342+ => Alias column -- ^ column to add
343+ -> ColumnTypeExpression schemas ty -- ^ type of the new column
344+ -> AlterTable sch tab schemas (constraints :=> Create column ty columns)
345+ addColumn column ty = UnsafeAlterTable $
346+ "ADD COLUMN" <+> renderSQL column <+> renderColumnTypeExpression ty
347+instance {-# OVERLAPPING #-} AddColumn ('Def :=> ty)
348+instance {-# OVERLAPPABLE #-} AddColumn ('NoDef :=> 'Null ty)
349+
350+-- | A `dropColumn` removes a column. Whatever data was in the column
351+-- disappears. Table constraints involving the column are dropped, too.
352+-- However, if the column is referenced by a foreign key constraint of
353+-- another table, PostgreSQL will not silently drop that constraint.
354+--
355+-- >>> :{
356+-- let
357+-- definition :: Definition
358+-- '["public" ::: '["tab" ::: 'Table ('[] :=>
359+-- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
360+-- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]]
361+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]
362+-- definition = alterTable #tab (dropColumn #col2)
363+-- in printSQL definition
364+-- :}
365+-- ALTER TABLE "tab" DROP COLUMN "col2";
366+dropColumn
367+ :: ( KnownSymbol column
368+ , Has sch schemas schema
369+ , Has tab schema ('Table table0)
370+ , table0 ~ (constraints :=> columns)
371+ , table1 ~ (constraints :=> Drop column columns) )
372+ => Alias column -- ^ column to remove
373+ -> AlterTable sch tab schemas table1
374+dropColumn column = UnsafeAlterTable $
375+ "DROP COLUMN" <+> renderSQL column
376+
377+-- | A `renameColumn` renames a column.
378+--
379+-- >>> :{
380+-- let
381+-- definition :: Definition
382+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["foo" ::: 'NoDef :=> 'Null 'PGint4])]]
383+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["bar" ::: 'NoDef :=> 'Null 'PGint4])]]
384+-- definition = alterTable #tab (renameColumn #foo #bar)
385+-- in printSQL definition
386+-- :}
387+-- ALTER TABLE "tab" RENAME COLUMN "foo" TO "bar";
388+renameColumn
389+ :: ( KnownSymbol column0
390+ , KnownSymbol column1
391+ , Has sch schemas schema
392+ , Has tab schema ('Table table0)
393+ , table0 ~ (constraints :=> columns)
394+ , table1 ~ (constraints :=> Rename column0 column1 columns) )
395+ => Alias column0 -- ^ column to rename
396+ -> Alias column1 -- ^ what to rename the column
397+ -> AlterTable sch tab schemas table1
398+renameColumn column0 column1 = UnsafeAlterTable $
399+ "RENAME COLUMN" <+> renderSQL column0 <+> "TO" <+> renderSQL column1
400+
401+-- | An `alterColumn` alters a single column.
402+alterColumn
403+ :: ( KnownSymbol column
404+ , Has sch schemas schema
405+ , Has tab schema ('Table table0)
406+ , table0 ~ (constraints :=> columns)
407+ , Has column columns ty0
408+ , table1 ~ (constraints :=> Alter column ty1 columns))
409+ => Alias column -- ^ column to alter
410+ -> AlterColumn schemas ty0 ty1 -- ^ alteration to perform
411+ -> AlterTable sch tab schemas table1
412+alterColumn column alteration = UnsafeAlterTable $
413+ "ALTER COLUMN" <+> renderSQL column <+> renderAlterColumn alteration
414+
415+-- | An `AlterColumn` describes the alteration to perform on a single column.
416+newtype AlterColumn (schemas :: SchemasType) (ty0 :: ColumnType) (ty1 :: ColumnType) =
417+ UnsafeAlterColumn {renderAlterColumn :: ByteString}
418+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
419+
420+-- | A `setDefault` sets a new default for a column. Note that this doesn't
421+-- affect any existing rows in the table, it just changes the default for
422+-- future insert and update commands.
423+--
424+-- >>> :{
425+-- let
426+-- definition :: Definition
427+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
428+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]]
429+-- definition = alterTable #tab (alterColumn #col (setDefault 5))
430+-- in printSQL definition
431+-- :}
432+-- ALTER TABLE "tab" ALTER COLUMN "col" SET DEFAULT 5;
433+setDefault
434+ :: Expression '[] '[] 'Ungrouped schemas '[] '[] ty -- ^ default value to set
435+ -> AlterColumn schemas (constraint :=> ty) ('Def :=> ty)
436+setDefault expression = UnsafeAlterColumn $
437+ "SET DEFAULT" <+> renderExpression expression
438+
439+-- | A `dropDefault` removes any default value for a column.
440+--
441+-- >>> :{
442+-- let
443+-- definition :: Definition
444+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]]
445+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
446+-- definition = alterTable #tab (alterColumn #col dropDefault)
447+-- in printSQL definition
448+-- :}
449+-- ALTER TABLE "tab" ALTER COLUMN "col" DROP DEFAULT;
450+dropDefault :: AlterColumn schemas ('Def :=> ty) ('NoDef :=> ty)
451+dropDefault = UnsafeAlterColumn $ "DROP DEFAULT"
452+
453+-- | A `setNotNull` adds a @NOT NULL@ constraint to a column.
454+-- The constraint will be checked immediately, so the table data must satisfy
455+-- the constraint before it can be added.
456+--
457+-- >>> :{
458+-- let
459+-- definition :: Definition
460+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
461+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
462+-- definition = alterTable #tab (alterColumn #col setNotNull)
463+-- in printSQL definition
464+-- :}
465+-- ALTER TABLE "tab" ALTER COLUMN "col" SET NOT NULL;
466+setNotNull
467+ :: AlterColumn schemas (constraint :=> 'Null ty) (constraint :=> 'NotNull ty)
468+setNotNull = UnsafeAlterColumn $ "SET NOT NULL"
469+
470+-- | A `dropNotNull` drops a @NOT NULL@ constraint from a column.
471+--
472+-- >>> :{
473+-- let
474+-- definition :: Definition
475+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
476+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
477+-- definition = alterTable #tab (alterColumn #col dropNotNull)
478+-- in printSQL definition
479+-- :}
480+-- ALTER TABLE "tab" ALTER COLUMN "col" DROP NOT NULL;
481+dropNotNull
482+ :: AlterColumn schemas (constraint :=> 'NotNull ty) (constraint :=> 'Null ty)
483+dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL"
484+
485+-- | An `alterType` converts a column to a different data type.
486+-- This will succeed only if each existing entry in the column can be
487+-- converted to the new type by an implicit cast.
488+--
489+-- >>> :{
490+-- let
491+-- definition :: Definition
492+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
493+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGnumeric])]]
494+-- definition =
495+-- alterTable #tab (alterColumn #col (alterType (numeric & notNullable)))
496+-- in printSQL definition
497+-- :}
498+-- ALTER TABLE "tab" ALTER COLUMN "col" TYPE numeric NOT NULL;
499+alterType :: ColumnTypeExpression schemas ty -> AlterColumn schemas ty0 ty
500+alterType ty = UnsafeAlterColumn $ "TYPE" <+> renderColumnTypeExpression ty
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Table/Constraint.hsnew file+339
@@ -0,0 +1,339 @@
1+{-|
2+Module: Squeal.PostgreSQL.Definition.Table.Constraint
3+Description: Table constraint expressions
4+Copyright: (c) Eitan Chatav, 2017
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Table constraint expressions.
9+-}
10+
11+{-# LANGUAGE
12+ AllowAmbiguousTypes
13+ , ConstraintKinds
14+ , DeriveAnyClass
15+ , DeriveGeneric
16+ , DerivingStrategies
17+ , FlexibleContexts
18+ , FlexibleInstances
19+ , GADTs
20+ , LambdaCase
21+ , MultiParamTypeClasses
22+ , OverloadedLabels
23+ , OverloadedStrings
24+ , RankNTypes
25+ , ScopedTypeVariables
26+ , TypeApplications
27+ , TypeInType
28+ , TypeOperators
29+ , UndecidableSuperClasses
30+#-}
31+
32+module Squeal.PostgreSQL.Definition.Table.Constraint
33+ ( TableConstraintExpression (..)
34+ , check
35+ , unique
36+ , primaryKey
37+ , foreignKey
38+ , ForeignKeyed
39+ , OnDeleteClause (..)
40+ , OnUpdateClause (..)
41+ ) where
42+
43+import Control.DeepSeq
44+import Data.ByteString
45+import GHC.TypeLits
46+
47+import qualified Generics.SOP as SOP
48+import qualified GHC.Generics as GHC
49+
50+import Squeal.PostgreSQL.Alias
51+import Squeal.PostgreSQL.Expression.Logic
52+import Squeal.PostgreSQL.List
53+import Squeal.PostgreSQL.Render
54+import Squeal.PostgreSQL.Schema
55+
56+-- $setup
57+-- >>> import Squeal.PostgreSQL
58+
59+-- | Data types are a way to limit the kind of data that can be stored in a
60+-- table. For many applications, however, the constraint they provide is
61+-- too coarse. For example, a column containing a product price should
62+-- probably only accept positive values. But there is no standard data type
63+-- that accepts only positive numbers. Another issue is that you might want
64+-- to constrain column data with respect to other columns or rows.
65+-- For example, in a table containing product information,
66+-- there should be only one row for each product number.
67+-- `TableConstraint`s give you as much control over the data in your tables
68+-- as you wish. If a user attempts to store data in a column that would
69+-- violate a constraint, an error is raised. This applies
70+-- even if the value came from the default value definition.
71+newtype TableConstraintExpression
72+ (sch :: Symbol)
73+ (tab :: Symbol)
74+ (schemas :: SchemasType)
75+ (constraint :: TableConstraint)
76+ = UnsafeTableConstraintExpression
77+ { renderTableConstraintExpression :: ByteString }
78+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
79+instance RenderSQL
80+ (TableConstraintExpression sch tab schemas constraint) where
81+ renderSQL = renderTableConstraintExpression
82+
83+{-| A `check` constraint is the most generic `TableConstraint` type.
84+It allows you to specify that the value in a certain column must satisfy
85+a Boolean (truth-value) expression.
86+
87+>>> :{
88+type Schema = '[
89+ "tab" ::: 'Table ('[ "inequality" ::: 'Check '["a","b"]] :=> '[
90+ "a" ::: 'NoDef :=> 'NotNull 'PGint4,
91+ "b" ::: 'NoDef :=> 'NotNull 'PGint4
92+ ])]
93+:}
94+
95+>>> :{
96+let
97+ definition :: Definition (Public '[]) (Public Schema)
98+ definition = createTable #tab
99+ ( (int & notNullable) `as` #a :*
100+ (int & notNullable) `as` #b )
101+ ( check (#a :* #b) (#a .> #b) `as` #inequality )
102+:}
103+
104+>>> printSQL definition
105+CREATE TABLE "tab" ("a" int NOT NULL, "b" int NOT NULL, CONSTRAINT "inequality" CHECK (("a" > "b")));
106+-}
107+check
108+ :: ( Has sch schemas schema
109+ , Has tab schema ('Table table)
110+ , HasAll aliases (TableToRow table) subcolumns )
111+ => NP Alias aliases
112+ -- ^ specify the subcolumns which are getting checked
113+ -> (forall t. Condition '[] '[] 'Ungrouped schemas '[] '[t ::: subcolumns])
114+ -- ^ a closed `Condition` on those subcolumns
115+ -> TableConstraintExpression sch tab schemas ('Check aliases)
116+check _cols condition = UnsafeTableConstraintExpression $
117+ "CHECK" <+> parenthesized (renderSQL condition)
118+
119+{-| A `unique` constraint ensure that the data contained in a column,
120+or a group of columns, is unique among all the rows in the table.
121+
122+>>> :{
123+type Schema = '[
124+ "tab" ::: 'Table( '[ "uq_a_b" ::: 'Unique '["a","b"]] :=> '[
125+ "a" ::: 'NoDef :=> 'Null 'PGint4,
126+ "b" ::: 'NoDef :=> 'Null 'PGint4
127+ ])]
128+:}
129+
130+>>> :{
131+let
132+ definition :: Definition (Public '[]) (Public Schema)
133+ definition = createTable #tab
134+ ( (int & nullable) `as` #a :*
135+ (int & nullable) `as` #b )
136+ ( unique (#a :* #b) `as` #uq_a_b )
137+:}
138+
139+>>> printSQL definition
140+CREATE TABLE "tab" ("a" int NULL, "b" int NULL, CONSTRAINT "uq_a_b" UNIQUE ("a", "b"));
141+-}
142+unique
143+ :: ( Has sch schemas schema
144+ , Has tab schema('Table table)
145+ , HasAll aliases (TableToRow table) subcolumns )
146+ => NP Alias aliases
147+ -- ^ specify subcolumns which together are unique for each row
148+ -> TableConstraintExpression sch tab schemas ('Unique aliases)
149+unique columns = UnsafeTableConstraintExpression $
150+ "UNIQUE" <+> parenthesized (renderSQL columns)
151+
152+{-| A `primaryKey` constraint indicates that a column, or group of columns,
153+can be used as a unique identifier for rows in the table.
154+This requires that the values be both unique and not null.
155+
156+>>> :{
157+type Schema = '[
158+ "tab" ::: 'Table ('[ "pk_id" ::: 'PrimaryKey '["id"]] :=> '[
159+ "id" ::: 'Def :=> 'NotNull 'PGint4,
160+ "name" ::: 'NoDef :=> 'NotNull 'PGtext
161+ ])]
162+:}
163+
164+>>> :{
165+let
166+ definition :: Definition (Public '[]) (Public Schema)
167+ definition = createTable #tab
168+ ( serial `as` #id :*
169+ (text & notNullable) `as` #name )
170+ ( primaryKey #id `as` #pk_id )
171+:}
172+
173+>>> printSQL definition
174+CREATE TABLE "tab" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_id" PRIMARY KEY ("id"));
175+-}
176+primaryKey
177+ :: ( Has sch schemas schema
178+ , Has tab schema ('Table table)
179+ , HasAll aliases (TableToColumns table) subcolumns
180+ , AllNotNull subcolumns )
181+ => NP Alias aliases
182+ -- ^ specify the subcolumns which together form a primary key.
183+ -> TableConstraintExpression sch tab schemas ('PrimaryKey aliases)
184+primaryKey columns = UnsafeTableConstraintExpression $
185+ "PRIMARY KEY" <+> parenthesized (renderSQL columns)
186+
187+{-| A `foreignKey` specifies that the values in a column
188+(or a group of columns) must match the values appearing in some row of
189+another table. We say this maintains the referential integrity
190+between two related tables.
191+
192+>>> :{
193+type Schema =
194+ '[ "users" ::: 'Table (
195+ '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
196+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
197+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext
198+ ])
199+ , "emails" ::: 'Table (
200+ '[ "pk_emails" ::: 'PrimaryKey '["id"]
201+ , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
202+ ] :=>
203+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
204+ , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
205+ , "email" ::: 'NoDef :=> 'Null 'PGtext
206+ ])
207+ ]
208+:}
209+
210+>>> :{
211+let
212+ setup :: Definition (Public '[]) (Public Schema)
213+ setup =
214+ createTable #users
215+ ( serial `as` #id :*
216+ (text & notNullable) `as` #name )
217+ ( primaryKey #id `as` #pk_users ) >>>
218+ createTable #emails
219+ ( serial `as` #id :*
220+ (int & notNullable) `as` #user_id :*
221+ (text & nullable) `as` #email )
222+ ( primaryKey #id `as` #pk_emails :*
223+ foreignKey #user_id #users #id
224+ OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
225+in printSQL setup
226+:}
227+CREATE TABLE "users" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_users" PRIMARY KEY ("id"));
228+CREATE TABLE "emails" ("id" serial, "user_id" int NOT NULL, "email" text NULL, CONSTRAINT "pk_emails" PRIMARY KEY ("id"), CONSTRAINT "fk_user_id" FOREIGN KEY ("user_id") REFERENCES "users" ("id") ON DELETE CASCADE ON UPDATE CASCADE);
229+
230+A `foreignKey` can even be a table self-reference.
231+
232+>>> :{
233+type Schema =
234+ '[ "employees" ::: 'Table (
235+ '[ "employees_pk" ::: 'PrimaryKey '["id"]
236+ , "employees_employer_fk" ::: 'ForeignKey '["employer_id"] "employees" '["id"]
237+ ] :=>
238+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
239+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext
240+ , "employer_id" ::: 'NoDef :=> 'Null 'PGint4
241+ ])
242+ ]
243+:}
244+
245+>>> :{
246+let
247+ setup :: Definition (Public '[]) (Public Schema)
248+ setup =
249+ createTable #employees
250+ ( serial `as` #id :*
251+ (text & notNullable) `as` #name :*
252+ (integer & nullable) `as` #employer_id )
253+ ( primaryKey #id `as` #employees_pk :*
254+ foreignKey #employer_id #employees #id
255+ OnDeleteCascade OnUpdateCascade `as` #employees_employer_fk )
256+in printSQL setup
257+:}
258+CREATE TABLE "employees" ("id" serial, "name" text NOT NULL, "employer_id" integer NULL, CONSTRAINT "employees_pk" PRIMARY KEY ("id"), CONSTRAINT "employees_employer_fk" FOREIGN KEY ("employer_id") REFERENCES "employees" ("id") ON DELETE CASCADE ON UPDATE CASCADE);
259+-}
260+foreignKey
261+ :: (ForeignKeyed schemas sch schema child parent
262+ table reftable
263+ columns refcolumns
264+ constraints cols
265+ reftys tys )
266+ => NP Alias columns
267+ -- ^ column or columns in the table
268+ -> Alias parent
269+ -- ^ reference table
270+ -> NP Alias refcolumns
271+ -- ^ reference column or columns in the reference table
272+ -> OnDeleteClause
273+ -- ^ what to do when reference is deleted
274+ -> OnUpdateClause
275+ -- ^ what to do when reference is updated
276+ -> TableConstraintExpression sch child schemas
277+ ('ForeignKey columns parent refcolumns)
278+foreignKey keys parent refs ondel onupd = UnsafeTableConstraintExpression $
279+ "FOREIGN KEY" <+> parenthesized (renderSQL keys)
280+ <+> "REFERENCES" <+> renderSQL parent
281+ <+> parenthesized (renderSQL refs)
282+ <+> renderSQL ondel
283+ <+> renderSQL onupd
284+
285+-- | A constraint synonym between types involved in a foreign key constraint.
286+type ForeignKeyed schemas
287+ sch
288+ schema
289+ child parent
290+ table reftable
291+ columns refcolumns
292+ constraints cols
293+ reftys tys =
294+ ( Has sch schemas schema
295+ , Has child schema ('Table table)
296+ , Has parent schema ('Table reftable)
297+ , HasAll columns (TableToColumns table) tys
298+ , reftable ~ (constraints :=> cols)
299+ , HasAll refcolumns cols reftys
300+ , SOP.AllZip SamePGType tys reftys
301+ , Uniquely refcolumns constraints )
302+
303+-- | `OnDeleteClause` indicates what to do with rows that reference a deleted row.
304+data OnDeleteClause
305+ = OnDeleteNoAction
306+ -- ^ if any referencing rows still exist when the constraint is checked,
307+ -- an error is raised
308+ | OnDeleteRestrict -- ^ prevents deletion of a referenced row
309+ | OnDeleteCascade
310+ -- ^ specifies that when a referenced row is deleted,
311+ -- row(s) referencing it should be automatically deleted as well
312+ deriving (GHC.Generic,Show,Eq,Ord)
313+instance NFData OnDeleteClause
314+-- | Render `OnDeleteClause`.
315+instance RenderSQL OnDeleteClause where
316+ renderSQL = \case
317+ OnDeleteNoAction -> "ON DELETE NO ACTION"
318+ OnDeleteRestrict -> "ON DELETE RESTRICT"
319+ OnDeleteCascade -> "ON DELETE CASCADE"
320+
321+-- | Analagous to `OnDeleteClause` there is also `OnUpdateClause` which is invoked
322+-- when a referenced column is changed (updated).
323+data OnUpdateClause
324+ = OnUpdateNoAction
325+ -- ^ if any referencing rows has not changed when the constraint is checked,
326+ -- an error is raised
327+ | OnUpdateRestrict -- ^ prevents update of a referenced row
328+ | OnUpdateCascade
329+ -- ^ the updated values of the referenced column(s) should be copied
330+ -- into the referencing row(s)
331+ deriving (GHC.Generic,Show,Eq,Ord)
332+instance NFData OnUpdateClause
333+
334+-- | Render `OnUpdateClause`.
335+instance RenderSQL OnUpdateClause where
336+ renderSQL = \case
337+ OnUpdateNoAction -> "ON UPDATE NO ACTION"
338+ OnUpdateRestrict -> "ON UPDATE RESTRICT"
339+ OnUpdateCascade -> "ON UPDATE CASCADE"
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Type.hsnew file+229
@@ -0,0 +1,229 @@
1+{-|
2+Module: Squeal.PostgreSQL.Definition.Type
3+Description: Create and drop type definitions
4+Copyright: (c) Eitan Chatav, 2017
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Create and drop type definitions.
9+-}
10+
11+{-# LANGUAGE
12+ AllowAmbiguousTypes
13+ , ConstraintKinds
14+ , DeriveAnyClass
15+ , DeriveGeneric
16+ , DerivingStrategies
17+ , FlexibleContexts
18+ , FlexibleInstances
19+ , GADTs
20+ , LambdaCase
21+ , MultiParamTypeClasses
22+ , OverloadedLabels
23+ , OverloadedStrings
24+ , RankNTypes
25+ , ScopedTypeVariables
26+ , TypeApplications
27+ , TypeInType
28+ , TypeOperators
29+ , UndecidableSuperClasses
30+#-}
31+
32+module Squeal.PostgreSQL.Definition.Type
33+ ( createTypeEnum
34+ , createTypeEnumFrom
35+ , createTypeComposite
36+ , createTypeCompositeFrom
37+ , createTypeRange
38+ , createDomain
39+ , dropType
40+ , dropTypeIfExists
41+ ) where
42+
43+import Data.ByteString
44+import Data.Monoid
45+import GHC.TypeLits
46+import Prelude hiding ((.), id)
47+
48+import qualified Generics.SOP as SOP
49+
50+import Squeal.PostgreSQL.Alias
51+import Squeal.PostgreSQL.Expression.Logic
52+import Squeal.PostgreSQL.Expression.Type
53+import Squeal.PostgreSQL.Definition
54+import Squeal.PostgreSQL.List
55+import Squeal.PostgreSQL.PG
56+import Squeal.PostgreSQL.Render
57+import Squeal.PostgreSQL.Schema
58+
59+-- $setup
60+-- >>> import Squeal.PostgreSQL
61+-- >>> import qualified GHC.Generics as GHC
62+-- >>> import qualified Generics.SOP as SOP
63+
64+-- | Enumerated types are created using the `createTypeEnum` command, for example
65+--
66+-- >>> printSQL $ (createTypeEnum #mood (label @"sad" :* label @"ok" :* label @"happy") :: Definition (Public '[]) '["public" ::: '["mood" ::: 'Typedef ('PGenum '["sad","ok","happy"])]])
67+-- CREATE TYPE "mood" AS ENUM ('sad', 'ok', 'happy');
68+createTypeEnum
69+ :: (KnownSymbol enum, Has sch schemas schema, SOP.All KnownSymbol labels)
70+ => QualifiedAlias sch enum
71+ -- ^ name of the user defined enumerated type
72+ -> NP PGlabel labels
73+ -- ^ labels of the enumerated type
74+ -> Definition schemas (Alter sch (Create enum ('Typedef ('PGenum labels)) schema) schemas)
75+createTypeEnum enum labels = UnsafeDefinition $
76+ "CREATE" <+> "TYPE" <+> renderSQL enum <+> "AS" <+> "ENUM" <+>
77+ parenthesized (renderSQL labels) <> ";"
78+
79+-- | Enumerated types can also be generated from a Haskell type, for example
80+--
81+-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic
82+-- >>> instance SOP.Generic Schwarma
83+-- >>> instance SOP.HasDatatypeInfo Schwarma
84+-- >>> :{
85+-- let
86+-- createSchwarma :: Definition (Public '[]) '["public" ::: '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))]]
87+-- createSchwarma = createTypeEnumFrom @Schwarma #schwarma
88+-- in
89+-- printSQL createSchwarma
90+-- :}
91+-- CREATE TYPE "schwarma" AS ENUM ('Beef', 'Lamb', 'Chicken');
92+createTypeEnumFrom
93+ :: forall hask sch enum schemas schema.
94+ ( SOP.Generic hask
95+ , SOP.All KnownSymbol (LabelsPG hask)
96+ , KnownSymbol enum
97+ , Has sch schemas schema )
98+ => QualifiedAlias sch enum
99+ -- ^ name of the user defined enumerated type
100+ -> Definition schemas (Alter sch (Create enum ('Typedef (PG (Enumerated hask))) schema) schemas)
101+createTypeEnumFrom enum = createTypeEnum enum
102+ (SOP.hpure label :: NP PGlabel (LabelsPG hask))
103+
104+{- | `createTypeComposite` creates a composite type. The composite type is
105+specified by a list of attribute names and data types.
106+
107+>>> :{
108+type PGcomplex = 'PGcomposite
109+ '[ "real" ::: 'NotNull 'PGfloat8
110+ , "imaginary" ::: 'NotNull 'PGfloat8 ]
111+:}
112+
113+>>> :{
114+let
115+ setup :: Definition (Public '[]) '["public" ::: '["complex" ::: 'Typedef PGcomplex]]
116+ setup = createTypeComposite #complex
117+ (float8 `as` #real :* float8 `as` #imaginary)
118+in printSQL setup
119+:}
120+CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);
121+-}
122+createTypeComposite
123+ :: (KnownSymbol ty, Has sch schemas schema, SOP.SListI fields)
124+ => QualifiedAlias sch ty
125+ -- ^ name of the user defined composite type
126+ -> NP (Aliased (TypeExpression schemas)) fields
127+ -- ^ list of attribute names and data types
128+ -> Definition schemas (Alter sch (Create ty ('Typedef ('PGcomposite fields)) schema) schemas)
129+createTypeComposite ty fields = UnsafeDefinition $
130+ "CREATE" <+> "TYPE" <+> renderSQL ty <+> "AS" <+> parenthesized
131+ (renderCommaSeparated renderField fields) <> ";"
132+ where
133+ renderField :: Aliased (TypeExpression schemas) x -> ByteString
134+ renderField (typ `As` alias) =
135+ renderSQL alias <+> renderSQL typ
136+
137+-- | Composite types can also be generated from a Haskell type, for example
138+--
139+-- >>> data Complex = Complex {real :: Double, imaginary :: Double} deriving GHC.Generic
140+-- >>> instance SOP.Generic Complex
141+-- >>> instance SOP.HasDatatypeInfo Complex
142+-- >>> type Schema = '["complex" ::: 'Typedef (PG (Composite Complex))]
143+-- >>> :{
144+-- let
145+-- createComplex :: Definition (Public '[]) (Public Schema)
146+-- createComplex = createTypeCompositeFrom @Complex #complex
147+-- in
148+-- printSQL createComplex
149+-- :}
150+-- CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);
151+createTypeCompositeFrom
152+ :: forall hask sch ty schemas schema.
153+ ( SOP.All (FieldTyped schemas) (RowPG hask)
154+ , KnownSymbol ty
155+ , Has sch schemas schema )
156+ => QualifiedAlias sch ty
157+ -- ^ name of the user defined composite type
158+ -> Definition schemas (Alter sch (Create ty ( 'Typedef (PG (Composite hask))) schema) schemas)
159+createTypeCompositeFrom ty = createTypeComposite ty
160+ (SOP.hcpure (SOP.Proxy :: SOP.Proxy (FieldTyped schemas)) fieldtype
161+ :: NP (Aliased (TypeExpression schemas)) (RowPG hask))
162+
163+{-|
164+`createDomain` creates a new domain. A domain is essentially a data type
165+with constraints (restrictions on the allowed set of values).
166+
167+Domains are useful for abstracting common constraints on fields
168+into a single location for maintenance. For example, several tables might
169+contain email address columns, all requiring the same `check` constraint
170+to verify the address syntax. Define a domain rather than setting up
171+each table's constraint individually.
172+
173+>>> :{
174+let
175+ createPositive :: Definition (Public '[]) (Public '["positive" ::: 'Typedef 'PGfloat4])
176+ createPositive = createDomain #positive real (#value .> 0 .&& (#value & isNotNull))
177+in printSQL createPositive
178+:}
179+CREATE DOMAIN "positive" AS real CHECK ((("value" > 0) AND "value" IS NOT NULL));
180+-}
181+createDomain
182+ :: (Has sch schemas schema, KnownSymbol dom)
183+ => QualifiedAlias sch dom
184+ -> (forall null. TypeExpression schemas (null ty))
185+ -> (forall tab. Condition '[] '[] 'Ungrouped schemas '[] '[tab ::: '["value" ::: 'Null ty]])
186+ -> Definition schemas (Alter sch (Create dom ('Typedef ty) schema) schemas)
187+createDomain dom ty condition =
188+ UnsafeDefinition $ "CREATE DOMAIN" <+> renderSQL dom
189+ <+> "AS" <+> renderTypeExpression ty
190+ <+> "CHECK" <+> parenthesized (renderSQL condition) <> ";"
191+
192+{- |
193+>>> :{
194+let
195+ createSmallIntRange :: Definition (Public '[]) (Public '["int2range" ::: 'Typedef ('PGrange 'PGint2)])
196+ createSmallIntRange = createTypeRange #int2range int2
197+in printSQL createSmallIntRange
198+:}
199+CREATE TYPE "int2range" AS RANGE (subtype = int2);
200+-}
201+createTypeRange
202+ :: (Has sch schemas schema, KnownSymbol range)
203+ => QualifiedAlias sch range
204+ -> (forall null. TypeExpression schemas (null ty))
205+ -> Definition schemas (Alter sch (Create range ('Typedef ('PGrange ty)) schema) schemas)
206+createTypeRange range ty = UnsafeDefinition $
207+ "CREATE" <+> "TYPE" <+> renderSQL range <+> "AS" <+> "RANGE" <+>
208+ parenthesized ("subtype" <+> "=" <+> renderTypeExpression ty) <> ";"
209+
210+-- | Drop a type.
211+--
212+-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic
213+-- >>> instance SOP.Generic Schwarma
214+-- >>> instance SOP.HasDatatypeInfo Schwarma
215+-- >>> printSQL (dropType #schwarma :: Definition '["public" ::: '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))]] (Public '[]))
216+-- DROP TYPE "schwarma";
217+dropType
218+ :: (Has sch schemas schema, KnownSymbol td)
219+ => QualifiedAlias sch td
220+ -- ^ name of the user defined type
221+ -> Definition schemas (Alter sch (DropSchemum td 'Typedef schema) schemas)
222+dropType tydef = UnsafeDefinition $ "DROP" <+> "TYPE" <+> renderSQL tydef <> ";"
223+
224+dropTypeIfExists
225+ :: (Has sch schemas schema, KnownSymbol td)
226+ => QualifiedAlias sch td
227+ -- ^ name of the user defined type
228+ -> Definition schemas (Alter sch (DropSchemumIfExists td 'Typedef schema) schemas)
229+dropTypeIfExists tydef = UnsafeDefinition $ "DROP" <+> "TYPE" <+> renderSQL tydef <> ";"
squeal-postgresql/src/Squeal/PostgreSQL/Definition/View.hsnew file+104
@@ -0,0 +1,104 @@
1+{-|
2+Module: Squeal.PostgreSQL.Definition.View
3+Description: Create and drop view definitions
4+Copyright: (c) Eitan Chatav, 2017
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Create and drop view definitions.
9+-}
10+
11+{-# LANGUAGE
12+ AllowAmbiguousTypes
13+ , ConstraintKinds
14+ , DeriveAnyClass
15+ , DeriveGeneric
16+ , DerivingStrategies
17+ , FlexibleContexts
18+ , FlexibleInstances
19+ , GADTs
20+ , LambdaCase
21+ , MultiParamTypeClasses
22+ , OverloadedLabels
23+ , OverloadedStrings
24+ , RankNTypes
25+ , ScopedTypeVariables
26+ , TypeApplications
27+ , TypeInType
28+ , TypeOperators
29+ , UndecidableSuperClasses
30+#-}
31+
32+module Squeal.PostgreSQL.Definition.View
33+ ( createView
34+ , createOrReplaceView
35+ , dropView
36+ , dropViewIfExists
37+ ) where
38+
39+import GHC.TypeLits
40+
41+import Squeal.PostgreSQL.Alias
42+import Squeal.PostgreSQL.Definition
43+import Squeal.PostgreSQL.Query
44+import Squeal.PostgreSQL.Render
45+import Squeal.PostgreSQL.Schema
46+
47+-- $setup
48+-- >>> import Squeal.PostgreSQL
49+
50+{- | Create a view.
51+>>> type ABC = '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4]
52+>>> type BC = '["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4]
53+>>> :{
54+let
55+ definition :: Definition
56+ '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC)]]
57+ '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC), "bc" ::: 'View BC]]
58+ definition =
59+ createView #bc (select_ (#b :* #c) (from (table #abc)))
60+in printSQL definition
61+:}
62+CREATE VIEW "bc" AS SELECT "b" AS "b", "c" AS "c" FROM "abc" AS "abc";
63+-}
64+createView
65+ :: (Has sch schemas schema, KnownSymbol vw)
66+ => QualifiedAlias sch vw -- ^ the name of the view to add
67+ -> Query '[] '[] schemas '[] view -- ^ query
68+ -> Definition schemas (Alter sch (Create vw ('View view) schema) schemas)
69+createView alias query = UnsafeDefinition $
70+ "CREATE" <+> "VIEW" <+> renderSQL alias <+> "AS"
71+ <+> renderQuery query <> ";"
72+
73+createOrReplaceView
74+ :: (Has sch schemas schema, KnownSymbol vw)
75+ => QualifiedAlias sch vw -- ^ the name of the view to add
76+ -> Query '[] '[] schemas '[] view -- ^ query
77+ -> Definition schemas (Alter sch (CreateOrReplace vw ('View view) schema) schemas)
78+createOrReplaceView alias query = UnsafeDefinition $
79+ "CREATE OR REPLACE VIEW" <+> renderSQL alias <+> "AS"
80+ <+> renderQuery query <> ";"
81+
82+-- | Drop a view.
83+--
84+-- >>> :{
85+-- let
86+-- definition :: Definition
87+-- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])
88+-- , "bc" ::: 'View ('["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4])]]
89+-- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])]]
90+-- definition = dropView #bc
91+-- in printSQL definition
92+-- :}
93+-- DROP VIEW "bc";
94+dropView
95+ :: (Has sch schemas schema, KnownSymbol vw)
96+ => QualifiedAlias sch vw -- ^ view to remove
97+ -> Definition schemas (Alter sch (DropSchemum vw 'View schema) schemas)
98+dropView vw = UnsafeDefinition $ "DROP VIEW" <+> renderSQL vw <> ";"
99+
100+dropViewIfExists
101+ :: (Has sch schemas schema, KnownSymbol vw)
102+ => QualifiedAlias sch vw -- ^ view to remove
103+ -> Definition schemas (Alter sch (DropIfExists vw schema) schemas)
104+dropViewIfExists vw = UnsafeDefinition $ "DROP VIEW IF EXISTS" <+> renderSQL vw <> ";"
squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs+100−64
@@ -1,14 +1,13 @@
11{-|
22Module: 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
@@ -35,49 +34,48 @@ module Squeal.PostgreSQL.Expression
3534 ( -- * Expression
3635 Expression (..)
3736 , Expr
38− , (:-->)
37+ , type (-->)
38+ , FunctionDB
3939 , unsafeFunction
40− , unsafeUnaryOpL
41− , unsafeUnaryOpR
40+ , function
41+ , unsafeLeftOp
42+ , leftOp
43+ , unsafeRightOp
44+ , rightOp
4245 , Operator
46+ , OperatorDB
4347 , unsafeBinaryOp
48+ , binaryOp
4449 , FunctionVar
4550 , unsafeFunctionVar
46− , FunctionN
51+ , type (--->)
52+ , FunctionNDB
4753 , unsafeFunctionN
48− , Literal (..)
54+ , functionN
4955 , PGSubset (..)
56+ , PGIntersect (..)
5057 -- * Re-export
5158 , (&)
5259 , K (..)
60+ , unK
5361 ) where
5462
5563import Control.Category
5664import Control.DeepSeq
5765import Data.ByteString (ByteString)
58−import Data.ByteString.Lazy (toStrict)
59−import ByteString.StrictBuilder (builderBytes)
6066import Data.Function ((&))
6167import Data.Semigroup hiding (All)
62−import qualified Data.Aeson as JSON
63−import Data.Int
6468import Data.String
65−import Data.Text (Text)
6669import Generics.SOP hiding (All, from)
6770import GHC.OverloadedLabels
6871import GHC.TypeLits
6972import Numeric
7073import Prelude hiding (id, (.))
7174
72−import qualified Data.Text as Text
73−import qualified Data.Text.Lazy as Lazy (Text)
74−import qualified Data.Text.Lazy as Lazy.Text
7575import qualified GHC.Generics as GHC
7676
7777import Squeal.PostgreSQL.Alias
78−import Squeal.PostgreSQL.Binary
7978import Squeal.PostgreSQL.List
80−import Squeal.PostgreSQL.PG
8179import Squeal.PostgreSQL.Render
8280import Squeal.PostgreSQL.Schema
8381
@@ -93,7 +91,7 @@ such as in the target `Squeal.PostgreSQL.Query.List` of the
9391`Squeal.PostgreSQL.Query.select` command,
9492as new column values in `Squeal.PostgreSQL.Manipulation.insertRow` or
9593`Squeal.PostgreSQL.Manipulation.update`,
96−or in search `Condition`s in a number of commands.
94+or in search `Squeal.PostgreSQL.Logic.Condition`s in a number of commands.
9795
9896The expression syntax allows the calculation of
9997values from primitive expression using arithmetic, logical,
@@ -127,7 +125,7 @@ instance RenderSQL (Expression outer commons grp schemas params from ty) where
127125 renderSQL = renderExpression
128126
129127-- | An `Expr` is a closed `Expression`.
130−-- It is a F`RankNType` but don't be scared.
128+-- It is a F@RankNType@ but don't be scared.
131129-- Think of it as an expression which sees no
132130-- namespaces, so you can't use parameters
133131-- or alias references. It can be used as
@@ -137,7 +135,7 @@ type Expr x
137135 . Expression outer commons grp schemas params from x
138136 -- ^ cannot reference aliases
139137
140−-- | A `RankNType` for binary operators.
138+-- | A @RankNType@ for binary operators.
141139type Operator x1 x2 y
142140 = forall outer commons grp schemas params from
143141 . Expression outer commons grp schemas params from x1
@@ -147,32 +145,55 @@ type Operator x1 x2 y
147145 -> Expression outer commons grp schemas params from y
148146 -- ^ output
149147
150−-- | A `RankNType` for functions with a single argument.
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.
151158-- These could be either function calls or unary operators.
152159-- This is a subtype of the usual Haskell function type `Prelude.->`,
153160-- indeed a subcategory as it is closed under the usual
154161-- `Prelude..` and `Prelude.id`.
155−type (:-->) x y
162+type (-->) x y
156163 = forall outer commons grp schemas params from
157164 . Expression outer commons grp schemas params from x
158165 -- ^ input
159166 -> Expression outer commons grp schemas params from y
160167 -- ^ output
161168
162−{- | A `RankNType` for functions with a fixed-length list of heterogeneous arguments.
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.
163177Use the `*:` operator to end your argument lists, like so.
164178
165179>>> printSQL (unsafeFunctionN "fun" (true :* false :* localTime *: true))
166180fun(TRUE, FALSE, LOCALTIME, TRUE)
167181-}
168−type FunctionN xs y
182+type (--->) xs y
169183 = forall outer commons grp schemas params from
170184 . NP (Expression outer commons grp schemas params from) xs
171185 -- ^ inputs
172186 -> Expression outer commons grp schemas params from y
173187 -- ^ output
174188
175−{- | A `RankNType` for functions with a variable-length list of
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
176197homogeneous arguments and at least 1 more argument.
177198-}
178199type FunctionVar x0 x1 y
@@ -297,28 +318,63 @@ unsafeBinaryOp :: ByteString -> Operator ty0 ty1 ty2
297318unsafeBinaryOp op x y = UnsafeExpression $ parenthesized $
298319 renderSQL x <+> op <+> renderSQL y
299320
300−-- | >>> printSQL $ unsafeUnaryOpL "NOT" true
321+binaryOp
322+ :: forall op sch schemas schema x y z.
323+ ( Has sch schemas schema
324+ , Has op schema ('Operator ('BinaryOp x y z)) )
325+ => OperatorDB schemas x y z
326+binaryOp = unsafeBinaryOp $ renderSymbol @op
327+
328+-- | >>> printSQL $ unsafeLeftOp "NOT" true
301329-- (NOT TRUE)
302−unsafeUnaryOpL :: ByteString -> x :--> y
303−unsafeUnaryOpL op x = UnsafeExpression $ parenthesized $ 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
304339
305−-- | >>> printSQL $ true & unsafeUnaryOpR "IS NOT TRUE"
340+-- | >>> printSQL $ true & unsafeRightOp "IS NOT TRUE"
306341-- (TRUE IS NOT TRUE)
307−unsafeUnaryOpR :: ByteString -> x :--> y
308−unsafeUnaryOpR op x = UnsafeExpression $ parenthesized $ renderSQL x <+> op
342+unsafeRightOp :: ByteString -> x --> y
343+unsafeRightOp op x = UnsafeExpression $ parenthesized $ renderSQL x <+> op
344+
345+rightOp
346+ :: forall op sch schemas schema x y.
347+ ( Has sch schemas schema
348+ , Has op schema ('Operator ('RightOp x y)) )
349+ => FunctionDB schemas x y
350+rightOp = unsafeRightOp $ renderSymbol @op
309351
310352-- | >>> printSQL $ unsafeFunction "f" true
311353-- f(TRUE)
312−unsafeFunction :: ByteString -> x :--> y
354+unsafeFunction :: ByteString -> x --> y
313355unsafeFunction fun x = UnsafeExpression $
314356 fun <> parenthesized (renderSQL x)
315357
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+
316364-- | >>> printSQL $ unsafeFunctionN "f" (currentTime :* localTimestamp :* false *: literal 'a')
317365-- f(CURRENT_TIME, LOCALTIMESTAMP, FALSE, E'a')
318−unsafeFunctionN :: SListI xs => ByteString -> FunctionN xs y
366+unsafeFunctionN :: SListI xs => ByteString -> xs ---> y
319367unsafeFunctionN fun xs = UnsafeExpression $
320368 fun <> parenthesized (renderCommaSeparated renderSQL xs)
321369
370+functionN
371+ :: ( Has sch schemas schema
372+ , Has fun schema ('Function (xs :=> 'Returns y))
373+ , SListI xs )
374+ => QualifiedAlias sch fun
375+ -> FunctionNDB schemas xs y
376+functionN = unsafeFunctionN . renderSQL
377+
322378instance ty `In` PGNum
323379 => Num (Expression outer commons grp schemas params from (null ty)) where
324380 (+) = unsafeBinaryOp "+"
@@ -363,14 +419,22 @@ instance (ty `In` PGNum, ty `In` PGFloating) => Floating
363419 acosh x = log (x + sqrt (x*x - 1))
364420 atanh x = log ((1 + x) / (1 - x)) / 2
365421
366−class PGSubset container where
367− (@>) :: Operator (null0 container) (null1 container) ('Null 'PGbool)
422+-- | Contained by operators
423+class PGSubset ty where
424+ (@>) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
368425 (@>) = unsafeBinaryOp "@>"
369− (<@) :: Operator (null0 container) (null1 container) ('Null 'PGbool)
426+ (<@) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
370427 (<@) = unsafeBinaryOp "<@"
371428instance PGSubset 'PGjsonb
372429instance PGSubset 'PGtsquery
373430instance 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)
374438
375439instance IsString
376440 (Expression outer commons grp schemas params from (null 'PGtext)) where
@@ -406,31 +470,3 @@ instance Monoid
406470 (Expression outer commons grp schemas params from (null 'PGtsvector)) where
407471 mempty = fromString ""
408472 mappend = (<>)
409−
410−class Literal hask where
411− literal :: hask -> Expr (null (PG hask))
412−instance JSON.ToJSON hask => Literal (Json hask) where
413− literal = UnsafeExpression . parenthesized . (<> " :: json")
414− . singleQuotedUtf8 . toStrict . JSON.encode . getJson
415−instance JSON.ToJSON hask => Literal (Jsonb hask) where
416− literal = UnsafeExpression . parenthesized . (<> " :: jsonb")
417− . singleQuotedUtf8 . toStrict . JSON.encode . getJsonb
418−instance Literal Char where
419− literal chr = UnsafeExpression $
420− "E\'" <> fromString (escape chr) <> "\'"
421−instance Literal String where literal = fromString
422−instance Literal Int16 where literal = fromIntegral
423−instance Literal Int32 where literal = fromIntegral
424−instance Literal Int64 where literal = fromIntegral
425−instance Literal Float where literal = fromRational . toRational
426−instance Literal Double where literal = fromRational . toRational
427−instance Literal Text where literal = fromString . Text.unpack
428−instance Literal Lazy.Text where literal = fromString . Lazy.Text.unpack
429−instance ToParam (Enumerated enum) (PG (Enumerated enum))
430− => Literal (Enumerated enum) where
431− literal
432− = UnsafeExpression
433− . singleQuotedUtf8
434− . builderBytes
435− . unK
436− . toParam @(Enumerated enum) @(PG (Enumerated enum))
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Aggregate.hs+30−5
@@ -1,3 +1,13 @@
1+{-|
2+Module: Squeal.PostgreSQL.Expression.Aggregate
3+Description: Aggregate functions
4+Copyright: (c) Eitan Chatav, 2019
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Aggregate functions
9+-}
10+
111{-# LANGUAGE
212 DataKinds
313 , DeriveGeneric
@@ -16,6 +26,7 @@
1626module Squeal.PostgreSQL.Expression.Aggregate
1727 ( Aggregate (..)
1828 , Distinction (..)
29+ , PGSum
1930 , PGAvg
2031 ) where
2132
@@ -39,7 +50,7 @@ import Squeal.PostgreSQL.Schema
3950{- |
4051`Aggregate` functions compute a single result from a set of input values.
4152`Aggregate` functions can be used as `GroupedBy` `Expression`s as well
42−as `WindowFunction`s.
53+as `Squeal.PostgreSQL.Expression.Window.WindowFunction`s.
4354-}
4455class Aggregate expr1 exprN aggr
4556 | aggr -> expr1, aggr -> exprN where
@@ -69,15 +80,14 @@ class Aggregate expr1 exprN aggr
6980
7081 -- | >>> :{
7182 -- let
72− -- expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: 'Null 'PGnumeric]] ('NotNull 'PGnumeric)
83+ -- expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: 'Null 'PGnumeric]] ('Null 'PGnumeric)
7384 -- expression = sum_ (Distinct #col)
7485 -- in printSQL expression
7586 -- :}
7687 -- sum(DISTINCT "col")
7788 sum_
78− :: ty `In` PGNum
79− => expr1 (null ty)
80− -> aggr ('NotNull ty)
89+ :: expr1 (null ty)
90+ -> aggr ('Null (PGSum ty))
8191
8292 -- | input values, including nulls, concatenated into an array
8393 arrayAgg
@@ -424,6 +434,21 @@ unsafeAggregateN
424434 -> Expression outer commons ('Grouped bys) schemas params from y
425435unsafeAggregateN fun xs = UnsafeExpression $ fun <> parenthesized (renderSQL xs)
426436
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+
427452-- | A type family that calculates `PGAvg` type of a `PGType`.
428453type family PGAvg ty where
429454 PGAvg 'PGint2 = 'PGnumeric
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Collection.hs+16−6
@@ -1,9 +1,20 @@
1+{-|
2+Module: Squeal.PostgreSQL.Expression.Collection
3+Description: Array and composite functions
4+Copyright: (c) Eitan Chatav, 2019
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Array and composite functions
9+-}
10+
111{-# LANGUAGE
212 AllowAmbiguousTypes
313 , DataKinds
414 , FlexibleContexts
515 , FlexibleInstances
616 , MultiParamTypeClasses
17+ , OverloadedLabels
718 , OverloadedStrings
819 , RankNTypes
920 , ScopedTypeVariables
@@ -31,7 +42,7 @@ import qualified Generics.SOP as SOP
3142
3243import Squeal.PostgreSQL.Alias
3344import Squeal.PostgreSQL.Expression
34−import Squeal.PostgreSQL.Expression.SetOf
45+import Squeal.PostgreSQL.Expression.Set
3546import Squeal.PostgreSQL.List
3647import Squeal.PostgreSQL.Render
3748import Squeal.PostgreSQL.Schema
@@ -100,21 +111,20 @@ array2 xss = UnsafeExpression $ "ARRAY" <>
100111
101112-- | >>> printSQL $ cardinality (array [null_, false, true])
102113-- cardinality(ARRAY[NULL, FALSE, TRUE])
103−cardinality :: null ('PGvararray ty) :--> null 'PGint8
114+cardinality :: null ('PGvararray ty) --> null 'PGint8
104115cardinality = unsafeFunction "cardinality"
105116
106117-- | >>> printSQL $ array [null_, false, true] & index 2
107118-- (ARRAY[NULL, FALSE, TRUE])[2]
108119index
109120 :: Word64 -- ^ index
110− -> null ('PGvararray ty) :--> NullifyType ty
121+ -> null ('PGvararray ty) --> NullifyType ty
111122index n expr = UnsafeExpression $
112123 parenthesized (renderSQL expr) <> "[" <> fromString (show n) <> "]"
113124
114125-- | Expand an array to a set of rows
115−unnest
116− :: SetOfFunction (null ('PGvararray ty)) '["unnest" ::: '["unnest" ::: ty]]
117−unnest = unsafeSetOfFunction "unnest"
126+unnest :: SetFunction "unnest" (null ('PGvararray ty)) '["unnest" ::: ty]
127+unnest = unsafeSetFunction
118128
119129-- | A row constructor is an expression that builds a row value
120130-- (also called a composite value) using values for its member fields.
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Comparison.hs+35−20
@@ -1,3 +1,13 @@
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+
111{-# LANGUAGE
212 OverloadedStrings
313 , RankNTypes
@@ -29,6 +39,8 @@ module Squeal.PostgreSQL.Expression.Comparison
2939 , isNotUnknown
3040 ) where
3141
42+import Data.ByteString
43+
3244import Squeal.PostgreSQL.Expression
3345import Squeal.PostgreSQL.Expression.Logic
3446import Squeal.PostgreSQL.Render
@@ -87,6 +99,9 @@ greatest = unsafeFunctionVar "GREATEST"
8799least :: FunctionVar ty ty ty
88100least = unsafeFunctionVar "LEAST"
89101
102+{- |
103+A @RankNType@ for comparison expressions like `between`.
104+-}
90105type BetweenExpr
91106 = forall outer commons grp schemas params from ty
92107 . Expression outer commons grp schemas params from ty
@@ -94,19 +109,21 @@ type BetweenExpr
94109 , Expression outer commons grp schemas params from ty ) -- ^ bounds
95110 -> Condition outer commons grp schemas params from
96111
112+unsafeBetweenExpr :: ByteString -> BetweenExpr
113+unsafeBetweenExpr fun a (x,y) = UnsafeExpression $
114+ renderSQL a <+> fun <+> renderSQL x <+> "AND" <+> renderSQL y
115+
97116{- | >>> printSQL $ true `between` (null_, false)
98117TRUE BETWEEN NULL AND FALSE
99118-}
100119between :: BetweenExpr
101−between a (x,y) = UnsafeExpression $ renderSQL a <+> "BETWEEN"
102− <+> renderSQL x <+> "AND" <+> renderSQL y
120+between = unsafeBetweenExpr "BETWEEN"
103121
104122{- | >>> printSQL $ true `notBetween` (null_, false)
105123TRUE NOT BETWEEN NULL AND FALSE
106124-}
107125notBetween :: BetweenExpr
108−notBetween a (x,y) = UnsafeExpression $ renderSQL a <+> "NOT BETWEEN"
109− <+> renderSQL x <+> "AND" <+> renderSQL y
126+notBetween = unsafeBetweenExpr "NOT BETWEEN"
110127
111128{- | between, after sorting the comparison values
112129
@@ -114,8 +131,7 @@ notBetween a (x,y) = UnsafeExpression $ renderSQL a <+> "NOT BETWEEN"
114131TRUE BETWEEN SYMMETRIC NULL AND FALSE
115132-}
116133betweenSymmetric :: BetweenExpr
117−betweenSymmetric a (x,y) = UnsafeExpression $ renderSQL a
118− <+> "BETWEEN SYMMETRIC" <+> renderSQL x <+> "AND" <+> renderSQL y
134+betweenSymmetric = unsafeBetweenExpr "BETWEEN SYMMETRIC"
119135
120136{- | not between, after sorting the comparison values
121137
@@ -123,8 +139,7 @@ betweenSymmetric a (x,y) = UnsafeExpression $ renderSQL a
123139TRUE NOT BETWEEN SYMMETRIC NULL AND FALSE
124140-}
125141notBetweenSymmetric :: BetweenExpr
126−notBetweenSymmetric a (x,y) = UnsafeExpression $ renderSQL a
127− <+> "NOT BETWEEN SYMMETRIC" <+> renderSQL x <+> "AND" <+> renderSQL y
142+notBetweenSymmetric = unsafeBetweenExpr "NOT BETWEEN SYMMETRIC"
128143
129144{- | not equal, treating null like an ordinary value
130145
@@ -147,45 +162,45 @@ isNotDistinctFrom = unsafeBinaryOp "IS NOT DISTINCT FROM"
147162>>> printSQL $ true & isTrue
148163(TRUE IS TRUE)
149164-}
150−isTrue :: null0 'PGbool :--> null1 'PGbool
151−isTrue = unsafeUnaryOpR "IS TRUE"
165+isTrue :: null0 'PGbool --> null1 'PGbool
166+isTrue = unsafeRightOp "IS TRUE"
152167
153168{- | is false or unknown
154169
155170>>> printSQL $ true & isNotTrue
156171(TRUE IS NOT TRUE)
157172-}
158−isNotTrue :: null0 'PGbool :--> null1 'PGbool
159−isNotTrue = unsafeUnaryOpR "IS NOT TRUE"
173+isNotTrue :: null0 'PGbool --> null1 'PGbool
174+isNotTrue = unsafeRightOp "IS NOT TRUE"
160175
161176{- | is false
162177
163178>>> printSQL $ true & isFalse
164179(TRUE IS FALSE)
165180-}
166−isFalse :: null0 'PGbool :--> null1 'PGbool
167−isFalse = unsafeUnaryOpR "IS FALSE"
181+isFalse :: null0 'PGbool --> null1 'PGbool
182+isFalse = unsafeRightOp "IS FALSE"
168183
169184{- | is true or unknown
170185
171186>>> printSQL $ true & isNotFalse
172187(TRUE IS NOT FALSE)
173188-}
174−isNotFalse :: null0 'PGbool :--> null1 'PGbool
175−isNotFalse = unsafeUnaryOpR "IS NOT FALSE"
189+isNotFalse :: null0 'PGbool --> null1 'PGbool
190+isNotFalse = unsafeRightOp "IS NOT FALSE"
176191
177192{- | is unknown
178193
179194>>> printSQL $ true & isUnknown
180195(TRUE IS UNKNOWN)
181196-}
182−isUnknown :: null0 'PGbool :--> null1 'PGbool
183−isUnknown = unsafeUnaryOpR "IS UNKNOWN"
197+isUnknown :: null0 'PGbool --> null1 'PGbool
198+isUnknown = unsafeRightOp "IS UNKNOWN"
184199
185200{- | is true or false
186201
187202>>> printSQL $ true & isNotUnknown
188203(TRUE IS NOT UNKNOWN)
189204-}
190−isNotUnknown :: null0 'PGbool :--> null1 'PGbool
191−isNotUnknown = unsafeUnaryOpR "IS NOT UNKNOWN"
205+isNotUnknown :: null0 'PGbool --> null1 'PGbool
206+isNotUnknown = unsafeRightOp "IS NOT UNKNOWN"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Json.hs+150−212
@@ -1,3 +1,13 @@
1+{-|
2+Module: Squeal.PostgreSQL.Expression.Json
3+Description: Json and Jsonb functions and operators
4+Copyright: (c) Eitan Chatav, 2019
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Json and Jsonb functions and operators
9+-}
10+
111{-# LANGUAGE
212 DataKinds
313 , FlexibleContexts
@@ -6,8 +16,12 @@
616 , OverloadedLabels
717 , OverloadedStrings
818 , PolyKinds
19+ , RankNTypes
20+ , ScopedTypeVariables
21+ , TypeApplications
922 , TypeOperators
1023 , UndecidableInstances
24+ , UndecidableSuperClasses
1125#-}
1226
1327module Squeal.PostgreSQL.Expression.Json
@@ -29,19 +43,13 @@ module Squeal.PostgreSQL.Expression.Json
2943 , rowToJson
3044 , jsonBuildArray
3145 , jsonbBuildArray
32− , PGBuildObject
33− , jsonBuildObject
34− , jsonbBuildObject
46+ , JsonBuildObject (..)
3547 , jsonObject
3648 , jsonbObject
3749 , jsonZipObject
3850 , jsonbZipObject
3951 , jsonArrayLength
4052 , jsonbArrayLength
41− , jsonExtractPath
42− , jsonbExtractPath
43− , jsonExtractPathAsText
44− , jsonbExtractPathAsText
4553 , jsonTypeof
4654 , jsonbTypeof
4755 , jsonStripNulls
@@ -56,10 +64,12 @@ module Squeal.PostgreSQL.Expression.Json
5664 , jsonbEachText
5765 , jsonObjectKeys
5866 , jsonbObjectKeys
67+ , JsonPopulateFunction
5968 , jsonPopulateRecord
6069 , jsonbPopulateRecord
6170 , jsonPopulateRecordSet
6271 , jsonbPopulateRecordSet
72+ , JsonToRecordFunction
6373 , jsonToRecord
6474 , jsonbToRecord
6575 , jsonToRecordSet
@@ -71,7 +81,7 @@ import GHC.TypeLits
7181
7282import Squeal.PostgreSQL.Alias
7383import Squeal.PostgreSQL.Expression
74−import Squeal.PostgreSQL.Expression.SetOf
84+import Squeal.PostgreSQL.Expression.Set
7585import Squeal.PostgreSQL.Expression.Type
7686import Squeal.PostgreSQL.List
7787import Squeal.PostgreSQL.Query
@@ -82,6 +92,7 @@ import qualified Generics.SOP as SOP
8292
8393-- $setup
8494-- >>> import Squeal.PostgreSQL
95+-- >>> import Data.Aeson
8596
8697{-----------------------------------------
8798 -- json and jsonb support
@@ -145,18 +156,18 @@ infixl 9 .?&
145156
146157-- | Delete a key or keys from a JSON object, or remove an array element.
147158--
148−-- If the right operand is..
159+-- If the right operand is
149160--
150−-- @ text @: Delete key/value pair or string element from left operand. Key/value pairs
151−-- are matched based on their key value.
161+-- @ text @: Delete key / value pair or string element from left operand.
162+-- Key / value pairs are matched based on their key value,
152163--
153−-- @ text[] @: Delete multiple key/value pairs or string elements
154−-- from left operand. Key/value pairs are matched based on their key value.
164+-- @ text[] @: Delete multiple key / value pairs or string elements
165+-- from left operand. Key / value pairs are matched based on their key value,
155166--
156167-- @ integer @: Delete the array element with specified index (Negative integers
157168-- count from the end). Throws an error if top level container is not an array.
158169(.-.)
159− :: (key `In` '[ 'PGtext, 'PGvararray ('NotNull 'PGtext), 'PGint4, 'PGint2 ]) -- hlint error without parens here
170+ :: key `In` '[ 'PGtext, 'PGvararray ('NotNull 'PGtext), 'PGint4, 'PGint2 ]
160171 => Operator (null 'PGjsonb) (null key) (null 'PGjsonb)
161172infixl 6 .-.
162173(.-.) = unsafeBinaryOp "-"
@@ -177,7 +188,7 @@ Table 9.45: JSON creation functions
177188-- otherwise, a scalar value is produced. For any scalar type other than a
178189-- number, a Boolean, or a null value, the text representation will be used, in
179190-- such a fashion that it is a valid json value.
180−toJson :: null ty :--> null 'PGjson
191+toJson :: null ty --> null 'PGjson
181192toJson = unsafeFunction "to_json"
182193
183194-- | Returns the value as jsonb. Arrays and composites are converted
@@ -186,48 +197,42 @@ toJson = unsafeFunction "to_json"
186197-- otherwise, a scalar value is produced. For any scalar type other than a
187198-- number, a Boolean, or a null value, the text representation will be used, in
188199-- such a fashion that it is a valid jsonb value.
189−toJsonb :: null ty :--> null 'PGjsonb
200+toJsonb :: null ty --> null 'PGjsonb
190201toJsonb = unsafeFunction "to_jsonb"
191202
192203-- | Returns the array as a JSON array. A PostgreSQL multidimensional array
193204-- becomes a JSON array of arrays.
194−arrayToJson :: null ('PGvararray ty) :--> null 'PGjson
205+arrayToJson :: null ('PGvararray ty) --> null 'PGjson
195206arrayToJson = unsafeFunction "array_to_json"
196207
197208-- | Returns the row as a JSON object.
198−rowToJson :: null ('PGcomposite ty) :--> null 'PGjson
209+rowToJson :: null ('PGcomposite ty) --> null 'PGjson
199210rowToJson = unsafeFunction "row_to_json"
200211
201212-- | Builds a possibly-heterogeneously-typed JSON array out of a variadic
202213-- argument list.
203−jsonBuildArray :: SOP.SListI tuple => FunctionN tuple (null 'PGjson)
214+jsonBuildArray :: SOP.SListI tuple => tuple ---> null 'PGjson
204215jsonBuildArray = unsafeFunctionN "json_build_array"
205216
206217-- | Builds a possibly-heterogeneously-typed (binary) JSON array out of a
207218-- variadic argument list.
208−jsonbBuildArray :: SOP.SListI tuple => FunctionN tuple (null 'PGjsonb)
219+jsonbBuildArray :: SOP.SListI tuple => tuple ---> null 'PGjsonb
209220jsonbBuildArray = unsafeFunctionN "jsonb_build_array"
210221
211−class PGBuildObject tys where
212−instance PGBuildObject '[]
213−instance (PGBuildObject tys, key `In` PGJsonKey)
214− => PGBuildObject ('NotNull key ': value ': tys)
215−
216222-- | Builds a possibly-heterogeneously-typed JSON object out of a variadic
217223-- argument list. The elements of the argument list must alternate between text
218224-- and values.
219−jsonBuildObject
220− :: (SOP.SListI elems, PGBuildObject elems)
221− => FunctionN elems (null 'PGjson)
222−jsonBuildObject = unsafeFunctionN "json_build_object"
223−
224−-- | Builds a possibly-heterogeneously-typed (binary) JSON object out of a
225−-- variadic argument list. The elements of the argument list must alternate
226−-- between keys and values.
227−jsonbBuildObject
228− :: (SOP.SListI elems, PGBuildObject elems)
229− => FunctionN elems (null 'PGjsonb)
230−jsonbBuildObject = unsafeFunctionN "jsonb_build_object"
225+class SOP.SListI tys => JsonBuildObject tys where
226+
227+ jsonBuildObject :: tys ---> null 'PGjson
228+ jsonBuildObject = unsafeFunctionN "json_build_object"
229+
230+ jsonbBuildObject :: tys ---> null 'PGjsonb
231+ jsonbBuildObject = unsafeFunctionN "jsonb_build_object"
232+
233+instance JsonBuildObject '[]
234+instance (JsonBuildObject tys, key `In` PGJsonKey)
235+ => JsonBuildObject ('NotNull key ': value ': tys)
231236
232237-- | Builds a JSON object out of a text array.
233238-- The array must have two dimensions
@@ -235,7 +240,7 @@ jsonbBuildObject = unsafeFunctionN "jsonb_build_object"
235240-- which are taken as a key/value pair.
236241jsonObject
237242 :: null ('PGfixarray '[n,2] ('NotNull 'PGtext))
238− :--> null 'PGjson
243+ --> null 'PGjson
239244jsonObject = unsafeFunction "json_object"
240245
241246-- | Builds a binary JSON object out of a text array.
@@ -244,24 +249,24 @@ jsonObject = unsafeFunction "json_object"
244249-- which are taken as a key/value pair.
245250jsonbObject
246251 :: null ('PGfixarray '[n,2] ('NotNull 'PGtext))
247− :--> null 'PGjsonb
252+ --> null 'PGjsonb
248253jsonbObject = unsafeFunction "jsonb_object"
249254
250255-- | This is an alternate form of 'jsonObject' that takes two arrays; one for
251256-- keys and one for values, that are zipped pairwise to create a JSON object.
252−jsonZipObject :: FunctionN
257+jsonZipObject ::
253258 '[ null ('PGvararray ('NotNull 'PGtext))
254259 , null ('PGvararray ('NotNull 'PGtext)) ]
255− ( null 'PGjson )
260+ ---> null 'PGjson
256261jsonZipObject = unsafeFunctionN "json_object"
257262
258263-- | This is an alternate form of 'jsonbObject' that takes two arrays; one for
259264-- keys and one for values, that are zipped pairwise to create a binary JSON
260265-- object.
261−jsonbZipObject :: FunctionN
266+jsonbZipObject ::
262267 '[ null ('PGvararray ('NotNull 'PGtext))
263268 , null ('PGvararray ('NotNull 'PGtext)) ]
264− ( null 'PGjsonb )
269+ ---> null 'PGjsonb
265270jsonbZipObject = unsafeFunctionN "jsonb_object"
266271
267272{-----------------------------------------
@@ -269,221 +274,170 @@ Table 9.46: JSON processing functions
269274-----------------------------------------}
270275
271276-- | Returns the number of elements in the outermost JSON array.
272−jsonArrayLength :: null 'PGjson :--> null 'PGint4
277+jsonArrayLength :: null 'PGjson --> null 'PGint4
273278jsonArrayLength = unsafeFunction "json_array_length"
274279
275280-- | Returns the number of elements in the outermost binary JSON array.
276−jsonbArrayLength :: null 'PGjsonb :--> null 'PGint4
281+jsonbArrayLength :: null 'PGjsonb --> null 'PGint4
277282jsonbArrayLength = unsafeFunction "jsonb_array_length"
278283
279−-- | Returns JSON value pointed to by the given path (equivalent to #>
280−-- operator).
281−jsonExtractPath
282− :: SOP.SListI elems
283− => Expression outer commons grp schemas params from (null 'PGjson)
284− -> NP (Expression outer commons grp schemas params from) elems
285− -> Expression outer commons grp schemas params from (null 'PGjsonb)
286−jsonExtractPath x xs =
287− unsafeFunctionN "json_extract_path" (x :* xs)
288−
289−-- | Returns JSON value pointed to by the given path (equivalent to #>
290−-- operator).
291−jsonbExtractPath
292− :: SOP.SListI elems
293− => Expression outer commons grp schemas params from (null 'PGjsonb)
294− -> NP (Expression outer commons grp schemas params from) elems
295− -> Expression outer commons grp schemas params from (null 'PGjsonb)
296−jsonbExtractPath x xs =
297− unsafeFunctionN "jsonb_extract_path" (x :* xs)
298−
299−-- | Returns JSON value pointed to by the given path (equivalent to #>
300−-- operator), as text.
301−jsonExtractPathAsText
302− :: SOP.SListI elems
303− => Expression outer commons grp schemas params from (null 'PGjson)
304− -> NP (Expression outer commons grp schemas params from) elems
305− -> Expression outer commons grp schemas params from (null 'PGjson)
306−jsonExtractPathAsText x xs =
307− unsafeFunctionN "json_extract_path_text" (x :* xs)
308−
309−-- | Returns JSON value pointed to by the given path (equivalent to #>
310−-- operator), as text.
311−jsonbExtractPathAsText
312− :: SOP.SListI elems
313− => Expression outer commons grp schemas params from (null 'PGjsonb)
314− -> NP (Expression outer commons grp schemas params from) elems
315− -> Expression outer commons grp schemas params from (null 'PGjsonb)
316−jsonbExtractPathAsText x xs =
317− unsafeFunctionN "jsonb_extract_path_text" (x :* xs)
318−
319284-- | Returns the type of the outermost JSON value as a text string. Possible
320285-- types are object, array, string, number, boolean, and null.
321−jsonTypeof :: null 'PGjson :--> null 'PGtext
286+jsonTypeof :: null 'PGjson --> null 'PGtext
322287jsonTypeof = unsafeFunction "json_typeof"
323288
324289-- | Returns the type of the outermost binary JSON value as a text string.
325290-- Possible types are object, array, string, number, boolean, and null.
326−jsonbTypeof :: null 'PGjsonb :--> null 'PGtext
291+jsonbTypeof :: null 'PGjsonb --> null 'PGtext
327292jsonbTypeof = unsafeFunction "jsonb_typeof"
328293
329294-- | Returns its argument with all object fields that have null values omitted.
330295-- Other null values are untouched.
331−jsonStripNulls :: null 'PGjson :--> null 'PGjson
296+jsonStripNulls :: null 'PGjson --> null 'PGjson
332297jsonStripNulls = unsafeFunction "json_strip_nulls"
333298
334299-- | Returns its argument with all object fields that have null values omitted.
335300-- Other null values are untouched.
336−jsonbStripNulls :: null 'PGjsonb :--> null 'PGjsonb
301+jsonbStripNulls :: null 'PGjsonb --> null 'PGjsonb
337302jsonbStripNulls = unsafeFunction "jsonb_strip_nulls"
338303
339304-- | @ jsonbSet target path new_value create_missing @
340305--
341−-- Returns target with the section designated by path replaced by new_value,
342−-- or with new_value added if create_missing is true ( default is true) and the
306+-- Returns target with the section designated by path replaced by @new_value@,
307+-- or with @new_value@ added if create_missing is
308+-- `Squeal.PostgreSQL.Expression.Logic.true` and the
343309-- item designated by path does not exist. As with the path orientated
344310-- operators, negative integers that appear in path count from the end of JSON
345311-- arrays.
346−jsonbSet
347− :: Expression outer commons grp schemas params from (null 'PGjsonb)
348− -> Expression outer commons grp schemas params from (null ('PGvararray ('NotNull 'PGtext)))
349− -> Expression outer commons grp schemas params from (null 'PGjsonb)
350− -> Maybe (Expression outer commons grp schemas params from (null 'PGbool))
351− -> Expression outer commons grp schemas params from (null 'PGjsonb)
352−jsonbSet tgt path val createMissing = case createMissing of
353− Just m -> unsafeFunctionN "jsonb_set" (tgt :* path :* val :* m :* Nil)
354− Nothing -> unsafeFunctionN "jsonb_set" (tgt :* path :* val :* Nil)
312+jsonbSet ::
313+ '[ null 'PGjsonb, null ('PGvararray ('NotNull 'PGtext))
314+ , null 'PGjsonb, null 'PGbool ] ---> null 'PGjsonb
315+jsonbSet = unsafeFunctionN "jsonbSet"
355316
356317-- | @ jsonbInsert target path new_value insert_after @
357318--
358−-- Returns target with new_value inserted. If target section designated by
359−-- path is in a JSONB array, new_value will be inserted before target or after
360−-- if insert_after is true (default is false). If target section designated by
361−-- path is in JSONB object, new_value will be inserted only if target does not
319+-- Returns target with @new_value@ inserted. If target section designated by
320+-- path is in a JSONB array, @new_value@ will be inserted before target or after
321+-- if @insert_after@ is `Squeal.PostgreSQL.Expression.Logic.true`.
322+-- If target section designated by
323+-- path is in JSONB object, @new_value@ will be inserted only if target does not
362324-- exist. As with the path orientated operators, negative integers that appear
363325-- in path count from the end of JSON arrays.
364−jsonbInsert
365− :: Expression outer commons grp schemas params from (null 'PGjsonb)
366− -> Expression outer commons grp schemas params from (null ('PGvararray ('NotNull 'PGtext)))
367− -> Expression outer commons grp schemas params from (null 'PGjsonb)
368− -> Maybe (Expression outer commons grp schemas params from (null 'PGbool))
369− -> Expression outer commons grp schemas params from (null 'PGjsonb)
370−jsonbInsert tgt path val insertAfter = case insertAfter of
371− Just i -> unsafeFunctionN "jsonb_insert" (tgt :* path :* val :* i :* Nil)
372− Nothing -> unsafeFunctionN "jsonb_insert" (tgt :* path :* val :* Nil)
326+jsonbInsert ::
327+ '[ null 'PGjsonb, null ('PGvararray ('NotNull 'PGtext))
328+ , null 'PGjsonb, null 'PGbool ] ---> null 'PGjsonb
329+jsonbInsert = unsafeFunctionN "jsonb_insert"
373330
374331-- | Returns its argument as indented JSON text.
375−jsonbPretty :: null 'PGjsonb :--> null 'PGtext
332+jsonbPretty :: null 'PGjsonb --> null 'PGtext
376333jsonbPretty = unsafeFunction "jsonb_pretty"
377334
335+{- | Expands the outermost JSON object into a set of key/value pairs.
378336
379−-- | Expands the outermost JSON object into a set of key/value pairs.
380−-- >>> import Data.Aeson
381−-- >>> printSQL (select Star (from (jsonEach (literal (Json (object ["a" .= "foo", "b" .= "bar"]))))))
382−-- SELECT * FROM json_each(('{"a":"foo","b":"bar"}' :: json))
383−jsonEach
384− :: Expression outer commons 'Ungrouped schemas params '[] (nullity 'PGjson) -- ^ json object
385− -> FromClause outer commons schemas params
386− '["json_each" ::: '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGjson]]
387−jsonEach = unsafeSetOfFunction "json_each"
388−
389−-- | Expands the outermost binary JSON object into a set of key/value pairs.
390−-- >>> import Data.Aeson
391−-- >>> printSQL (select Star (from (jsonbEach (literal (Jsonb (object ["a" .= "foo", "b" .= "bar"]))))))
392−-- SELECT * FROM jsonb_each(('{"a":"foo","b":"bar"}' :: jsonb))
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+-}
393349jsonbEach
394− :: Expression outer commons 'Ungrouped schemas params '[] (nullity 'PGjsonb) -- ^ jsonb object
395− -> FromClause outer commons schemas params
396− '["jsonb_each" ::: '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGjson]]
397−jsonbEach = unsafeSetOfFunction "jsonb_each"
350+ :: SetFunction "jsonb_each" (nullity 'PGjsonb)
351+ '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGjson]
352+jsonbEach = unsafeSetFunction
398353
399−-- | Expands the outermost JSON object into a set of key/value pairs.-- | Expands the outermost binary JSON object into a set of key/value pairs.
400−-- >>> import Data.Aeson
401−-- >>> printSQL (select Star (from (jsonEachText (literal (Json (object ["a" .= "foo", "b" .= "bar"]))))))
402−-- SELECT * FROM json_each_text(('{"a":"foo","b":"bar"}' :: json))
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+-}
403359jsonEachText
404− :: Expression outer commons 'Ungrouped schemas params '[] (nullity 'PGjson) -- ^ json object
405− -> FromClause outer commons schemas params
406− '["json_each" ::: '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext]]
407−jsonEachText = unsafeSetOfFunction "json_each_text"
360+ :: SetFunction "json_each_text" (null 'PGjson)
361+ '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext]
362+jsonEachText = unsafeSetFunction
408363
409−-- | Expands the outermost binary JSON object into a set of key/value pairs.
410−-- >>> import Data.Aeson
411−-- >>> printSQL (select Star (from (jsonbEachText (literal (Jsonb (object ["a" .= "foo", "b" .= "bar"]))))))
412−-- SELECT * FROM jsonb_each_text(('{"a":"foo","b":"bar"}' :: jsonb))
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+-}
413369jsonbEachText
414− :: Expression outer commons 'Ungrouped schemas params '[] (nullity 'PGjsonb) -- ^ jsonb object
415− -> FromClause outer commons schemas params
416− '["jsonb_each" ::: '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext]]
417−jsonbEachText = unsafeSetOfFunction "jsonb_each_text"
370+ :: SetFunction "jsonb_each_text" (null 'PGjsonb)
371+ '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext]
372+jsonbEachText = unsafeSetFunction
418373
419−-- | Returns set of keys in the outermost JSON object.
420−-- >>> import Data.Aeson
421−-- >>> printSQL (jsonObjectKeys (literal (Json (object ["a" .= "foo", "b" .= "bar"]))))
422−-- json_object_keys(('{"a":"foo","b":"bar"}' :: json))
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+-}
423379jsonObjectKeys
424− :: Expression outer commons 'Ungrouped schemas params '[] (nullity 'PGjson) -- ^ json object
425− -> FromClause outer commons schemas params
426− '["json_object_keys" ::: '["json_object_keys" ::: 'NotNull 'PGtext]]
427−jsonObjectKeys = unsafeSetOfFunction "json_object_keys"
380+ :: SetFunction "json_object_keys" (nullity 'PGjson)
381+ '["json_object_keys" ::: 'NotNull 'PGtext]
382+jsonObjectKeys = unsafeSetFunction
428383
429−-- | Returns set of keys in the outermost JSON object.
430−-- >>> import Data.Aeson
431−-- >>> printSQL (jsonbObjectKeys (literal (Jsonb (object ["a" .= "foo", "b" .= "bar"]))))
432−-- jsonb_object_keys(('{"a":"foo","b":"bar"}' :: jsonb))
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+-}
433389jsonbObjectKeys
434− :: Expression outer commons 'Ungrouped schemas params '[] (nullity 'PGjsonb) -- ^ jsonb object
435− -> FromClause outer commons schemas params
436− '["jsonb_object_keys" ::: '["jsonb_object_keys" ::: 'NotNull 'PGtext]]
437−jsonbObjectKeys = unsafeSetOfFunction "jsonb_object_keys"
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]
438402
439403unsafePopulateFunction
440− :: KnownSymbol fun
441− => Alias fun
442− -> TypeExpression schemas (nullity ('PGcomposite row))
443− -> Expression outer commons 'Ungrouped schemas params '[] ty
444− -> FromClause outer commons schemas params '[fun ::: row]
445−unsafePopulateFunction fun ty expr = UnsafeFromClause $ renderSQL fun
404+ :: forall fun ty
405+ . KnownSymbol fun => Alias fun -> JsonPopulateFunction fun ty
406+unsafePopulateFunction _fun ty expr = UnsafeFromClause $ renderSymbol @fun
446407 <> parenthesized ("null::" <> renderSQL ty <> ", " <> renderSQL expr)
447408
448409-- | Expands the JSON expression to a row whose columns match the record
449410-- type defined by the given table.
450−jsonPopulateRecord
451− :: TypeExpression schemas (nullity ('PGcomposite row)) -- ^ row type
452− -> Expression outer commons 'Ungrouped schemas params '[] (nullity 'PGjson) -- ^ json object
453− -> FromClause outer commons schemas params '["json_populate_record" ::: row]
411+jsonPopulateRecord :: JsonPopulateFunction "json_populate_record" 'PGjson
454412jsonPopulateRecord = unsafePopulateFunction #json_populate_record
455413
456414-- | Expands the binary JSON expression to a row whose columns match the record
457415-- type defined by the given table.
458−jsonbPopulateRecord
459− :: TypeExpression schemas (nullity ('PGcomposite row)) -- ^ row type
460− -> Expression outer commons 'Ungrouped schemas params '[] (nullity 'PGjsonb) -- ^ jsonb object
461− -> FromClause outer commons schemas params '["jsonb_populate_record" ::: row]
416+jsonbPopulateRecord :: JsonPopulateFunction "jsonb_populate_record" 'PGjsonb
462417jsonbPopulateRecord = unsafePopulateFunction #jsonb_populate_record
463418
464419-- | Expands the outermost array of objects in the given JSON expression to a
465420-- set of rows whose columns match the record type defined by the given table.
466−jsonPopulateRecordSet
467− :: TypeExpression schemas (nullity ('PGcomposite row)) -- ^ row type
468− -> Expression outer commons 'Ungrouped schemas params '[] (nullity 'PGjson) -- ^ json array
469− -> FromClause outer commons schemas params '["json_populate_record_set" ::: row]
421+jsonPopulateRecordSet :: JsonPopulateFunction "json_populate_record_set" 'PGjson
470422jsonPopulateRecordSet = unsafePopulateFunction #json_populate_record_set
471423
472424-- | Expands the outermost array of objects in the given binary JSON expression
473425-- to a set of rows whose columns match the record type defined by the given
474426-- table.
475−jsonbPopulateRecordSet
476− :: TypeExpression schemas (nullity ('PGcomposite row)) -- ^ row type
477− -> Expression outer commons 'Ungrouped schemas params '[] (nullity 'PGjsonb) -- ^ jsonb array
478− -> FromClause outer commons schemas params '["jsonb_populate_record_set" ::: row]
427+jsonbPopulateRecordSet :: JsonPopulateFunction "jsonb_populate_record_set" 'PGjsonb
479428jsonbPopulateRecordSet = unsafePopulateFunction #jsonb_populate_record_set
480429
481−unsafeRecordFunction
482− :: (SOP.SListI record, json `In` PGJsonType)
483− => ByteString
484− -> Expression outer commons 'Ungrouped schemas params '[] (nullity json)
485− -> Aliased (NP (Aliased (TypeExpression schemas))) (tab ::: record)
486− -> FromClause outer commons schemas params '[tab ::: record]
430+-- | Build rows from Json types.
431+type JsonToRecordFunction json
432+ = forall outer commons schemas params tab row
433+ . (SOP.SListI row, json `In` PGJsonType)
434+ => Expression outer commons 'Ungrouped schemas params '[] ('NotNull json)
435+ -- ^ json type
436+ -> Aliased (NP (Aliased (TypeExpression schemas))) (tab ::: row)
437+ -- ^ row type
438+ -> FromClause outer commons schemas params '[tab ::: row]
439+
440+unsafeRecordFunction :: ByteString -> JsonToRecordFunction json
487441unsafeRecordFunction fun expr (types `As` tab) = UnsafeFromClause $
488442 fun <> parenthesized (renderSQL expr) <+> "AS" <+> renderSQL tab
489443 <> parenthesized (renderCommaSeparated renderTy types)
@@ -492,33 +446,17 @@ unsafeRecordFunction fun expr (types `As` tab) = UnsafeFromClause $
492446 renderTy (ty `As` alias) = renderSQL alias <+> renderSQL ty
493447
494448-- | Builds an arbitrary record from a JSON object.
495−jsonToRecord
496− :: SOP.SListI record
497− => Expression outer commons 'Ungrouped schemas params '[] (nullity 'PGjson) -- ^ json object
498− -> Aliased (NP (Aliased (TypeExpression schemas))) (tab ::: record)
499− -> FromClause outer commons schemas params '[tab ::: record]
449+jsonToRecord :: JsonToRecordFunction 'PGjson
500450jsonToRecord = unsafeRecordFunction "json_to_record"
501451
502452-- | Builds an arbitrary record from a binary JSON object.
503−jsonbToRecord
504− :: SOP.SListI record
505− => Expression outer commons 'Ungrouped schemas params '[] (nullity 'PGjsonb) -- ^ jsonb object
506− -> Aliased (NP (Aliased (TypeExpression schemas))) (tab ::: record)
507− -> FromClause outer commons schemas params '[tab ::: record]
453+jsonbToRecord :: JsonToRecordFunction 'PGjsonb
508454jsonbToRecord = unsafeRecordFunction "jsonb_to_record"
509455
510456-- | Builds an arbitrary set of records from a JSON array of objects.
511−jsonToRecordSet
512− :: SOP.SListI record
513− => Expression outer commons 'Ungrouped schemas params '[] (nullity 'PGjson) -- ^ json array
514− -> Aliased (NP (Aliased (TypeExpression schemas))) (tab ::: record)
515− -> FromClause outer commons schemas params '[tab ::: record]
457+jsonToRecordSet :: JsonToRecordFunction 'PGjson
516458jsonToRecordSet = unsafeRecordFunction "json_to_record_set"
517459
518460-- | Builds an arbitrary set of records from a binary JSON array of objects.
519−jsonbToRecordSet
520− :: SOP.SListI record
521− => Expression outer commons 'Ungrouped schemas params '[] (nullity 'PGjsonb) -- ^ jsonb array
522− -> Aliased (NP (Aliased (TypeExpression schemas))) (tab ::: record)
523− -> FromClause outer commons schemas params '[tab ::: record]
461+jsonbToRecordSet :: JsonToRecordFunction 'PGjsonb
524462jsonbToRecordSet = unsafeRecordFunction "jsonb_to_record_set"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Literal.hsnew file+87
@@ -0,0 +1,87 @@
1+{-|
2+Module: Squeal.PostgreSQL.Expression.Literal
3+Description: Literal expressions
4+Copyright: (c) Eitan Chatav, 2019
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Literal expressions
9+-}
10+
11+{-# LANGUAGE
12+ FlexibleContexts
13+ , FlexibleInstances
14+ , LambdaCase
15+ , OverloadedStrings
16+ , RankNTypes
17+ , ScopedTypeVariables
18+ , TypeApplications
19+ , TypeSynonymInstances
20+ , UndecidableInstances
21+#-}
22+
23+module Squeal.PostgreSQL.Expression.Literal (Literal (..)) where
24+
25+import ByteString.StrictBuilder (builderBytes)
26+import Data.ByteString.Lazy (toStrict)
27+import Data.Int
28+import Data.String
29+import Data.Text (Text)
30+
31+import qualified Data.Aeson as JSON
32+import qualified Data.Text as Text
33+import qualified Data.Text.Lazy as Lazy (Text)
34+import qualified Data.Text.Lazy as Lazy.Text
35+
36+import Squeal.PostgreSQL.Binary
37+import Squeal.PostgreSQL.Expression
38+import Squeal.PostgreSQL.Expression.Logic
39+import Squeal.PostgreSQL.PG
40+import Squeal.PostgreSQL.Render
41+
42+{- |
43+The `Literal` class allows embedding a Haskell value directly
44+as an `Expression` using `literal`.
45+
46+>>> printSQL (literal 'a')
47+E'a'
48+
49+>>> printSQL (literal (1 :: Double))
50+1.0
51+
52+>>> printSQL (literal (Json [1 :: Double, 2]))
53+('[1.0,2.0]' :: json)
54+
55+>>> printSQL (literal (Enumerated GT))
56+'GT'
57+-}
58+class Literal hask where literal :: hask -> Expr (null (PG hask))
59+instance Literal Bool where
60+ literal = \case
61+ True -> true
62+ False -> false
63+instance JSON.ToJSON hask => Literal (Json hask) where
64+ literal = UnsafeExpression . parenthesized . (<> " :: json")
65+ . singleQuotedUtf8 . toStrict . JSON.encode . getJson
66+instance JSON.ToJSON hask => Literal (Jsonb hask) where
67+ literal = UnsafeExpression . parenthesized . (<> " :: jsonb")
68+ . singleQuotedUtf8 . toStrict . JSON.encode . getJsonb
69+instance Literal Char where
70+ literal chr = UnsafeExpression $
71+ "E\'" <> fromString (escape chr) <> "\'"
72+instance Literal String where literal = fromString
73+instance Literal Int16 where literal = fromIntegral
74+instance Literal Int32 where literal = fromIntegral
75+instance Literal Int64 where literal = fromIntegral
76+instance Literal Float where literal = fromRational . toRational
77+instance Literal Double where literal = fromRational . toRational
78+instance Literal Text where literal = fromString . Text.unpack
79+instance Literal Lazy.Text where literal = fromString . Lazy.Text.unpack
80+instance ToParam (Enumerated enum) (PG (Enumerated enum))
81+ => Literal (Enumerated enum) where
82+ literal
83+ = UnsafeExpression
84+ . singleQuotedUtf8
85+ . builderBytes
86+ . unK
87+ . toParam @(Enumerated enum) @(PG (Enumerated enum))
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Logic.hs+13−3
@@ -1,3 +1,13 @@
1+{-|
2+Module: Squeal.PostgreSQL.Expression.Logic
3+Description: Logical expressions
4+Copyright: (c) Eitan Chatav, 2019
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Logical expressions and operators
9+-}
10+
111{-# LANGUAGE
212 DataKinds
313 , OverloadedStrings
@@ -20,7 +30,7 @@ import Squeal.PostgreSQL.Render
2030import Squeal.PostgreSQL.Schema
2131
2232-- | A `Condition` is an `Expression`, which can evaluate
23−-- to `true`, `false` or `null_`. This is because SQL uses
33+-- to `true`, `false` or `Squeal.PostgreSQL.Null.null_`. This is because SQL uses
2434-- a three valued logic.
2535type Condition outer commons grp schemas params from =
2636 Expression outer commons grp schemas params from ('Null 'PGbool)
@@ -37,8 +47,8 @@ false = UnsafeExpression "FALSE"
3747
3848-- | >>> printSQL $ not_ true
3949-- (NOT TRUE)
40−not_ :: null 'PGbool :--> null 'PGbool
41−not_ = unsafeUnaryOpL "NOT"
50+not_ :: null 'PGbool --> null 'PGbool
51+not_ = unsafeLeftOp "NOT"
4252
4353-- | >>> printSQL $ true .&& false
4454-- (TRUE AND FALSE)
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Math.hs+14−7
@@ -1,3 +1,13 @@
1+{-|
2+Module: Squeal.PostgreSQL.Expression.Math
3+Description: Math expressions
4+Copyright: (c) Eitan Chatav, 2019
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Mathematical functions and operators
9+-}
10+
111{-# LANGUAGE
212 DataKinds
313 , OverloadedStrings
@@ -19,7 +29,6 @@ import Squeal.PostgreSQL.Schema
1929
2030-- $setup
2131-- >>> import Squeal.PostgreSQL
22−-- >>> import Squeal.PostgreSQL.Render
2332
2433-- | >>> :{
2534-- let
@@ -28,9 +37,7 @@ import Squeal.PostgreSQL.Schema
2837-- in printSQL expression
2938-- :}
3039-- atan2(pi(), 2)
31−atan2_
32− :: float `In` PGFloating
33− => FunctionN '[ null float, null float] (null float)
40+atan2_ :: float `In` PGFloating => '[ null float, null float] ---> null float
3441atan2_ = unsafeFunctionN "atan2"
3542
3643
@@ -69,7 +76,7 @@ rem_ = unsafeBinaryOp "%"
6976-- in printSQL expression
7077-- :}
7178-- trunc(pi())
72−trunc :: frac `In` PGFloating => null frac :--> null frac
79+trunc :: frac `In` PGFloating => null frac --> null frac
7380trunc = unsafeFunction "trunc"
7481
7582-- | >>> :{
@@ -79,7 +86,7 @@ trunc = unsafeFunction "trunc"
7986-- in printSQL expression
8087-- :}
8188-- round(pi())
82−round_ :: frac `In` PGFloating => null frac :--> null frac
89+round_ :: frac `In` PGFloating => null frac --> null frac
8390round_ = unsafeFunction "round"
8491
8592-- | >>> :{
@@ -89,5 +96,5 @@ round_ = unsafeFunction "round"
8996-- in printSQL expression
9097-- :}
9198-- ceiling(pi())
92−ceiling_ :: frac `In` PGFloating => null frac :--> null frac
99+ceiling_ :: frac `In` PGFloating => null frac --> null frac
93100ceiling_ = unsafeFunction "ceiling"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Null.hs+14−4
@@ -1,3 +1,13 @@
1+{-|
2+Module: Squeal.PostgreSQL.Expression.Null
3+Description: Null
4+Copyright: (c) Eitan Chatav, 2019
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Null values and null handling functions
9+-}
10+
111{-# LANGUAGE
212 DataKinds
313 , OverloadedStrings
@@ -34,7 +44,7 @@ null_ = UnsafeExpression "NULL"
3444--
3545-- >>> printSQL $ notNull true
3646-- TRUE
37−notNull :: 'NotNull ty :--> 'Null ty
47+notNull :: 'NotNull ty --> 'Null ty
3848notNull = UnsafeExpression . renderSQL
3949
4050-- | return the leftmost value which is not NULL
@@ -59,12 +69,12 @@ fromNull notNullx nullx = coalesce [nullx] notNullx
5969
6070-- | >>> printSQL $ null_ & isNull
6171-- NULL IS NULL
62−isNull :: 'Null ty :--> null 'PGbool
72+isNull :: 'Null ty --> null 'PGbool
6373isNull x = UnsafeExpression $ renderSQL x <+> "IS NULL"
6474
6575-- | >>> printSQL $ null_ & isNotNull
6676-- NULL IS NOT NULL
67−isNotNull :: 'Null ty :--> null 'PGbool
77+isNotNull :: 'Null ty --> null 'PGbool
6878isNotNull x = UnsafeExpression $ renderSQL x <+> "IS NOT NULL"
6979
7080-- | analagous to `maybe` using @IS NULL@
@@ -90,5 +100,5 @@ matchNull y f x = ifThenElse (isNull x) y
90100>>> printSQL expr
91101NULLIF(FALSE, ($1 :: bool))
92102-}
93−nullIf :: FunctionN '[ 'NotNull ty, 'NotNull ty] ('Null ty)
103+nullIf :: '[ 'NotNull ty, 'NotNull ty] ---> 'Null ty
94104nullIf = unsafeFunctionN "NULLIF"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Parameter.hs+10
@@ -1,3 +1,13 @@
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+
111{-# LANGUAGE
212 AllowAmbiguousTypes
313 , DataKinds
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/SetOf.hsdeleted−69
@@ -1,69 +0,0 @@
1−{-# LANGUAGE
2− AllowAmbiguousTypes
3− , DataKinds
4− , FlexibleContexts
5− , OverloadedStrings
6− , PolyKinds
7− , RankNTypes
8− , TypeOperators
9−#-}
10−
11−module Squeal.PostgreSQL.Expression.SetOf
12− ( SetOfFunction
13− , unsafeSetOfFunction
14− , SetOfFunctionN
15− , unsafeSetOfFunctionN
16− , generateSeries
17− , generateSeriesStep
18− , generateSeriesTimestamp
19− ) where
20−
21−import Data.ByteString (ByteString)
22−
23−import qualified Generics.SOP as SOP
24−
25−import Squeal.PostgreSQL.Alias
26−import Squeal.PostgreSQL.Expression
27−import Squeal.PostgreSQL.List
28−import Squeal.PostgreSQL.Render
29−import Squeal.PostgreSQL.Query
30−import Squeal.PostgreSQL.Schema
31−
32−type SetOfFunction ty setof
33− = forall outer commons schemas params
34− . Expression outer commons 'Ungrouped schemas params '[] ty
35− -> FromClause outer commons schemas params setof
36−
37−unsafeSetOfFunction :: ByteString -> SetOfFunction ty setof
38−unsafeSetOfFunction fun x = UnsafeFromClause $
39− fun <> parenthesized (renderSQL x)
40−
41−type SetOfFunctionN tys setof
42− = forall outer commons schemas params
43− . NP (Expression outer commons 'Ungrouped schemas params '[]) tys
44− -> FromClause outer commons schemas params setof
45−
46−unsafeSetOfFunctionN
47− :: SOP.SListI tys
48− => ByteString
49− -> SetOfFunctionN tys setof
50−unsafeSetOfFunctionN fun xs = UnsafeFromClause $
51− fun <> parenthesized (renderCommaSeparated renderSQL xs)
52−
53−generateSeries
54− :: ty `In` '[ 'PGint4, 'PGint8, 'PGnumeric]
55− => SetOfFunctionN '[ null ty, null ty]
56− '["generate_series" ::: '["generate_series" ::: '[null ty]]]
57−generateSeries = unsafeSetOfFunctionN "generate_series"
58−
59−generateSeriesStep
60− :: ty `In` '[ 'PGint4, 'PGint8, 'PGnumeric]
61− => SetOfFunctionN '[null ty, null ty, null ty]
62− '["generate_series" ::: '["generate_series" ::: '[null ty]]]
63−generateSeriesStep = unsafeSetOfFunctionN "generate_series"
64−
65−generateSeriesTimestamp
66− :: ty `In` '[ 'PGtimestamp, 'PGtimestamptz]
67− => SetOfFunctionN '[null ty, null ty, null 'PGinterval]
68− '["generate_series" ::: '["generate_series" ::: '[null ty]]]
69−generateSeriesTimestamp = unsafeSetOfFunctionN "generate_series"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Sort.hs+24−14
@@ -1,3 +1,13 @@
1+{-|
2+Module: Squeal.PostgreSQL.Expression.Sort
3+Description: Sort expressions
4+Copyright: (c) Eitan Chatav, 2019
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Sort expressions
9+-}
10+
111{-# LANGUAGE
212 DataKinds
313 , GADTs
@@ -19,8 +29,10 @@ import Squeal.PostgreSQL.Schema
1929-- of a `Squeal.PostgreSQL.Query.Query`. `Asc` or `Desc`
2030-- set the sort direction of a `NotNull` result
2131-- column to ascending or descending. Ascending order puts smaller values
22−-- first, where "smaller" is defined in terms of the `.<` operator. Similarly,
23−-- descending order is determined with the `.>` operator. `AscNullsFirst`,
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`,
2436-- `AscNullsLast`, `DescNullsFirst` and `DescNullsLast` options are used to
2537-- determine whether nulls appear before or after non-null values in the sort
2638-- ordering of a `Null` result column.
@@ -44,6 +56,16 @@ data SortExpression outer commons grp schemas params from where
4456 :: Expression outer commons grp schemas params from ('Null ty)
4557 -> SortExpression outer commons grp schemas params from
4658deriving 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"
4769
4870{- |
4971The `orderBy` clause causes the result rows of a `Squeal.PostgreSQL.Query.TableExpression`
@@ -61,15 +83,3 @@ class OrderBy expr where
6183 :: [SortExpression outer commons grp schemas params from]
6284 -> expr outer commons grp schemas params from
6385 -> expr outer commons grp schemas params from
64−
65−-- | Render a `SortExpression`.
66−instance RenderSQL (SortExpression outer commons grp schemas params from) where
67− renderSQL = \case
68− Asc expression -> renderSQL expression <+> "ASC"
69− Desc expression -> renderSQL expression <+> "DESC"
70− AscNullsFirst expression -> renderSQL expression
71− <+> "ASC NULLS FIRST"
72− DescNullsFirst expression -> renderSQL expression
73− <+> "DESC NULLS FIRST"
74− AscNullsLast expression -> renderSQL expression <+> "ASC NULLS LAST"
75− DescNullsLast expression -> renderSQL expression <+> "DESC NULLS LAST"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Subquery.hs+15−5
@@ -1,3 +1,13 @@
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+
111{-# LANGUAGE
212 DataKinds
313 , OverloadedStrings
@@ -23,7 +33,6 @@ import Squeal.PostgreSQL.Schema
2333
2434-- $setup
2535-- >>> import Squeal.PostgreSQL
26−-- >>> import Squeal.PostgreSQL.Render
2736
2837{- |
2938The argument of `exists` is an arbitrary subquery. The subquery is evaluated
@@ -49,8 +58,9 @@ row of the subquery result using the given `Operator`,
4958which must yield a Boolean result. The result of `subAll` is `true`
5059if all rows yield true (including the case where the subquery returns no rows).
5160The result is `false` if any `false` result is found.
52−The result is `null_` if no comparison with a subquery row returns `false`,
53−and at least one comparison returns `null_`.
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_`.
5464
5565>>> printSQL $ subAll true (.==) (values_ (true `as` #foo))
5666(TRUE = ALL (SELECT * FROM (VALUES (TRUE)) AS t ("foo")))
@@ -70,8 +80,8 @@ using the given `Operator`, which must yield a Boolean result. The result of `su
7080if any `true` result is obtained. The result is `false` if no true result is found
7181(including the case where the subquery returns no rows).
7282
73−>>> printSQL $ subAll "foo" like (values_ ("foobar" `as` #foo))
74−(E'foo' LIKE ALL (SELECT * FROM (VALUES (E'foobar')) AS t ("foo")))
83+>>> printSQL $ subAny "foo" like (values_ ("foobar" `as` #foo))
84+(E'foo' LIKE ANY (SELECT * FROM (VALUES (E'foobar')) AS t ("foo")))
7585-}
7686subAny
7787 :: Expression outer commons grp schemas params from ty1 -- ^ expression
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Text.hs+13−4
@@ -1,3 +1,13 @@
1+{-|
2+Module: Squeal.PostgreSQL.Expression.Text
3+Description: Text expressions
4+Copyright: (c) Eitan Chatav, 2019
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+String functions and operators
9+-}
10+
111{-# LANGUAGE
212 DataKinds
313 , OverloadedStrings
@@ -17,21 +27,20 @@ import Squeal.PostgreSQL.Schema
1727
1828-- $setup
1929-- >>> import Squeal.PostgreSQL
20−-- >>> import Squeal.PostgreSQL.Render
2130
2231-- | >>> printSQL $ lower "ARRRGGG"
2332-- lower(E'ARRRGGG')
24−lower :: null 'PGtext :--> null 'PGtext
33+lower :: null 'PGtext --> null 'PGtext
2534lower = unsafeFunction "lower"
2635
2736-- | >>> printSQL $ upper "eeee"
2837-- upper(E'eeee')
29−upper :: null 'PGtext :--> null 'PGtext
38+upper :: null 'PGtext --> null 'PGtext
3039upper = unsafeFunction "upper"
3140
3241-- | >>> printSQL $ charLength "four"
3342-- char_length(E'four')
34−charLength :: null 'PGtext :--> null 'PGint4
43+charLength :: null 'PGtext --> null 'PGint4
3544charLength = unsafeFunction "char_length"
3645
3746-- | The `like` expression returns true if the @string@ matches
squeal-postgresql/src/Squeal/PostgreSQL/Expression/TextSearch.hs+71−21
@@ -1,3 +1,13 @@
1+{-|
2+Module: Squeal.PostgreSQL.Expression.TextSearch
3+Description: Text search expressions
4+Copyright: (c) Eitan Chatav, 2019
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Text search functions and operators
9+-}
10+
111{-# LANGUAGE
212 DataKinds
313 , OverloadedStrings
@@ -32,76 +42,116 @@ import Squeal.PostgreSQL.Expression
3242import Squeal.PostgreSQL.List
3343import Squeal.PostgreSQL.Schema
3444
45+-- | `Squeal.PostgreSQL.Expression.Type.tsvector` matches tsquery ?
3546(@@) :: Operator (null 'PGtsvector) (null 'PGtsquery) ('Null 'PGbool)
3647(@@) = unsafeBinaryOp "@@"
3748
49+-- | AND `Squeal.PostgreSQL.Expression.Type.tsquery`s together
3850(.&) :: Operator (null 'PGtsquery) (null 'PGtsquery) (null 'PGtsquery)
3951(.&) = unsafeBinaryOp "&&"
4052
53+-- | OR `Squeal.PostgreSQL.Expression.Type.tsquery`s together
4154(.|) :: Operator (null 'PGtsquery) (null 'PGtsquery) (null 'PGtsquery)
4255(.|) = unsafeBinaryOp "||"
4356
44−(.!) :: null 'PGtsquery :--> null 'PGtsquery
45−(.!) = unsafeUnaryOpL "!!"
57+-- | negate a `Squeal.PostgreSQL.Expression.Type.tsquery`
58+(.!) :: null 'PGtsquery --> null 'PGtsquery
59+(.!) = unsafeLeftOp "!!"
4660
61+-- | `Squeal.PostgreSQL.Expression.Type.tsquery` followed by
62+-- `Squeal.PostgreSQL.Expression.Type.tsquery`
4763(<->) :: Operator (null 'PGtsquery) (null 'PGtsquery) (null 'PGtsquery)
4864(<->) = unsafeBinaryOp "<->"
4965
66+-- | convert array of lexemes to `Squeal.PostgreSQL.Expression.Type.tsvector`
5067arrayToTSvector
5168 :: null ('PGvararray ('NotNull 'PGtext))
52− :--> null 'PGtsvector
69+ --> null 'PGtsvector
5370arrayToTSvector = unsafeFunction "array_to_tsvector"
5471
55−tsvectorLength :: null 'PGtsvector :--> null 'PGint4
72+-- | number of lexemes in `Squeal.PostgreSQL.Expression.Type.tsvector`
73+tsvectorLength :: null 'PGtsvector --> null 'PGint4
5674tsvectorLength = unsafeFunction "length"
5775
58−numnode :: null 'PGtsquery :--> null 'PGint4
76+-- | number of lexemes plus operators in `Squeal.PostgreSQL.Expression.Type.tsquery`
77+numnode :: null 'PGtsquery --> null 'PGint4
5978numnode = unsafeFunction "numnode"
6079
61−plainToTSquery :: null 'PGtext :--> null 'PGtsquery
80+-- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` ignoring punctuation
81+plainToTSquery :: null 'PGtext --> null 'PGtsquery
6282plainToTSquery = unsafeFunction "plainto_tsquery"
6383
64−phraseToTSquery :: null 'PGtext :--> null 'PGtsquery
84+-- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` that searches for a phrase,
85+-- ignoring punctuation
86+phraseToTSquery :: null 'PGtext --> null 'PGtsquery
6587phraseToTSquery = unsafeFunction "phraseto_tsquery"
6688
67−websearchToTSquery :: null 'PGtext :--> null 'PGtsquery
89+-- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` from a web search style query
90+websearchToTSquery :: null 'PGtext --> null 'PGtsquery
6891websearchToTSquery = unsafeFunction "websearch_to_tsquery"
6992
70−queryTree :: null 'PGtsquery :--> null 'PGtext
93+-- | get indexable part of a `Squeal.PostgreSQL.Expression.Type.tsquery`
94+queryTree :: null 'PGtsquery --> null 'PGtext
7195queryTree = unsafeFunction "query_tree"
7296
73−toTSquery :: null 'PGtext :--> null 'PGtsquery
97+-- | normalize words and convert to `Squeal.PostgreSQL.Expression.Type.tsquery`
98+toTSquery :: null 'PGtext --> null 'PGtsquery
7499toTSquery = unsafeFunction "to_tsquery"
75100
101+-- | reduce document text to `Squeal.PostgreSQL.Expression.Type.tsvector`
76102toTSvector
77103 :: ty `In` '[ 'PGtext, 'PGjson, 'PGjsonb]
78− => null ty :--> null 'PGtsvector
104+ => null ty --> null 'PGtsvector
79105toTSvector = unsafeFunction "to_tsvector"
80106
81−setWeight
82− :: FunctionN '[null 'PGtsvector, null ('PGchar 1)] (null 'PGtsvector)
107+-- | assign weight to each element of `Squeal.PostgreSQL.Expression.Type.tsvector`
108+setWeight :: '[null 'PGtsvector, null ('PGchar 1)] ---> null 'PGtsvector
83109setWeight = unsafeFunctionN "set_weight"
84110
85−strip :: null 'PGtsvector :--> null 'PGtsvector
111+-- | remove positions and weights from `Squeal.PostgreSQL.Expression.Type.tsvector`
112+strip :: null 'PGtsvector --> null 'PGtsvector
86113strip = unsafeFunction "strip"
87114
88−jsonToTSvector :: FunctionN '[null 'PGjson, null 'PGjson] (null 'PGtsvector)
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
89126jsonToTSvector = unsafeFunctionN "json_to_tsvector"
90127
91−jsonbToTSvector :: FunctionN '[null 'PGjsonb, null 'PGjsonb] (null 'PGtsvector)
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
92139jsonbToTSvector = unsafeFunctionN "jsonb_to_tsvector"
93140
94−tsDelete :: FunctionN
141+-- | remove given lexeme from `Squeal.PostgreSQL.Expression.Type.tsvector`
142+tsDelete ::
95143 '[null 'PGtsvector, null ('PGvararray ('NotNull 'PGtext))]
96− (null 'PGtsvector)
144+ ---> null 'PGtsvector
97145tsDelete = unsafeFunctionN "ts_delete"
98146
99−tsFilter :: FunctionN
147+-- | select only elements with given weights from `Squeal.PostgreSQL.Expression.Type.tsvector`
148+tsFilter ::
100149 '[null 'PGtsvector, null ('PGvararray ('NotNull ('PGchar 1)))]
101− (null 'PGtsvector)
150+ ---> null 'PGtsvector
102151tsFilter = unsafeFunctionN "ts_filter"
103152
153+-- | display a `Squeal.PostgreSQL.Expression.Type.tsquery` match
104154tsHeadline
105155 :: document `In` '[ 'PGtext, 'PGjson, 'PGjsonb]
106− => FunctionN '[null document, null 'PGtsquery] (null 'PGtext)
156+ => '[null document, null 'PGtsquery] ---> null 'PGtext
107157tsHeadline = unsafeFunctionN "ts_headline"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Time.hs+18−12
@@ -1,3 +1,13 @@
1+{-|
2+Module: Squeal.PostgreSQL.Expression.Time
3+Description: Date/Time expressions
4+Copyright: (c) Eitan Chatav, 2019
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Date/Time functions and operators
9+-}
10+
111{-# LANGUAGE
212 DataKinds
313 , DeriveGeneric
@@ -7,6 +17,7 @@
717 , OverloadedStrings
818 , PolyKinds
919 , RankNTypes
20+ , TypeOperators
1021#-}
1122
1223module Squeal.PostgreSQL.Expression.Time
@@ -75,9 +86,7 @@ Create date from year, month and day fields
7586>>> printSQL (makeDate (1984 :* 7 *: 3))
7687make_date(1984, 7, 3)
7788-}
78−makeDate :: FunctionN
79− '[ null 'PGint4, null 'PGint4, null 'PGint4 ]
80− ( null 'PGdate )
89+makeDate :: '[ null 'PGint4, null 'PGint4, null 'PGint4 ] ---> null 'PGdate
8190makeDate = unsafeFunctionN "make_date"
8291
8392{-|
@@ -86,9 +95,7 @@ Create time from hour, minute and seconds fields
8695>>> printSQL (makeTime (8 :* 15 *: 23.5))
8796make_time(8, 15, 23.5)
8897-}
89−makeTime :: FunctionN
90− '[ null 'PGint4, null 'PGint4, null 'PGfloat8 ]
91− ( null 'PGtime )
98+makeTime :: '[ null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtime
9299makeTime = unsafeFunctionN "make_time"
93100
94101{-|
@@ -97,10 +104,9 @@ Create timestamp from year, month, day, hour, minute and seconds fields
97104>>> printSQL (makeTimestamp (2013 :* 7 :* 15 :* 8 :* 15 *: 23.5))
98105make_timestamp(2013, 7, 15, 8, 15, 23.5)
99106-}
100−makeTimestamp :: FunctionN
107+makeTimestamp ::
101108 '[ null 'PGint4, null 'PGint4, null 'PGint4
102− , null 'PGint4, null 'PGint4, null 'PGfloat8 ]
103− ( null 'PGtimestamp )
109+ , null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtimestamp
104110makeTimestamp = unsafeFunctionN "make_timestamp"
105111
106112{-|
@@ -111,10 +117,9 @@ the current time zone is used
111117>>> printSQL (makeTimestamptz (2013 :* 7 :* 15 :* 8 :* 15 *: 23.5))
112118make_timestamptz(2013, 7, 15, 8, 15, 23.5)
113119-}
114−makeTimestamptz :: FunctionN
120+makeTimestamptz ::
115121 '[ null 'PGint4, null 'PGint4, null 'PGint4
116− , null 'PGint4, null 'PGint4, null 'PGfloat8 ]
117− ( null 'PGtimestamptz )
122+ , null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtimestamptz
118123makeTimestamptz = unsafeFunctionN "make_timestamptz"
119124
120125{-|
@@ -156,6 +161,7 @@ infixl 6 +!
156161infixl 6 !-
157162infixl 6 !-!
158163
164+-- | A `TimeUnit` to use in `interval_` construction.
159165data TimeUnit
160166 = Years | Months | Weeks | Days
161167 | Hours | Minutes | Seconds
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Type.hs+180−5
@@ -1,3 +1,13 @@
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+
111{-# LANGUAGE
212 AllowAmbiguousTypes
313 , DataKinds
@@ -13,12 +23,16 @@
1323 , ScopedTypeVariables
1424 , TypeApplications
1525 , TypeOperators
26+ , UndecidableInstances
1627#-}
1728
1829module Squeal.PostgreSQL.Expression.Type
19− ( TypeExpression (..)
20− , cast
21− , PGTyped (..)
30+ ( -- * type casting
31+ cast
32+ , astype
33+ , inferredtype
34+ -- * type expressions
35+ , TypeExpression (..)
2236 , typedef
2337 , typetable
2438 , typeview
@@ -44,9 +58,11 @@ module Squeal.PostgreSQL.Expression.Type
4458 , bytea
4559 , timestamp
4660 , timestampWithTimeZone
61+ , timestamptz
4762 , date
4863 , time
4964 , timeWithTimeZone
65+ , timetz
5066 , interval
5167 , uuid
5268 , inet
@@ -56,6 +72,29 @@ module Squeal.PostgreSQL.Expression.Type
5672 , fixarray
5773 , tsvector
5874 , 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 (..)
5998 ) where
6099
61100import Control.DeepSeq
@@ -69,6 +108,7 @@ import qualified Generics.SOP as SOP
69108
70109import Squeal.PostgreSQL.Alias
71110import Squeal.PostgreSQL.Expression
111+import Squeal.PostgreSQL.PG
72112import Squeal.PostgreSQL.Render
73113import Squeal.PostgreSQL.Schema
74114
@@ -90,6 +130,29 @@ cast
90130cast ty x = UnsafeExpression $ parenthesized $
91131 renderSQL x <+> "::" <+> renderSQL ty
92132
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
93156
94157{-----------------------------------------
95158type expressions
@@ -107,6 +170,7 @@ instance RenderSQL (TypeExpression schemas ty) where
107170typedef
108171 :: (Has sch schemas schema, Has td schema ('Typedef ty))
109172 => QualifiedAlias sch td
173+ -- ^ type alias
110174 -> TypeExpression schemas (null ty)
111175typedef = UnsafeTypeExpression . renderSQL
112176
@@ -115,6 +179,7 @@ typedef = UnsafeTypeExpression . renderSQL
115179typetable
116180 :: (Has sch schemas schema, Has tab schema ('Table table))
117181 => QualifiedAlias sch tab
182+ -- ^ table alias
118183 -> TypeExpression schemas (null ('PGcomposite (TableToRow table)))
119184typetable = UnsafeTypeExpression . renderSQL
120185
@@ -123,6 +188,7 @@ typetable = UnsafeTypeExpression . renderSQL
123188typeview
124189 :: (Has sch schemas schema, Has vw schema ('View view))
125190 => QualifiedAlias sch vw
191+ -- ^ view alias
126192 -> TypeExpression schemas (null ('PGcomposite view))
127193typeview = UnsafeTypeExpression . renderSQL
128194
@@ -179,8 +245,9 @@ bytea = UnsafeTypeExpression "bytea"
179245timestamp :: TypeExpression schemas (null 'PGtimestamp)
180246timestamp = UnsafeTypeExpression "timestamp"
181247-- | date and time, including time zone
182−timestampWithTimeZone :: TypeExpression schemas (null 'PGtimestamptz)
248+timestampWithTimeZone, timestamptz :: TypeExpression schemas (null 'PGtimestamptz)
183249timestampWithTimeZone = UnsafeTypeExpression "timestamp with time zone"
250+timestamptz = UnsafeTypeExpression "timestamptz"
184251-- | calendar date (year, month, day)
185252date :: TypeExpression schemas (null 'PGdate)
186253date = UnsafeTypeExpression "date"
@@ -188,8 +255,9 @@ date = UnsafeTypeExpression "date"
188255time :: TypeExpression schemas (null 'PGtime)
189256time = UnsafeTypeExpression "time"
190257-- | time of day, including time zone
191−timeWithTimeZone :: TypeExpression schemas (null 'PGtimetz)
258+timeWithTimeZone, timetz :: TypeExpression schemas (null 'PGtimetz)
192259timeWithTimeZone = UnsafeTypeExpression "time with time zone"
260+timetz = UnsafeTypeExpression "timetz"
193261-- | time span
194262interval :: TypeExpression schemas (null 'PGinterval)
195263interval = UnsafeTypeExpression "interval"
@@ -230,10 +298,34 @@ fixarray ty = UnsafeTypeExpression $
230298 $ SOP.hcmap (SOP.Proxy @KnownNat)
231299 (K . fromString . show . natVal)
232300 (SOP.hpure SOP.Proxy :: SOP.NP SOP.Proxy ns)
301+-- | text search query
233302tsvector :: TypeExpression schemas (null 'PGtsvector)
234303tsvector = UnsafeTypeExpression "tsvector"
304+-- | text search document
235305tsquery :: TypeExpression schemas (null 'PGtsquery)
236306tsquery = 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"
237329
238330-- | `pgtype` is a demoted version of a `PGType`
239331class PGTyped schemas (ty :: NullityType) where
@@ -269,3 +361,86 @@ instance (SOP.All KnownNat dims, PGTyped schemas ty)
269361 pgtype = fixarray @dims (pgtype @schemas @ty)
270362instance PGTyped schemas (null 'PGtsvector) where pgtype = tsvector
271363instance PGTyped schemas (null 'PGtsquery) where pgtype = tsquery
364+instance PGTyped schemas (null 'PGoid) where pgtype = oid
365+instance PGTyped schemas (null ('PGrange 'PGint4)) where pgtype = int4range
366+instance PGTyped schemas (null ('PGrange 'PGint8)) where pgtype = int8range
367+instance PGTyped schemas (null ('PGrange 'PGnumeric)) where pgtype = numrange
368+instance PGTyped schemas (null ('PGrange 'PGtimestamp)) where pgtype = tsrange
369+instance PGTyped schemas (null ('PGrange 'PGtimestamptz)) where pgtype = tstzrange
370+instance PGTyped schemas (null ('PGrange 'PGdate)) where pgtype = daterange
371+
372+-- | Lift `PGTyped` to a field
373+class FieldTyped schemas ty where
374+ fieldtype :: Aliased (TypeExpression schemas) ty
375+instance (KnownSymbol alias, PGTyped schemas ty)
376+ => FieldTyped schemas (alias ::: ty) where
377+ fieldtype = pgtype `As` Alias
378+
379+-- | `ColumnTypeExpression`s are used in `createTable` commands.
380+newtype ColumnTypeExpression (schemas :: SchemasType) (ty :: ColumnType)
381+ = UnsafeColumnTypeExpression { renderColumnTypeExpression :: ByteString }
382+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
383+instance RenderSQL (ColumnTypeExpression schemas ty) where
384+ renderSQL = renderColumnTypeExpression
385+
386+-- | used in `createTable` commands as a column constraint to note that
387+-- @NULL@ may be present in a column
388+nullable
389+ :: TypeExpression schemas (nullity ty)
390+ -> ColumnTypeExpression schemas ('NoDef :=> 'Null ty)
391+nullable ty = UnsafeColumnTypeExpression $ renderSQL ty <+> "NULL"
392+
393+-- | used in `createTable` commands as a column constraint to ensure
394+-- @NULL@ is not present in a column
395+notNullable
396+ :: TypeExpression schemas (nullity ty)
397+ -> ColumnTypeExpression schemas ('NoDef :=> 'NotNull ty)
398+notNullable ty = UnsafeColumnTypeExpression $ renderSQL ty <+> "NOT NULL"
399+
400+-- | used in `createTable` commands as a column constraint to give a default
401+default_
402+ :: Expression '[] '[] 'Ungrouped schemas '[] '[] ty
403+ -> ColumnTypeExpression schemas ('NoDef :=> ty)
404+ -> ColumnTypeExpression schemas ('Def :=> ty)
405+default_ x ty = UnsafeColumnTypeExpression $
406+ renderSQL ty <+> "DEFAULT" <+> renderExpression x
407+
408+-- | not a true type, but merely a notational convenience for creating
409+-- unique identifier columns with type `PGint2`
410+serial2, smallserial
411+ :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint2)
412+serial2 = UnsafeColumnTypeExpression "serial2"
413+smallserial = UnsafeColumnTypeExpression "smallserial"
414+-- | not a true type, but merely a notational convenience for creating
415+-- unique identifier columns with type `PGint4`
416+serial4, serial
417+ :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint4)
418+serial4 = UnsafeColumnTypeExpression "serial4"
419+serial = UnsafeColumnTypeExpression "serial"
420+-- | not a true type, but merely a notational convenience for creating
421+-- unique identifier columns with type `PGint8`
422+serial8, bigserial
423+ :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint8)
424+serial8 = UnsafeColumnTypeExpression "serial8"
425+bigserial = UnsafeColumnTypeExpression "bigserial"
426+
427+-- | Like @PGTyped@ but also accounts for nullity.
428+class PGNullityTyped schemas (nullty :: NullityType) where
429+ pgNullityType :: ColumnTypeExpression schemas ('NoDef :=> nullty)
430+
431+instance PGTyped schemas ('Null ty) => PGNullityTyped schemas ('Null ty) where
432+ pgNullityType = nullable (pgtype @_ @('Null ty))
433+
434+instance PGTyped schemas ('NotNull ty) => PGNullityTyped schemas ('NotNull ty) where
435+ pgNullityType = notNullable (pgtype @_ @('NotNull ty))
436+
437+-- | Allow you to specify pg column types in relation to haskell types.
438+-- >>> printSQL $ hask @(Maybe String)
439+-- text NULL
440+--
441+-- >>> printSQL $ hask @Double
442+-- float8 NOT NULL
443+hask
444+ :: forall hask schemas. PGNullityTyped schemas (NullPG hask)
445+ => ColumnTypeExpression schemas ('NoDef :=> NullPG hask)
446+hask = pgNullityType
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Window.hs+44−6
@@ -1,3 +1,13 @@
1+{-|
2+Module: Squeal.PostgreSQL.Expression.Window
3+Description: Window functions
4+Copyright: (c) Eitan Chatav, 2019
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Window functions and definitions
9+-}
10+
111{-# LANGUAGE
212 DataKinds
313 , DeriveGeneric
@@ -13,9 +23,8 @@
1323#-}
1424
1525module Squeal.PostgreSQL.Expression.Window
16− ( WindowDefinition (..)
17− , partitionBy
18− , WindowFunction (..)
26+ ( -- * functions
27+ partitionBy
1928 , rank
2029 , rowNumber
2130 , denseRank
@@ -27,6 +36,14 @@ module Squeal.PostgreSQL.Expression.Window
2736 , firstValue
2837 , lastValue
2938 , nthValue
39+ , unsafeWindowFunction1
40+ , unsafeWindowFunctionN
41+ -- * types
42+ , WindowFunction (..)
43+ , WindowDefinition (..)
44+ , WinFun0
45+ , WinFun1
46+ , WinFunN
3047 ) where
3148
3249import Control.DeepSeq
@@ -80,14 +97,15 @@ instance Aggregate
8097 varPop = unsafeWindowFunction1 "var_pop"
8198 varSamp = unsafeWindowFunction1 "var_samp"
8299
83−
84100-- | A `WindowDefinition` is a set of table rows that are somehow related
85101-- to the current row
86102data WindowDefinition outer commons grp schemas params from where
87103 WindowDefinition
88104 :: SOP.SListI bys
89105 => NP (Expression outer commons grp schemas params from) bys
106+ -- ^ `partitionBy` clause
90107 -> [SortExpression outer commons grp schemas params from]
108+ -- ^ `Squeal.PostgreSQL.Expression.Sort.orderBy` clause
91109 -> WindowDefinition outer commons grp schemas params from
92110
93111instance OrderBy WindowDefinition where
@@ -114,7 +132,7 @@ the same partition as the current row.
114132-}
115133partitionBy
116134 :: SOP.SListI bys
117− => NP (Expression outer commons grp schemas params from) bys
135+ => NP (Expression outer commons grp schemas params from) bys -- ^ partitions
118136 -> WindowDefinition outer commons grp schemas params from
119137partitionBy bys = WindowDefinition bys []
120138
@@ -142,11 +160,17 @@ newtype WindowFunction
142160instance RenderSQL (WindowFunction outer commons grp schemas params from ty) where
143161 renderSQL = renderWindowFunction
144162
163+{- |
164+A @RankNType@ for window functions with no arguments.
165+-}
145166type WinFun0 x
146167 = forall outer commons grp schemas params from
147168 . WindowFunction outer commons grp schemas params from x
148169 -- ^ cannot reference aliases
149170
171+{- |
172+A @RankNType@ for window functions with 1 argument.
173+-}
150174type WinFun1 x y
151175 = forall outer commons grp schemas params from
152176 . Expression outer commons grp schemas params from x
@@ -154,6 +178,10 @@ type WinFun1 x y
154178 -> WindowFunction outer commons grp schemas params from y
155179 -- ^ output
156180
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+-}
157185type WinFunN xs y
158186 = forall outer commons grp schemas params from
159187 . NP (Expression outer commons grp schemas params from) xs
@@ -161,15 +189,18 @@ type WinFunN xs y
161189 -> WindowFunction outer commons grp schemas params from y
162190 -- ^ output
163191
192+-- | escape hatch for defining window functions
164193unsafeWindowFunction1 :: ByteString -> WinFun1 x y
165194unsafeWindowFunction1 fun x
166195 = UnsafeWindowFunction $ fun <> parenthesized (renderSQL x)
167196
197+-- | escape hatch for defining multi-argument window functions
168198unsafeWindowFunctionN :: SOP.SListI xs => ByteString -> WinFunN xs y
169199unsafeWindowFunctionN fun xs = UnsafeWindowFunction $ fun <>
170200 parenthesized (renderCommaSeparated renderSQL xs)
171201
172202{- | rank of the current row with gaps; same as `rowNumber` of its first peer
203+
173204>>> printSQL rank
174205rank()
175206-}
@@ -177,6 +208,7 @@ rank :: WinFun0 ('NotNull 'PGint8)
177208rank = UnsafeWindowFunction "rank()"
178209
179210{- | number of the current row within its partition, counting from 1
211+
180212>>> printSQL rowNumber
181213row_number()
182214-}
@@ -184,6 +216,7 @@ rowNumber :: WinFun0 ('NotNull 'PGint8)
184216rowNumber = UnsafeWindowFunction "row_number()"
185217
186218{- | rank of the current row without gaps; this function counts peer groups
219+
187220>>> printSQL denseRank
188221dense_rank()
189222-}
@@ -191,6 +224,7 @@ denseRank :: WinFun0 ('NotNull 'PGint8)
191224denseRank = UnsafeWindowFunction "dense_rank()"
192225
193226{- | relative rank of the current row: (rank - 1) / (total partition rows - 1)
227+
194228>>> printSQL percentRank
195229percent_rank()
196230-}
@@ -199,6 +233,7 @@ percentRank = UnsafeWindowFunction "percent_rank()"
199233
200234{- | cumulative distribution: (number of partition rows
201235preceding or peer with current row) / total partition rows
236+
202237>>> printSQL cumeDist
203238cume_dist()
204239-}
@@ -207,6 +242,9 @@ cumeDist = UnsafeWindowFunction "cume_dist()"
207242
208243{- | integer ranging from 1 to the argument value,
209244dividing the partition as equally as possible
245+
246+>>> printSQL $ ntile 5
247+ntile(5)
210248-}
211249ntile :: WinFun1 ('NotNull 'PGint4) ('NotNull 'PGint4)
212250ntile = unsafeWindowFunction1 "ntile"
@@ -225,7 +263,7 @@ row within the partition; if there is no such row, instead return default
225263evaluated with respect to the current row.
226264-}
227265lead :: WinFunN '[ty, 'NotNull 'PGint4, ty] ty
228−lead = unsafeWindowFunctionN "lag"
266+lead = unsafeWindowFunctionN "lead"
229267
230268{- | returns value evaluated at the row that is the
231269first row of the window frame
squeal-postgresql/src/Squeal/PostgreSQL/List.hs+21−50
@@ -32,17 +32,17 @@ module Squeal.PostgreSQL.List
3232 , (*:)
3333 , Join
3434 , disjoin
35− , Additionally (..)
36− , AlignedList (..)
37− , single
38− , extractList
39− , mapAligned
35+ , Additional (..)
36+ , Path (..)
37+ , CFunctor (..)
38+ , CFoldable (..)
39+ , CFree (..)
4040 , Elem
4141 , In
4242 , Length
4343 ) where
4444
45−import Control.Category
45+import Control.Category.Free
4646import Data.Function ((&))
4747import Data.Kind
4848import Data.Type.Bool
@@ -50,8 +50,6 @@ import GHC.TypeLits
5050
5151import Generics.SOP as SOP
5252
53−import Squeal.PostgreSQL.Render
54−
5553-- | `Join` is simply promoted `++` and is used in @JOIN@s in
5654-- `Squeal.PostgreSQL.Query.FromClause`s.
5755type family Join xs ys where
@@ -68,52 +66,16 @@ disjoin = case sList @xs of
6866 SCons -> \(x :* xsys) ->
6967 case disjoin xsys of (xs,ys) -> (x :* xs, ys)
7068
71−-- | The `Additionally` class is for appending
69+-- | The `Additional` class is for appending
7270-- type-level list parameterized constructors such as `NP`,
7371-- `Squeal.PostgreSQL.Query.Selection`, and `Squeal.PostgreSQL.Query.FromClause`.
74−class Additionally expr where
72+class Additional expr where
7573 also :: expr ys -> expr xs -> expr (Join xs ys)
76−instance Additionally (NP expr) where
74+instance Additional (NP expr) where
7775 also ys = \case
7876 Nil -> ys
7977 x :* xs -> x :* (xs & also ys)
8078
81−-- | An `AlignedList` is a type-aligned list or free category.
82−data AlignedList p x0 x1 where
83− Done :: AlignedList p x x
84− (:>>) :: p x0 x1 -> AlignedList p x1 x2 -> AlignedList p x0 x2
85−infixr 7 :>>
86−instance Category (AlignedList p) where
87− id = Done
88− (.) list = \case
89− Done -> list
90− step :>> steps -> step :>> (steps >>> list)
91−instance (forall t0 t1. RenderSQL (p t0 t1))
92− => RenderSQL (AlignedList p x0 x1) where
93− renderSQL = \case
94− Done -> ""
95− step :>> Done -> renderSQL step
96− step :>> steps -> renderSQL step <> ", " <> renderSQL steps
97−
98−-- | `extractList` turns an `AlignedList` into a standard list.
99−extractList :: (forall a0 a1. p a0 a1 -> b) -> AlignedList p x0 x1 -> [b]
100−extractList f = \case
101− Done -> []
102− step :>> steps -> (f step):extractList f steps
103−
104−-- | `mapAligned` applies a function to each element of an `AlignedList`.
105−mapAligned
106− :: (forall z0 z1. p z0 z1 -> q z0 z1)
107− -> AlignedList p x0 x1
108− -> AlignedList q x0 x1
109−mapAligned f = \case
110− Done -> Done
111− x :>> xs -> f x :>> mapAligned f xs
112−
113−-- | A `single` step.
114−single :: p x0 x1 -> AlignedList p x0 x1
115−single step = step :>> Done
116−
11779-- | A useful operator for ending an `NP` list of length at least 2 without `Nil`.
11880(*:) :: f x -> f y -> NP f '[x,y]
11981x *: y = x :* y :* Nil
@@ -122,13 +84,18 @@ infixl 9 *:
12284-- | @Elem@ is a promoted `Data.List.elem`.
12385type family Elem x xs where
12486 Elem x '[] = 'False
125− Elem x (x ': xs) = 'True
87+ Elem x (x ': _) = 'True
88+ Elem x (_ ': x ': _) = 'True
89+ Elem x (_ ': _ ': x ': _) = 'True
90+ Elem x (_ ': _ ': _ ': x ': _) = 'True
91+ Elem x (_ ': _ ': _ ': _ ': x ': _) = 'True
92+ Elem x (_ ': _ ': _ ': _ ': _ ': x ': _) = 'True
12693 Elem x (_ ': xs) = Elem x xs
12794
12895-- | @In x xs@ is a constraint that proves that @x@ is in @xs@.
12996type family In x xs :: Constraint where
13097 In x xs = If (Elem x xs) (() :: Constraint)
131− (TypeError ('ShowType x ':<>: 'Text "is not in " ':<>: 'ShowType xs))
98+ (TypeError ('ShowType x ':<>: 'Text " is not in " ':<>: 'ShowType xs))
13299
133100{- | Calculate the `Length` of a type level list
134101
@@ -137,5 +104,9 @@ Length '[Char,String,Bool,Double] :: Nat
137104= 4
138105-}
139106type family Length (xs :: [k]) :: Nat where
140− Length (x : xs) = 1 + Length xs
107+ Length (_ ': _ ': _ ': _ ': _ : xs) = 5 + Length xs
108+ Length (_ ': _ ': _ ': _ : xs) = 4 + Length xs
109+ Length (_ ': _ ': _ : xs) = 3 + Length xs
110+ Length (_ ': _ : xs) = 2 + Length xs
111+ Length (_ : xs) = 1 + Length xs
141112 Length '[] = 0
squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs+155−153
@@ -18,6 +18,7 @@ Squeal data manipulation language.
1818 , MultiParamTypeClasses
1919 , OverloadedStrings
2020 , PatternSynonyms
21+ , QuantifiedConstraints
2122 , RankNTypes
2223 , ScopedTypeVariables
2324 , TypeApplications
@@ -29,19 +30,9 @@ Squeal data manipulation language.
2930
3031module Squeal.PostgreSQL.Manipulation
3132 ( -- * Manipulation
32− Manipulation (..)
33− , Manipulation_
33+ Manipulation_
34+ , Manipulation (..)
3435 , queryStatement
35− , QueryClause (..)
36− , pattern Values_
37− , DefaultAliasable (..)
38− , ColumnExpression (..)
39− , ReturningClause (..)
40− , pattern Returning_
41− , ConflictClause (..)
42− , ConflictTarget (..)
43− , ConflictAction (..)
44− , UsingClause (..)
4536 -- * Insert
4637 , insertInto
4738 , insertInto_
@@ -51,12 +42,21 @@ module Squeal.PostgreSQL.Manipulation
5142 -- * Delete
5243 , deleteFrom
5344 , deleteFrom_
45+ -- * Clauses
46+ , Optional (..)
47+ , QueryClause (..)
48+ , pattern Values_
49+ , ReturningClause (..)
50+ , pattern Returning_
51+ , ConflictClause (..)
52+ , ConflictTarget (..)
53+ , ConflictAction (..)
54+ , UsingClause (..)
5455 ) where
5556
5657import Control.DeepSeq
5758import Data.ByteString hiding (foldr)
5859import Data.Kind (Type)
59−import GHC.TypeLits (KnownSymbol)
6060
6161import qualified Generics.SOP as SOP
6262import qualified GHC.Generics as GHC
@@ -72,21 +72,65 @@ import Squeal.PostgreSQL.Schema
7272
7373-- $setup
7474-- >>> import Squeal.PostgreSQL
75+-- >>> import Data.Int
76+-- >>> import Data.Time
7577
7678{- |
7779A `Manipulation` is a statement which may modify data in the database,
7880but does not alter its schemas. Examples are inserts, updates and deletes.
7981A `Query` is also considered a `Manipulation` even though it does not modify data.
8082
83+The general `Manipulation` type is parameterized by
84+
85+* @commons :: FromType@ - scope for all `common` table expressions,
86+* @schemas :: SchemasType@ - scope for all `table`s and `view`s,
87+* @params :: [NullityType]@ - scope for all `Squeal.Expression.Parameter.parameter`s,
88+* @row :: RowType@ - return type of the `Query`.
89+-}
90+newtype Manipulation
91+ (commons :: FromType)
92+ (schemas :: SchemasType)
93+ (params :: [NullityType])
94+ (columns :: RowType)
95+ = UnsafeManipulation { renderManipulation :: ByteString }
96+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
97+instance RenderSQL (Manipulation commons schemas params columns) where
98+ renderSQL = renderManipulation
99+instance With Manipulation where
100+ with Done manip = manip
101+ with ctes manip = UnsafeManipulation $
102+ "WITH" <+> commaSeparated (ctoList renderSQL ctes) <+> renderSQL manip
103+
104+{- |
105+The top level `Manipulation_` type is parameterized by a @schemas@ `SchemasType`,
106+against which the query is type-checked, an input @parameters@ Haskell `Type`,
107+and an ouput row Haskell `Type`.
108+
109+A top-level `Manipulation_` can be run
110+using `Squeal.PostgreSQL.PQ.manipulateParams`, or if @parameters = ()@
111+using `Squeal.PostgreSQL.PQ.manipulate`.
112+
113+Generally, @parameters@ will be a Haskell tuple or record whose entries
114+may be referenced using positional
115+`Squeal.PostgreSQL.Expression.Parameter.parameter`s and @row@ will be a
116+Haskell record, whose entries will be targeted using overloaded labels.
117+
118+>>> :set -XDeriveAnyClass -XDerivingStrategies
119+>>> :{
120+data Row a b = Row { col1 :: a, col2 :: b }
121+ deriving stock (GHC.Generic)
122+ deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
123+:}
124+
81125simple insert:
82126
83127>>> type Columns = '["col1" ::: 'NoDef :=> 'Null 'PGint4, "col2" ::: 'Def :=> 'NotNull 'PGint4]
84128>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]
85129>>> :{
86130let
87− manipulation :: Manipulation '[] (Public Schema) '[] '[]
131+ manipulation :: Manipulation_ (Public Schema) () ()
88132 manipulation =
89− insertInto_ #tab (Values_ (2 `as` #col1 :* defaultAs #col2))
133+ insertInto_ #tab (Values_ (Set 2 `as` #col1 :* Default `as` #col2))
90134in printSQL manipulation
91135:}
92136INSERT INTO "tab" ("col1", "col2") VALUES (2, DEFAULT)
@@ -97,9 +141,9 @@ parameterized insert:
97141>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]
98142>>> :{
99143let
100− manipulation :: Manipulation '[] (Public Schema) '[ 'NotNull 'PGint4, 'NotNull 'PGint4 ] '[]
144+ manipulation :: Manipulation_ (Public Schema) (Int32, Int32) ()
101145 manipulation =
102− insertInto_ #tab (Values_ (param @1 `as` #col1 :* param @2 `as` #col2))
146+ insertInto_ #tab (Values_ (Set (param @1) `as` #col1 :* Set (param @2) `as` #col2))
103147in printSQL manipulation
104148:}
105149INSERT INTO "tab" ("col1", "col2") VALUES (($1 :: int4), ($2 :: int4))
@@ -108,9 +152,9 @@ returning insert:
108152
109153>>> :{
110154let
111− manipulation :: Manipulation '[] (Public Schema) '[] '["fromOnly" ::: 'NotNull 'PGint4]
155+ manipulation :: Manipulation_ (Public Schema) () (Only Int32)
112156 manipulation =
113− insertInto #tab (Values_ (2 `as` #col1 :* 3 `as` #col2))
157+ insertInto #tab (Values_ (Set 2 `as` #col1 :* Set 3 `as` #col2))
114158 OnConflictDoRaise (Returning (#col1 `as` #fromOnly))
115159in printSQL manipulation
116160:}
@@ -123,12 +167,12 @@ upsert:
123167>>> type CustomersSchema = '["customers" ::: 'Table (CustomersConstraints :=> CustomersColumns)]
124168>>> :{
125169let
126− manipulation :: Manipulation '[] (Public CustomersSchema) '[] '[]
170+ manipulation :: Manipulation_ (Public CustomersSchema) () ()
127171 manipulation =
128172 insertInto #customers
129− (Values_ ("John Smith" `as` #name :* "john@smith.com" `as` #email))
173+ (Values_ (Set "John Smith" `as` #name :* Set "john@smith.com" `as` #email))
130174 (OnConflict (OnConstraint #uq)
131− (DoUpdate (((#excluded ! #email) <> "; " <> (#customers ! #email)) `as` #email) []))
175+ (DoUpdate (Set (#excluded ! #email <> "; " <> #customers ! #email) `as` #email) []))
132176 (Returning_ Nil)
133177in printSQL manipulation
134178:}
@@ -138,7 +182,7 @@ query insert:
138182
139183>>> :{
140184let
141− manipulation :: Manipulation '[] (Public Schema) '[] '[]
185+ manipulation :: Manipulation_ (Public Schema) () ()
142186 manipulation = insertInto_ #tab (Subquery (select Star (from (table #tab))))
143187in printSQL manipulation
144188:}
@@ -148,8 +192,8 @@ update:
148192
149193>>> :{
150194let
151− manipulation :: Manipulation '[] (Public Schema) '[] '[]
152− manipulation = update_ #tab (2 `as` #col1) (#col1 ./= #col2)
195+ manipulation :: Manipulation_ (Public Schema) () ()
196+ manipulation = update_ #tab (Set 2 `as` #col1) (#col1 ./= #col2)
153197in printSQL manipulation
154198:}
155199UPDATE "tab" SET "col1" = 2 WHERE ("col1" <> "col2")
@@ -158,9 +202,7 @@ delete:
158202
159203>>> :{
160204let
161− manipulation :: Manipulation '[] (Public Schema) '[]
162− '[ "col1" ::: 'NotNull 'PGint4
163− , "col2" ::: 'NotNull 'PGint4 ]
205+ manipulation :: Manipulation_ (Public Schema) () (Row Int32 Int32)
164206 manipulation = deleteFrom #tab NoUsing (#col1 .== #col2) (Returning Star)
165207in printSQL manipulation
166208:}
@@ -171,13 +213,13 @@ delete and using clause:
171213>>> :{
172214type Schema3 =
173215 '[ "tab" ::: 'Table ('[] :=> Columns)
174− , "other_tab" ::: 'Table ('[] :=> Columns)
175− , "third_tab" ::: 'Table ('[] :=> Columns) ]
216+ , "other_tab" ::: 'Table ('[] :=> Columns)
217+ , "third_tab" ::: 'Table ('[] :=> Columns) ]
176218:}
177219
178220>>> :{
179221let
180− manipulation :: Manipulation '[] (Public Schema3) '[] '[]
222+ manipulation :: Manipulation_ (Public Schema3) () ()
181223 manipulation =
182224 deleteFrom #tab (Using (table #other_tab & also (table #third_tab)))
183225 ( (#tab ! #col2 .== #other_tab ! #col2)
@@ -193,7 +235,7 @@ with manipulation:
193235>>> type ProductsSchema = '["products" ::: 'Table ('[] :=> ProductsColumns), "products_deleted" ::: 'Table ('[] :=> ProductsColumns)]
194236>>> :{
195237let
196− manipulation :: Manipulation '[] (Public ProductsSchema) '[ 'NotNull 'PGdate] '[]
238+ manipulation :: Manipulation_ (Public ProductsSchema) (Only Day) ()
197239 manipulation = with
198240 (deleteFrom #products NoUsing (#date .< param @1) (Returning Star) `as` #del)
199241 (insertInto_ #products_deleted (Subquery (select Star (from (common #del)))))
@@ -201,26 +243,13 @@ in printSQL manipulation
201243:}
202244WITH "del" AS (DELETE FROM "products" WHERE ("date" < ($1 :: date)) RETURNING *) INSERT INTO "products_deleted" SELECT * FROM "del" AS "del"
203245-}
204−newtype Manipulation
205− (commons :: FromType)
206− (schemas :: SchemasType)
207− (params :: [NullityType])
208− (columns :: RowType)
209− = UnsafeManipulation { renderManipulation :: ByteString }
210− deriving (GHC.Generic,Show,Eq,Ord,NFData)
211−instance RenderSQL (Manipulation commons schemas params columns) where
212− renderSQL = renderManipulation
213−instance With Manipulation where
214− with Done manip = manip
215− with ctes manip = UnsafeManipulation $
216− "WITH" <+> renderSQL ctes <+> renderSQL manip
217−
218246type family Manipulation_ (schemas :: SchemasType) (params :: Type) (row :: Type) where
219247 Manipulation_ schemas params row = Manipulation '[] schemas (TuplePG params) (RowPG row)
220248
221249-- | Convert a `Query` into a `Manipulation`.
222250queryStatement
223251 :: Query '[] commons schemas params columns
252+ -- ^ `Query` to embed as a `Manipulation`
224253 -> Manipulation commons schemas params columns
225254queryStatement q = UnsafeManipulation $ renderSQL q
226255
@@ -243,9 +272,13 @@ insertInto
243272 , SOP.SListI columns
244273 , SOP.SListI row1 )
245274 => QualifiedAlias sch tab
275+ -- ^ table
246276 -> QueryClause commons schemas params columns
277+ -- ^ what to insert
247278 -> ConflictClause tab commons schemas params table
279+ -- ^ what to do in case of conflict
248280 -> ReturningClause commons schemas params '[tab ::: row0] row1
281+ -- ^ what to return
249282 -> Manipulation commons schemas params row1
250283insertInto tab qry conflict ret = UnsafeManipulation $
251284 "INSERT" <+> "INTO" <+> renderSQL tab
@@ -253,6 +286,7 @@ insertInto tab qry conflict ret = UnsafeManipulation $
253286 <> renderSQL conflict
254287 <> renderSQL ret
255288
289+-- | Like `insertInto` but with `OnConflictDoRaise` and `no` `ReturningClause`.
256290insertInto_
257291 :: ( Has sch schemas schema
258292 , Has tab schema ('Table table)
@@ -260,25 +294,33 @@ insertInto_
260294 , row ~ TableToRow table
261295 , SOP.SListI columns )
262296 => QualifiedAlias sch tab
297+ -- ^ table
263298 -> QueryClause commons schemas params columns
299+ -- ^ what to insert
264300 -> Manipulation commons schemas params '[]
265301insertInto_ tab qry =
266302 insertInto tab qry OnConflictDoRaise (Returning_ Nil)
267303
304+-- | A `QueryClause` describes what to `insertInto` a table.
268305data QueryClause commons schemas params columns where
269306 Values
270307 :: SOP.SListI columns
271− => NP (ColumnExpression 'Ungrouped schemas params '[]) columns
272− -> [NP (ColumnExpression 'Ungrouped schemas params '[]) columns]
308+ => NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[]))) columns
309+ -- ^ row of values
310+ -> [NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[]))) columns]
311+ -- ^ additional rows of values
273312 -> QueryClause commons schemas params columns
274313 Select
275314 :: SOP.SListI columns
276− => NP (ColumnExpression grp schemas params from) columns
315+ => NP (Aliased (Optional (Expression '[] commons grp schemas params from))) columns
316+ -- ^ row of values
277317 -> TableExpression '[] commons grp schemas params from
318+ -- ^ from a table expression
278319 -> QueryClause commons schemas params columns
279320 Subquery
280321 :: ColumnsToRow columns ~ row
281322 => Query '[] commons schemas params row
323+ -- ^ subquery to insert
282324 -> QueryClause commons schemas params columns
283325
284326instance RenderSQL (QueryClause commons schemas params columns) where
@@ -297,109 +339,41 @@ instance RenderSQL (QueryClause commons schemas params columns) where
297339 Subquery qry -> renderQuery qry
298340 where
299341 renderSQLPartMaybe, renderValuePartMaybe
300− :: ColumnExpression grp schemas params from column -> Maybe ByteString
342+ :: Aliased (Optional (Expression '[] commons grp schemas params from)) column
343+ -> Maybe ByteString
301344 renderSQLPartMaybe = \case
302− DefaultAs _ -> Nothing
303− Specific (_ `As` name) -> Just $ renderSQL name
345+ Default `As` _ -> Nothing
346+ Set _ `As` name -> Just $ renderSQL name
304347 renderValuePartMaybe = \case
305− DefaultAs _ -> Nothing
306− Specific (value `As` _) -> Just $ renderExpression value
348+ Default `As` _ -> Nothing
349+ Set value `As` _ -> Just $ renderExpression value
307350 renderSQLPart, renderValuePart
308− :: ColumnExpression grp schemas params from column -> ByteString
309− renderSQLPart = \case
310− DefaultAs name -> renderSQL name
311− Specific (_ `As` name) -> renderSQL name
312− renderValuePart = \case
313− DefaultAs _ -> "DEFAULT"
314− Specific (value `As` _) -> renderExpression value
351+ :: Aliased (Optional (Expression '[] commons grp schemas params from)) column
352+ -> ByteString
353+ renderSQLPart (_ `As` name) = renderSQL name
354+ renderValuePart (value `As` _) = renderSQL value
315355
356+-- | `Values_` describes a single `NP` list of `Aliased` `Optional` `Expression`s
357+-- whose `ColumnsType` must match the tables'.
316358pattern Values_
317359 :: SOP.SListI columns
318− => NP (ColumnExpression 'Ungrouped schemas params '[]) columns
360+ => NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[]))) columns
361+ -- ^ row of values
319362 -> QueryClause commons schemas params columns
320363pattern Values_ vals = Values vals []
321364
322−data ColumnExpression grp schemas params from column where
323− DefaultAs
324− :: KnownSymbol col
325− => Alias col
326− -> ColumnExpression grp schemas params from (col ::: 'Def :=> ty)
327− Specific
328− :: Aliased (Expression '[] '[] grp schemas params from) (col ::: ty)
329− -> ColumnExpression grp schemas params from (col ::: defness :=> ty)
330−
331−instance (KnownSymbol col, column ~ (col ::: defness :=> ty))
332− => Aliasable col
333− (Expression '[] '[] grp schemas params from ty)
334− (ColumnExpression grp schemas params from column) where
335− expression `as` col = Specific (expression `As` col)
336−instance (KnownSymbol col, columns ~ '[col ::: defness :=> ty])
337− => Aliasable col
338− (Expression '[] '[] grp schemas params from ty)
339− (NP (ColumnExpression grp schemas params from) columns) where
340− expression `as` col = expression `as` col :* Nil
341−instance (KnownSymbol col, column ~ (col ::: 'Def :=> ty))
342− => DefaultAliasable col (ColumnExpression grp schemas params from column) where
343− defaultAs = DefaultAs
344−instance (KnownSymbol col, columns ~ '[col ::: 'Def :=> ty])
345− => DefaultAliasable col (NP (ColumnExpression grp schemas params from) columns) where
346− defaultAs col = defaultAs col :* Nil
347−
348−instance (HasUnique tab from row, Has col row ty, column ~ (col ::: defness :=> ty))
349− => IsLabel col (ColumnExpression 'Ungrouped schemas params from column) where
350− fromLabel = fromLabel @col `as` Alias
351−instance (HasUnique tab from row, Has col row ty, columns ~ '[col ::: defness :=> ty])
352− => IsLabel col
353− (NP (ColumnExpression 'Ungrouped schemas params from) columns) where
354− fromLabel = fromLabel @col `as` Alias
355−
356−instance (Has tab from row, Has col row ty, column ~ (col ::: defness :=> ty))
357− => IsQualified tab col (ColumnExpression 'Ungrouped schemas params from column) where
358− tab ! col = tab ! col `as` col
359−instance (Has tab from row, Has col row ty, columns ~ '[col ::: defness :=> ty])
360− => IsQualified tab col (NP (ColumnExpression 'Ungrouped schemas params from) columns) where
361− tab ! col = tab ! col `as` col
362−
363−instance
364− ( HasUnique tab from row
365− , Has col row ty
366− , GroupedBy tab col bys
367− , column ~ (col ::: defness :=> ty)
368− ) => IsLabel col
369− (ColumnExpression ('Grouped bys) schemas params from column) where
370− fromLabel = fromLabel @col `as` Alias
371−instance
372− ( HasUnique tab from row
373− , Has col row ty
374− , GroupedBy tab col bys
375− , columns ~ '[col ::: defness :=> ty]
376− ) => IsLabel col
377− (NP (ColumnExpression ('Grouped bys) schemas params from) columns) where
378− fromLabel = fromLabel @col `as` Alias
379−
380−instance
381− ( Has tab from row
382− , Has col row ty
383− , GroupedBy tab col bys
384− , column ~ (col ::: defness :=> ty)
385− ) => IsQualified tab col
386− (ColumnExpression ('Grouped bys) schemas params from column) where
387− tab ! col = tab ! col `as` col
388−instance
389− ( Has tab from row
390− , Has col row ty
391− , GroupedBy tab col bys
392− , columns ~ '[col ::: defness :=> ty]
393− ) => IsQualified tab col
394− (NP (ColumnExpression ('Grouped bys) schemas params from) columns) where
395− tab ! col = tab ! col :* Nil
396−
397−instance RenderSQL (ColumnExpression grp schemas params from column) where
365+-- | `Optional` is either `Default` or a value, parameterized by an appropriate
366+-- `ColumnConstraint`.
367+data Optional expr ty where
368+ -- | Use the `Default` value for a column.
369+ Default :: Optional expr ('Def :=> ty)
370+ -- | `Set` a value for a column.
371+ Set :: expr ty -> Optional expr (def :=> ty)
372+
373+instance (forall x. RenderSQL (expr x)) => RenderSQL (Optional expr ty) where
398374 renderSQL = \case
399− DefaultAs col ->
400− renderSQL col <+> "=" <+> "DEFAULT"
401− Specific (expression `As` col) ->
402− renderSQL col <+> "=" <+> renderSQL expression
375+ Default -> "DEFAULT"
376+ Set expr -> renderSQL expr
403377
404378-- | A `ReturningClause` computes and return value(s) based
405379-- on each row actually inserted, updated or deleted. This is primarily
@@ -409,7 +383,7 @@ instance RenderSQL (ColumnExpression grp schemas params from column) where
409383-- deleted will be returned. For example, if a row was locked
410384-- but not updated because an `OnConflict` `DoUpdate` condition was not satisfied,
411385-- the row will not be returned. `Returning` `Star` will return all columns
412−-- in the row. Use @Returning Nil@ in the common case where no return
386+-- in the row. Use `Returning` `Nil` in the common case where no return
413387-- values are desired.
414388newtype ReturningClause commons schemas params from row =
415389 Returning (Selection '[] commons 'Ungrouped schemas params from row)
@@ -419,9 +393,11 @@ instance RenderSQL (ReturningClause commons schemas params from row) where
419393 Returning (List Nil) -> ""
420394 Returning selection -> " RETURNING" <+> renderSQL selection
421395
396+-- | `Returning` a `List`
422397pattern Returning_
423398 :: SOP.SListI row
424399 => NP (Aliased (Expression '[] commons 'Ungrouped schemas params from)) row
400+ -- ^ row of values
425401 -> ReturningClause commons schemas params from row
426402pattern Returning_ list = Returning (List list)
427403
@@ -434,7 +410,9 @@ data ConflictClause tab commons schemas params table where
434410 OnConflictDoRaise :: ConflictClause tab commons schemas params table
435411 OnConflict
436412 :: ConflictTarget constraints
413+ -- ^ conflict target
437414 -> ConflictAction tab commons schemas params columns
415+ -- ^ conflict action
438416 -> ConflictClause tab commons schemas params (constraints :=> columns)
439417
440418-- | Render a `ConflictClause`.
@@ -445,6 +423,17 @@ instance SOP.SListI (TableToColumns table)
445423 OnConflict target action -> " ON CONFLICT"
446424 <+> renderSQL target <+> renderSQL action
447425
426+{- |
427+`ConflictAction` specifies an alternative `OnConflict` action.
428+It can be either `DoNothing`, or a `DoUpdate` clause specifying
429+the exact details of the `update` action to be performed in case of a conflict.
430+The `Set` and WHERE `Condition`s in `OnConflict` `DoUpdate` have access to the
431+existing row using the table's name (or an alias), and to rows proposed
432+for insertion using the special @#excluded@ table.
433+`OnConflict` `DoNothing` simply avoids inserting a row as its alternative action.
434+`OnConflict` `DoUpdate` updates the existing row that conflicts
435+with the row proposed for insertion as its alternative action.
436+-}
448437data ConflictAction tab commons schemas params columns where
449438 DoNothing :: ConflictAction tab commons schemas params columns
450439 DoUpdate
@@ -453,8 +442,9 @@ data ConflictAction tab commons schemas params columns where
453442 , columns ~ (col0 ': cols)
454443 , SOP.All (HasIn columns) subcolumns
455444 , AllUnique subcolumns )
456− => NP (ColumnExpression 'Ungrouped schemas params '[tab ::: row, "excluded" ::: row]) subcolumns
445+ => NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[tab ::: row, "excluded" ::: row]))) subcolumns
457446 -> [Condition '[] commons 'Ungrouped schemas params '[tab ::: row, "excluded" ::: row]]
447+ -- ^ WHERE `Condition`s
458448 -> ConflictAction tab commons schemas params columns
459449
460450instance RenderSQL (ConflictAction tab commons schemas params columns) where
@@ -462,11 +452,17 @@ instance RenderSQL (ConflictAction tab commons schemas params columns) where
462452 DoNothing -> "DO NOTHING"
463453 DoUpdate updates whs'
464454 -> "DO UPDATE SET"
465− <+> renderCommaSeparated renderSQL updates
455+ <+> renderCommaSeparated renderUpdate updates
466456 <> case whs' of
467457 [] -> ""
468458 wh:whs -> " WHERE" <+> renderSQL (foldr (.&&) wh whs)
469459
460+renderUpdate
461+ :: (forall x. RenderSQL (expr x))
462+ => Aliased (Optional expr) ty
463+ -> ByteString
464+renderUpdate (expr `As` col) = renderSQL col <+> "=" <+> renderSQL expr
465+
470466-- | A `ConflictTarget` specifies the constraint violation that triggers a
471467-- `ConflictAction`.
472468data ConflictTarget constraints where
@@ -489,7 +485,6 @@ UPDATE statements
489485update
490486 :: ( SOP.SListI columns
491487 , SOP.SListI row1
492− , db ~ (commons :=> schemas)
493488 , Has sch schemas schema
494489 , Has tab schema ('Table table)
495490 , row0 ~ TableToRow table
@@ -497,7 +492,7 @@ update
497492 , SOP.All (HasIn columns) subcolumns
498493 , AllUnique subcolumns )
499494 => QualifiedAlias sch tab -- ^ table to update
500− -> NP (ColumnExpression 'Ungrouped schemas params '[tab ::: row0]) subcolumns
495+ -> NP (Aliased (Optional (Expression '[] '[] 'Ungrouped schemas params '[tab ::: row0]))) subcolumns
501496 -- ^ modified values to replace old values
502497 -> Condition '[] commons 'Ungrouped schemas params '[tab ::: row0]
503498 -- ^ condition under which to perform update on a row
@@ -507,14 +502,13 @@ update tab columns wh returning = UnsafeManipulation $
507502 "UPDATE"
508503 <+> renderSQL tab
509504 <+> "SET"
510− <+> renderCommaSeparated renderSQL columns
505+ <+> renderCommaSeparated renderUpdate columns
511506 <+> "WHERE" <+> renderSQL wh
512507 <> renderSQL returning
513508
514509-- | Update a row returning `Nil`.
515510update_
516511 :: ( SOP.SListI columns
517− , db ~ (commons :=> schemas)
518512 , Has sch schemas schema
519513 , Has tab schema ('Table table)
520514 , row ~ TableToRow table
@@ -522,7 +516,7 @@ update_
522516 , SOP.All (HasIn columns) subcolumns
523517 , AllUnique subcolumns )
524518 => QualifiedAlias sch tab -- ^ table to update
525− -> NP (ColumnExpression 'Ungrouped schemas params '[tab ::: row]) subcolumns
519+ -> NP (Aliased (Optional (Expression '[] '[] 'Ungrouped schemas params '[tab ::: row]))) subcolumns
526520 -- ^ modified values to replace old values
527521 -> Condition '[] commons 'Ungrouped schemas params '[tab ::: row]
528522 -- ^ condition under which to perform update on a row
@@ -533,16 +527,25 @@ update_ tab columns wh = update tab columns wh (Returning_ Nil)
533527DELETE statements
534528-----------------------------------------}
535529
530+-- | Specify additional tables with `Using`
531+-- an `also` list of table expressions, allowing columns
532+-- from other tables to appear in the WHERE condition.
533+-- This is similar to the list of tables that can be specified
534+-- in the FROM Clause of a SELECT statement;
535+-- for example, an alias for the table name can be specified.
536+-- Do not repeat the target table in the `Using` list,
537+-- unless you wish to set up a self-join.
538+-- `NoUsing` if no additional tables are to be used.
536539data UsingClause commons schemas params from where
537540 NoUsing :: UsingClause commons schemas params '[]
538541 Using
539542 :: FromClause '[] commons schemas params from
543+ -- ^ what to use
540544 -> UsingClause commons schemas params from
541545
542546-- | Delete rows from a table.
543547deleteFrom
544548 :: ( SOP.SListI row1
545− , db ~ (commons :=> schemas)
546549 , Has sch schemas schema
547550 , Has tab schema ('Table table)
548551 , row0 ~ TableToRow table
@@ -564,8 +567,7 @@ deleteFrom tab using wh returning = UnsafeManipulation $
564567
565568-- | Delete rows returning `Nil`.
566569deleteFrom_
567− :: ( db ~ (commons :=> schemas)
568− , Has sch schemas schema
570+ :: ( Has sch schemas schema
569571 , Has tab schema ('Table table)
570572 , row ~ TableToRow table
571573 , columns ~ TableToColumns table )
squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs+53−57
@@ -66,7 +66,7 @@ let
6666 }
6767:}
6868
69−Now that we have a couple migrations we can chain them together into an `AlignedList`.
69+Now that we have a couple migrations we can chain them together into a `Path`.
7070
7171>>> let migrations = makeUsers :>> makeEmails :>> Done
7272
@@ -156,7 +156,6 @@ import Data.Function ((&))
156156import Data.List ((\\))
157157import Data.Text (Text)
158158import Data.Time (UTCTime)
159−import Generics.SOP (K (..))
160159import Prelude hiding ((.), id)
161160import System.Environment
162161import UnliftIO (MonadIO (..))
@@ -165,7 +164,21 @@ import qualified Data.Text.IO as Text (putStrLn)
165164import qualified Generics.SOP as SOP
166165import qualified GHC.Generics as GHC
167166
168−import Squeal.PostgreSQL
167+import Squeal.PostgreSQL.Alias
168+import Squeal.PostgreSQL.Binary
169+import Squeal.PostgreSQL.Definition
170+import Squeal.PostgreSQL.Definition.Table
171+import Squeal.PostgreSQL.Definition.Table.Constraint
172+import Squeal.PostgreSQL.Expression.Comparison
173+import Squeal.PostgreSQL.Expression.Parameter
174+import Squeal.PostgreSQL.Expression.Time
175+import Squeal.PostgreSQL.Expression.Type
176+import Squeal.PostgreSQL.List
177+import Squeal.PostgreSQL.Manipulation
178+import Squeal.PostgreSQL.PQ
179+import Squeal.PostgreSQL.Query
180+import Squeal.PostgreSQL.Schema
181+import Squeal.PostgreSQL.Transaction
169182
170183-- | A `Migration` is a named "isomorphism" over a given category.
171184-- It should contain an inverse pair of `up` and `down`
@@ -179,34 +192,34 @@ data Migration p schemas0 schemas1 = Migration
179192
180193{- |
181194A `Migratory` @p@ is a `Category` for which one can execute or rewind
182−an `AlignedList` of `Migration`s over @p@. This includes the category of pure
195+a `Path` of `Migration`s over @p@. This includes the category of pure
183196SQL `Definition`s and the category of impure `Terminally` `PQ` `IO` actions.
184197-}
185198class Category p => Migratory p where
186199
187200 {- |
188− Run an `AlignedList` of `Migration`s.
201+ Run a `Path` of `Migration`s.
189202 Create the `MigrationsTable` as @public.schema_migrations@ if it does not already exist.
190− In a transaction for each each `Migration`, query to see if the `Migration` has been executed;
191− if not, execute the `Migration` and insert a row in the `MigrationsTable`.
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`.
192205 -}
193206 migrateUp
194− :: AlignedList (Migration p) schemas0 schemas1
207+ :: Path (Migration p) schemas0 schemas1
195208 -> PQ schemas0 schemas1 IO ()
196209
197210 {- |
198− Rewind an `AlignedList` of `Migration`s.
211+ Rewind a `Path` of `Migration`s.
199212 Create the `MigrationsTable` as @public.schema_migrations@ if it does not already exist.
200− In a transaction for each each `Migration`, query to see if the `Migration` has been executed;
201− if so, rewind the `Migration` and delete its row in the `MigrationsTable`.
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`.
202215 -}
203216 migrateDown
204− :: AlignedList (Migration p) schemas0 schemas1
217+ :: Path (Migration p) schemas0 schemas1
205218 -> PQ schemas1 schemas0 IO ()
206219
207220instance Migratory Definition where
208− migrateUp = migrateUp . mapAligned pureMigration
209− migrateDown = migrateDown . mapAligned pureMigration
221+ migrateUp = migrateUp . cmap pureMigration
222+ migrateDown = migrateDown . cmap pureMigration
210223
211224{- | `Terminally` turns an indexed monad transformer and the monad it transforms
212225into a category by restricting the return type to @()@ and permuting the type variables.
@@ -238,8 +251,8 @@ terminally = Terminally . void
238251-- | A `pureMigration` turns a `Migration` involving only pure SQL
239252-- `Definition`s into a `Migration` that may be combined with arbitrary `IO`.
240253pureMigration
241− :: Migration Definition schema0 schema1
242− -> Migration (Terminally PQ IO) schema0 schema1
254+ :: Migration Definition schemas0 schemas1
255+ -> Migration (Terminally PQ IO) schemas0 schemas1
243256pureMigration migration = Migration
244257 { name = name migration
245258 , up = terminally . define $ up migration
@@ -248,81 +261,64 @@ pureMigration migration = Migration
248261
249262instance Migratory (Terminally PQ IO) where
250263
251− migrateUp migration = unsafePQ $
264+ migrateUp migration = unsafePQ . transactionally_ $ do
252265 define createMigrations
253− & pqBind okResult
254− & pqThen (transactionallySchema_ (upMigrations migration))
266+ upMigrations migration
255267
256268 where
257269
258270 upMigrations
259− :: AlignedList (Migration (Terminally PQ IO)) schemas0 schemas1
271+ :: Path (Migration (Terminally PQ IO)) schemas0 schemas1
260272 -> PQ MigrationsSchemas MigrationsSchemas IO ()
261273 upMigrations = \case
262274 Done -> return ()
263− step :>> steps -> upMigration step & pqThen (upMigrations steps)
275+ step :>> steps -> upMigration step >> upMigrations steps
264276
265277 upMigration
266278 :: Migration (Terminally PQ IO) schemas0 schemas1
267279 -> PQ MigrationsSchemas MigrationsSchemas IO ()
268− upMigration step =
269− queryExecuted step
270− & pqBind ( \ executed -> unless (executed == 1)
271− $ unsafePQ (runTerminally (up step))
272− & pqThen (manipulateParams insertMigration (Only (name step)))
273− -- insert execution record
274− & pqBind okResult )
280+ upMigration step = do
281+ executed <- queryExecuted step
282+ unless (executed == 1) $ do
283+ unsafePQ . runTerminally $ up step
284+ manipulateParams_ insertMigration (Only (name step))
275285
276286 queryExecuted
277287 :: Migration (Terminally PQ IO) schemas0 schemas1
278288 -> PQ MigrationsSchemas MigrationsSchemas IO Row
279289 queryExecuted step = do
280290 result <- runQueryParams selectMigration (Only (name step))
281− okResult result
282291 ntuples result
283292
284− migrateDown migrations = unsafePQ $
293+ migrateDown migrations = unsafePQ . transactionally_ $ do
285294 define createMigrations
286− & pqBind okResult
287− & pqThen (transactionallySchema_ (downMigrations migrations))
295+ downMigrations migrations
288296
289297 where
290298
291299 downMigrations
292− :: AlignedList (Migration (Terminally PQ IO)) schemas0 schemas1
300+ :: Path (Migration (Terminally PQ IO)) schemas0 schemas1
293301 -> PQ MigrationsSchemas MigrationsSchemas IO ()
294302 downMigrations = \case
295303 Done -> return ()
296− step :>> steps -> downMigrations steps & pqThen (downMigration step)
304+ step :>> steps -> downMigrations steps >> downMigration step
297305
298306 downMigration
299307 :: Migration (Terminally PQ IO) schemas0 schemas1
300308 -> PQ MigrationsSchemas MigrationsSchemas IO ()
301− downMigration step =
302− queryExecuted step
303− & pqBind ( \ executed -> unless (executed == 0)
304− $ unsafePQ (runTerminally (down step))
305− & pqThen (manipulateParams deleteMigration (Only (name step)))
306− -- delete execution record
307− & pqBind okResult )
309+ downMigration step = do
310+ executed <- queryExecuted step
311+ unless (executed == 0) $ do
312+ unsafePQ . runTerminally $ down step
313+ manipulateParams_ deleteMigration (Only (name step))
308314
309315 queryExecuted
310316 :: Migration (Terminally PQ IO) schemas0 schemas1
311317 -> PQ MigrationsSchemas MigrationsSchemas IO Row
312318 queryExecuted step = do
313319 result <- runQueryParams selectMigration (Only (name step))
314− okResult result
315320 ntuples result
316321
317−okResult :: K Result results -> PQ schema schema IO ()
318−okResult result = do
319− status <- resultStatus result
320− when (not (status `elem` [CommandOk, TuplesOk])) $ do
321− errorMessageMaybe <- resultErrorMessage result
322− case errorMessageMaybe of
323− Nothing -> error "migration: unknown error"
324− Just msg -> error ("migration: " <> show msg)
325−
326322unsafePQ :: (Functor m) => PQ db0 db1 m x -> PQ db0' db1' m x
327323unsafePQ (PQ pq) = PQ $ fmap (SOP.K . SOP.unK) . pq . SOP.K . SOP.unK
328324
@@ -357,7 +353,7 @@ createMigrations =
357353-- the time at which it was inserted.
358354insertMigration :: Manipulation_ MigrationsSchemas (Only Text) ()
359355insertMigration = insertInto_ #schema_migrations
360− (Values_ ((param @1) `as` #name :* defaultAs #executed_at))
356+ (Values_ (Set (param @1) `as` #name :* Default `as` #executed_at))
361357
362358-- | Deletes a `Migration` from the `MigrationsTable`, returning
363359-- the time at which it was inserted.
@@ -367,8 +363,8 @@ deleteMigration = deleteFrom_ #schema_migrations (#name .== param @1)
367363-- | Selects a `Migration` from the `MigrationsTable`, returning
368364-- the time at which it was inserted.
369365selectMigration
370− :: Query_ MigrationsSchemas (Only Text) (P ("executed_at" ::: UTCTime))
371−selectMigration = select_ #executed_at
366+ :: Query_ MigrationsSchemas (Only Text) (Only UTCTime)
367+selectMigration = select_ (#executed_at `as` #fromOnly)
372368 $ from (table (#schema_migrations))
373369 & where_ (#name .== param @1)
374370
@@ -388,7 +384,7 @@ defaultMain
388384 :: Migratory p
389385 => ByteString
390386 -- ^ connection string
391− -> AlignedList (Migration p) db0 db1
387+ -> Path (Migration p) db0 db1
392388 -- ^ migrations
393389 -> IO ()
394390defaultMain connectTo migrations = do
@@ -409,12 +405,12 @@ defaultMain connectTo migrations = do
409405 migrateStatus :: PQ schema schema IO ()
410406 migrateStatus = unsafePQ $ do
411407 runNames <- getRunMigrationNames
412− let names = extractList name migrations
408+ let names = ctoList name migrations
413409 unrunNames = names \\ runNames
414410 liftIO $ displayRunned runNames >> displayUnrunned unrunNames
415411
416412 suppressNotices :: PQ schema schema IO ()
417− suppressNotices = void . manipulate $
413+ suppressNotices = manipulate_ $
418414 UnsafeManipulation "SET client_min_messages TO WARNING;"
419415
420416 readCommandFromArgs :: IO (Maybe MigrateCommand)
squeal-postgresql/src/Squeal/PostgreSQL/PG.hs+42−43
@@ -10,18 +10,20 @@ Stability: experimental
1010-}
1111{-# LANGUAGE
1212 AllowAmbiguousTypes
13+ , DeriveAnyClass
1314 , DeriveFoldable
1415 , DeriveFunctor
1516 , DeriveGeneric
1617 , DeriveTraversable
18+ , DerivingStrategies
1719 , DefaultSignatures
1820 , FlexibleContexts
1921 , FlexibleInstances
2022 , FunctionalDependencies
2123 , GADTs
2224 , LambdaCase
23− , OverloadedStrings
2425 , MultiParamTypeClasses
26+ , OverloadedStrings
2527 , ScopedTypeVariables
2628 , TypeApplications
2729 , TypeFamilies
@@ -45,7 +47,7 @@ module Squeal.PostgreSQL.PG
4547 , Enumerated (..)
4648 , VarArray (..)
4749 , FixArray (..)
48− , SOP.P (..)
50+ , LibPQ.Oid (..)
4951 -- * Type families
5052 , LabelsPG
5153 , DimPG
@@ -64,7 +66,6 @@ import Data.Int (Int16, Int32, Int64)
6466import Data.Scientific (Scientific)
6567import Data.Time (Day, DiffTime, LocalTime, TimeOfDay, TimeZone, UTCTime)
6668import Data.Vector (Vector)
67−import Data.Word (Word16, Word32, Word64)
6869import Data.UUID.Types (UUID)
6970import GHC.TypeLits
7071import Network.IP.Addr (NetAddr, IP)
@@ -73,13 +74,13 @@ import qualified Data.ByteString.Lazy as Lazy (ByteString)
7374import qualified Data.ByteString as Strict (ByteString)
7475import qualified Data.Text.Lazy as Lazy (Text)
7576import qualified Data.Text as Strict (Text)
77+import qualified Database.PostgreSQL.LibPQ as LibPQ
7678import qualified GHC.Generics as GHC
7779import qualified Generics.SOP as SOP
7880import qualified Generics.SOP.Record as SOP
7981import qualified Generics.SOP.Type.Metadata as Type
8082
8183import Squeal.PostgreSQL.Alias
82−import Squeal.PostgreSQL.List
8384import Squeal.PostgreSQL.Schema
8485
8586-- $setup
@@ -107,11 +108,7 @@ type instance PG Int32 = 'PGint4
107108-- | `PGint8`
108109type instance PG Int64 = 'PGint8
109110-- | `PGint2`
110−type instance PG Word16 = 'PGint2
111−-- | `PGint4`
112−type instance PG Word32 = 'PGint4
113−-- | `PGint8`
114−type instance PG Word64 = 'PGint8
111+type instance PG LibPQ.Oid = 'PGoid
115112-- | `PGnumeric`
116113type instance PG Scientific = 'PGnumeric
117114-- | `PGfloat4`
@@ -167,7 +164,7 @@ type family LabelsPG (hask :: Type) :: [Type.ConstructorName] where
167164`RowPG` turns a Haskell `Type` into a `RowType`.
168165
169166`RowPG` may be applied to normal Haskell record types provided they
170−have the `SOP.Generic` and `SOP.HasDatatypeInfo` instances;
167+have `SOP.Generic` and `SOP.HasDatatypeInfo` instances;
171168
172169>>> data Person = Person { name :: Strict.Text, age :: Int32 } deriving GHC.Generic
173170>>> instance SOP.Generic Person
@@ -175,37 +172,22 @@ have the `SOP.Generic` and `SOP.HasDatatypeInfo` instances;
175172>>> :kind! RowPG Person
176173RowPG Person :: [(Symbol, NullityType)]
177174= '["name" ::: 'NotNull 'PGtext, "age" ::: 'NotNull 'PGint4]
178−
179−Or to tuples of `SOP.P` types;
180−
181−>>> :kind! RowPG (SOP.P ("id" ::: Int32), SOP.P ("foreign_id" ::: Int32))
182−RowPG (SOP.P ("id" ::: Int32), SOP.P ("foreign_id" ::: Int32)) :: [(Symbol,
183− NullityType)]
184−= '[ '("id", 'NotNull 'PGint4), "foreign_id" ::: 'NotNull 'PGint4]
185−
186−Or to tuples which mix `SOP.P` types and record types.
187−
188−>>> :kind! RowPG (SOP.P ("id" ::: Int32), Person, SOP.P ("foreign_id" ::: Int32))
189−RowPG (SOP.P ("id" ::: Int32), Person, SOP.P ("foreign_id" ::: Int32)) :: [(Symbol,
190− NullityType)]
191−= '[ '("id", 'NotNull 'PGint4), '("name", 'NotNull 'PGtext),
192− '("age", 'NotNull 'PGint4), "foreign_id" ::: 'NotNull 'PGint4]
193175-}
194176type family RowPG (hask :: Type) :: RowType where
195− RowPG (hask1, hask2) = Join (RowPG hask1) (RowPG hask2)
196− RowPG (hask1, hask2, hask3) =
197− Join (RowPG hask1) (RowPG (hask2, hask3))
198− RowPG (hask1, hask2, hask3, hask4) =
199− Join (RowPG hask1) (RowPG (hask2, hask3, hask4))
200− RowPG (hask1, hask2, hask3, hask4, hask5) =
201− Join (RowPG hask1) (RowPG (hask2, hask3, hask4, hask5))
202− RowPG (SOP.P (col ::: ty)) = '[col ::: NullPG ty]
203177 RowPG hask = RowOf (SOP.RecordCodeOf hask)
204178
205179-- | `RowOf` applies `NullPG` to the fields of a list.
206180type family RowOf (record :: [(Symbol, Type)]) :: RowType where
207− RowOf '[] = '[]
181+ RowOf (col ::: ty ': col1 ::: ty1 ': col2 ::: ty2 ': col3 ::: ty3 ': col4 ::: ty4 ': record) =
182+ col ::: NullPG ty ': col1 ::: NullPG ty1 ': col2 ::: NullPG ty2 ': col3 ::: NullPG ty3 ': col4 ::: NullPG ty4 ': RowOf record
183+ RowOf (col ::: ty ': col1 ::: ty1 ': col2 ::: ty2 ': col3 ::: ty3 ': record) =
184+ col ::: NullPG ty ': col1 ::: NullPG ty1 ': col2 ::: NullPG ty2 ': col3 ::: NullPG ty3 ': RowOf record
185+ RowOf (col ::: ty ': col1 ::: ty1 ': col2 ::: ty2 ': record) =
186+ col ::: NullPG ty ': col1 ::: NullPG ty1 ': col2 ::: NullPG ty2 ': RowOf record
187+ RowOf (col ::: ty ': col1 ::: ty1 ': record) =
188+ col ::: NullPG ty ': col1::: NullPG ty1 ': RowOf record
208189 RowOf (col ::: ty ': record) = col ::: NullPG ty ': RowOf record
190+ RowOf '[] = '[]
209191
210192{- | `NullPG` turns a Haskell type into a `NullityType`.
211193
@@ -232,8 +214,17 @@ type family TuplePG (hask :: Type) :: [NullityType] where
232214
233215-- | `TupleOf` turns a list of Haskell `Type`s into a list of `NullityType`s.
234216type family TupleOf (tuple :: [Type]) :: [NullityType] where
235− TupleOf '[] = '[]
217+ TupleOf (hask ': hask1 ': hask2 ': hask3 ': hask4 ': hask5 ': tuple) =
218+ NullPG hask ': NullPG hask1 ': NullPG hask2 ': NullPG hask3 ': NullPG hask4 ': NullPG hask5 ': TupleOf tuple
219+ TupleOf (hask ': hask1 ': hask2 ': hask3 ': hask4 ': tuple) =
220+ NullPG hask ': NullPG hask1 ': NullPG hask2 ': NullPG hask3 ': NullPG hask4 ': TupleOf tuple
221+ TupleOf (hask ': hask1 ': hask2 ': hask3 ': tuple) =
222+ NullPG hask ': NullPG hask1 ': NullPG hask2 ': NullPG hask3 ': TupleOf tuple
223+ TupleOf (hask ': hask1 ': hask2 ': tuple) =
224+ NullPG hask ': NullPG hask1 ': NullPG hask2 ': TupleOf tuple
225+ TupleOf (hask ': hask1 ': tuple) = NullPG hask ': NullPG hask1 ': TupleOf tuple
236226 TupleOf (hask ': tuple) = NullPG hask ': TupleOf tuple
227+ TupleOf '[] = '[]
237228
238229-- | `TupleCodeOf` takes the `SOP.Code` of a haskell `Type`
239230-- and if it's a simple product returns it, otherwise giving a `TypeError`.
@@ -320,7 +311,7 @@ let
320311>>> let input = Only (Money 20020)
321312
322313>>> :{
323−void . withConnection "host=localhost port=5432 dbname=exampledb" $ do
314+withConnection "host=localhost port=5432 dbname=exampledb" $ do
324315 result <- runQueryParams roundTrip input
325316 Just output <- firstRow result
326317 liftIO . print $ input == output
@@ -328,7 +319,8 @@ void . withConnection "host=localhost port=5432 dbname=exampledb" $ do
328319True
329320-}
330321newtype Money = Money { cents :: Int64 }
331− deriving (Eq, Ord, Show, Read, GHC.Generic)
322+ deriving stock (Eq, Ord, Show, Read, GHC.Generic)
323+ deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
332324-- | `PGmoney`
333325type instance PG Money = 'PGmoney
334326
@@ -336,7 +328,8 @@ type instance PG Money = 'PGmoney
336328type it's applied to should be stored as a `PGjson`.
337329-}
338330newtype Json hask = Json {getJson :: hask}
339− deriving (Eq, Ord, Show, Read, GHC.Generic)
331+ deriving stock (Eq, Ord, Show, Read, GHC.Generic)
332+ deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
340333-- | `PGjson`
341334type instance PG (Json hask) = 'PGjson
342335
@@ -344,7 +337,8 @@ type instance PG (Json hask) = 'PGjson
344337type it's applied to should be stored as a `PGjsonb`.
345338-}
346339newtype Jsonb hask = Jsonb {getJsonb :: hask}
347− deriving (Eq, Ord, Show, Read, GHC.Generic)
340+ deriving stock (Eq, Ord, Show, Read, GHC.Generic)
341+ deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
348342-- | `PGjsonb`
349343type instance PG (Jsonb hask) = 'PGjsonb
350344
@@ -352,7 +346,8 @@ type instance PG (Jsonb hask) = 'PGjsonb
352346type it's applied to should be stored as a `PGcomposite`.
353347-}
354348newtype Composite record = Composite {getComposite :: record}
355− deriving (Eq, Ord, Show, Read, GHC.Generic)
349+ deriving stock (Eq, Ord, Show, Read, GHC.Generic)
350+ deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
356351-- | `PGcomposite` @(@`RowPG` @hask)@
357352type instance PG (Composite hask) = 'PGcomposite (RowPG hask)
358353
@@ -360,7 +355,8 @@ type instance PG (Composite hask) = 'PGcomposite (RowPG hask)
360355type it's applied to should be stored as a `PGenum`.
361356-}
362357newtype Enumerated enum = Enumerated {getEnumerated :: enum}
363− deriving (Eq, Ord, Show, Read, GHC.Generic)
358+ deriving stock (Eq, Ord, Show, Read, GHC.Generic)
359+ deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
364360-- | `PGenum` @(@`LabelsPG` @hask)@
365361type instance PG (Enumerated hask) = 'PGenum (LabelsPG hask)
366362
@@ -372,9 +368,11 @@ PG (VarArray (Vector Double)) :: PGType
372368= 'PGvararray ('NotNull 'PGfloat8)
373369-}
374370newtype VarArray arr = VarArray {getVarArray :: arr}
375− deriving (Eq, Ord, Show, Read, GHC.Generic)
371+ deriving stock (Eq, Ord, Show, Read, GHC.Generic)
372+ deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
376373-- | `PGvararray` @(@`NullPG` @hask)@
377374type instance PG (VarArray (Vector hask)) = 'PGvararray (NullPG hask)
375+type instance PG (VarArray [hask]) = 'PGvararray (NullPG hask)
378376
379377{- | The `FixArray` newtype is an indication that the Haskell
380378type it's applied to should be stored as a `PGfixarray`.
@@ -384,6 +382,7 @@ PG (FixArray ((Double, Double), (Double, Double))) :: PGType
384382= 'PGfixarray '[2, 2] ('NotNull 'PGfloat8)
385383-}
386384newtype FixArray arr = FixArray {getFixArray :: arr}
387− deriving (Eq, Ord, Show, Read, GHC.Generic)
385+ deriving stock (Eq, Ord, Show, Read, GHC.Generic)
386+ deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
388387-- | `PGfixarray` @(@`DimPG` @hask) (@`FixPG` @hask)@
389388type instance PG (FixArray hask) = 'PGfixarray (DimPG hask) (FixPG hask)
squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs+96−40
@@ -64,17 +64,21 @@ module Squeal.PostgreSQL.PQ
6464 , resultErrorCode
6565 -- * Exceptions
6666 , SquealException (..)
67+ , PQState (..)
68+ , okResult
6769 , catchSqueal
6870 , handleSqueal
71+ , trySqueal
6972 ) where
7073
7174import Control.Exception (Exception, throw)
7275import Control.Monad.Except
7376import Control.Monad.Morph
74−import UnliftIO (MonadUnliftIO (..), bracket, catch, handle)
77+import UnliftIO (MonadUnliftIO (..), bracket, catch, handle, try)
7578import Data.ByteString (ByteString)
7679import Data.Foldable
7780import Data.Function ((&))
81+import Data.Functor ((<&>))
7882import Data.Kind
7983import Data.Text (pack, Text)
8084import Data.Traversable
@@ -83,6 +87,7 @@ import PostgreSQL.Binary.Encoding (encodingBytes)
8387
8488import qualified Control.Monad.Fail as Fail
8589import qualified Database.PostgreSQL.LibPQ as LibPQ
90+import qualified PostgreSQL.Binary.Encoding as Encoding
8691
8792import Squeal.PostgreSQL.Binary
8893import Squeal.PostgreSQL.Definition
@@ -243,13 +248,16 @@ class IndexedMonadTransPQ pq where
243248 -> x -> pq schemas0 schemas2 m z
244249 pqAndThen g f x = pqBind g (f x)
245250
246− -- | Run a `Definition` with `LibPQ.exec`, we expect that libpq obeys the law
251+ -- | Run a `Definition` with `LibPQ.exec`.
247252 --
248− -- @define statement1 & pqThen (define statement2) = define (statement1 >>> statement2)@
253+ -- It should be functorial in effect.
254+ --
255+ -- @define id = return ()@
256+ -- @define (statement1 >>> statement2) = define statement1 & pqThen (define statement2)@
249257 define
250258 :: MonadIO io
251259 => Definition schemas0 schemas1
252− -> pq schemas0 schemas1 io (K LibPQ.Result '[])
260+ -> pq schemas0 schemas1 io ()
253261
254262instance IndexedMonadTransPQ PQ where
255263
@@ -267,7 +275,7 @@ instance IndexedMonadTransPQ PQ where
267275 case resultMaybe of
268276 Nothing -> throw $ ResultException
269277 "define: LibPQ.exec returned no results"
270− Just result -> return $ K (K result)
278+ Just result -> K <$> okResult_ result
271279
272280{- | `MonadPQ` is an @mtl@ style constraint, similar to
273281`Control.Monad.State.Class.MonadState`, for using `Database.PostgreSQL.LibPQ` to
@@ -276,8 +284,12 @@ instance IndexedMonadTransPQ PQ where
276284 with a `ToParams` constraint. It calls `LibPQ.execParams` and
277285 doesn't afraid of anything.
278286
287+* `manipulateParams_` is like `manipulateParams` for a returning-free statement.
288+
279289* `manipulate` is like `manipulateParams` for a parameter-free statement.
280290
291+* `manipulate_` is like `manipulate` for a returning-free statement.
292+
281293* `runQueryParams` is like `manipulateParams` for query statements.
282294
283295* `runQuery` is like `runQueryParams` for a parameter-free statement.
@@ -291,7 +303,7 @@ instance IndexedMonadTransPQ PQ where
291303* `forPrepared` is a flipped `traversePrepared`
292304
293305* `traversePrepared_` is like `traversePrepared` but works on `Foldable`
294− containers and returns unit.
306+ containers for a returning-free statement.
295307
296308* `forPrepared_` is a flipped `traversePrepared_`.
297309
@@ -305,24 +317,34 @@ a default instance.
305317-}
306318class Monad pq => MonadPQ schemas pq | pq -> schemas where
307319 manipulateParams
308− :: ToParams x params
320+ :: (ToParams x params, All OidOfParam params)
309321 => Manipulation '[] schemas params ys
310322 -- ^ `insertInto`, `update` or `deleteFrom`
311323 -> x -> pq (K LibPQ.Result ys)
312324 default manipulateParams
313325 :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)
314− => ToParams x params
326+ => (ToParams x params, All OidOfParam params)
315327 => Manipulation '[] schemas params ys
316328 -- ^ `insertInto`, `update` or `deleteFrom`
317329 -> x -> pq (K LibPQ.Result ys)
318330 manipulateParams manipulation params = lift $
319331 manipulateParams manipulation params
320332
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+
321340 manipulate :: Manipulation '[] schemas '[] ys -> pq (K LibPQ.Result ys)
322341 manipulate statement = manipulateParams statement ()
323342
343+ manipulate_ :: Manipulation '[] schemas '[] '[] -> pq ()
344+ manipulate_ = void . manipulate
345+
324346 runQueryParams
325− :: ToParams x params
347+ :: (ToParams x params, All OidOfParam params)
326348 => Query '[] '[] schemas params ys
327349 -- ^ `select` and friends
328350 -> x -> pq (K LibPQ.Result ys)
@@ -335,19 +357,19 @@ class Monad pq => MonadPQ schemas pq | pq -> schemas where
335357 runQuery q = runQueryParams q ()
336358
337359 traversePrepared
338− :: (ToParams x params, Traversable list)
360+ :: (ToParams x params, Traversable list, All OidOfParam params)
339361 => Manipulation '[] schemas params ys
340362 -- ^ `insertInto`, `update`, or `deleteFrom`, and friends
341363 -> list x -> pq (list (K LibPQ.Result ys))
342364 default traversePrepared
343365 :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)
344− => (ToParams x params, Traversable list)
366+ => (ToParams x params, Traversable list, All OidOfParam params)
345367 => Manipulation '[] schemas params ys -> list x -> pq (list (K LibPQ.Result ys))
346368 traversePrepared manipulation params = lift $
347369 traversePrepared manipulation params
348370
349371 forPrepared
350− :: (ToParams x params, Traversable list)
372+ :: (ToParams x params, Traversable list, All OidOfParam params)
351373 => list x
352374 -> Manipulation '[] schemas params ys
353375 -- ^ `insertInto`, `update` or `deleteFrom`
@@ -355,13 +377,13 @@ class Monad pq => MonadPQ schemas pq | pq -> schemas where
355377 forPrepared = flip traversePrepared
356378
357379 traversePrepared_
358− :: (ToParams x params, Foldable list)
380+ :: (ToParams x params, Foldable list, All OidOfParam params)
359381 => Manipulation '[] schemas params '[]
360382 -- ^ `insertInto`, `update` or `deleteFrom`
361383 -> list x -> pq ()
362384 default traversePrepared_
363385 :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)
364− => (ToParams x params, Foldable list)
386+ => (ToParams x params, Foldable list, All OidOfParam params)
365387 => Manipulation '[] schemas params '[]
366388 -- ^ `insertInto`, `update` or `deleteFrom`
367389 -> list x -> pq ()
@@ -369,7 +391,7 @@ class Monad pq => MonadPQ schemas pq | pq -> schemas where
369391 traversePrepared_ manipulation params
370392
371393 forPrepared_
372− :: (ToParams x params, Foldable list)
394+ :: (ToParams x params, Foldable list, All OidOfParam params)
373395 => list x
374396 -> Manipulation '[] schemas params '[]
375397 -- ^ `insertInto`, `update` or `deleteFrom`
@@ -389,54 +411,76 @@ instance (MonadIO io, schemas0 ~ schemas, schemas1 ~ schemas)
389411 (UnsafeManipulation q :: Manipulation '[] schemas ps ys) (params :: x) =
390412 PQ $ \ (K conn) -> do
391413 let
392− toParam' encoding =
393− (LibPQ.invalidOid, encodingBytes encoding, LibPQ.Binary)
394− 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
395425 q' = q <> ";"
396426 resultMaybe <- liftIO $ LibPQ.execParams conn q' params' LibPQ.Binary
397427 case resultMaybe of
398428 Nothing -> throw $ ResultException
399429 "manipulateParams: LibPQ.execParams returned no results"
400430 Just result -> do
401− tryResult result
431+ okResult_ result
402432 return $ K (K result)
403433
404434 traversePrepared
405435 (UnsafeManipulation q :: Manipulation '[] schemas xs ys) (list :: list x) =
406436 PQ $ \ (K conn) -> liftIO $ do
407− let temp = "temporary_statement"
408− prepResultMaybe <- LibPQ.prepare conn temp q Nothing
437+ let
438+ temp = "temporary_statement"
439+ paramOid :: forall p. OidOfParam p => K LibPQ.Oid p
440+ paramOid = K (oidOfParam @p)
441+ paramOids :: NP (K LibPQ.Oid) xs
442+ paramOids = hcpure (Proxy @OidOfParam) paramOid
443+ paramOids' :: [LibPQ.Oid]
444+ paramOids' = hcollapse paramOids
445+ prepResultMaybe <- LibPQ.prepare conn temp q (Just paramOids')
409446 case prepResultMaybe of
410447 Nothing -> throw $ ResultException
411448 "traversePrepared: LibPQ.prepare returned no results"
412− Just prepResult -> tryResult prepResult
449+ Just prepResult -> okResult_ prepResult
413450 results <- for list $ \ params -> do
414451 let
415− toParam' encoding = (encodingBytes encoding,LibPQ.Binary)
452+ toParam' encoding = (encodingBytes encoding, LibPQ.Binary)
416453 params' = fmap (fmap toParam') (hcollapse (toParams @x @xs params))
417454 resultMaybe <- LibPQ.execPrepared conn temp params' LibPQ.Binary
418455 case resultMaybe of
419456 Nothing -> throw $ ResultException
420457 "traversePrepared: LibPQ.execParams returned no results"
421458 Just result -> do
422− tryResult result
459+ okResult_ result
423460 return $ K result
424461 deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")
425462 case deallocResultMaybe of
426463 Nothing -> throw $ ResultException
427464 "traversePrepared: LibPQ.exec DEALLOCATE returned no results"
428− Just deallocResult -> tryResult deallocResult
465+ Just deallocResult -> okResult_ deallocResult
429466 return (K results)
430467
431468 traversePrepared_
432469 (UnsafeManipulation q :: Manipulation '[] schemas xs '[]) (list :: list x) =
433470 PQ $ \ (K conn) -> liftIO $ do
434− let temp = "temporary_statement"
435− prepResultMaybe <- LibPQ.prepare conn temp q Nothing
471+ let
472+ temp = "temporary_statement"
473+ paramOid :: forall p. OidOfParam p => K LibPQ.Oid p
474+ paramOid = K (oidOfParam @p)
475+ paramOids :: NP (K LibPQ.Oid) xs
476+ paramOids = hcpure (Proxy @OidOfParam) paramOid
477+ paramOids' :: [LibPQ.Oid]
478+ paramOids' = hcollapse paramOids
479+ prepResultMaybe <- LibPQ.prepare conn temp q (Just paramOids')
436480 case prepResultMaybe of
437481 Nothing -> throw $ ResultException
438482 "traversePrepared_: LibPQ.prepare returned no results"
439− Just prepResult -> tryResult prepResult
483+ Just prepResult -> okResult_ prepResult
440484 for_ list $ \ params -> do
441485 let
442486 toParam' encoding = (encodingBytes encoding, LibPQ.Binary)
@@ -445,12 +489,12 @@ instance (MonadIO io, schemas0 ~ schemas, schemas1 ~ schemas)
445489 case resultMaybe of
446490 Nothing -> throw $ ResultException
447491 "traversePrepared_: LibPQ.execParams returned no results"
448− Just result -> tryResult result
492+ Just result -> okResult_ result
449493 deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")
450494 case deallocResultMaybe of
451495 Nothing -> throw $ ResultException
452496 "traversePrepared: LibPQ.exec DEALLOCATE returned no results"
453− Just deallocResult -> tryResult deallocResult
497+ Just deallocResult -> okResult_ deallocResult
454498 return (K ())
455499
456500 liftPQ pq = PQ $ \ (K conn) -> do
@@ -613,24 +657,24 @@ resultErrorCode
613657 -> io (Maybe ByteString)
614658resultErrorCode = liftResult (flip LibPQ.resultErrorField LibPQ.DiagSqlstate)
615659
616−-- | `Exception`s that can be thrown by Squeal.
617−data SquealException
618− = PQException
660+-- | the state of LibPQ
661+data PQState = PQState
619662 { sqlExecStatus :: LibPQ.ExecStatus
620663 , sqlStateCode :: Maybe ByteString
621664 -- ^ https://www.postgresql.org/docs/current/static/errcodes-appendix.html
622665 , sqlErrorMessage :: Maybe ByteString
623− }
666+ } deriving (Eq, Show)
667+
668+-- | `Exception`s that can be thrown by Squeal.
669+data SquealException
670+ = PQException PQState
624671 | ResultException Text
625672 | ParseException Text
626673 deriving (Eq, Show)
627674instance Exception SquealException
628675
629−tryResult
630− :: MonadIO io
631− => LibPQ.Result
632− -> io ()
633−tryResult result = liftIO $ do
676+okResult_ :: MonadIO io => LibPQ.Result -> io ()
677+okResult_ result = liftIO $ do
634678 status <- LibPQ.resultStatus result
635679 case status of
636680 LibPQ.CommandOk -> return ()
@@ -638,7 +682,12 @@ tryResult result = liftIO $ do
638682 _ -> do
639683 stateCode <- LibPQ.resultErrorField result LibPQ.DiagSqlstate
640684 msg <- LibPQ.resultErrorMessage result
641− throw $ PQException status stateCode msg
685+ throw . PQException $ PQState status stateCode msg
686+
687+-- | Check if a `LibPQ.Result`'s status is either `LibPQ.CommandOk`
688+-- or `LibPQ.TuplesOk` otherwise `throw` a `PQException`.
689+okResult :: MonadIO io => K LibPQ.Result row -> io ()
690+okResult = okResult_ . unK
642691
643692-- | Catch `SquealException`s.
644693catchSqueal
@@ -654,3 +703,10 @@ handleSqueal
654703 => (SquealException -> io a) -- ^ handler
655704 -> io a -> io a
656705handleSqueal = handle
706+
707+-- | `Either` return a `SquealException` or a result.
708+trySqueal
709+ :: MonadUnliftIO io
710+ => io a
711+ -> io (Either SquealException a)
712+trySqueal = try
squeal-postgresql/src/Squeal/PostgreSQL/Pool.hs+67−99
@@ -1,11 +1,33 @@
11{-|
2−Module: Squeal.PostgreSQL.Definition
3−Description: Pooled connections
2+Module: Squeal.PostgreSQL.Pool
3+Description: Connection pools
44Copyright: (c) Eitan Chatav, 2017
55Maintainer: eitan@morphism.tech
66Stability: experimental
77
8−A `MonadPQ` for pooled connections.
8+Connection pools.
9+
10+Typical use case would be to create your pool using `createConnectionPool`
11+and run anything that requires the pool connection with `usingConnectionPool`.
12+
13+Here's a simplified example:
14+
15+>>> import Squeal.PostgreSQL
16+
17+>>> :{
18+do
19+ let
20+ query :: Query_ (Public '[]) () (Only Char)
21+ query = values_ (literal 'a' `as` #fromOnly)
22+ pool <- createConnectionPool "host=localhost port=5432 dbname=exampledb" 1 0.5 10
23+ chr <- usingConnectionPool pool $ do
24+ result <- runQuery query
25+ Just (Only a) <- firstRow result
26+ return a
27+ destroyConnectionPool pool
28+ putChar chr
29+:}
30+a
931-}
1032
1133{-# LANGUAGE
@@ -23,51 +45,19 @@ A `MonadPQ` for pooled connections.
2345
2446module Squeal.PostgreSQL.Pool
2547 ( -- * Pools
26− PoolPQ (..)
48+ Pool
2749 , createConnectionPool
28− , Pool
29− , destroyAllResources
50+ , usingConnectionPool
51+ , destroyConnectionPool
3052 ) where
3153
32−import Control.Monad.Trans
3354import Data.ByteString
3455import Data.Time
35−import Generics.SOP (K(..))
56+import Generics.SOP (K(..), unK)
3657import UnliftIO (MonadUnliftIO (..))
3758import UnliftIO.Pool (Pool, createPool, destroyAllResources, withResource)
3859
39−import qualified Control.Monad.Fail as Fail
40−
4160import Squeal.PostgreSQL.PQ
42−import Squeal.PostgreSQL.Schema
43−
44−{- | `PoolPQ` @schemas@ should be a drop-in replacement for `PQ` @schemas schemas@.
45−
46−Typical use case would be to create your pool using `createConnectionPool` and run anything that requires the pool connection with it.
47−
48−Here's a simplified example:
49−
50−>>> import Squeal.PostgreSQL
51−>>> :{
52−do
53− let
54− query :: Query_ (Public '[]) () (Only Char)
55− query = values_ $ literal 'a' `as` #fromOnly
56− session :: PoolPQ (Public '[]) IO Char
57− session = do
58− result <- runQuery query
59− Just (Only chr) <- firstRow result
60− return chr
61− pool <- createConnectionPool "host=localhost port=5432 dbname=exampledb" 1 0.5 10
62− chr <- runPoolPQ session pool
63− destroyAllResources pool
64− putChar chr
65−:}
66−a
67−-}
68−newtype PoolPQ (schemas :: SchemasType) m x =
69− PoolPQ { runPoolPQ :: Pool (K Connection schemas) -> m x }
70− deriving Functor
7161
7262-- | Create a striped pool of connections.
7363-- Although the garbage collector will destroy all idle connections when the pool is garbage collected it's recommended to manually `destroyAllResources` when you're done with the pool so that the connections are freed up as soon as possible.
@@ -92,63 +82,41 @@ createConnectionPool
9282createConnectionPool conninfo stripes idle maxResrc =
9383 createPool (connectdb conninfo) finish stripes idle maxResrc
9484
95−-- | `Applicative` instance for `PoolPQ`.
96−instance Monad m => Applicative (PoolPQ schemas m) where
97− pure x = PoolPQ $ \ _ -> pure x
98− PoolPQ f <*> PoolPQ x = PoolPQ $ \ pool -> do
99− f' <- f pool
100− x' <- x pool
101− return $ f' x'
102−
103−-- | `Monad` instance for `PoolPQ`.
104−instance Monad m => Monad (PoolPQ schemas m) where
105− return = pure
106− PoolPQ x >>= f = PoolPQ $ \ pool -> do
107− x' <- x pool
108− runPoolPQ (f x') pool
109−
110−-- | `Fail.MonadFail` instance for `PoolPQ`.
111−instance Monad m => Fail.MonadFail (PoolPQ schemas m) where
112− fail = Fail.fail
113−
114−-- | `MonadTrans` instance for `PoolPQ`.
115−instance MonadTrans (PoolPQ schemas) where
116− lift m = PoolPQ $ \ _pool -> m
117−
118−-- | `MonadPQ` instance for `PoolPQ`.
119−instance MonadUnliftIO io => MonadPQ schemas (PoolPQ schemas io) where
120− manipulateParams manipulation params = PoolPQ $ \ pool -> do
121− withResource pool $ \ conn -> do
122− (K result :: K (K Result ys) schemas) <- flip unPQ conn $
123− manipulateParams manipulation params
124− return result
125− traversePrepared manipulation params = PoolPQ $ \ pool ->
126− withResource pool $ \ conn -> do
127− (K result :: K (list (K Result ys)) schemas) <- flip unPQ conn $
128− traversePrepared manipulation params
129− return result
130− traversePrepared_ manipulation params = PoolPQ $ \ pool -> do
131− withResource pool $ \ conn -> do
132− (_ :: K () schemas) <- flip unPQ conn $
133− traversePrepared_ manipulation params
134− return ()
135− liftPQ m = PoolPQ $ \ pool ->
136− withResource pool $ \ conn -> do
137− (K result :: K result schemas) <- flip unPQ conn $
138− liftPQ m
139− return result
140−
141−-- | 'MonadIO' instance for 'PoolPQ'.
142−instance (MonadIO m)
143− => MonadIO (PoolPQ schemas m) where
144− liftIO = lift . liftIO
145−
146−-- | 'MonadUnliftIO' instance for 'PoolPQ'.
147−instance (MonadUnliftIO m)
148− => MonadUnliftIO (PoolPQ schemas m) where
149− withRunInIO
150− :: ((forall a . PoolPQ schemas m a -> IO a) -> IO b)
151− -> PoolPQ schemas m b
152− withRunInIO inner = PoolPQ $ \pool ->
153− withRunInIO $ \(run :: (forall x . m x -> IO x)) ->
154− inner (\poolpq -> run $ runPoolPQ poolpq pool)
85+{-|
86+Temporarily take a connection from a `Pool`, perform an action with it,
87+and return it to the pool afterwards.
88+
89+If the pool has an idle connection available, it is used immediately.
90+Otherwise, if the maximum number of connections has not yet been reached,
91+a new connection is created and used.
92+If the maximum number of connections has been reached, this function blocks
93+until a connection becomes available.
94+-}
95+usingConnectionPool
96+ :: MonadUnliftIO io
97+ => Pool (K Connection schemas) -- ^ pool
98+ -> PQ schemas schemas io x -- ^ session
99+ -> io x
100+usingConnectionPool pool (PQ session) = unK <$> withResource pool session
101+
102+{- |
103+Destroy all connections in all stripes in the pool.
104+Note that this will ignore any exceptions in the destroy function.
105+
106+This function is useful when you detect that all connections
107+in the pool are broken. For example after a database has been
108+restarted all connections opened before the restart will be broken.
109+In that case it's better to close those connections so that
110+`usingConnectionPool` won't take a broken connection from the pool
111+but will open a new connection instead.
112+
113+Another use-case for this function is that when you know you are done
114+with the pool you can destroy all idle connections immediately
115+instead of waiting on the garbage collector to destroy them,
116+thus freeing up those connections sooner.
117+-}
118+destroyConnectionPool
119+ :: MonadUnliftIO io
120+ => Pool (K Connection schemas) -- ^ pool
121+ -> io ()
122+destroyConnectionPool = destroyAllResources
squeal-postgresql/src/Squeal/PostgreSQL/Query.hs+235−93
@@ -32,13 +32,15 @@ Squeal queries.
3232
3333module Squeal.PostgreSQL.Query
3434 ( -- * Queries
35− Query (..)
36− , Query_
35+ Query_
36+ , Query (..)
3737 -- ** Select
3838 , select
3939 , select_
4040 , selectDistinct
4141 , selectDistinct_
42+ , selectDistinctOn
43+ , selectDistinctOn_
4244 , Selection (..)
4345 -- ** Values
4446 , values
@@ -53,6 +55,7 @@ module Squeal.PostgreSQL.Query
5355 -- ** With
5456 , With (..)
5557 , CommonTableExpression (..)
58+ , withRecursive
5659 -- * Table Expressions
5760 , TableExpression (..)
5861 , from
@@ -100,10 +103,55 @@ import Squeal.PostgreSQL.Schema
100103
101104-- $setup
102105-- >>> import Squeal.PostgreSQL
106+-- >>> import Data.Int (Int32, Int64)
107+-- >>> import Data.Monoid (Sum (..))
108+-- >>> import Data.Text (Text)
109+-- >>> import qualified Generics.SOP as SOP
103110
104111{- |
105−The process of retrieving or the command to retrieve data from a database
106−is called a `Query`. Let's see some examples of queries.
112+The process of retrieving or the command to retrieve data from
113+a database is called a `Query`.
114+
115+The general `Query` type is parameterized by
116+
117+* @outer :: FromType@ - outer scope for a correlated subquery,
118+* @commons :: FromType@ - scope for all `common` table expressions,
119+* @schemas :: SchemasType@ - scope for all `table`s and `view`s,
120+* @params :: [NullityType]@ - scope for all `Squeal.Expression.Parameter.parameter`s,
121+* @row :: RowType@ - return type of the `Query`.
122+-}
123+newtype Query
124+ (outer :: FromType)
125+ (commons :: FromType)
126+ (schemas :: SchemasType)
127+ (params :: [NullityType])
128+ (row :: RowType)
129+ = UnsafeQuery { renderQuery :: ByteString }
130+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
131+instance RenderSQL (Query outer commons schemas params row) where renderSQL = renderQuery
132+
133+{- |
134+The top level `Query_` type is parameterized by a @schemas@ `SchemasType`,
135+against which the query is type-checked, an input @parameters@ Haskell `Type`,
136+and an ouput row Haskell `Type`.
137+
138+A top-level query can be run
139+using `Squeal.PostgreSQL.PQ.runQueryParams`, or if @parameters = ()@
140+using `Squeal.PostgreSQL.PQ.runQuery`.
141+
142+Generally, @parameters@ will be a Haskell tuple or record whose entries
143+may be referenced using positional
144+`Squeal.PostgreSQL.Expression.Parameter.parameter`s and @row@ will be a
145+Haskell record, whose entries will be targeted using overloaded labels.
146+
147+Let's see some examples of queries.
148+
149+>>> :set -XDeriveAnyClass -XDerivingStrategies
150+>>> :{
151+data Row a b = Row { col1 :: a, col2 :: b }
152+ deriving stock (GHC.Generic)
153+ deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
154+:}
107155
108156simple query:
109157
@@ -111,7 +159,7 @@ simple query:
111159>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]
112160>>> :{
113161let
114− query :: Query '[] '[] (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]
162+ query :: Query_ (Public Schema) () (Row Int32 Int32)
115163 query = select Star (from (table #tab))
116164in printSQL query
117165:}
@@ -121,21 +169,21 @@ restricted query:
121169
122170>>> :{
123171let
124− query :: Query '[] '[] (Public Schema) '[] '["sum" ::: 'NotNull 'PGint4, "col1" ::: 'NotNull 'PGint4]
172+ query :: Query_ (Public Schema) () (Row Int32 Int32)
125173 query =
126− select_ ((#col1 + #col2) `as` #sum :* #col1)
174+ select_ ((#col1 + #col2) `as` #col1 :* #col1 `as` #col2)
127175 ( from (table #tab)
128176 & where_ (#col1 .> #col2)
129177 & where_ (#col2 .> 0) )
130178in printSQL query
131179:}
132−SELECT ("col1" + "col2") AS "sum", "col1" AS "col1" FROM "tab" AS "tab" WHERE (("col1" > "col2") AND ("col2" > 0))
180+SELECT ("col1" + "col2") AS "col1", "col1" AS "col2" FROM "tab" AS "tab" WHERE (("col1" > "col2") AND ("col2" > 0))
133181
134182subquery:
135183
136184>>> :{
137185let
138− query :: Query '[] '[] (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]
186+ query :: Query_ (Public Schema) () (Row Int32 Int32)
139187 query = select Star (from (subquery (select Star (from (table #tab)) `as` #sub)))
140188in printSQL query
141189:}
@@ -145,7 +193,7 @@ limits and offsets:
145193
146194>>> :{
147195let
148− query :: Query '[] '[] (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]
196+ query :: Query_ (Public Schema) () (Row Int32 Int32)
149197 query = select Star (from (table #tab) & limit 100 & offset 2 & limit 50 & offset 2)
150198in printSQL query
151199:}
@@ -155,7 +203,7 @@ parameterized query:
155203
156204>>> :{
157205let
158− query :: Query '[] '[] (Public Schema) '[ 'NotNull 'PGint4] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]
206+ query :: Query_ (Public Schema) (Only Int32) (Row Int32 Int32)
159207 query = select Star (from (table #tab) & where_ (#col1 .> param @1))
160208in printSQL query
161209:}
@@ -165,21 +213,21 @@ aggregation query:
165213
166214>>> :{
167215let
168− query :: Query '[] '[] (Public Schema) '[] '["sum" ::: 'NotNull 'PGint4, "col1" ::: 'NotNull 'PGint4 ]
216+ query :: Query_ (Public Schema) () (Row Int64 Int32)
169217 query =
170− select_ (sum_ (All #col2) `as` #sum :* #col1)
218+ select_ ((fromNull 0 (sum_ (All #col2))) `as` #col1 :* #col1 `as` #col2)
171219 ( from (table (#tab `as` #table1))
172220 & groupBy #col1
173− & having (#col1 + sum_ (Distinct #col2) .> 1) )
221+ & having (sum_ (Distinct #col2) .> 1) )
174222in printSQL query
175223:}
176−SELECT sum(ALL "col2") AS "sum", "col1" AS "col1" FROM "tab" AS "table1" GROUP BY "col1" HAVING (("col1" + sum(DISTINCT "col2")) > 1)
224+SELECT COALESCE(sum(ALL "col2"), 0) AS "col1", "col1" AS "col2" FROM "tab" AS "table1" GROUP BY "col1" HAVING (sum(DISTINCT "col2") > 1)
177225
178226sorted query:
179227
180228>>> :{
181229let
182− query :: Query '[] '[] (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]
230+ query :: Query_ (Public Schema) () (Row Int32 Int32)
183231 query = select Star (from (table #tab) & orderBy [#col1 & Asc])
184232in printSQL query
185233:}
@@ -187,14 +235,12 @@ SELECT * FROM "tab" AS "tab" ORDER BY "col1" ASC
187235
188236joins:
189237
190−>>> :set -XFlexibleContexts
191238>>> :{
192239type OrdersColumns =
193240 '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4
194− , "price" ::: 'NoDef :=> 'NotNull 'PGfloat4
195− , "customer_id" ::: 'NoDef :=> 'NotNull 'PGint4
196− , "shipper_id" ::: 'NoDef :=> 'NotNull 'PGint4
197− ]
241+ , "price" ::: 'NoDef :=> 'NotNull 'PGfloat4
242+ , "customer_id" ::: 'NoDef :=> 'NotNull 'PGint4
243+ , "shipper_id" ::: 'NoDef :=> 'NotNull 'PGint4 ]
198244:}
199245
200246>>> :{
@@ -210,22 +256,27 @@ type OrdersConstraints =
210256>>> :{
211257type OrdersSchema =
212258 '[ "orders" ::: 'Table (OrdersConstraints :=> OrdersColumns)
213− , "customers" ::: 'Table (CustomersConstraints :=> NamesColumns)
214− , "shippers" ::: 'Table (ShippersConstraints :=> NamesColumns) ]
259+ , "customers" ::: 'Table (CustomersConstraints :=> NamesColumns)
260+ , "shippers" ::: 'Table (ShippersConstraints :=> NamesColumns) ]
261+:}
262+
263+>>> :{
264+data Order = Order
265+ { price :: Float
266+ , customerName :: Text
267+ , shipperName :: Text
268+ } deriving GHC.Generic
269+instance SOP.Generic Order
270+instance SOP.HasDatatypeInfo Order
215271:}
216272
217273>>> :{
218274let
219− query :: Query '[] '[] (Public OrdersSchema)
220− '[]
221− '[ "order_price" ::: 'NotNull 'PGfloat4
222− , "customer_name" ::: 'NotNull 'PGtext
223− , "shipper_name" ::: 'NotNull 'PGtext
224− ]
275+ query :: Query_ (Public OrdersSchema) () Order
225276 query = select_
226− ( #o ! #price `as` #order_price :*
227− #c ! #name `as` #customer_name :*
228− #s ! #name `as` #shipper_name )
277+ ( #o ! #price `as` #price :*
278+ #c ! #name `as` #customerName :*
279+ #s ! #name `as` #shipperName )
229280 ( from (table (#orders `as` #o)
230281 & innerJoin (table (#customers `as` #c))
231282 (#o ! #customer_id .== #c ! #id)
@@ -233,14 +284,16 @@ let
233284 (#o ! #shipper_id .== #s ! #id)) )
234285in printSQL query
235286:}
236−SELECT "o"."price" AS "order_price", "c"."name" AS "customer_name", "s"."name" AS "shipper_name" FROM "orders" AS "o" INNER JOIN "customers" AS "c" ON ("o"."customer_id" = "c"."id") INNER JOIN "shippers" AS "s" ON ("o"."shipper_id" = "s"."id")
287+SELECT "o"."price" AS "price", "c"."name" AS "customerName", "s"."name" AS "shipperName" FROM "orders" AS "o" INNER JOIN "customers" AS "c" ON ("o"."customer_id" = "c"."id") INNER JOIN "shippers" AS "s" ON ("o"."shipper_id" = "s"."id")
237288
238289self-join:
239290
240291>>> :{
241292let
242− query :: Query '[] '[] (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]
243− query = select (#t1 & DotStar) (from (table (#tab `as` #t1) & crossJoin (table (#tab `as` #t2))))
293+ query :: Query_ (Public Schema) () (Row Int32 Int32)
294+ query = select
295+ (#t1 & DotStar)
296+ (from (table (#tab `as` #t1) & crossJoin (table (#tab `as` #t2))))
244297in printSQL query
245298:}
246299SELECT "t1".* FROM "tab" AS "t1" CROSS JOIN "tab" AS "t2"
@@ -249,17 +302,19 @@ value queries:
249302
250303>>> :{
251304let
252− query :: Query '[] commons schemas '[] '["foo" ::: 'NotNull 'PGint2, "bar" ::: 'NotNull 'PGbool]
253− query = values (1 `as` #foo :* true `as` #bar) [2 `as` #foo :* false `as` #bar]
305+ query :: Query_ schemas () (Row String Bool)
306+ query = values
307+ ("true" `as` #col1 :* true `as` #col2)
308+ ["false" `as` #col1 :* false `as` #col2]
254309in printSQL query
255310:}
256−SELECT * FROM (VALUES (1, TRUE), (2, FALSE)) AS t ("foo", "bar")
311+SELECT * FROM (VALUES (E'true', TRUE), (E'false', FALSE)) AS t ("col1", "col2")
257312
258313set operations:
259314
260315>>> :{
261316let
262− query :: Query '[] '[] (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]
317+ query :: Query_ (Public Schema) () (Row Int32 Int32)
263318 query = select Star (from (table #tab)) `unionAll` select Star (from (table #tab))
264319in printSQL query
265320:}
@@ -269,7 +324,7 @@ with queries:
269324
270325>>> :{
271326let
272− query :: Query '[] '[] (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]
327+ query :: Query_ (Public Schema) () (Row Int32 Int32)
273328 query = with (
274329 select Star (from (table #tab)) `as` #cte1 :>>
275330 select Star (from (common #cte1)) `as` #cte2
@@ -282,40 +337,35 @@ window function queries
282337
283338>>> :{
284339let
285− query :: Query '[] '[] (Public Schema) '[] ["col1" ::: 'NotNull 'PGint4, "rank" ::: 'NotNull 'PGint8]
340+ query :: Query_ (Public Schema) () (Row Int32 Int64)
286341 query = select
287− (#col1 & Also (rank `as` #rank `Over` (partitionBy #col1 & orderBy [#col2 & Asc])))
342+ (#col1 & Also (rank `as` #col2 `Over` (partitionBy #col1 & orderBy [#col2 & Asc])))
288343 (from (table #tab))
289344in printSQL query
290345:}
291−SELECT "col1" AS "col1", rank() OVER (PARTITION BY "col1" ORDER BY "col2" ASC) AS "rank" FROM "tab" AS "tab"
346+SELECT "col1" AS "col1", rank() OVER (PARTITION BY "col1" ORDER BY "col2" ASC) AS "col2" FROM "tab" AS "tab"
292347
293348correlated subqueries
294349
295350>>> :{
296351let
297− query :: Query '[] '[] (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4]
352+ query :: Query_ (Public Schema) () (Only Int32)
298353 query =
299− select #col1 (from (table (#tab `as` #t1))
354+ select (#col1 `as` #fromOnly) (from (table (#tab `as` #t1))
300355 & where_ (exists (
301356 select Star (from (table (#tab `as` #t2))
302357 & where_ (#t2 ! #col2 .== #t1 ! #col1)))))
303358in printSQL query
304359:}
305−SELECT "col1" AS "col1" FROM "tab" AS "t1" WHERE EXISTS (SELECT * FROM "tab" AS "t2" WHERE ("t2"."col2" = "t1"."col1"))
360+SELECT "col1" AS "fromOnly" FROM "tab" AS "t1" WHERE EXISTS (SELECT * FROM "tab" AS "t2" WHERE ("t2"."col2" = "t1"."col1"))
361+
306362-}
307−newtype Query
308− (outer :: FromType)
309− (commons :: FromType)
363+type family Query_
310364 (schemas :: SchemasType)
311− (params :: [NullityType])
312− (row :: RowType)
313− = UnsafeQuery { renderQuery :: ByteString }
314− deriving (GHC.Generic,Show,Eq,Ord,NFData)
315−instance RenderSQL (Query outer commons schemas params row) where renderSQL = renderQuery
316−
317−type family Query_ (schemas :: SchemasType) (params :: Type) (row :: Type) where
318− Query_ schemas params row = Query '[] '[] schemas (TuplePG params) (RowPG row)
365+ (parameters :: Type)
366+ (row :: Type) where
367+ Query_ schemas params row =
368+ Query '[] '[] schemas (TuplePG params) (RowPG row)
319369
320370-- | The results of two queries can be combined using the set operation
321371-- `union`. Duplicate rows are eliminated.
@@ -387,28 +437,39 @@ q1 `exceptAll` q2 = UnsafeQuery $
387437SELECT queries
388438-----------------------------------------}
389439
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+-}
390446data Selection outer commons grp schemas params from row where
391− List
392− :: SListI row
393− => NP (Aliased (Expression outer commons grp schemas params from)) row
394− -> Selection outer commons grp schemas params from row
395447 Star
396448 :: HasUnique tab from row
397449 => Selection outer commons 'Ungrouped schemas params from row
450+ -- ^ `HasUnique` table in the `FromClause`
398451 DotStar
399452 :: Has tab from row
400453 => Alias tab
454+ -- ^ `Has` table with `Alias`
401455 -> Selection outer commons 'Ungrouped schemas params from row
402− Also
403− :: Selection outer commons grp schemas params from right
404− -> Selection outer commons grp schemas params from left
405− -> Selection outer commons grp schemas params from (Join left right)
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
406461 Over
407462 :: SListI row
408463 => NP (Aliased (WindowFunction outer commons grp schemas params from)) row
464+ -- ^ `NP` list of `Aliased` `WindowFunction`s
409465 -> WindowDefinition outer commons grp schemas params from
410466 -> Selection outer commons grp schemas params from row
411−instance Additionally (Selection outer commons grp schemas params from) where
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
412473 also = Also
413474instance (KnownSymbol col, row ~ '[col ::: ty])
414475 => Aliasable col
@@ -469,7 +530,7 @@ instance IsString
469530select
470531 :: (SListI row, row ~ (x ': xs))
471532 => Selection outer commons grp schemas params from row
472− -- ^ select list
533+ -- ^ selection
473534 -> TableExpression outer commons grp schemas params from
474535 -- ^ intermediate virtual table
475536 -> Query outer commons schemas params row
@@ -478,20 +539,24 @@ select selection tabexpr = UnsafeQuery $
478539 <+> renderSQL selection
479540 <+> renderSQL tabexpr
480541
542+-- | Like `select` but takes an `NP` list of `Expression`s instead
543+-- of a general `Selection`.
481544select_
482545 :: (SListI row, row ~ (x ': xs))
483546 => NP (Aliased (Expression outer commons grp schemas params from)) row
547+ -- ^ select list
484548 -> TableExpression outer commons grp schemas params from
549+ -- ^ intermediate virtual table
485550 -> Query outer commons schemas params row
486−select_ list = select (List list)
551+select_ = select . List
487552
488553-- | After the select list has been processed, the result table can
489554-- be subject to the elimination of duplicate rows using `selectDistinct`.
490555selectDistinct
491556 :: (SListI columns, columns ~ (col ': cols))
492− => Selection outer commons 'Ungrouped schemas params from columns
493− -- ^ select list
494− -> TableExpression outer commons 'Ungrouped schemas params from
557+ => Selection outer commons grp schemas params from columns
558+ -- ^ selection
559+ -> TableExpression outer commons grp schemas params from
495560 -- ^ intermediate virtual table
496561 -> Query outer commons schemas params columns
497562selectDistinct selection tabexpr = UnsafeQuery $
@@ -499,14 +564,65 @@ selectDistinct selection tabexpr = UnsafeQuery $
499564 <+> renderSQL selection
500565 <+> renderSQL tabexpr
501566
567+-- | Like `selectDistinct` but takes an `NP` list of `Expression`s instead
568+-- of a general `Selection`.
502569selectDistinct_
503570 :: (SListI columns, columns ~ (col ': cols))
504− => NP (Aliased (Expression outer commons 'Ungrouped schemas params from)) columns
571+ => NP (Aliased (Expression outer commons grp schemas params from)) columns
505572 -- ^ select list
506− -> TableExpression outer commons 'Ungrouped schemas params from
573+ -> TableExpression outer commons grp schemas params from
507574 -- ^ intermediate virtual table
508575 -> Query outer commons schemas params columns
509−selectDistinct_ list = select (List list)
576+selectDistinct_ = selectDistinct . List
577+
578+{-|
579+`selectDistinctOn` keeps only the first row of each set of rows where
580+the given expressions evaluate to equal. The DISTINCT ON expressions are
581+interpreted using the same rules as for ORDER BY. ORDER BY is used to
582+ensure that the desired row appears first.
583+
584+The DISTINCT ON expression(s) must match the leftmost ORDER BY expression(s).
585+The ORDER BY clause will normally contain additional expression(s) that
586+determine the desired precedence of rows within each DISTINCT ON group.
587+
588+In order to guarantee they match and reduce redundancy, this function
589+will prepend the The DISTINCT ON expressions to the ORDER BY clause.
590+-}
591+selectDistinctOn
592+ :: (SListI columns, columns ~ (col ': cols))
593+ => [SortExpression outer commons grp schemas params from]
594+ -- ^ DISTINCT ON expression(s) and prepended to ORDER BY clause
595+ -> Selection outer commons grp schemas params from columns
596+ -- ^ selection
597+ -> TableExpression outer commons grp schemas params from
598+ -- ^ intermediate virtual table
599+ -> Query outer commons schemas params columns
600+selectDistinctOn distincts selection tab = UnsafeQuery $
601+ "SELECT DISTINCT ON"
602+ <+> parenthesized (commaSeparated (renderDistinctOn <$> distincts))
603+ <+> renderSQL selection
604+ <+> renderSQL (tab {orderByClause = distincts <> orderByClause tab})
605+ where
606+ renderDistinctOn = \case
607+ Asc expression -> renderSQL expression
608+ Desc expression -> renderSQL expression
609+ AscNullsFirst expression -> renderSQL expression
610+ DescNullsFirst expression -> renderSQL expression
611+ AscNullsLast expression -> renderSQL expression
612+ DescNullsLast expression -> renderSQL expression
613+
614+-- | Like `selectDistinctOn` but takes an `NP` list of `Expression`s instead
615+-- of a general `Selection`.
616+selectDistinctOn_
617+ :: (SListI columns, columns ~ (col ': cols))
618+ => [SortExpression outer commons grp schemas params from]
619+ -- ^ distinct on and return the first row in ordering
620+ -> NP (Aliased (Expression outer commons grp schemas params from)) columns
621+ -- ^ selection
622+ -> TableExpression outer commons grp schemas params from
623+ -- ^ intermediate virtual table
624+ -> Query outer commons schemas params columns
625+selectDistinctOn_ distincts = selectDistinctOn distincts . List
510626
511627-- | `values` computes a row value or set of row values
512628-- specified by value expressions. It is most commonly used
@@ -641,7 +757,7 @@ instance RenderSQL (TableExpression outer commons grp schemas params from) where
641757from
642758 :: FromClause outer commons schemas params from -- ^ table reference
643759 -> TableExpression outer commons 'Ungrouped schemas params from
644−from tab = TableExpression tab [] NoGroups NoHaving [] [] []
760+from tab = TableExpression tab [] noGroups NoHaving [] [] []
645761
646762-- | A `where_` is an endomorphism of `TableExpression`s which adds a
647763-- search condition to the `whereClause`.
@@ -662,7 +778,7 @@ groupBy
662778groupBy bys rels = TableExpression
663779 { fromClause = fromClause rels
664780 , whereClause = whereClause rels
665− , groupByClause = Group bys
781+ , groupByClause = group bys
666782 , havingClause = Having []
667783 , orderByClause = []
668784 , limitClause = limitClause rels
@@ -741,7 +857,7 @@ common
741857common (cte `As` alias) = UnsafeFromClause $
742858 renderSQL cte <+> "AS" <+> renderSQL alias
743859
744−instance Additionally (FromClause outer commons schemas params) where
860+instance Additional (FromClause outer commons schemas params) where
745861 also right left = UnsafeFromClause $
746862 renderSQL left <> ", " <> renderSQL right
747863
@@ -876,19 +992,20 @@ instance (Has rel rels cols, Has col cols ty, bys ~ '[ '(rel, col)])
876992-- done on @NoGroups@ while all output `Expression`s must be aggregated
877993-- in @Group Nil@. In general, all output `Expression`s in the
878994-- complement of @bys@ must be aggregated in @Group bys@.
879−data GroupByClause grp from where
880− NoGroups :: GroupByClause 'Ungrouped from
881− Group
882− :: SListI bys
883− => NP (By from) bys
884− -> GroupByClause ('Grouped bys) from
885−
886−-- | Renders a `GroupByClause`.
995+newtype GroupByClause grp from = UnsafeGroupByClause
996+ { renderGroupByClause :: ByteString }
997+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
887998instance RenderSQL (GroupByClause grp from) where
888− renderSQL = \case
889− NoGroups -> ""
890− Group Nil -> ""
891− 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'
8921009
8931010-- | A `HavingClause` is used to eliminate groups that are not of interest.
8941011-- An `Ungrouped` `TableExpression` may only use `NoHaving` while a `Grouped`
@@ -932,8 +1049,8 @@ instance
9321049 , commons1 ~ (cte ::: common ': commons)
9331050 ) => Aliasable cte
9341051 (statement commons schemas params common)
935− (AlignedList (CommonTableExpression statement schemas params) commons commons1) where
936− statement `as` cte = single (statement `as` cte)
1052+ (Path (CommonTableExpression statement schemas params) commons commons1) where
1053+ statement `as` cte = csingleton (statement `as` cte)
9371054
9381055instance (forall c s p r. RenderSQL (statement c s p r)) => RenderSQL
9391056 (CommonTableExpression statement schemas params commons0 commons1) where
@@ -945,7 +1062,7 @@ instance (forall c s p r. RenderSQL (statement c s p r)) => RenderSQL
9451062-- defining temporary tables that exist just for one query.
9461063class With statement where
9471064 with
948− :: AlignedList (CommonTableExpression statement schemas params) commons0 commons1
1065+ :: Path (CommonTableExpression statement schemas params) commons0 commons1
9491066 -- ^ common table expressions
9501067 -> statement commons1 schemas params row
9511068 -- ^ larger query
@@ -953,4 +1070,29 @@ class With statement where
9531070instance With (Query outer) where
9541071 with Done query = query
9551072 with ctes query = UnsafeQuery $
956− "WITH" <+> renderSQL ctes <+> renderSQL query
1073+ "WITH" <+> commaSeparated (ctoList renderSQL ctes) <+> renderSQL query
1074+
1075+{- |
1076+>>> import Data.Monoid (Sum (..))
1077+>>> import Data.Int (Int64)
1078+>>> :{
1079+ let
1080+ query :: Query_ schema () (Sum Int64)
1081+ query = withRecursive
1082+ ( values_ ((1 & astype int) `as` #n)
1083+ `unionAll`
1084+ select_ ((#n + 1) `as` #n)
1085+ (from (common #t) & where_ (#n .< 100)) `as` #t )
1086+ ( select_ (fromNull 0 (sum_ (All #n)) `as` #getSum) (from (common #t) & groupBy Nil))
1087+ in printSQL query
1088+:}
1089+WITH RECURSIVE "t" AS ((SELECT * FROM (VALUES ((1 :: int))) AS t ("n")) UNION ALL (SELECT ("n" + 1) AS "n" FROM "t" AS "t" WHERE ("n" < 100))) SELECT COALESCE(sum(ALL "n"), 0) AS "getSum" FROM "t" AS "t"
1090+-}
1091+withRecursive
1092+ :: Aliased (Query outer (recursive ': commons) schemas params) recursive
1093+ -> Query outer (recursive ': commons) schemas params row
1094+ -> Query outer commons schemas params row
1095+withRecursive (recursive `As` cte) query = UnsafeQuery $
1096+ "WITH RECURSIVE" <+> renderSQL cte
1097+ <+> "AS" <+> parenthesized (renderSQL recursive)
1098+ <+> renderSQL query
squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs+161−60
@@ -44,6 +44,10 @@ module Squeal.PostgreSQL.Schema
4444 , ColumnsType
4545 , TableType
4646 , SchemumType (..)
47+ , IndexType (..)
48+ , FunctionType
49+ , OperatorType (..)
50+ , ReturnsType (..)
4751 , SchemaType
4852 , SchemasType
4953 , Public
@@ -58,15 +62,21 @@ module Squeal.PostgreSQL.Schema
5862 , PGlabel (..)
5963 -- * Data Definitions
6064 , Create
65+ , CreateIfNotExists
66+ , CreateOrReplace
6167 , Drop
68+ , DropSchemum
69+ , DropIfExists
70+ , DropSchemumIfExists
6271 , Alter
72+ , AlterIfExists
6373 , Rename
74+ , RenameIfExists
6475 , ConstraintInvolves
6576 , DropIfConstraintsInvolve
6677 , IsNotElem
6778 , AllUnique
6879 -- * Type Classifications
69− , HasOid (..)
7080 , PGNum
7181 , PGIntegral
7282 , PGFloating
@@ -90,17 +100,19 @@ import Control.Category
90100import Data.Kind
91101import Data.Monoid hiding (All)
92102import Data.Type.Bool
93−import Data.Word (Word32)
94103import Generics.SOP
95104import GHC.TypeLits
96105import Prelude hiding (id, (.))
97106
98107import Squeal.PostgreSQL.Alias
108+import Squeal.PostgreSQL.List
99109import Squeal.PostgreSQL.Render
100110
111+-- $setup
112+-- >>> import Squeal.PostgreSQL
113+
101114-- | `PGType` is the promoted datakind of PostgreSQL types.
102115--
103−-- >>> import Squeal.PostgreSQL.Schema
104116-- >>> :kind 'PGbool
105117-- 'PGbool :: PGType
106118data PGType
@@ -131,37 +143,11 @@ data PGType
131143 | PGenum [Symbol] -- ^ enumerated (enum) types are data types that comprise a static, ordered set of values.
132144 | PGcomposite RowType -- ^ a composite type represents the structure of a row or record; it is essentially just a list of field names and their data types.
133145 | PGtsvector -- ^ A tsvector value is a sorted list of distinct lexemes, which are words that have been normalized to merge different variants of the same word.
134− | PGtsquery -- ^ A tsquery value stores lexemes that are to be searched for
146+ | PGtsquery -- ^ A tsquery value stores lexemes that are to be searched for.
147+ | PGoid -- Object identifiers (OIDs) are used internally by PostgreSQL as primary keys for various system tables.
148+ | PGrange PGType -- ^ Range types are data types representing a range of values of some element type (called the range's subtype).
135149 | UnsafePGType Symbol -- ^ an escape hatch for unsupported PostgreSQL types
136150
137−-- | The object identifier of a `PGType`.
138−--
139−-- >>> :set -XTypeApplications
140−-- >>> oid @'PGbool
141−-- 16
142−class HasOid (ty :: PGType) where oid :: Word32
143−instance HasOid 'PGbool where oid = 16
144−instance HasOid 'PGint2 where oid = 21
145−instance HasOid 'PGint4 where oid = 23
146−instance HasOid 'PGint8 where oid = 20
147−instance HasOid 'PGnumeric where oid = 1700
148−instance HasOid 'PGfloat4 where oid = 700
149−instance HasOid 'PGfloat8 where oid = 701
150−instance HasOid ('PGchar n) where oid = 18
151−instance HasOid ('PGvarchar n) where oid = 1043
152−instance HasOid 'PGtext where oid = 25
153−instance HasOid 'PGbytea where oid = 17
154−instance HasOid 'PGtimestamp where oid = 1114
155−instance HasOid 'PGtimestamptz where oid = 1184
156−instance HasOid 'PGdate where oid = 1082
157−instance HasOid 'PGtime where oid = 1083
158−instance HasOid 'PGtimetz where oid = 1266
159−instance HasOid 'PGinterval where oid = 1186
160−instance HasOid 'PGuuid where oid = 2950
161−instance HasOid 'PGinet where oid = 869
162−instance HasOid 'PGjson where oid = 114
163−instance HasOid 'PGjsonb where oid = 3802
164−
165151-- | `NullityType` encodes the potential presence or definite absence of a
166152-- @NULL@ allowing operations which are sensitive to such to be well typed.
167153--
@@ -274,9 +260,19 @@ type FromType = [(Symbol,RowType)]
274260
275261-- | `ColumnsToRow` removes column constraints.
276262type family ColumnsToRow (columns :: ColumnsType) :: RowType where
277− ColumnsToRow '[] = '[]
278− ColumnsToRow (column ::: constraint :=> ty ': columns) =
263+ ColumnsToRow (column ::: _ :=> ty ': column1 ::: _ :=> ty1 ': column2 ::: _ :=> ty2 ': column3 ::: _ :=> ty3 ': column4 ::: _ :=> ty4 ': column5 ::: _ :=> ty5 ': columns) =
264+ column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': column3 ::: ty3 ': column4 ::: ty4 ': column5 ::: ty5 ': ColumnsToRow columns
265+ ColumnsToRow (column ::: _ :=> ty ': column1 ::: _ :=> ty1 ': column2 ::: _ :=> ty2 ': column3 ::: _ :=> ty3 ': column4 ::: _ :=> ty4 ': columns) =
266+ column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': column3 ::: ty3 ': column4 ::: ty4 ': ColumnsToRow columns
267+ ColumnsToRow (column ::: _ :=> ty ': column1 ::: _ :=> ty1 ': column2 ::: _ :=> ty2 ': column3 ::: _ :=> ty3 ': columns) =
268+ column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': column3 ::: ty3 ': ColumnsToRow columns
269+ ColumnsToRow (column ::: _ :=> ty ': column1 ::: _ :=> ty1 ': column2 ::: _ :=> ty2 ': columns) =
270+ column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': ColumnsToRow columns
271+ ColumnsToRow (column ::: _ :=> ty ': column1 ::: _ :=> ty1 ': columns) =
272+ column ::: ty ': column1 ::: ty1 ': ColumnsToRow columns
273+ ColumnsToRow (column ::: _ :=> ty ': columns) =
279274 column ::: ty ': ColumnsToRow columns
275+ ColumnsToRow '[] = '[]
280276
281277-- | `TableToColumns` removes table constraints.
282278type family TableToColumns (table :: TableType) :: ColumnsType where
@@ -286,15 +282,6 @@ type family TableToColumns (table :: TableType) :: ColumnsType where
286282type family TableToRow (table :: TableType) :: RowType where
287283 TableToRow tab = ColumnsToRow (TableToColumns tab)
288284
289−-- | @Elem@ is a promoted `Data.List.elem`.
290−type family Elem x xs where
291− Elem x '[] = 'False
292− Elem x (x ': xs) = 'True
293− Elem x (_ ': xs) = Elem x xs
294−
295−-- | @In x xs@ is a constraint that proves that @x@ is in @xs@.
296−type family In x xs :: Constraint where In x xs = Elem x xs ~ 'True
297−
298285-- | Numeric Postgres types.
299286type PGNum =
300287 '[ 'PGint2, 'PGint4, 'PGint8, 'PGnumeric, 'PGfloat4, 'PGfloat8]
@@ -318,14 +305,24 @@ instance ty0 ~ ty1 => SamePGType
318305
319306-- | `AllNotNull` is a constraint that proves a `ColumnsType` has no @NULL@s.
320307type family AllNotNull (columns :: ColumnsType) :: Constraint where
308+ AllNotNull (_ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': columns) = AllNotNull columns
309+ AllNotNull (_ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': columns) = AllNotNull columns
310+ AllNotNull (_ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': columns) = AllNotNull columns
311+ AllNotNull (_ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': columns) = AllNotNull columns
312+ AllNotNull (_ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': columns) = AllNotNull columns
313+ AllNotNull (_ ::: _ :=> 'NotNull _ ': columns) = AllNotNull columns
321314 AllNotNull '[] = ()
322− AllNotNull (column ::: def :=> 'NotNull ty ': columns) = AllNotNull columns
323315
324316-- | `NotAllNull` is a constraint that proves a `ColumnsType` has some
325317-- @NOT NULL@.
326318type family NotAllNull (columns :: ColumnsType) :: Constraint where
327− NotAllNull (column ::: def :=> 'NotNull ty ': columns) = ()
328− NotAllNull (column ::: def :=> 'Null ty ': columns) = NotAllNull columns
319+ NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()
320+ NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()
321+ NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()
322+ NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()
323+ NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()
324+ NotAllNull (_ ::: _ :=> 'NotNull _ ': _) = ()
325+ NotAllNull (_ ::: _ :=> 'Null _ ': columns) = NotAllNull columns
329326
330327-- | `NullifyType` is an idempotent that nullifies a `NullityType`.
331328type family NullifyType (ty :: NullityType) :: NullityType where
@@ -334,17 +331,37 @@ type family NullifyType (ty :: NullityType) :: NullityType where
334331
335332-- | `NullifyRow` is an idempotent that nullifies a `RowType`.
336333type family NullifyRow (columns :: RowType) :: RowType where
337− NullifyRow '[] = '[]
334+ NullifyRow (column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': column3 ::: ty3 ': column4 ::: ty4 ': column5 ::: ty5 ': columns) =
335+ column ::: NullifyType ty ': column1 ::: NullifyType ty1 ': column2 ::: NullifyType ty2 ': column3 ::: NullifyType ty3 ': column4 ::: NullifyType ty4 ': column5 ::: NullifyType ty5 ': NullifyRow columns
336+ NullifyRow (column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': column3 ::: ty3 ': column4 ::: ty4 ': columns) =
337+ column ::: NullifyType ty ': column1 ::: NullifyType ty1 ': column2 ::: NullifyType ty2 ': column3 ::: NullifyType ty3 ': column4 ::: NullifyType ty4 ': NullifyRow columns
338+ NullifyRow (column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': column3 ::: ty3 ': columns) =
339+ column ::: NullifyType ty ': column1 ::: NullifyType ty1 ': column2 ::: NullifyType ty2 ': column3 ::: NullifyType ty3 ': NullifyRow columns
340+ NullifyRow (column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': columns) =
341+ column ::: NullifyType ty ': column1 ::: NullifyType ty1 ': column2 ::: NullifyType ty2 ': NullifyRow columns
342+ NullifyRow (column ::: ty ': column1 ::: ty1 ': columns) =
343+ column ::: NullifyType ty ': column1 ::: NullifyType ty1 ': NullifyRow columns
338344 NullifyRow (column ::: ty ': columns) =
339345 column ::: NullifyType ty ': NullifyRow columns
346+ NullifyRow '[] = '[]
340347
341348-- | `NullifyFrom` is an idempotent that nullifies a `FromType`
342349-- used to nullify the left or right hand side of an outer join
343350-- in a `Squeal.PostgreSQL.Query.FromClause`.
344351type family NullifyFrom (tables :: FromType) :: FromType where
345− NullifyFrom '[] = '[]
352+ NullifyFrom (table ::: columns ': table1 ::: columns1 ': table2 ::: columns2 ': table3 ::: columns3 ': table4 ::: columns4 ': table5 ::: columns5 ': tables) =
353+ table ::: NullifyRow columns ': table1 ::: NullifyRow columns1 ': table2 ::: NullifyRow columns2 ': table3 ::: NullifyRow columns3 ': table4 ::: NullifyRow columns5 ': table5 ::: NullifyRow columns4 ': NullifyFrom tables
354+ NullifyFrom (table ::: columns ': table1 ::: columns1 ': table2 ::: columns2 ': table3 ::: columns3 ': table4 ::: columns4 ': tables) =
355+ table ::: NullifyRow columns ': table1 ::: NullifyRow columns1 ': table2 ::: NullifyRow columns2 ': table3 ::: NullifyRow columns3 ': table4 ::: NullifyRow columns4 ': NullifyFrom tables
356+ NullifyFrom (table ::: columns ': table1 ::: columns1 ': table2 ::: columns2 ': table3 ::: columns3 ': tables) =
357+ table ::: NullifyRow columns ': table1 ::: NullifyRow columns1 ': table2 ::: NullifyRow columns2 ': table3 ::: NullifyRow columns3 ': NullifyFrom tables
358+ NullifyFrom (table ::: columns ': table1 ::: columns1 ': table2 ::: columns2 ': tables) =
359+ table ::: NullifyRow columns ': table1 ::: NullifyRow columns1 ': table2 ::: NullifyRow columns2 ': NullifyFrom tables
360+ NullifyFrom (table ::: columns ': table1 ::: columns1 ': tables) =
361+ table ::: NullifyRow columns ': table1 ::: NullifyRow columns1 ': NullifyFrom tables
346362 NullifyFrom (table ::: columns ': tables) =
347363 table ::: NullifyRow columns ': NullifyFrom tables
364+ NullifyFrom '[] = '[]
348365
349366-- | @Create alias x xs@ adds @alias ::: x@ to the end of @xs@ and is used in
350367-- `Squeal.PostgreSQL.Definition.createTable` statements and in @ALTER TABLE@
@@ -354,30 +371,101 @@ type family Create alias x xs where
354371 Create alias x (alias ::: y ': xs) = TypeError
355372 ('Text "Create: alias "
356373 ':<>: 'ShowType alias
357− ':<>: 'Text "already in use")
374+ ':<>: 'Text "already exists")
358375 Create alias y (x ': xs) = x ': Create alias y xs
359376
377+type family CreateIfNotExists alias x xs where
378+ CreateIfNotExists alias x '[] = '[alias ::: x]
379+ CreateIfNotExists alias x (alias ::: y ': xs) = alias ::: y ': xs
380+ CreateIfNotExists alias y (x ': xs) = x ': CreateIfNotExists alias y xs
381+
382+type family CreateOrReplace alias x xs where
383+ CreateOrReplace alias x '[] = '[alias ::: x]
384+ CreateOrReplace alias x (alias ::: x ': xs) = alias ::: x ': xs
385+ CreateOrReplace alias x (alias ::: y ': xs) = TypeError
386+ ('Text "CreateOrReplace: expected type "
387+ ':<>: 'ShowType x
388+ ':<>: 'Text " but alias "
389+ ':<>: 'ShowType alias
390+ ':<>: 'Text " has type "
391+ ':<>: 'ShowType y)
392+ CreateOrReplace alias y (x ': xs) = x ': CreateOrReplace alias y xs
393+
360394-- | @Drop alias xs@ removes the type associated with @alias@ in @xs@
361395-- and is used in `Squeal.PostgreSQL.Definition.dropTable` statements
362396-- and in @ALTER TABLE@ `Squeal.PostgreSQL.Definition.dropColumn` statements.
363397type family Drop alias xs where
364− Drop alias ((alias ::: x) ': xs) = xs
398+ Drop alias '[] = TypeError
399+ ('Text "Drop: alias "
400+ ':<>: 'ShowType alias
401+ ':<>: 'Text " does not exist" )
402+ Drop alias (alias ::: x ': xs) = xs
365403 Drop alias (x ': xs) = x ': Drop alias xs
366404
405+type family DropSchemum alias sch xs where
406+ DropSchemum alias sch '[] = TypeError
407+ ('Text "DropSchemum: alias "
408+ ':<>: 'ShowType alias
409+ ':<>: 'Text " does not exist" )
410+ DropSchemum alias sch (alias ::: sch x ': xs) = xs
411+ DropSchemum alias sch0 (alias ::: sch1 x ': xs) = TypeError
412+ ('Text "DropSchemum: expected schemum "
413+ ':<>: 'ShowType sch0
414+ ':<>: 'Text " but alias "
415+ ':<>: 'ShowType alias
416+ ':<>: 'Text " has schemum "
417+ ':<>: 'ShowType sch1)
418+ DropSchemum alias sch (x ': xs) = x ': DropSchemum alias sch xs
419+
420+type family DropIfExists alias xs where
421+ DropIfExists alias '[] = '[]
422+ DropIfExists alias (alias ::: x ': xs) = xs
423+ DropIfExists alias (x ': xs) = x ': DropIfExists alias xs
424+
425+type family DropSchemumIfExists alias sch xs where
426+ DropSchemumIfExists alias sch '[] = '[]
427+ DropSchemumIfExists alias sch (alias ::: sch x ': xs) = xs
428+ DropSchemumIfExists alias sch0 (alias ::: sch1 x ': xs) = TypeError
429+ ('Text "DropSchemumIfExists: expected schemum "
430+ ':<>: 'ShowType sch1
431+ ':<>: 'Text " but alias "
432+ ':<>: 'ShowType alias
433+ ':<>: 'Text " has schemum "
434+ ':<>: 'ShowType sch0)
435+ DropSchemumIfExists alias sch (x ': xs) = x ': DropSchemumIfExists alias sch xs
436+
367437-- | @Alter alias x xs@ replaces the type associated with an @alias@ in @xs@
368438-- with the type @x@ and is used in `Squeal.PostgreSQL.Definition.alterTable`
369439-- and `Squeal.PostgreSQL.Definition.alterColumn`.
370440type family Alter alias x xs where
441+ Alter alias x '[] = TypeError
442+ ('Text "Alter: alias "
443+ ':<>: 'ShowType alias
444+ ':<>: 'Text " does not exist" )
371445 Alter alias x1 (alias ::: x0 ': xs) = alias ::: x1 ': xs
372446 Alter alias x1 (x0 ': xs) = x0 ': Alter alias x1 xs
373447
448+type family AlterIfExists alias x xs where
449+ AlterIfExists alias x '[] = '[]
450+ AlterIfExists alias x1 (alias ::: x0 ': xs) = alias ::: x1 ': xs
451+ AlterIfExists alias x1 (x0 ': xs) = x0 ': AlterIfExists alias x1 xs
452+
374453-- | @Rename alias0 alias1 xs@ replaces the alias @alias0@ by @alias1@ in @xs@
375454-- and is used in `Squeal.PostgreSQL.Definition.alterTableRename` and
376455-- `Squeal.PostgreSQL.Definition.renameColumn`.
377456type family Rename alias0 alias1 xs where
457+ Rename alias0 alias1 '[] = TypeError
458+ ('Text "Rename: alias "
459+ ':<>: 'ShowType alias0
460+ ':<>: 'Text " does not exist" )
378461 Rename alias0 alias1 ((alias0 ::: x0) ': xs) = (alias1 ::: x0) ': xs
379462 Rename alias0 alias1 (x ': xs) = x ': Rename alias0 alias1 xs
380463
464+type family RenameIfExists alias0 alias1 xs where
465+ RenameIfExists alias x '[] = '[]
466+ RenameIfExists alias0 alias1 ((alias0 ::: x0) ': xs) = (alias1 ::: x0) ': xs
467+ RenameIfExists alias0 alias1 (x ': xs) = x ': RenameIfExists alias0 alias1 xs
468+
381469-- | Check if a `TableConstraint` involves a column
382470type family ConstraintInvolves column constraint where
383471 ConstraintInvolves column ('Check columns) = column `Elem` columns
@@ -394,22 +482,35 @@ type family DropIfConstraintsInvolve column constraints where
394482 (DropIfConstraintsInvolve column constraints)
395483 (alias ::: constraint ': DropIfConstraintsInvolve column constraints)
396484
397−{- | Calculate the `Length` of a type level list
398−
399−>>> :kind! Length '[Char,String,Bool,Double]
400−Length '[Char,String,Bool,Double] :: Nat
401−= 4
402−-}
403−type family Length (xs :: [k]) :: Nat where
404− Length (x : xs) = 1 + Length xs
405− Length '[] = 0
406−
407485-- | A `SchemumType` is a user-defined type, either a `Table`,
408486-- `View` or `Typedef`.
409487data SchemumType
410488 = Table TableType
411489 | View RowType
412490 | Typedef PGType
491+ | Index IndexType
492+ | Function FunctionType
493+ | Operator OperatorType
494+ | UnsafeSchemum Symbol
495+
496+type FunctionType = ([NullityType], ReturnsType)
497+
498+data IndexType
499+ = Btree
500+ | Hash
501+ | Gist
502+ | Spgist
503+ | Gin
504+ | Brin
505+
506+data ReturnsType
507+ = Returns NullityType
508+ | ReturnsTable RowType
509+
510+data OperatorType
511+ = BinaryOp NullityType NullityType NullityType
512+ | LeftOp NullityType NullityType
513+ | RightOp NullityType NullityType
413514
414515{- | The schema of a database consists of a list of aliased,
415516user-defined `SchemumType`s.
squeal-postgresql/src/Squeal/PostgreSQL/Transaction.hs+76−44
@@ -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,68 +35,99 @@ module Squeal.PostgreSQL.Transaction
3435 , DeferrableMode (..)
3536 ) where
3637
37−import Generics.SOP
38−import UnliftIO (MonadUnliftIO, liftIO, mask, onException)
39−
40−import qualified Database.PostgreSQL.LibPQ as LibPQ
38+import UnliftIO
4139
4240import Squeal.PostgreSQL.Manipulation
4341import Squeal.PostgreSQL.Render
4442import Squeal.PostgreSQL.PQ
45−import Squeal.PostgreSQL.Schema
4643
47−-- | Run a schema invariant computation `transactionally`.
44+{- | Run a computation `transactionally`;
45+first `begin`,
46+then run the computation,
47+`onException` `rollback` and rethrow the exception,
48+otherwise `commit` and `return` the result.
49+-}
4850transactionally
4951 :: (MonadUnliftIO tx, MonadPQ schemas tx)
5052 => TransactionMode
5153 -> tx x -- ^ run inside a transaction
5254 -> tx x
5355transactionally mode tx = mask $ \restore -> do
54− _ <- begin mode
55− result <- restore tx `onException` rollback
56− _ <- commit
56+ manipulate_ $ begin mode
57+ result <- restore tx `onException` (manipulate_ rollback)
58+ manipulate_ commit
5759 return result
5860
59−-- | Run a schema invariant computation `transactionally_` in `defaultMode`.
61+-- | Run a computation `transactionally_`, in `defaultMode`.
6062transactionally_
6163 :: (MonadUnliftIO tx, MonadPQ schemas tx)
6264 => tx x -- ^ run inside a transaction
6365 -> tx x
6466transactionally_ = transactionally defaultMode
6567
66−-- | @BEGIN@ a transaction.
67−begin :: MonadPQ schemas tx => TransactionMode -> tx (K Result ('[] :: RowType))
68−begin mode = manipulate . UnsafeManipulation $
69− "BEGIN" <+> renderSQL mode <> ";"
68+{- |
69+`transactionallyRetry` a computation;
7070
71−-- | @COMMIT@ a schema invariant transaction.
72−commit :: MonadPQ schemas tx => tx (K Result ('[] :: RowType))
73−commit = manipulate $ UnsafeManipulation "COMMIT;"
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
74112
75−-- | @ROLLBACK@ a schema invariant transaction.
76−rollback :: MonadPQ schemas tx => tx (K Result ('[] :: RowType))
77−rollback = manipulate $ UnsafeManipulation "ROLLBACK;"
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
78119
79−-- | Run a schema changing computation `transactionallySchema`.
80−transactionallySchema
81− :: MonadUnliftIO io
82− => TransactionMode
83− -> PQ schemas0 schemas1 io x
84− -> PQ schemas0 schemas1 io x
85−transactionallySchema mode u = PQ $ \ conn -> mask $ \ restore -> do
86− _ <- liftIO . LibPQ.exec (unK conn) $
87− "BEGIN" <+> renderSQL mode <> ";"
88− x <- restore (unPQ u conn)
89− `onException` (liftIO (LibPQ.exec (unK conn) "ROLLBACK"))
90− _ <- liftIO $ LibPQ.exec (unK conn) "COMMIT"
91− return x
92−
93−-- | Run a schema changing computation `transactionallySchema_` in `defaultMode`.
94−transactionallySchema_
95− :: MonadUnliftIO io
96− => PQ schemas0 schemas1 io x
97− -> PQ schemas0 schemas1 io x
98−transactionallySchema_ = transactionallySchema defaultMode
120+-- | @BEGIN@ a transaction.
121+begin :: TransactionMode -> Manipulation_ schemas () ()
122+begin mode = UnsafeManipulation $ "BEGIN" <+> renderSQL mode
123+
124+-- | @COMMIT@ a transaction.
125+commit :: Manipulation_ schemas () ()
126+commit = UnsafeManipulation "COMMIT"
127+
128+-- | @ROLLBACK@ a transaction.
129+rollback :: Manipulation_ schemas () ()
130+rollback = UnsafeManipulation "ROLLBACK"
99131
100132-- | The available transaction characteristics are the transaction `IsolationLevel`,
101133-- the transaction `AccessMode` (`ReadWrite` or `ReadOnly`), and the `DeferrableMode`.
@@ -108,7 +140,7 @@ data TransactionMode = TransactionMode
108140-- | `TransactionMode` with a `Serializable` `IsolationLevel`,
109141-- `ReadWrite` `AccessMode` and `NotDeferrable` `DeferrableMode`.
110142defaultMode :: TransactionMode
111−defaultMode = TransactionMode Serializable ReadWrite NotDeferrable
143+defaultMode = TransactionMode ReadCommitted ReadWrite NotDeferrable
112144
113145-- | `TransactionMode` with a `Serializable` `IsolationLevel`,
114146-- `ReadOnly` `AccessMode` and `Deferrable` `DeferrableMode`.
squeal-postgresql/src/Squeal/PostgreSQL/Tutorial.hsdeleted−39
@@ -1,39 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Tutorail
3−Description: Squeal tutorial module
4−Copyright: (c) Eitan Chatav, 2017
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−== `P` records
9−
10−A `P` record is an ad-hoc, anonymous record constructed
11−as a tuple of `P`s, a datatype from `Generics.SOP.Record`, like so:
12−
13−>>> type Rec = (P ("foo" ::: Double), P ("bar" ::: Char))
14−
15−Let's see what the image of `Rec` is under the `RowPG` type family.
16−
17−>>> :kind! RowPG Rec
18−RowPG Rec :: [(Symbol, NullityType)]
19−= '[ '("foo", 'NotNull 'PGfloat8), "bar" ::: 'NotNull ('PGchar 1)]
20−
21−`P` records are ad-hoc, anonymous records so unlike Haskell records
22−you don't have to define them outside of their use site, for instance
23−in the row type parameter of a `Query_` type family.
24−
25−>>> :{
26−let
27− query :: Query_ schemas () (P ("foo" ::: Double))
28− query = values_ (1 `as` #foo)
29−in printSQL query
30−:}
31−SELECT * FROM (VALUES (1)) AS t ("foo")
32−
33−You can even mix `P` records with normal Haskell records, which is very
34−useful for creating entity types, Haskell records with associated ids.
35−
36−>>> data Row = Row {foo :: Double, bar :: Char} deriving (GHC.Generic)
37−-}
38−
39−module Squeal.PostgreSQL.Tutorial where
squeal-postgresql/test/Doc.hsnew file+6
@@ -0,0 +1,6 @@
1+module Main (main) where
2+
3+import Test.DocTest
4+
5+main :: IO ()
6+main = doctest [ "-isrc", "src" ]
squeal-postgresql/test/DocTest.hsdeleted−18
@@ -1,18 +0,0 @@
1−module Main (main) where
2−
3−import Test.DocTest
4−
5−main :: IO ()
6−main = doctest
7− [ "-isrc"
8− , "src/Squeal/PostgreSQL.hs"
9− , "src/Squeal/PostgreSQL/Binary.hs"
10− , "src/Squeal/PostgreSQL/Definition.hs"
11− , "src/Squeal/PostgreSQL/Manipulation.hs"
12− , "src/Squeal/PostgreSQL/Query.hs"
13− , "src/Squeal/PostgreSQL/Expression.hs"
14− , "src/Squeal/PostgreSQL/PQ.hs"
15− , "src/Squeal/PostgreSQL/Migration.hs"
16− , "src/Squeal/PostgreSQL/Transaction.hs"
17− , "src/Squeal/PostgreSQL/Pool.hs"
18− ]
squeal-postgresql/test/Property.hsnew file+166
@@ -0,0 +1,166 @@
1+{-# LANGUAGE
2+ DataKinds
3+ , GADTs
4+ , LambdaCase
5+ , OverloadedLabels
6+ , OverloadedStrings
7+ , TypeApplications
8+ , TypeOperators
9+#-}
10+
11+module Main (main) where
12+
13+import Control.Monad.Trans
14+import Data.ByteString (ByteString)
15+import Data.ByteString.Char8 (unpack)
16+import Data.Scientific (fromFloatDigits)
17+import Data.Fixed (Fixed(MkFixed), Micro, Pico)
18+import Data.String (IsString(fromString))
19+import Data.Time
20+import Squeal.PostgreSQL hiding (check, defaultMain, Group)
21+import Hedgehog hiding (Range)
22+import qualified Hedgehog.Gen as Gen
23+import qualified Hedgehog.Main as Main
24+import qualified Hedgehog.Range as Range
25+
26+main :: IO ()
27+main = Main.defaultMain [checkSequential roundtrips]
28+
29+roundtrips :: Group
30+roundtrips = Group "roundtrips"
31+ [ roundtrip int2 genInt16
32+ , roundtrip int4 genInt32
33+ , roundtrip int8 genInt64
34+ , roundtrip bool Gen.bool
35+ , roundtrip numeric genScientific
36+ , roundtrip float4 genFloat
37+ , roundtrip float8 genDouble
38+ , roundtripOn normalizeTimeOfDay time genTimeOfDay
39+ -- , roundtrip timetz genTimeWithZone normalizeTimeWithZone
40+ , roundtripOn normalizeLocalTime timestamp genLocalTime
41+ , roundtrip timestamptz genUTCTime
42+ , roundtrip date genDay
43+ , roundtrip interval genDiffTime
44+ , roundtripOn normalizeIntRange int4range (genRange genInt32)
45+ , roundtripOn normalizeIntRange int8range (genRange genInt64)
46+ , roundtrip numrange (genRange genScientific)
47+ , roundtripOn (fmap normalizeLocalTime) tsrange (genRange genLocalTime)
48+ , roundtrip tstzrange (genRange genUTCTime)
49+ , roundtripOn normalizeIntRange daterange (genRange genDay)
50+ ]
51+ where
52+ genInt16 = Gen.int16 Range.exponentialBounded
53+ genInt32 = Gen.int32 Range.exponentialBounded
54+ genInt64 = Gen.int64 Range.exponentialBounded
55+ genScientific = fromFloatDigits <$> genFloat
56+ genPosFloat = Gen.float
57+ (Range.exponentialFloatFrom 1 minPosFloat maxPosFloat)
58+ genFloat = Gen.prune $ Gen.choice
59+ [ genPosFloat
60+ , negate <$> genPosFloat
61+ , Gen.element [0,1/0] ]
62+ genPosDouble = Gen.double
63+ (Range.exponentialFloatFrom 1 minPosFloat maxPosFloat)
64+ genDouble = Gen.prune $ Gen.choice
65+ [ genPosDouble
66+ , negate <$> genPosDouble
67+ , Gen.element [0,1/0] ]
68+ genRange gen = do
69+ lb <- gen
70+ ub <- Gen.filter (lb <) gen
71+ Gen.element
72+ [ Empty, singleton lb, whole
73+ , lb <=..<= ub , lb <=..< ub, lb <..<= ub, lb <..< ub
74+ , atLeast lb, moreThan lb, atMost ub, lessThan ub ]
75+ genDay = do
76+ y <- toInteger <$> Gen.int (Range.constant 2000 2019)
77+ m <- Gen.int (Range.constant 1 12)
78+ d <- Gen.int (Range.constant 1 28)
79+ return $ fromGregorian y m d
80+ genDiffTime = secondsToDiffTime . toInteger <$>
81+ Gen.int (Range.constant 0 86401)
82+ genUTCTime = UTCTime <$> genDay <*> genDiffTime
83+ genTimeOfDay = do
84+ h <- Gen.int (Range.constant 0 23)
85+ m <- Gen.int (Range.constant 0 59)
86+ s <- MkFixed . toInteger <$> Gen.int (Range.constant 0 59)
87+ return $ TimeOfDay h m s
88+ genLocalTime = LocalTime <$> genDay <*> genTimeOfDay
89+ -- genTimeZone = Gen.element $ map (read @TimeZone)
90+ -- [ "UTC", "UT", "GMT", "EST", "EDT", "CST"
91+ -- , "CDT", "MST", "MDT", "PST", "PDT" ]
92+ -- genTimeWithZone = (,) <$> genTimeOfDay <*> genTimeZone
93+
94+roundtrip
95+ :: (OidOf ty, ToParam x ty, FromValue ty x, Show x, Eq x)
96+ => TypeExpression schemas ('NotNull ty)
97+ -> Gen x
98+ -> (PropertyName, Property)
99+roundtrip = roundtripOn id
100+
101+roundtripOn
102+ :: (OidOf ty, ToParam x ty, FromValue ty x, Show x, Eq x)
103+ => (x -> x)
104+ -> TypeExpression schemas ('NotNull ty)
105+ -> Gen x
106+ -> (PropertyName, Property)
107+roundtripOn norm ty gen = propertyWithName $ do
108+ x <- forAll gen
109+ Just (Only y) <- lift . withConnection connectionString $
110+ firstRow =<< runQueryParams
111+ (values_ (parameter @1 ty `as` #fromOnly)) (Only x)
112+ norm x === y
113+ where
114+ propertyWithName prop =
115+ (fromString (unpack (renderSQL ty)), property prop)
116+
117+maxPosFloat :: RealFloat a => a
118+maxPosFloat = x
119+ where
120+ n = floatDigits x
121+ b = floatRadix x
122+ (_, u) = floatRange x
123+ x = encodeFloat (b^n - 1) (u - n)
124+
125+minPosFloat :: RealFloat a => a
126+minPosFloat = x
127+ where
128+ n = floatDigits x
129+ b = floatRadix x
130+ (l, _) = floatRange x
131+ x = encodeFloat (b^n - 1) (l - n - 1)
132+
133+connectionString :: ByteString
134+connectionString = "host=localhost port=5432 dbname=exampledb"
135+
136+normalizeIntRange :: (Enum int, Ord int) => Range int -> Range int
137+normalizeIntRange = \case
138+ Empty -> Empty
139+ NonEmpty l u ->
140+ let
141+ l' = normalizeL l
142+ u' = normalizeU u
143+ in if emptyNormalized l' u' then Empty else NonEmpty l' u'
144+ where
145+ normalizeL = \case
146+ Open l -> Closed (succ l)
147+ normalized -> normalized
148+ normalizeU = \case
149+ Closed u -> Open (succ u)
150+ normalized -> normalized
151+ emptyNormalized (Closed l) (Open u) = l >= u
152+ emptyNormalized _ _ = False
153+
154+normalizeTimeOfDay :: TimeOfDay -> TimeOfDay
155+normalizeTimeOfDay (TimeOfDay h m s) = TimeOfDay h m
156+ . fromRational @Pico
157+ . toRational @Micro
158+ . fromRational @Micro
159+ . toRational @Pico
160+ $ s
161+
162+normalizeLocalTime :: LocalTime -> LocalTime
163+normalizeLocalTime (LocalTime d t) = LocalTime d (normalizeTimeOfDay t)
164+
165+-- normalizeTimeWithZone :: (TimeOfDay, TimeZone) -> (TimeOfDay, TimeZone)
166+-- normalizeTimeWithZone (t, z) = (normalizeTimeOfDay t, z)
squeal-postgresql/test/Spec.hsnew file+136
@@ -0,0 +1,136 @@
1+{-# LANGUAGE
2+ DataKinds
3+ , DeriveAnyClass
4+ , DeriveGeneric
5+ , DerivingStrategies
6+ , DuplicateRecordFields
7+ , FlexibleContexts
8+ , OverloadedLabels
9+ , OverloadedLists
10+ , OverloadedStrings
11+ , TypeApplications
12+ , TypeFamilies
13+ , TypeInType
14+ , TypeOperators
15+#-}
16+
17+module Main (main) where
18+
19+import Control.Concurrent.Async (replicateConcurrently)
20+import Data.ByteString (ByteString)
21+import Data.Int (Int32)
22+import Data.Text (Text)
23+import Test.Hspec
24+
25+import qualified Generics.SOP as SOP
26+import qualified GHC.Generics as GHC
27+
28+import Squeal.PostgreSQL
29+
30+main :: IO ()
31+main = hspec spec
32+
33+type Schemas = Public
34+ '[ "users" ::: 'Table (
35+ '[ "pk_users" ::: 'PrimaryKey '["id"]
36+ , "unique_names" ::: 'Unique '["name"]
37+ ] :=>
38+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
39+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext ] ) ]
40+
41+data User = User
42+ { userName :: Text
43+ } deriving stock (Eq, Show, GHC.Generic)
44+ deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
45+
46+insertUser :: Manipulation_ Schemas User ()
47+insertUser = insertInto_ #users
48+ (Values_ (Default `as` #id :* Set (param @1) `as` #name))
49+
50+setup :: Definition (Public '[]) Schemas
51+setup =
52+ createTable #users
53+ ( serial `as` #id :*
54+ notNullable text `as` #name )
55+ ( primaryKey #id `as` #pk_users :*
56+ unique #name `as` #unique_names )
57+
58+teardown :: Definition Schemas (Public '[])
59+teardown = dropTable #users
60+
61+silence :: MonadPQ schemas pq => pq ()
62+silence = manipulate_ $
63+ UnsafeManipulation "SET client_min_messages TO WARNING;"
64+
65+setupDB :: IO ()
66+setupDB = withConnection connectionString $
67+ silence & pqThen (define setup)
68+
69+dropDB :: IO ()
70+dropDB = withConnection connectionString $
71+ silence & pqThen (define teardown)
72+
73+connectionString :: ByteString
74+connectionString = "host=localhost port=5432 dbname=exampledb"
75+
76+spec :: Spec
77+spec = before_ setupDB . after_ dropDB $ do
78+
79+ describe "Exceptions" $ do
80+
81+ let
82+ testUser = User "TestUser"
83+ newUser = manipulateParams_ insertUser
84+ insertUserTwice = newUser testUser >> newUser testUser
85+ err23505 = PQException $ PQState FatalError (Just "23505")
86+ (Just "ERROR: duplicate key value violates unique constraint \"unique_names\"\nDETAIL: Key (name)=(TestUser) already exists.\n")
87+
88+ it "should be thrown for constraint violation" $
89+ withConnection connectionString insertUserTwice
90+ `shouldThrow` (== err23505)
91+
92+ it "should be rethrown for constraint violation in a transaction" $
93+ withConnection connectionString (transactionally_ insertUserTwice)
94+ `shouldThrow` (== err23505)
95+
96+ describe "Pools" $
97+
98+ it "should manage concurrent transactions" $ do
99+ pool <- createConnectionPool
100+ "host=localhost port=5432 dbname=exampledb" 1 0.5 10
101+ let
102+ query :: Query_ (Public '[]) () (Only Char)
103+ query = values_ (literal 'a' `as` #fromOnly)
104+ session = usingConnectionPool pool . transactionally_ $ do
105+ result <- runQuery query
106+ Just (Only chr) <- firstRow result
107+ return chr
108+ chrs <- replicateConcurrently 10 session
109+ chrs `shouldSatisfy` all (== 'a')
110+
111+ describe "Ranges" $
112+
113+ it "should correctly decode ranges" $ do
114+
115+ rangesOut <- withConnection connectionString $ do
116+ let
117+ query :: Query_ (Public '[]) () (Only (Range Int32))
118+ query = values
119+ ( range int4range (atLeast 3) `as` #fromOnly )
120+ [ range int4range (3 <=..< 5) `as` #fromOnly
121+ , range int4range Empty `as` #fromOnly
122+ , range int4range whole `as` #fromOnly ]
123+ getRows =<< runQuery query
124+ (fromOnly <$> rangesOut :: [Range Int32]) `shouldBe`
125+ [ atLeast 3, 3 <=..< 5, Empty, whole ]
126+
127+ describe "Parameters" $ do
128+
129+ it "should run queries that don't reference all their parameters" $ do
130+
131+ out <- withConnection connectionString $ do
132+ let
133+ query :: Query_ (Public '[]) (Char,Int32) (Only Int32)
134+ query = values_ (param @2 `as` #fromOnly)
135+ firstRow =<< runQueryParams query ('a', 3 :: Int32)
136+ (fromOnly <$> out :: Maybe Int32) `shouldBe` Just 3
squeal-postgresql/test/Specs/ExceptionHandling.hsdeleted−126
@@ -1,126 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE DeriveGeneric #-}
3−{-# LANGUAGE DuplicateRecordFields #-}
4−{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE OverloadedLabels #-}
6−{-# LANGUAGE OverloadedLists #-}
7−{-# LANGUAGE OverloadedStrings #-}
8−{-# LANGUAGE TypeApplications #-}
9−{-# LANGUAGE TypeFamilies #-}
10−{-# LANGUAGE TypeInType #-}
11−{-# LANGUAGE TypeOperators #-}
12−module ExceptionHandling
13− ( specs
14− , User (..)
15− )
16−where
17−
18−import Control.Monad (void)
19−import Control.Monad.IO.Class (MonadIO (..))
20−import qualified Data.ByteString.Char8 as Char8
21−import Data.Int (Int16)
22−import Data.Text (Text)
23−import Data.Vector (Vector)
24−import qualified Generics.SOP as SOP
25−import qualified GHC.Generics as GHC
26−import Squeal.PostgreSQL
27−import Squeal.PostgreSQL.Migration
28−import Test.Hspec
29−
30−type Schema =
31− '[ "users" ::: 'Table (
32− '[ "pk_users" ::: 'PrimaryKey '["id"]
33− , "unique_names" ::: 'Unique '["name"]
34− ] :=>
35− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
36− , "name" ::: 'NoDef :=> 'NotNull 'PGtext
37− , "vec" ::: 'NoDef :=> 'NotNull ('PGvararray ('Null 'PGint2))
38− ])
39− , "emails" ::: 'Table (
40− '[ "pk_emails" ::: 'PrimaryKey '["id"]
41− , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
42− ] :=>
43− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
44− , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
45− , "email" ::: 'NoDef :=> 'Null 'PGtext
46− ])
47− ]
48−
49−type Schemas = Public Schema
50−
51−data User =
52− User { userName :: Text
53− , userEmail :: Maybe Text
54− , userVec :: VarArray (Vector (Maybe Int16)) }
55− deriving (Show, GHC.Generic)
56−instance SOP.Generic User
57−instance SOP.HasDatatypeInfo User
58−
59−insertUser :: Manipulation '[] Schemas '[ 'NotNull 'PGtext, 'NotNull ('PGvararray ('Null 'PGint2))]
60− '[ "fromOnly" ::: 'NotNull 'PGint4 ]
61−insertUser = insertInto #users
62− (Values_ (defaultAs #id :* param @1 `as` #name :* param @2 `as` #vec))
63− OnConflictDoRaise (Returning (#id `as` #fromOnly))
64−
65−setup :: Definition (Public '[]) Schemas
66−setup =
67− createTable #users
68− ( serial `as` #id :*
69− (text & notNullable) `as` #name :*
70− (vararray int2 & notNullable) `as` #vec )
71− ( primaryKey #id `as` #pk_users
72− :* unique #name `as` #unique_names )
73− >>>
74− createTable #emails
75− ( serial `as` #id :*
76− (int & notNullable) `as` #user_id :*
77− (text & nullable) `as` #email )
78− ( primaryKey #id `as` #pk_emails :*
79− foreignKey #user_id #users #id
80− OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
81−
82−teardown :: Definition Schemas (Public '[])
83−teardown = dropTable #emails >>> dropTable #users
84−
85−migration :: Migration Definition (Public '[]) Schemas
86−migration = Migration { name = "test"
87− , up = setup
88− , down = teardown }
89−
90−setupDB :: IO ()
91−setupDB = void . withConnection connectionString $
92− manipulate (UnsafeManipulation "SET client_min_messages TO WARNING;")
93− & pqThen (migrateUp (single migration))
94−
95−dropDB :: IO ()
96−dropDB = void . withConnection connectionString $
97− manipulate (UnsafeManipulation "SET client_min_messages TO WARNING;")
98− & pqThen (migrateDown (single migration))
99−
100−connectionString :: Char8.ByteString
101−connectionString = "host=localhost port=5432 dbname=exampledb"
102−
103−testUser :: User
104−testUser = User "TestUser" Nothing (VarArray [])
105−
106−newUser :: (MonadIO m, MonadPQ Schemas m) => User -> m ()
107−newUser u = void $ manipulateParams insertUser (userName u, userVec u)
108−
109−insertUserTwice :: (MonadIO m, MonadPQ Schemas m) => m ()
110−insertUserTwice = newUser testUser >> newUser testUser
111−
112−specs :: SpecWith ()
113−specs = before_ setupDB $ after_ dropDB $
114− describe "Exceptions" $ do
115−
116− let
117− dupKeyErr = PQException FatalError (Just "23505")
118− (Just "ERROR: duplicate key value violates unique constraint \"unique_names\"\nDETAIL: Key (name)=(TestUser) already exists.\n")
119−
120− it "should be thrown for unique constraint violation in a manipulation" $
121− withConnection connectionString insertUserTwice
122− `shouldThrow` (== dupKeyErr)
123−
124− it "should be rethrown for unique constraint violation in a manipulation by a transaction" $
125− withConnection connectionString (transactionally_ insertUserTwice)
126− `shouldThrow` (== dupKeyErr)
squeal-postgresql/test/Specs/Specs.hsdeleted−7
@@ -1,7 +0,0 @@
1−module Specs where
2−
3−import Test.Hspec
4−import qualified ExceptionHandling
5−
6−main :: IO ()
7−main = hspec ExceptionHandling.specs
stack.yaml+3−1
@@ -1,6 +1,8 @@
1−resolver: lts-13.8
1+resolver: nightly-2019-07-14
22packages:
33- squeal-postgresql
44
55extra-deps:
66- unliftio-pool-0.2.1.0
7+- github: morphismtech/free-categories
8+ commit: c0e555fbefb5c21619e532264c4dfeac556d0630