git.iko.soy/squeal
on ee65456 help sign in
ddc9847
swap
0 ahead, 845 behind
.circleci/config.ymldeleted−24
since splitsnapshots
unifiedsplit
@@ -1,24 +0,0 @@
1−version: 2
2−jobs:
3− build:
4− docker:
5− - image: haskell:8.6.5
6− - image: circleci/postgres:latest
7− environment:
8− POSTGRES_USER: root
9− POSTGRES_DB: exampledb
10− steps:
11− - checkout
12− - restore_cache:
13− keys:
14− - dependency-cache
15− - run: apt-get update && apt-get install -y libpq-dev xz-utils make
16− - run: stack upgrade && stack update
17− - run: stack build --fast
18− - run: stack test
19− - run: stack haddock
20− - save_cache:
21− key: dependency-cache
22− paths:
23− - ".stack-work"
24− - "/root/.stack/"
.gitignore−1
@@ -17,4 +17,3 @@ cabal.sandbox.config
17*.eventlog
17*.eventlog
18.stack-work/
18.stack-work/
19cabal.project.local
19cabal.project.local
20−.DS_Store
README.md+2−275
@@ -2,279 +2,6 @@
2
2
3![squeal-icon](http://www.emoticonswallpapers.com/emotion/cute-big-pig/cute-pig-smiley-046.gif)
3![squeal-icon](http://www.emoticonswallpapers.com/emotion/cute-big-pig/cute-pig-smiley-046.gif)
4
4
5−[![CircleCI](https://circleci.com/gh/echatav/squeal.svg?style=svg&circle-token=a699a654ef50db2c3744fb039cf2087c484d1226)](https://circleci.com/gh/morphismtech/squeal)
5+[![CircleCI](https://circleci.com/gh/echatav/squeal.svg?style=svg&circle-token=a699a654ef50db2c3744fb039cf2087c484d1226)](https://circleci.com/gh/echatav/squeal)
6
6
7−[Github](https://github.com/morphismtech/squeal)
7+Main repository for the squeal database library.
8−
9−[Hackage](https://hackage.haskell.org/package/squeal-postgresql)
10−
11−[Stackage](https://www.stackage.org/package/squeal-postgresql)
12−
13−[YouTube](https://www.youtube.com/watch?v=rWfEQfAaNc4)
14−
15−## introduction
16−
17−Squeal is a deep embedding of SQL into Haskell. By "deep embedding", I am abusing the
18−term somewhat. What I mean is that Squeal embeds both SQL terms and SQL types
19−into Haskell at the term and type levels respectively. This leads to a very high level
20−of type-safety in Squeal.
21−
22−Squeal embeds not just the structured query language of SQL but also the
23−data manipulation language and the data definition language; that's `SELECT`,
24−`INSERT`, `UPDATE`, `DELETE`, `WITH`, `CREATE`, `DROP`, and `ALTER` commands.
25−
26−Squeal expressions closely match their corresponding SQL expressions so that
27−the SQL they actually generate is completely predictable. They are also highly
28−composable and cover a large portion of SQL.
29−
30−## features
31−
32−* generic encoding of Haskell tuples and records into query parameters
33− and generic decoding of query results into Haskell records
34− using [`generics-sop`](https://hackage.haskell.org/package/generics-sop)
35−* access to SQL alias system using the `OverloadedLabels` extension
36−* type-safe `NULL` and `DEFAULT`
37−* type-safe SQL constraints `CHECK`, `UNIQUE`, `PRIMARY KEY` and `FOREIGN KEY`
38−* type-safe aggregation
39−* escape hatches for writing raw SQL
40−* [`mtl`](https://hackage.haskell.org/package/mtl) compatible monad transformer
41− for executing as well as preparing queries and manipulations
42− and [Atkey](https://bentnib.org/paramnotions-jfp.pdf) indexed monad transformer
43− for executing definitions.
44−* linear, invertible migrations
45−* connection pools
46−* transactions
47−* views
48−* array, composite and enumerated types
49−* json functions and operations
50−* multischema support
51−* correlated subqueries
52−* window functions
53−* text search
54−
55−## installation
56−
57−`stack install squeal-postgresql`
58−
59−## testing
60−
61−Start postgres on localhost port `5432` and create a database named `exampledb`.
62−
63−`stack test`
64−
65−## contributing
66−
67−We welcome contributors.
68−Please make pull requests on the `dev` branch instead of `master`.
69−The `Issues` page is a good place to communicate.
70−
71−## usage
72−
73−Let's see an example!
74−
75−First, we need some language extensions because Squeal uses modern GHC
76−features.
77−
78−```Haskell
79−>>> :set -XDataKinds -XDeriveGeneric -XOverloadedLabels -XFlexibleContexts
80−>>> :set -XOverloadedStrings -XTypeApplications -XTypeOperators -XGADTs
81−```
82−
83−We'll need some imports.
84−
85−```Haskell
86−>>> import Control.Monad.IO.Class (liftIO)
87−>>> import Data.Int (Int32)
88−>>> import Data.Text (Text)
89−>>> import Squeal.PostgreSQL
90−```
91−
92−We'll use generics to easily convert between Haskell and PostgreSQL values.
93−
94−```Haskell
95−>>> import qualified Generics.SOP as SOP
96−>>> import qualified GHC.Generics as GHC
97−```
98−
99−The first step is to define the schema of our database. This is where
100−we use `DataKinds` and `TypeOperators`.
101−
102−```Haskell
103−>>> :{
104−type UsersColumns =
105− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
106− , "name" ::: 'NoDef :=> 'NotNull 'PGtext ]
107−type UsersConstraints = '[ "pk_users" ::: 'PrimaryKey '["id"] ]
108−type EmailsColumns =
109− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
110− , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
111− , "email" ::: 'NoDef :=> 'Null 'PGtext ]
112−type EmailsConstraints =
113− '[ "pk_emails" ::: 'PrimaryKey '["id"]
114− , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"] ]
115−type Schema =
116− '[ "users" ::: 'Table (UsersConstraints :=> UsersColumns)
117− , "emails" ::: 'Table (EmailsConstraints :=> EmailsColumns) ]
118−type Schemas = Public Schema
119−:}
120−```
121−
122−Notice the use of type operators.
123−
124−`:::` is used to pair an alias `Symbol` with a `SchemumType`,
125−a `TableConstraint` or a `ColumnType`. It is intended to connote Haskell's `::`
126−operator.
127−
128−`:=>` is used to pair `TableConstraints` with a `ColumnsType`,
129−yielding a `TableType`, or to pair a `ColumnConstraint` with a `NullityType`,
130−yielding a `ColumnType`. It is intended to connote Haskell's `=>` operator
131−
132−Next, we'll write `Definition`s to set up and tear down the schema. In
133−Squeal, a `Definition` like `createTable`, `alterTable` or `dropTable`
134−has two type parameters, corresponding to the schema
135−before being run and the schema after. We can compose definitions using `>>>`.
136−Here and in the rest of our commands we make use of overloaded
137−labels to refer to named tables and columns in our schema.
138−
139−```Haskell
140−>>> :{
141−let
142− setup :: Definition (Public '[]) Schemas
143− setup =
144− createTable #users
145− ( serial `as` #id :*
146− (text & notNullable) `as` #name )
147− ( primaryKey #id `as` #pk_users ) >>>
148− createTable #emails
149− ( serial `as` #id :*
150− (int & notNullable) `as` #user_id :*
151− (text & nullable) `as` #email )
152− ( primaryKey #id `as` #pk_emails :*
153− foreignKey #user_id #users #id
154− OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
155−:}
156−```
157−
158−We can easily see the generated SQL is unsurprising looking.
159−
160−```Haskell
161−>>> printSQL setup
162−CREATE TABLE "users" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_users" PRIMARY KEY ("id"));
163−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);
164−```
165−
166−Notice that `setup` starts with an empty schema `'[]` and produces `Schema`.
167−In our `createTable` commands we included `TableConstraint`s to define
168−primary and foreign keys, making them somewhat complex. Our `teardown`
169−`Definition` is simpler.
170−
171−```Haskell
172−>>> :{
173−let
174− teardown :: Definition Schemas (Public '[])
175− teardown = dropTable #emails >>> dropTable #users
176−:}
177−
178−>>> printSQL teardown
179−DROP TABLE "emails";
180−DROP TABLE "users";
181−```
182−
183−We'll need a Haskell type for `User`s. We give the type `SOP.Generic` and
184−`SOP.HasDatatypeInfo` instances so that we can encode and decode `User`s.
185−
186−```Haskell
187−>>> data User = User { userName :: Text, userEmail :: Maybe Text } deriving (Show, GHC.Generic)
188−>>> instance SOP.Generic User
189−>>> instance SOP.HasDatatypeInfo User
190−```
191−
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
196−we insert into the users table, we will need a parameter for the `name`
197−field but not for the `id` field. Since it's serial, we can use a default
198−value. However, since the emails table refers to the users table, we will
199−need to retrieve the user id that the insert generates and insert it into
200−the emails table. We can do this in a single `Manipulation_` by using a
201−`with` statement.
202−
203−```Haskell
204−>>> :{
205−let
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))
215−:}
216−
217−>>> printSQL insertUser
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"
219−```
220−
221−Next we write a `Query_` to retrieve users from the database. We're not
222−interested in the ids here, just the usernames and email addresses. We
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.
225−
226−```Haskell
227−>>> :{
228−let
229− getUsers :: Query_ Schemas () User
230− getUsers = select_
231− (#u ! #name `as` #userName :* #e ! #email `as` #userEmail)
232− ( from (table (#users `as` #u)
233− & innerJoin (table (#emails `as` #e))
234− (#u ! #id .== #e ! #user_id)) )
235−:}
236−
237−>>> printSQL getUsers
238−SELECT "u"."name" AS "userName", "e"."email" AS "userEmail" FROM "users" AS "u" INNER JOIN "emails" AS "e" ON ("u"."id" = "e"."user_id")
239−```
240−
241−Let's create some users to add to the database.
242−
243−```Haskell
244−>>> :{
245−let
246− users :: [User]
247− users =
248− [ User "Alice" (Just "alice@gmail.com")
249− , User "Bob" Nothing
250− , User "Carole" (Just "carole@hotmail.com")
251− ]
252−:}
253−```
254−
255−Now we can put together all the pieces into a program. The program
256−connects to the database, sets up the schema, inserts the user data
257−(using prepared statements as an optimization), queries the user
258−data and prints it out and finally closes the connection. We can thread
259−the changing schema information through by using the indexed `PQ` monad
260−transformer and when the schema doesn't change we can use `Monad` and
261−`MonadPQ` functionality.
262−
263−```Haskell
264−>>> :{
265−let
266− session :: PQ Schemas Schemas IO ()
267− session = do
268− _ <- traversePrepared_ insertUser users
269− usersResult <- runQuery getUsers
270− usersRows <- getRows usersResult
271− liftIO $ print (usersRows :: [User])
272−in
273− withConnection "host=localhost port=5432 dbname=exampledb" $
274− define setup
275− & pqThen session
276− & pqThen (define teardown)
277−:}
278−[User {userName = "Alice", userEmail = Just "alice@gmail.com"},User {userName = "Bob", userEmail = Nothing},User {userName = "Carole", userEmail = Just "carole@hotmail.com"}]
279−-}
280−```
RELEASE NOTES.mddeleted−1217
@@ -1,1217 +0,0 @@
1−## RELEASE NOTES
2−
3−### Version 0.5
4−
5−Version 0.5 makes a number of large changes and additions to Squeal.
6−I want to thank folks who contributed issues and pull requests;
7−Raveline, rimmington, ilyakooo0, chshersh, reygoch, and more.
8−
9−**Multi-schema support**
10−
11−Previous versions of Squeal only supported definitions in the "public"
12−schema. Squeal 0.5 adds support for multiple schemas with the new kind
13−
14−```Haskell
15−type SchemasType = [(Symbol,SchemaType)]
16−```
17−
18−In order to upgrade your queries, manipulations and definitions from
19−Squeal 0.4, you will have to apply the `Public` type family, which indicates
20−that your only schema is the "public" schema.
21−
22−```Haskell
23−-- Squeal 0.4
24−setup :: Definition '[] Schema
25−
26−-- Squeal 0.5
27−setup :: Definition (Public '[]) (Public Schema)
28−```
29−
30−You can create non-public schemas using `createSchema` and inversely
31−remove them using `dropSchema`. There is also an idempotent
32−`createSchemaIfNotExists`.
33−
34−In order to handle aliases which may refer to non-public schemas, Squeal 0.5
35−introduces `QualifiedAlias`es. A `QualifiedAlias` can be referred to using
36−the `(!)` operator from the `IsQualified` typeclass; but if you want to refer
37−to an alias from the "public" schema, you can continue to use a single
38−overloaded label, no need to write `#public ! #tab`, just write `#tab`.
39−
40−**Top-level statements**
41−
42−As a consequence of multi-schema support, common table expressions that
43−a `Query` or `Manipulation` may refer to had to be broken into a new parameter.
44−Additionally, `Query` gained another new parameter for its outer scope which
45−will be discussed in the next section.
46−
47−To simplify type signatures that you have to write for top-level queries
48−and manipulations, Squeal 0.5 introduces the `Query_` and `Manipulation_`
49−type families.
50−
51−```
52−type family Query_
53− (schemas :: SchemasType)
54− (parameters :: Type)
55− (row :: Type) where
56− Query_ schemas params row =
57− Query '[] '[] schemas (TuplePG params) (RowPG row)
58−```
59−
60−As you see, a top-level `Query_` has no outer scope and no common
61−table expressions in scope, they are empty `'[]`. Moreover,
62−its parameters and row parameters are now `Type`s, which are
63−converted to corresponding Postgres types using the `TuplePG`
64−and `RowPG` type families. This means you can write the type signatures
65−for your top-level statements using the Haskell types that you
66−intend to input and retrieve when running the statements. Similar
67−to `Query_`, there is a `Manipulation_` type, the only difference
68−being that a general `Manipulation` doesn't have an outer scope,
69−only a scope for common table expressions.
70−
71−**Subquery expressions**
72−
73−Previous versions of Squeal offered subquery expression support
74−but there were issues. The common use case of using the `IN` operator
75−from SQL was overly complex. There was a proliferation of subquery
76−functions to handle different comparison operators, each with two versions
77−for comparing `ALL` or `ANY` of the query rows. And, most confoundedly,
78−there was no way to support the `EXISTS` subquery because the "outer scope"
79−for a query was not available.
80−
81−Squeal adds an outer scope to the `Query` type.
82−
83−```Haskell
84−newtype Query
85− (outer :: FromType)
86− (commons :: FromType)
87− (schemas :: SchemasType)
88− (params :: [NullityType])
89− (row :: RowType)
90− = UnsafeQuery { renderQuery :: ByteString }
91−```
92−
93−This enables a well-typed `exists` function.
94−
95−```Haskell
96−exists
97− :: Query (Join outer from) commons schemas params row
98− -> Condition outer commons grp schemas params from
99−```
100−
101−The `in_` and `notIn` functions were simplified to handle the most
102−common use case of comparing to a list of values.
103−
104−```Haskell
105−in_
106− :: Expression outer commons grp schemas params from ty -- ^ expression
107− -> [Expression outer commons grp schemas params from ty]
108− -> Condition outer commons grp schemas params from
109−```
110−
111−Finally, general subquery comparisons were abstracted to work with
112−any comparison operators, using the `Operator` type which will be discussed in
113−the next section.
114−
115−```Haskell
116−subAll
117− :: Expression outer commons grp schemas params from ty1
118− -> Operator ty1 ty2 ('Null 'PGbool)
119− -> Query (Join outer from) commons schemas params '[col ::: ty2]
120− -> Condition outer commons grp schemas params from
121−
122−subAny
123− :: Expression outer commons grp schemas params from ty1
124− -> Operator ty1 ty2 ('Null 'PGbool)
125− -> Query (Join outer from) commons schemas params '[col ::: ty2]
126− -> Condition outer commons grp schemas params from
127−```
128−
129−**Expression RankNTypes**
130−
131−Squeal 0.5 introduces RankNType type synonyms for common expression patterns.
132−The simplest example is the `Expr` type, a type for "closed" expressions
133−that cannot reference any aliases or parameters.
134−
135−```Haskell
136−type Expr x
137− = forall outer commons grp schemas params from
138− . Expression outer commons grp schemas params from x
139−```
140−
141−There is also a function type `(-->)`, which is a subtype of the usual Haskell function
142−type `(->)`.
143−
144−```Haskell
145−type (-->) x y
146− = forall outer commons grp schemas params from
147− . Expression outer commons grp schemas params from x
148− -> Expression outer commons grp schemas params from y
149−```
150−
151−We saw in the subquery section that there is an `Operator` type.
152−
153−```Haskell
154−type Operator x1 x2 y
155− = forall outer commons grp schemas params from
156− . Expression outer commons grp schemas params from x1
157− -> Expression outer commons grp schemas params from x2
158− -> Expression outer commons grp schemas params from y
159−```
160−
161−There are also types `FunctionN` and `FunctionVar` for n-ary functions
162−and variadic functions.
163−
164−```
165−type FunctionN xs y
166− = forall outer commons grp schemas params from
167− . NP (Expression outer commons grp schemas params from) xs
168− -> Expression outer commons grp schemas params from y
169−```
170−
171−An n-ary function takes an `NP` list of `Expression`s as its argument.
172−Squeal 0.5 adds a helpful operator `(*:)`, to help scrap your `Nil`s.
173−You can construct an `NP` list now by using the operator `(:*)`,
174−until your last element, using `(*:)` there. For instance, the function
175−`atan2_` takes two arguments, `atan2_ (pi *: 2)`.
176−
177−**Selections**
178−
179−Previously, Squeal provided a couple versions of `SELECT` depending
180−on whether you wanted to select all columns of a unique table
181−in the from clause, i.e. `*`, all columns of a particular table
182−in the from clause, i.e. `.*`, or a list of columns from the from clause.
183−
184−Squeal 0.5 refactors this pattern into a `Selection` GADT type, allowing
185−for abstraction and combinations that were not possible before.
186−
187−```Haskell
188−data Selection outer commons grp schemas params from row where
189− Star
190− :: HasUnique tab from row
191− => Selection outer commons 'Ungrouped schemas params from row
192− DotStar
193− :: Has tab from row
194− => Alias tab
195− -> Selection outer commons 'Ungrouped schemas params from row
196− List
197− :: SListI row
198− => NP (Aliased (Expression outer commons grp schemas params from)) row
199− -> Selection outer commons grp schemas params from row
200− Over
201− :: SListI row
202− => NP (Aliased (WindowFunction outer commons grp schemas params from)) row
203− -> WindowDefinition outer commons grp schemas params from
204− -> Selection outer commons grp schemas params from row
205− Also
206− :: Selection outer commons grp schemas params from right
207− -> Selection outer commons grp schemas params from left
208− -> Selection outer commons grp schemas params from (Join left right)
209−```
210−
211−In addition to the `Star`, `DotStar` and `List` constructors, there is an
212−`Also` constructor combinator, which enables users to combine `Selection`s.
213−Additionally, there is an `Over` constructor that is used to enable
214−window functions, described in the next section.
215−
216−To upgrade from Squeal 0.4, you will replace `selectStar` with `select Star`,
217−replace `selectDotStar #tab` with `select (DotStar #tab)`. The `List`
218−selection is such a common use case that there is a function `select_` which
219−automatically applies it, so to upgrade from Squeal 0.4, replace `select`
220−with `select_`. There are also independent `selectDistinct` and `selectDistinct_`
221−functions to filter out duplicate rows.
222−
223−**Query clauses**
224−
225−Previously, Squeal provided a couple versions of `INSERT` depending
226−on whether you wanted to insert `VALUES` or a query.
227−
228−Squeal 0.5 refactors this pattern into a `QueryClause` GADT.
229−
230−```
231−-- Squeal 0.4
232−insertRow_ #tab (Set 2 `as` #col1 :* Default `as` #col2)
233−insertQuery_ #tab (selectStar (from (table #other_tab)))
234−
235−-- Squeal 0.5
236−insertInto_ #tab (Values_ (Set 2 `as` #col1 :* Default `as` #col2))
237−insertInto_ #tab (Subquery (select Star (from (table #other_tab))))
238−```
239−
240−**Window functions and aggregation**
241−
242−Previous versions of Squeal provided no support for window functions.
243−Squeal 0.5 adds support for window functions. We saw `Over` in the
244−previous section.
245−
246−```Haskell
247−Over
248− :: SListI row
249− => NP (Aliased (WindowFunction outer commons grp schemas params from)) row
250− -> WindowDefinition outer commons grp schemas params from
251− -> Selection outer commons grp schemas params from row
252−```
253−
254−`Over` combines window functions with window definitions. A `WindowDefinition`
255−is constructed using the `partitionBy` function, optionally with an `orderBy`
256−clause. For example,
257−
258−```Haskell
259−query :: Query_ (Public Schema) () (Row Int32 Int32)
260−query = select
261− (#col1 & Also (rank `as` #col2 `Over` (partitionBy #col1 & orderBy [#col2 & Asc])))
262− (from (table #tab))
263−```
264−
265−Here the `rank` function is a `WindowFunction`
266−
267−```Haskell
268−rank :: WinFun0 ('NotNull 'PGint8)
269−rank = UnsafeWindowFunction "rank()"
270−```
271−
272−`WinFun0` is a RankNType, like `Expr` was, used for no argument window functions.
273−Similarly, there are also `WinFun1` and `WinFunN` types for
274−window functions and n-ary window functions.
275−
276−In order to use the same syntax for certain window functions and aggregate functions,
277−a new typeclass `Aggregate` was introduced. So for instance, `sum_` can be
278−either a `Distinction` `Expression` or a `WindowFunction`, used either with
279−a `groupBy` or with a `partitionBy` in the appropriate way.
280−
281−```
282−data Distinction (expr :: kind -> Type) (ty :: kind)
283− = All (expr ty)
284− | Distinct (expr ty)
285−```
286−
287−Aggregate functions can be run over all rows or only over distinct rows,
288−while window functions bear no such distinction.
289−
290−**Migrations**
291−
292−Thanks to [https://github.com/Raveline](Raveline) Squeal 0.5 introduces
293−a function `defaultMain` to easily create a command line program to
294−run or rewind your migrations.
295−
296−Previously, Squeal's migrations were impure, allowing in addition to
297−running `Definition`s to run arbitrary `IO` operations, such as inserting
298−data into the database or printing out status messages. In order to
299−provide compatibility with other migration systems, Squeal 0.5 introduces
300−pure migrations, that is migrations that are only `Definition`s.
301−
302−```Haskell
303−data Migration p schemas0 schemas1 = Migration
304− { name :: Text -- ^ The `name` of a `Migration`.
305− -- Each `name` in a `Migration` should be unique.
306− , up :: p schemas0 schemas1 -- ^ The `up` instruction of a `Migration`.
307− , down :: p schemas1 schemas0 -- ^ The `down` instruction of a `Migration`.
308− } deriving (GHC.Generic)
309−```
310−
311−A pure migration is a `Migration Definition`, a pair of inverse
312−`Definition`s with a unique name. To recover impure migrations, Squeal 0.5
313−introduces the `Terminally` type.
314−
315−```Haskell
316−newtype Terminally trans monad x0 x1 = Terminally
317− { runTerminally :: trans x0 x1 monad () }
318−```
319−
320−`Terminally` applies the indexed monad transformer and the monad it transforms
321−to the unit type `()`, thereby turning an indexed monad into a `Category`. An
322−impure migration is a `Migration (Terminally PQ IO)`. You can always cast
323−a pure migration into an impure migration with the functor, `pureMigration`.
324−
325−```Haskell
326−pureMigration
327− :: Migration Definition schemas0 schemas1
328− -> Migration (Terminally PQ IO) schemas0 schemas1
329−```
330−
331−To run either pure or impure migrations, Squeal 0.5 introduces
332−a typeclass, `Migratory`.
333−
334−```
335−class Category p => Migratory p where
336−
337− migrateUp
338− :: AlignedList (Migration p) schemas0 schemas1
339− -> PQ schemas0 schemas1 IO ()
340−
341− migrateDown
342− :: AlignedList (Migration p) schemas0 schemas1
343− -> PQ schemas1 schemas0 IO ()
344−```
345−
346−The signatures of `migrateUp` and `migrateDown` have been changed
347−to make them easier to compose with other `PQ` actions.
348−
349−**Transactions**
350−
351−You can now run transactions `ephemerally`, guaranteed to roll back,
352−but return the result or throw the exception that the transaction
353−would have generated. This is useful for testing. You can also
354−`transactionallyRetry` computations, retrying the transaction if
355−a [serialization failure](https://www.postgresql.org/docs/11/transaction-iso.html#XACT-REPEATABLE-READ) occurs.
356−
357−**Types**
358−
359−Squeal now supports money via a `Money` Haskell `Type` and a `'PGmoney`
360−`PGType`. Squeal 0.5 also adds support for creating domain types
361−with `createDomain`.
362−
363−**Time**
364−
365−Squeal 0.5 adds support for new functions; `now`, `makeDate`, `makeTime`,
366−, `makeTimestamp`, and `makeTimestamptz`, a function `interval_` for
367−constructing time intervals out multiples of `TimeUnit`s, and a new
368−`TimeOp` class, defining affine space operators for time types and their
369−differences.
370−
371−**Literals**
372−
373−Squeal allows you to include Haskell values in your statements using
374−out of line `parameter`s, but often you want to include them inline,
375−as a SQL `literal`. Squeal 0.5 enables this using the `Literal` class.
376−
377−**Set returning functions**
378−
379−Squeal 0.5 adds support for set returning functions such as `unnest`,
380−with the `RankNType` `SetOfFunction`, which can be used as as a `FromClause`.
381−
382−**Text search**
383−
384−Squeal 0.5 adds extensive support for text search types, functions and operators.
385−
386−**Much more**
387−
388−Lots more changes went into and under the hood of the new version.
389−The `Expression` module was split into coherent submodules since it
390−had grown to immense proportions. New modules `Alias`, `PG` and `List`
391−were added to relieve some of the burden that the `Schema` module
392−had been carrying. Rendering has been better unified with a new
393−`RenderSQL` typeclass. Type level list concatenation with the `Additional`
394−typeclass has been added. `Manipulation`s `update` and `delete`
395−were upgraded, so you can leave out fields you don't want to update and
396−use `USING` clauses in deletes. Upserts which were previously broken
397−now work. The `IO` typeclass hierarchy was changed from `MonadBase`
398−and `MonadBaseControl` to `MonadIO` and `MonadUnliftIO`. A new
399−`withRecursive` `Manipulation` was added. `SquealException`s were
400−refactored and a `trySqueal` function added. Arrays were refactored.
401−And there was probably more I've forgotten.
402−
403−### Version 0.4
404−
405−Version 0.4 strengthens Squeal's type system, adds
406−support for multidimensional arrays, improves support
407−for container type, improves `with` statements,
408−improves runtime exceptions, accomodates SQL's three-valued logic,
409−adds subquery expressions, and adds table and view type expressions.
410−
411−**Types**
412−
413−Squeal 0.4 renames some kinds to aid intuition:
414−
415−```Haskell
416−type RowType = [(Symbol, NullityType)] -- previously RelationType
417−type FromType = [(Symbol, RowType)] -- previously RelationsType
418−```
419−
420−Null safety for array and composite types is gained by having the base
421−type of an array be a `NullityType` and the base type of a composite
422−a `RowType`.
423−
424−```Haskell
425−data PGType
426− = ..
427− | PGvararray NullityType
428− | PGfixarray Nat NullityType
429− | PGcomposite RowType
430−```
431−
432−Squeal embeds Postgres types into Haskell using data kinds and type-in-type:
433−
434−```Haskell
435−data PGType = PGbool | ..
436−data NullityType = Null PGType | NotNull PGType
437−type RowType = [(Symbol, NullityType)] -- previously RelationType
438−type FromType = [(Symbol, RowType)] -- previously RelationsType
439−```
440−
441−In another sense, we can embed Haskell types
442−into Postgres types by providing type families:
443−
444−```Haskell
445−type family PG (hask :: Type) :: PGType
446−type family NullPG (hask :: Type) :: NullityType
447−type family TuplePG (hask :: Type) :: [NullityType]
448−type family RowPG (hask :: Type) :: RowType
449−```
450−
451−Let's look at these one by one.
452−
453−`PG` was introduced in Squeal 0.3. It was a closed type family that
454−associates some Haskell types to their obvious corresponding Postgres
455−types like `PG Double = 'PGfloat8`. It only worked on base types,
456−no arrays or composites. Squeal 0.4 extends it to
457−such container types and makes it an open type family so that
458−users can make their own type instances.
459−
460−`NullPG` had a different name before but it does the obvious
461−thing for Haskell with `Maybe`s:
462−
463−```Haskell
464−type family NullPG hask where
465− NullPG (Maybe hask) = 'Null (PG hask)
466− NullPG hask = 'NotNull (PG hask)
467−```
468−
469−`TuplePG` uses generics to turn tuple types (including records)
470−into lists of `NullityType`s in the logical way, e.g.
471−`TuplePG (Bool, Day) = '[ 'PGbool, 'PGdate]`.
472−
473−`RowPG` also uses generics to turn record types into a `RowType` in the logical way, e.g.
474−
475−```Haskell
476−>>> data Person = Person { name :: Text, age :: Int32 } deriving GHC.Generic
477−>>> instance SOP.Generic Person
478−>>> instance SOP.HasDatatypeInfo Person
479−>>> :kind! TuplePG Person
480−TuplePG Person :: [NullityType]
481−= '['NotNull 'PGtext, 'NotNull 'PGint4]
482−>>> :kind! RowPG Person
483−RowPG Person :: [(Symbol, NullityType)]
484−= '["name" ::: 'NotNull 'PGtext, "age" ::: 'NotNull 'PGint4]
485−```
486−
487−We've already seen a hint of why these types are useful in one construction
488−from Squeal 0.3. Creating composite types in Postgres directly from a Haskell
489−record type essentially uses `RowPG`. Another important use is in simplifying
490−the type signatures for a `Query` or `Manipulation`. Very often, you will have
491−a tuple type corresponding to the parameters and a record type corresponding
492−to the returned columns of a `Query` or `Manipulation`. Instead of writing
493−boilerplate signature you can reuse these with the help of `TuplePG` and `RowPG`
494−
495−For instance:
496−
497−```Haskell
498−>>> :{
499−let
500− query :: Query '["user" ::: 'View (RowPG Person)] (TuplePG (Only Int32)) (RowPG Person)
501− query = selectStar (from (view #user) & where_ (#age .> param @1))
502−:}
503−```
504−
505−**Arrays**
506−
507−In addition to being able to encode and decode basic Haskell types
508−like `Int16` and `Text`, Squeal 0.4 permits you to encode and decode Haskell types to
509−Postgres array types. The `Vector` type corresponds to to variable length arrays.
510−And thanks to an idea from [Mike Ledger](https://github.com/mikeplus64),
511−homogeneous tuples correspond to fixed length arrays. We can even
512−create multi-dimensional fixed length arrays. Let's see an example.
513−
514−```Haskell
515−>>> :{
516−data Row = Row
517− { col1 :: Vector Int16
518− , col2 :: (Maybe Int16,Maybe Int16)
519− , col3 :: ((Int16,Int16),(Int16,Int16),(Int16,Int16))
520− } deriving (Eq, GHC.Generic)
521−:}
522−
523−>>> instance Generic Row
524−>>> instance HasDatatypeInfo Row
525−```
526−
527−Define a simple round trip query.
528−
529−```Haskell
530−>>> :{
531−let
532− roundTrip :: Query '[] (TuplePG Row) (RowPG Row)
533− roundTrip = values_ $
534− parameter @1 (int2 & vararray) `as` #col1 :*
535− parameter @2 (int2 & fixarray @2) `as` #col2 :*
536− parameter @3 (int2 & fixarray @2 & fixarray @3) `as` #col3
537−:}
538−
539−>>> :set -XOverloadedLists
540−>>> let input = Row [1,2] (Just 1,Nothing) ((1,2),(3,4),(5,6))
541−>>> :{
542−void . withConnection "host=localhost port=5432 dbname=exampledb" $ do
543− result <- runQueryParams roundTrip input
544− Just output <- firstRow result
545− liftBase . print $ input == output
546−:}
547−True
548−```
549−
550−**Containers**
551−
552−Squeal aims to provide a correspondence between Haskell types and Postgres types.
553−In particular, Haskell ADTs with nullary constructors can correspond to
554−Postgres enum types and Haskell record types can correspond to Postgres
555−composite types. However, it's not always obvious that that's how a user
556−will choose to store values of those types. So Squeal 0.4 introduces newtypes
557−whose purpose is to specify how a user wants to store values of a type.
558−
559−```Haskell
560−newtype Json hask = Json {getJson :: hask}
561−newtype Jsonb hask = Jsonb {getJsonb :: hask}
562−newtype Composite record = Composite {getComposite :: record}
563−newtype Enumerated enum = Enumerated {getEnumerated :: enum}
564−```
565−
566−Let's see an example:
567−
568−```Haskell
569−>>> data Schwarma = Beef | Lamb | Chicken deriving (Eq, Show, GHC.Generic)
570−>>> instance SOP.Generic Schwarma
571−>>> instance SOP.HasDatatypeInfo Schwarma
572−>>>
573−>>> data Person = Person {name :: Text, age :: Int32} deriving (Eq, Show, GHC.Generic)
574−>>> instance SOP.Generic Person
575−>>> instance SOP.HasDatatypeInfo Person
576−>>> instance Aeson.FromJSON Person
577−>>> instance Aeson.ToJSON Person
578−```
579−
580−We can create the equivalent Postgres types directly from their Haskell types.
581−
582−```Haskell
583−>>> :{
584−type Schema =
585− '[ "schwarma" ::: 'Typedef (PG (Enumerated Schwarma))
586− , "person" ::: 'Typedef (PG (Composite Person))
587− ]
588−:}
589−
590−>>> :{
591−let
592− setup :: Definition '[] Schema
593− setup =
594− createTypeEnumFrom @Schwarma #schwarma >>>
595− createTypeCompositeFrom @Person #person
596−:}
597−```
598−
599−Let's demonstrate how to associate our Haskell types `Schwarma` and `Person`
600−with enumerated, composite or json types in Postgres. First create a Haskell
601−`Row` type using the `Enumerated`, `Composite` and `Json` newtypes as fields.
602−
603−```Haskell
604−>>> :{
605−data Row = Row
606− { schwarma :: Enumerated Schwarma
607− , person1 :: Composite Person
608− , person2 :: Json Person
609− } deriving (Eq, GHC.Generic)
610−:}
611−
612−>>> instance Generic Row
613−>>> instance HasDatatypeInfo Row
614−>>> :{
615−let
616− input = Row
617− (Enumerated Chicken)
618− (Composite (Person "Faisal" 24))
619− (Json (Person "Ahmad" 48))
620−:}
621−```
622−
623−Once again, define a round trip query.
624−
625−```Haskell
626−>>> :{
627−let
628− roundTrip :: Query Schema (TuplePG Row) (RowPG Row)
629− roundTrip = values_ $
630− parameter @1 (typedef #schwarma) `as` #schwarma :*
631− parameter @2 (typedef #person) `as` #person1 :*
632− parameter @3 json `as` #person2
633−:}
634−```
635−
636−Finally, we can drop our type definitions.
637−
638−```Haskell
639−>>> :{
640−let
641− teardown :: Definition Schema '[]
642− teardown = dropType #schwarma >>> dropType #person
643−:}
644−```
645−
646−Now let's run it.
647−
648−```Haskell
649−>>> :{
650−let
651− session = do
652− result <- runQueryParams roundTrip input
653− Just output <- firstRow result
654− liftBase . print $ input == output
655−in
656− void . withConnection "host=localhost port=5432 dbname=exampledb" $
657− define setup
658− & pqThen session
659− & pqThen (define teardown)
660−:}
661−True
662−```
663−
664−**With**
665−
666−Squeal 0.3 supported WITH statements but there's a couple problems with them.
667−Here's the type signature for `with` in Squeal 0.3.
668−
669−```Haskell
670−with
671− :: SOP.SListI commons
672− => NP (Aliased (Manipulation schema params)) (common ': commons)
673− -- ^ common table expressions
674− -> Manipulation (With (common ': commons) schema) params results
675− -> Manipulation schema params results
676−```
677−
678−The first problem is that `with` only works with `Manipulations`.
679−It can work on `Query`s by using `queryStatement` but it still will
680−return a `Manipulation`. We can fix this issue by making `with` a
681−method of a type class with instances for both `Query` and `Manipulation`.
682−
683−The second problem is that all the common table expressions
684−refer the base schema, whereas in SQL, each subsequent CTE can
685−refer to previous CTEs as well. But this can be fixed! First define a datatype:
686−
687−```Haskell
688−data CommonTableExpression statement params schema0 schema1 where
689− CommonTableExpression
690− :: Aliased (statement schema params) (alias ::: cte)
691− -> CommonTableExpression statement params schema (alias ::: 'View cte ': schema)
692−```
693−
694−It's just a wrapper around an aliased statement, where the statement
695−could be either a `Query` or `Manipulation`, but it augments the schema
696−by adding a view to it. It almost looks like a morphism between schemas
697−but there is no way yet to compose them. Luckily, Squeal already has
698−a datatype for this, which is used for migrations, the `AlignedList`
699−type which is really the "free category". So we can then define a `With` type class:
700−
701−```Haskell
702−class With statement where
703− with
704− :: AlignedList (CommonTableExpression statement params) schema0 schema1
705− -> statement schema1 params row
706− -> statement schema0 params row
707−```
708−
709−By giving `Aliasable` instances to CTEs and aligned singleton lists of CTEs (i.e. scrap-your-nils), we get a nice syntax for WITH statements in Squeal.
710−
711−Here's an example of using `with` for a `Query` and a `Manipulation`:
712−
713−```Haskell
714−>>> :{
715−let
716− query :: Query
717− '[ "t1" ::: 'View
718− '[ "c1" ::: 'NotNull 'PGtext
719− , "c2" ::: 'NotNull 'PGtext] ]
720− '[]
721− '[ "c1" ::: 'NotNull 'PGtext
722− , "c2" ::: 'NotNull 'PGtext ]
723− query = with (
724− selectStar (from (view #t1)) `as` #t2 :>>
725− selectStar (from (view #t2)) `as` #t3
726− ) (selectStar (from (view #t3)))
727−in printSQL query
728−:}
729−WITH "t2" AS (SELECT * FROM "t1" AS "t1"), "t3" AS (SELECT * FROM "t2" AS "t2") SELECT * FROM "t3" AS "t3"
730−
731−>>> type ProductsTable = '[] :=> '["product" ::: 'NoDef :=> 'NotNull 'PGtext, "date" ::: 'Def :=> 'NotNull 'PGdate]
732−
733−>>> :{
734−let
735− manipulation :: Manipulation
736− '[ "products" ::: 'Table ProductsTable
737− , "products_deleted" ::: 'Table ProductsTable
738− ] '[ 'NotNull 'PGdate] '[]
739− manipulation = with
740− (deleteFrom #products (#date .< param @1) ReturningStar `as` #deleted_rows)
741− (insertQuery_ #products_deleted (selectStar (from (view (#deleted_rows `as` #t)))))
742−in printSQL manipulation
743−:}
744−WITH "deleted_rows" AS (DELETE FROM "products" WHERE ("date" < ($1 :: date)) RETURNING *) INSERT INTO "products_deleted" SELECT * FROM "deleted_rows" AS "t"
745−```
746−
747−**Three Valued Logic**
748−
749−In previous versions of Squeal, conditions followed classical two valued logic
750−of `true` and `false`.
751−
752−```Haskell
753−-- Squeal 0.3
754−type Condition schema from grouping params =
755− Expression schema from grouping params ('NotNull 'PGbool)
756−```
757−
758−I had thought that three valued logic, which is what SQL uses, was confusing.
759−However, multiple users reported being confused at being forced to do `NULL`
760−handling, particularly in their left joins. Since the original motivation
761−of being less confusing evaporated I decided to switch to three valued logic
762−of `true`, `false` and `null_`.
763−
764−```Haskell
765−-- Squeal 0.4
766−type Condition schema from grouping params =
767− Expression schema from grouping params ('Null 'PGbool)
768−```
769−
770−**Subquery Expressions**
771−
772−Squeal 0.4 adds support for subquery expressions such as `IN` and `op ANY/ALL`.
773−
774−**Row Types**
775−
776−Squeal 0.4 adds functions to define type expressions from tables and views
777−and a type expression for user defined types, `typetable`, `typeview` and
778−`typedef`.
779−
780−**Runtime Exceptions**
781−
782−Squeal now has an exception type which gives details on the sort of error
783−encountered and handler functions.
784−
785−```Haskell
786−data SquealException
787− = PQException
788− { sqlExecStatus :: LibPQ.ExecStatus
789− , sqlStateCode :: Maybe ByteString
790− -- ^ https://www.postgresql.org/docs/current/static/errcodes-appendix.html
791− , sqlErrorMessage :: Maybe ByteString
792− }
793− | ResultException Text
794− | ParseException Text
795− deriving (Eq, Show)
796−instance Exception SquealException
797−
798−catchSqueal
799− :: MonadBaseControl IO io
800− => io a
801− -> (SquealException -> io a) -- ^ handler
802− -> io a
803−
804−handleSqueal
805− :: MonadBaseControl IO io
806− => (SquealException -> io a) -- ^ handler
807− -> io a -> io a
808−```
809−
810−**Additional Changes**
811−
812−Squeal 0.4 adds `field` and `index` functions to get components of composite
813−and array expressions.
814−
815−Squeal 0.4 adds a dependency on `records-sop` to offload a lot of boilerplate
816−type family logic that was needed for `RowPG`.
817−
818−The above changes required major and minor changes to Squeal DSL functions.
819−Please consult the documentation.
820−
821−### Version 0.3.2 - August 4, 2018
822−
823−Version 0.3.2 features extensive support for `JSON` functionality with
824−more than 50 new functions.
825−This work is entirely due to [Mike Ledger](https://github.com/mikeplus64)
826−who has been making terrific contributions to Squeal. Thanks!
827−We also got some examples in the documentation for pools submitted by
828−[Raveline](https://github.com/Raveline). I'm so pleased to be
829−getting pull requests and issue submissions from you all!
830−
831−### Version 0.3.1 - July 7, 2018
832−
833−Version 0.3.1 of Squeal enables the "Scrap your Nils" trick for
834−heterogeneous lists of `Alias`es, `Aliased` expressions, `PGlabel`s and `By`s
835−with the typeclasses `IsLabel`, `IsQualified`, `IsPGlabel`,
836−and the new `Aliasable` typeclass, to eliminate all need of using `Nil` in a list.
837−There were a couple minor name changes, i.e. the function `group` was renamed to `groupBy`.
838−Please consult the documentation.
839−
840−### Version 0.3 - June 26, 2018
841−
842−Version 0.3 of Squeal adds views as well as composite and enumerated types to Squeal.
843−To support these features, a new kind `SchemumType` was added.
844−
845−```Haskell
846−data SchemumType
847− = Table TableType
848− | View RelationType
849− | Typedef PGType
850−```
851−
852−As a consequence, you will have to update your schema definitions like so:
853−
854−```Haskell
855−-- Squeal 0.2
856−type Schema =
857− '[ "users" :::
858− '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
859− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
860− , "name" ::: 'NoDef :=> 'NotNull 'PGtext
861− ]
862− ]
863−
864−-- Squeal 0.3
865−type Schema =
866− '[ "users" ::: 'Table (
867− '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
868− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
869− , "name" ::: 'NoDef :=> 'NotNull 'PGtext
870− ])
871− ]
872−```
873−
874−**Views**
875−
876−You can now create, drop, and query views.
877−
878−```Haskell
879−>>> :{
880−type ABC =
881− ('[] :: TableConstraints) :=>
882− '[ "a" ::: 'NoDef :=> 'Null 'PGint4
883− , "b" ::: 'NoDef :=> 'Null 'PGint4
884− , "c" ::: 'NoDef :=> 'Null 'PGint4
885− ]
886−type BC =
887− '[ "b" ::: 'Null 'PGint4
888− , "c" ::: 'Null 'PGint4
889− ]
890−:}
891−
892−>>> :{
893−let
894− definition :: Definition '["abc" ::: 'Table ABC ] '["abc" ::: 'Table ABC, "bc" ::: 'View BC]
895− definition = createView #bc (select (#b :* #c :* Nil) (from (table #abc)))
896−in printSQL definition
897−:}
898−CREATE VIEW "bc" AS SELECT "b" AS "b", "c" AS "c" FROM "abc" AS "abc";
899−
900−>>> :{
901−let
902− definition :: Definition '["abc" ::: 'Table ABC, "bc" ::: 'View BC] '["abc" ::: 'Table ABC]
903− definition = dropView #bc
904−in printSQL definition
905−:}
906−DROP VIEW "bc";
907−
908−>>> :{
909−let
910− query :: Query '["abc" ::: 'Table ABC, "bc" ::: 'View BC] '[] BC
911− query = selectStar (from (view #bc))
912−in printSQL query
913−:}
914−SELECT * FROM "bc" AS "bc"
915−```
916−
917−**Enumerated Types**
918−
919−PostgreSQL has a powerful type system. It even allows for user defined types.
920−For instance, you can define enumerated types which are data types that comprise
921−a static, ordered set of values. They are equivalent to Haskell algebraic data
922−types whose constructors are nullary. An example of an enum type might be the days of the week,
923−or a set of status values for a piece of data.
924−
925−Enumerated types are created using the `createTypeEnum` command, for example:
926−
927−```Haskell
928−>>> :{
929−let
930− definition :: Definition '[] '["mood" ::: 'Typedef ('PGenum '["sad", "ok", "happy"])]
931− definition = createTypeEnum #mood (label @"sad" :* label @"ok" :* label @"happy" :* Nil)
932−:}
933−>>> printSQL definition
934−CREATE TYPE "mood" AS ENUM ('sad', 'ok', 'happy');
935−```
936−
937−Enumerated types can also be generated from a Haskell algebraic data type with nullary constructors, for example:
938−
939−```Haskell
940−>>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic
941−>>> instance SOP.Generic Schwarma
942−>>> instance SOP.HasDatatypeInfo Schwarma
943−
944−>>> :kind! EnumFrom Schwarma
945−EnumFrom Schwarma :: PGType
946−= 'PGenum '["Beef", "Lamb", "Chicken"]
947−
948−>>> :{
949−let
950− definition :: Definition '[] '["schwarma" ::: 'Typedef (EnumFrom Schwarma)]
951− definition = createTypeEnumFrom @Schwarma #schwarma
952−:}
953−>>> printSQL definition
954−CREATE TYPE "schwarma" AS ENUM ('Beef', 'Lamb', 'Chicken');
955−```
956−
957−You can express values of an enum type using `label`, which is an overloaded method
958−of the `IsPGlabel` typeclass.
959−
960−```Haskell
961−>>> :{
962−let
963− expression :: Expression sch rels grp params ('NotNull (EnumFrom Schwarma))
964− expression = label @"Chicken"
965−in printSQL expression
966−:}
967−'Chicken'
968−```
969−
970−**Composite Types**
971−
972−In addition to enum types, you can define composite types.
973−A composite type represents the structure of a row or record;
974−it is essentially just a list of field names and their data types.
975−
976−
977−`createTypeComposite` creates a composite type. The composite type is
978−specified by a list of attribute names and data types.
979−
980−```Haskell
981−>>> :{
982−let
983− definition :: Definition '[] '["complex" ::: 'Typedef ('PGcomposite '["real" ::: 'PGfloat8, "imaginary" ::: 'PGfloat8])]
984− definition = createTypeComposite #complex (float8 `As` #real :* float8 `As` #imaginary :* Nil)
985−:}
986−>>> printSQL definition
987−CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);
988−```
989−
990−Composite types are almost equivalent to Haskell record types.
991−However, because of the potential presence of `NULL`
992−all the record fields must be `Maybe`s of basic types.
993−Composite types can be generated from a Haskell record type, for example:
994−
995−```Haskell
996−>>> data Complex = Complex {real :: Maybe Double, imaginary :: Maybe Double} deriving GHC.Generic
997−>>> instance SOP.Generic Complex
998−>>> instance SOP.HasDatatypeInfo Complex
999−
1000−>>> :kind! CompositeFrom Complex
1001−CompositeFrom Complex :: PGType
1002−= 'PGcomposite '['("real", 'PGfloat8), '("imaginary", 'PGfloat8)]
1003−
1004−>>> :{
1005−let
1006− definition :: Definition '[] '["complex" ::: 'Typedef (CompositeFrom Complex)]
1007− definition = createTypeCompositeFrom @Complex #complex
1008−in printSQL definition
1009−:}
1010−CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);
1011−```
1012−
1013−A row constructor is an expression that builds a row value
1014−(also called a composite value) using values for its member fields.
1015−
1016−```Haskell
1017−>>> :{
1018−let
1019− i :: Expression '[] '[] 'Ungrouped '[] ('NotNull (CompositeFrom Complex))
1020− i = row (0 `As` #real :* 1 `As` #imaginary :* Nil)
1021−:}
1022−>>> printSQL i
1023−ROW(0, 1)
1024−```
1025−
1026−You can also use `(&)` to apply a field label to a composite value.
1027−
1028−```Haskell
1029−>>> :{
1030−let
1031− expr :: Expression '[] '[] 'Ungrouped '[] ('Null 'PGfloat8)
1032− expr = i & #imaginary
1033−in printSQL expr
1034−:}
1035−(ROW(0, 1)).imaginary
1036−```
1037−
1038−Both composite and enum types can be automatically encoded from and decoded to their equivalent Haskell types.
1039−And they can be dropped.
1040−
1041−```Haskell
1042−>>> :{
1043−let
1044− definition :: Definition '["mood" ::: 'Typedef ('PGenum '["sad", "ok", "happy"])] '[]
1045− definition = dropType #mood
1046−:}
1047−>>> printSQL definition
1048−DROP TYPE "mood";
1049−```
1050−
1051−**Additional Changes**
1052−
1053−Squeal 0.3 also introduces a typeclass `HasAll` similar to `Has` but for a list of aliases.
1054−This makes it possible to clean up some unfortunately messy Squeal 0.2 definitions.
1055−
1056−```Haskell
1057−-- Squeal 0.2
1058−>>> unique (Column #a :* Column #b :* Nil)
1059−
1060−-- Squeal 0.3
1061−>>> unique (#a :* #b :* Nil)
1062−```
1063−
1064−Squeal 0.3 also adds `IsLabel` instances for `Aliased` expressions and tables as well as
1065−heterogeneous lists, allowing for some more economy of code.
1066−
1067−```Haskell
1068−-- Squeal 0.2 (or 0.3)
1069−>>> select (#a `As` #a :* Nil) (from (table (#t `As` #t)))
1070−
1071−-- Squeal 0.3
1072−>>> select #a (from (table #t))
1073−```
1074−
1075−Squeal 0.3 also fixes a bug that prevented joined queries on self-referencing tables.
1076−
1077−The above changes required major and minor changes to Squeal DSL functions.
1078−Please consult the documentation.
1079−
1080−### Version 0.2.1 - April 7, 2018
1081−
1082−This minor update fixes an issue where alias identifiers could conflict with
1083−reserved words in PostgreSQL. To fix the issue, alias identifiers are now
1084−quoted. Thanks to Petter Rasmussen for the fix.
1085−
1086−### Version 0.2 - March 26, 2018
1087−
1088−**Changes**
1089−- **Constraints** - Type level table constraints like primary and foreign keys and column constraints like having `DEFAULT`.
1090−- **Migrations** - Support for linear, invertible migrations tracked in an auxiliary table
1091−- **Arrays** - Support for fixed- and variable-length arrays
1092−- **Aliases** - Generalized `Has` constraint
1093−- **Pools** - Support for pooled connections
1094−- **Transactions** - Support for transaction control language
1095−- **Queries, Manipulations, Definitions** - Small and large changes to Squeal's DSL
1096−
1097−Well, a lot of things changed!
1098−
1099−**Constraints**
1100−
1101−An important request was to bring constraints to the type level.
1102−This means that more of the schema is statically known. In `0.1` column constraints - which boil down
1103−to having `DEFAULT` or not - were at the type level, but they were confusingly named.
1104−
1105−```haskell
1106−0.1: 'Optional ('NotNull 'PGInt4)
1107−0.2: 'Def :=> 'NotNull 'PGInt4
1108−0.1: 'Required ('NotNull 'PGInt4)
1109−0.2: 'NoDef :=> 'NotNull 'PGInt4
1110−```
1111−
1112−The `:=>` type operator is intended to helpfully connote a constraint relation.
1113−It's also used for table constraints which are new in `0.2`.
1114−
1115−```haskell
1116−"emails" :::
1117− '[ "pk_emails" ::: 'PrimaryKey '["id"]
1118− , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
1119− ] :=>
1120− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
1121− , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
1122− , "email" ::: 'NoDef :=> 'Null 'PGtext
1123− ]
1124−```
1125−
1126−Another change in the constraint system was the removal of column constraints from
1127−query and manipulation results, as result columns don't support a notion of `DEFAULT`.
1128−This necessitates a distinction between `TableType`s which have both column and table
1129−constraints and `RelationType`s which have neither.
1130−
1131−**Migrations**
1132−
1133−Migrations are a hot topic and many people have requested this feature. Squeal `0.2`
1134−adds support for linear, invertible migrations. That is, a migration is a named,
1135−invertible, schema-tracking computation:
1136−
1137−```haskell
1138−data Migration io schema0 schema1 = Migration
1139− { name :: Text -- ^ The `name` of a `Migration`.
1140− -- Each `name` in a `Migration` should be unique.
1141− , up :: PQ schema0 schema1 io () -- ^ The `up` instruction of a `Migration`.
1142− , down :: PQ schema1 schema0 io () -- ^ The `down` instruction of a `Migration`.
1143− }
1144−```
1145−
1146−And, `Migration`s can be put together in an "aligned" list:
1147−
1148−```haskell
1149−data AlignedList p x0 x1 where
1150− Done :: AlignedList p x x
1151− (:>>) :: p x0 x1 -> AlignedList p x1 x2 -> AlignedList p x0 x2
1152−```
1153−
1154−These aligned lists are free categories and might look familiar from
1155−the [reflections without remorse](http://okmij.org/ftp/Haskell/zseq.pdf) technique,
1156−which uses their cousins, aligned sequences.
1157−
1158−In the context of migration, they allow one to chain new migrations as a
1159−schema evolves over time. `Migration`s' execution is tracked in an auxiliary
1160−migrations table. Migration lists can then be run or rewinded.
1161−
1162−```haskell
1163−migrateUp
1164− :: MonadBaseControl IO io
1165− => AlignedList (Migration io) schema0 schema1 -- ^ migrations to run
1166− -> PQ
1167− ("schema_migrations" ::: MigrationsTable ': schema0)
1168− ("schema_migrations" ::: MigrationsTable ': schema1)
1169− io ()
1170−
1171−migrateDown
1172− :: MonadBaseControl IO io
1173− => AlignedList (Migration io) schema0 schema1 -- ^ migrations to rewind
1174− -> PQ
1175− ("schema_migrations" ::: MigrationsTable ': schema1)
1176− ("schema_migrations" ::: MigrationsTable ': schema0)
1177− io ()
1178−```
1179−
1180−**Aliases**
1181−
1182−In Squeal `0.1`, we had different typeclasses `HasColumn` and `HasTable` to indicate
1183−that a table has a column or that a schema has a table. In Squeal `0.2` this has been
1184−unified to a single typeclass,
1185−
1186−```haskell
1187−class KnownSymbol alias =>
1188− Has (alias :: Symbol) (fields :: [(Symbol,kind)]) (field :: kind)
1189− | alias fields -> field where
1190−```
1191−
1192−**Arrays**
1193−
1194−Support for array types has been added to Squeal `0.2` through
1195−the `'PGfixarray` and `'PGvararray` `PGType`s. Array values can be
1196−constructed using the `array` function and can be encoded from and decoded to
1197−Haskell `Vector`s.
1198−
1199−**Pools**
1200−
1201−Squeal `0.2` provides a monad transformer `PoolPQ` that's an instance of `MonadPQ`.
1202−The `resource-pool` library is leveraged to provide striped pools of `Connection`s.
1203−`PoolPQ` should be a drop in replacement for running `Manipulation`s and `Query`s with
1204−`PQ`.
1205−
1206−**Transactions**
1207−
1208−Squeal `0.2` supports a simple transaction control language. A computation in
1209−`MonadPQ` can be called `transactionally` with different levels of isolation.
1210−Additionally, a schema changing computation, a data definition, can be run in a
1211−transaction. Running a computation in a transaction means that all SQL statements
1212−will be rolled back if an exception is encountered.
1213−
1214−**Queries, Manipulations and Definitions**
1215−
1216−The above changes required major and minor changes to Squeal DSL functions.
1217−Please consult the documentation.
circle.ymlnew file+12
@@ -0,0 +1,12 @@
1+dependencies:
2+ cache_directories:
3+ - "~/.stack"
4+ - ".stack-work"
5+ override:
6+ - stack upgrade
7+ - stack update
8+ - stack setup
9+ - stack test --no-run-tests
10+test:
11+ override:
12+ - stack test
scrap-your-nils.mddeleted−60
@@ -1,60 +0,0 @@
1−## Scrap your Nils
2−
3−One of the most useful types I've come across in Haskell is the type of
4−"heterogeneous lists". This is the same as the [Rec](http://hackage.haskell.org/package/vinyl-0.8.1.1/docs/Data-Vinyl-Core.html)
5−datatype from the [vinyl](http://hackage.haskell.org/package/vinyl) library.
6−It's also the same as the [NP](http://hackage.haskell.org/package/generics-sop-0.3.2.0/docs/Generics-SOP-NP.html)
7−datatype from the [generics-sop](http://hackage.haskell.org/package/generics-sop) library.
8−Squeal makes heavy use of this type.
9−
10−```Haskell
11−>>> import Generics.SOP (NP(..))
12−>>> :i NP
13−type role NP representational nominal
14−data NP (a :: k -> *) (b :: [k]) where
15− Nil :: forall k (a :: k -> *). NP a '[]
16− (:*) :: forall k (a :: k -> *) (x :: k) (xs :: [k]).
17− (a x) -> (NP a xs) -> NP a (x : xs)
18− -- Defined in ‘Generics.SOP.NP’
19−```
20−
21−This type allows us to construct "product" types, where the types of the individual
22−"terms" are hosted at the type level.
23−
24−```Haskell
25−>>> :set -XDataKinds
26−>>> import Generics.SOP (I(..))
27−>>> let example = I "foo" :* I pi :* Nil :: NP I '[String, Double]
28−>>> example
29−I "foo" :* I 3.141592653589793 :* Nil
30−```
31−
32−One thing Squeal uses `NP` for is to form lists of aliases,
33−using GHC's `OverloadedLabels` extension, hosting the names
34−of the aliases themselves at the type level.
35−
36−```Haskell
37−>>> :set -XKindSignatures -XOverloadedLabels -XFlexibleInstances -XMultiParamTypeClasses
38−>>> import GHC.TypeLits
39−>>> import GHC.OverloadedLabels
40−>>> data Alias (alias :: Symbol) = Alias deriving (Eq,Ord,Show)
41−>>> instance IsLabel label (Alias label) where fromLabel = Alias
42−>>> let aliases = #foo :* #bar :* Nil :: NP Alias '["foo", "bar"]
43−```
44−
45−However, it's very ugly to have to end every list with `:* Nil`.
46−When I announced the release of Squeal, people rightly [complained](https://www.reddit.com/r/haskell/comments/6yr5v6/announcing_squeal_a_deep_embedding_of_sql_in/dmq8vvn)
47−about the syntactic noise. Luckily, there's a neat trick we can use to get rid of it.
48−Making an `IsLabel` instance not only for elements of our list
49−but also for lists of length 1, we can ask GHC to interpret
50−the last label as a list.
51−
52−```Haskell
53−>>> instance IsLabel label (NP Alias '[label]) where fromLabel = Alias :* Nil
54−>>> let aliases' = #foo :* #bar :: NP Alias '["foo", "bar"]
55−```
56−
57−Version 0.3.1 of Squeal enables the "Scrap your Nils" trick for
58−heterogeneous lists of `Alias`es, `Aliased` expressions, `PGlabel`s and `By`s
59−with the typeclasses `IsLabel`, `IsQualified`, `IsPGlabel`,
60−and the new `Aliasable` typeclass, to eliminate all need of using `Nil` in a list.
squeal-postgresql/LICENSEdeleted−31
@@ -1,31 +0,0 @@
1−Copyright (c) 2017 Morphism, LLC
2−
3−All rights reserved.
4−
5−Redistribution and use in source and binary forms, with or without
6−modification, are permitted provided that the following conditions are
7−met:
8−
9− * Redistributions of source code must retain the above copyright
10− notice, this list of conditions and the following disclaimer.
11−
12− * Redistributions in binary form must reproduce the above
13− copyright notice, this list of conditions and the following
14− disclaimer in the documentation and/or other materials provided
15− with the distribution.
16−
17− * Neither the names of the copyright holders nor the names of the
18− contributors may be used to endorse or promote products derived
19− from this software without specific prior written permission.
20−
21−THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
22−"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
23−LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
24−A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
25−OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
26−SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
27−LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
28−DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
29−THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
30−(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
31−OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
squeal-postgresql/README.mddeleted−11
@@ -1,11 +0,0 @@
1−# squeal-postgresql
2−
3−![squeal-icon](http://www.emoticonswallpapers.com/emotion/cute-big-pig/cute-pig-smiley-046.gif)
4−
5−[![CircleCI](https://circleci.com/gh/echatav/squeal.svg?style=svg&circle-token=a699a654ef50db2c3744fb039cf2087c484d1226)](https://circleci.com/gh/morphismtech/squeal)
6−
7−[Github](https://github.com/morphismtech/squeal)
8−
9−[Hackage](https://hackage.haskell.org/package/squeal-postgresql)
10−
11−[Stackage](https://www.stackage.org/package/squeal-postgresql)
squeal-postgresql/docs-upload.shdeleted−18
@@ -1,18 +0,0 @@
1−#!/bin/bash
2−
3−# Run this script in the top-level of your package directory
4−# (where the .cabal file is) to compile documentation and
5−# upload it to hackage.
6−
7−# Requirements:
8−# cabal-install-1.24 (for --for-hackage)
9−# haddock 2.17 (for the hyperlinked source)
10−
11−set -e
12−
13−dir=$(mktemp -d dist-docs.XXXXXX)
14−trap 'rm -r "$dir"' EXIT
15−
16−cabal configure --builddir="$dir"
17−cabal haddock --builddir="$dir" --for-hackage --haddock-option=--hyperlinked-source
18−cabal upload -d $dir/*-docs.tar.gz
squeal-postgresql/exe/Example.hs+58−96
@@ -1,107 +1,42 @@
1+{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}
1{-# LANGUAGE
2{-# LANGUAGE
2 DataKinds
3 DataKinds
3 , DeriveGeneric
4 , DeriveGeneric
4− , FlexibleContexts
5+ , FlexibleInstances
6+ , MultiParamTypeClasses
5 , OverloadedLabels
7 , OverloadedLabels
6 , OverloadedStrings
8 , OverloadedStrings
7− , OverloadedLists
9+ , PartialTypeSignatures
8 , TypeApplications
10 , TypeApplications
9 , TypeOperators
11 , TypeOperators
12+ , TypeSynonymInstances
10#-}
13#-}
11
14
12−module Main (main, main2) where
15+module Main (main,col1,col2) where
13−
14−import Control.Monad.IO.Class (MonadIO (..))
15−import Data.Int (Int16, Int32)
16−import Data.Monoid ((<>))
17−import Data.Text (Text)
18−import Data.Vector (Vector)
19
16
17+import Control.Category ((>>>))
18+import Control.Monad.Base
19+import Data.Function ((&))
20+import Data.Int
21+import Data.Monoid
22+import Generics.SOP hiding (from)
20import Squeal.PostgreSQL
23import Squeal.PostgreSQL
21
24
22import qualified Data.ByteString.Char8 as Char8
25import qualified Data.ByteString.Char8 as Char8
23−import qualified Generics.SOP as SOP
24import qualified GHC.Generics as GHC
26import qualified GHC.Generics as GHC
25
27
26type Schema =
28type Schema =
27− '[ "users" ::: 'Table (
28− '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
29− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
30− , "name" ::: 'NoDef :=> 'NotNull 'PGtext
29+ '[ "students" ::: '["name" ::: 'Required ('NotNull 'PGtext)]
31− , "vec" ::: 'NoDef :=> 'NotNull ('PGvararray ('Null 'PGint2))
30+ , "table1" :::
32− ])
33− , "emails" ::: 'Table (
34− '[ "pk_emails" ::: 'PrimaryKey '["id"]
35− , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
36− ] :=>
37− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
31+ '[ "col1" ::: 'Required ('NotNull 'PGint4)
38− , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
32+ , "col2" ::: 'Required ('NotNull 'PGint4)
39− , "email" ::: 'NoDef :=> 'Null 'PGtext
40− ])
33+ ]
41− , "positive" ::: 'Typedef 'PGfloat4
42 ]
34 ]
43
35
44−type Schemas = Public Schema
36+data Row = Row { col1 :: Int32, col2 :: Int32 }
45−
46−setup :: Definition (Public '[]) Schemas
47−setup =
48− createTable #users
49− ( serial `as` #id :*
50− (text & notNullable) `as` #name :*
51− (vararray int2 & notNullable) `as` #vec )
52− ( primaryKey #id `as` #pk_users )
53− >>>
54− createTable #emails
55− ( serial `as` #id :*
56− hask @Int32 `as` #user_id :*
57− hask @(Maybe Text) `as` #email )
58− ( primaryKey #id `as` #pk_emails :*
59− foreignKey #user_id #users #id
60− OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
61− >>>
62− createDomain #positive real (#value .> 0 .&& (#value & isNotNull))
63−
64−teardown :: Definition Schemas (Public '[])
65−teardown = dropType #positive >>> dropTable #emails >>> dropTable #users
66−
67−insertUser :: Manipulation_ Schemas (Text, VarArray (Vector (Maybe Int16))) (Only Int32)
68−insertUser = insertInto #users
69− (Values_ (Default `as` #id :* Set (param @1) `as` #name :* Set (param @2) `as` #vec))
70− (OnConflict (OnConstraint #pk_users) DoNothing) (Returning_ (#id `as` #fromOnly))
71−
72−insertEmail :: Manipulation_ Schemas (Int32, Maybe Text) ()
73−insertEmail = insertInto_ #emails
74− (Values_ (Default `as` #id :* Set (param @1) `as` #user_id :* Set (param @2) `as` #email))
75−
76−getUsers :: Query_ Schemas () User
77−getUsers = select_
78− (#u ! #name `as` #userName :* #e ! #email `as` #userEmail :* #u ! #vec `as` #userVec)
79− ( from (table (#users `as` #u)
80− & innerJoin (table (#emails `as` #e))
81− (#u ! #id .== #e ! #user_id)) )
82−
83−data User = User { userName :: Text, userEmail :: Maybe Text, userVec :: VarArray (Vector (Maybe Int16)) }
84 deriving (Show, GHC.Generic)
37 deriving (Show, GHC.Generic)
85−instance SOP.Generic User
38+instance Generic Row
86−instance SOP.HasDatatypeInfo User
39+instance HasDatatypeInfo Row
87−
88−users :: [User]
89−users =
90− [ User "Alice" (Just "alice@gmail.com") (VarArray [Nothing, Just 1])
91− , User "Bob" Nothing (VarArray [Just 2, Nothing])
92− , User "Carole" (Just "carole@hotmail.com") (VarArray [Just 3])
93− ]
94−
95−session :: (MonadIO pq, MonadPQ Schemas pq) => pq ()
96−session = do
97− liftIO $ Char8.putStrLn "manipulating"
98− idResults <- traversePrepared insertUser ([(userName user, userVec user) | user <- users])
99− ids <- traverse (fmap fromOnly . getRow 0) idResults
100− traversePrepared_ insertEmail (zip (ids :: [Int32]) (userEmail <$> users))
101− liftIO $ Char8.putStrLn "querying"
102− usersResult <- runQuery getUsers
103− usersRows <- getRows usersResult
104− liftIO $ print (usersRows :: [User])
105
40
106main :: IO ()
41main :: IO ()
107main = do
42main = do
@@ -111,15 +46,42 @@ main = do
111 Char8.putStrLn $ "connecting to " <> connectionString
46 Char8.putStrLn $ "connecting to " <> connectionString
112 connection0 <- connectdb connectionString
47 connection0 <- connectdb connectionString
113 Char8.putStrLn "setting up schema"
48 Char8.putStrLn "setting up schema"
114− connection1 <- execPQ (define setup) connection0
49+ connection1 <- flip execPQ (connection0 :: Connection '[]) $ define $
50+ createTable #students ((text & notNull) `As` #name :* Nil ) []
51+ >>>
52+ createTable #table1
53+ ((int4 & notNull) `As` #col1 :* (int4 & notNull) `As` #col2 :* Nil) []
115− connection2 <- execPQ session connection1
54+ connection2 <- flip execPQ (connection1 :: Connection Schema) $ do
55+ let
56+ insert :: Manipulation Schema '[_,_,_,_] '[]
57+ insert =
58+ insertInto #table1
59+ ( Values
60+ (param @1 `As` #col1 :* param @2 `As` #col2 :* Nil)
61+ [param @3 `As` #col1 :* param @4 `As` #col2 :* Nil]
62+ ) OnConflictDoNothing (Returning Nil)
63+ liftBase $ Char8.putStrLn "manipulating"
64+ _insertResult <- manipulateParams insert
65+ (1::Int32,2::Int32,3::Int32,4::Int32)
66+ liftBase $ Char8.putStrLn "querying"
67+ result <- runQuery $
68+ selectStar (from (Table (#table1 `As` #table1)))
69+ value00 <- getValue (RowNumber 0) (columnNumber @0) result
70+ value01 <- getValue (RowNumber 0) (columnNumber @1) result
71+ value10 <- getValue (RowNumber 1) (columnNumber @0) result
72+ value11 <- getValue (RowNumber 1) (columnNumber @1) result
73+ row0 <- getRow (RowNumber 0) result
74+ row1 <- getRow (RowNumber 1) result
75+ rows <- getRows result
76+ liftBase $ do
77+ print (value00 :: Int32)
78+ print (value01 :: Int32)
79+ print (value10 :: Int32)
80+ print (value11 :: Int32)
81+ print (row0 :: Row)
82+ print (row1 :: Row)
83+ print (rows :: [Row])
116 Char8.putStrLn "tearing down schema"
84 Char8.putStrLn "tearing down schema"
117− connection3 <- execPQ (define teardown) connection2
85+ connection3 <- flip execPQ (connection2 :: Connection Schema) $ define $
86+ dropTable #table1 >>> dropTable #students
118− finish connection3
87+ finish (connection3 :: Connection '[])
119−
120−main2 :: IO ()
121−main2 =
122− withConnection "host=localhost port=5432 dbname=exampledb" $
123− define setup
124− & pqThen session
125− & pqThen (define teardown)
squeal-postgresql/squeal-postgresql.cabal+44−101
@@ -1,17 +1,15 @@
1name: squeal-postgresql
1name: squeal-postgresql
2−version: 0.5.1.0
2+version: 0.1.0.0
3synopsis: Squeal PostgreSQL Library
3synopsis: Squeal PostgreSQL Library
4description: Squeal is a type-safe embedding of PostgreSQL in Haskell
4description: Squeal is a type-safe embedding of PostgreSQL in Haskell
5homepage: https://github.com/morphismtech/squeal
5homepage: https://github.com/morphismtech/squeal
6bug-reports: https://github.com/morphismtech/squeal/issues
6bug-reports: https://github.com/morphismtech/squeal/issues
7−license: BSD3
8−license-file: LICENSE
9author: Eitan Chatav
7author: Eitan Chatav
10maintainer: eitan.chatav@gmail.com
8maintainer: eitan.chatav@gmail.com
11copyright: Copyright (c) 2017 Morphism, LLC
9copyright: Copyright (c) 2017 Morphism, LLC
12category: Database
10category: Database
13build-type: Simple
11build-type: Simple
14−cabal-version: >=1.18
12+cabal-version: >=1.10
15extra-doc-files: README.md
13extra-doc-files: README.md
16
14
17source-repository head
15source-repository head
@@ -22,126 +20,71 @@ library
22 hs-source-dirs: src
20 hs-source-dirs: src
23 exposed-modules:
21 exposed-modules:
24 Squeal.PostgreSQL
22 Squeal.PostgreSQL
25− Squeal.PostgreSQL.Alias
26 Squeal.PostgreSQL.Binary
23 Squeal.PostgreSQL.Binary
27 Squeal.PostgreSQL.Definition
24 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
35 Squeal.PostgreSQL.Expression
25 Squeal.PostgreSQL.Expression
36− Squeal.PostgreSQL.Expression.Aggregate
37− Squeal.PostgreSQL.Expression.Collection
38− Squeal.PostgreSQL.Expression.Comparison
39− Squeal.PostgreSQL.Expression.Json
40− Squeal.PostgreSQL.Expression.Literal
41− Squeal.PostgreSQL.Expression.Logic
42− Squeal.PostgreSQL.Expression.Math
43− Squeal.PostgreSQL.Expression.Null
44− Squeal.PostgreSQL.Expression.Parameter
45− Squeal.PostgreSQL.Expression.Range
46− Squeal.PostgreSQL.Expression.Set
47− Squeal.PostgreSQL.Expression.Sort
48− Squeal.PostgreSQL.Expression.Subquery
49− Squeal.PostgreSQL.Expression.Text
50− Squeal.PostgreSQL.Expression.TextSearch
51− Squeal.PostgreSQL.Expression.Time
52− Squeal.PostgreSQL.Expression.Type
53− Squeal.PostgreSQL.Expression.Window
54− Squeal.PostgreSQL.List
55 Squeal.PostgreSQL.Manipulation
26 Squeal.PostgreSQL.Manipulation
56− Squeal.PostgreSQL.Migration
57− Squeal.PostgreSQL.Pool
58− Squeal.PostgreSQL.PG
59 Squeal.PostgreSQL.PQ
27 Squeal.PostgreSQL.PQ
60− Squeal.PostgreSQL.Render
28+ Squeal.PostgreSQL.Prettyprint
61 Squeal.PostgreSQL.Query
29 Squeal.PostgreSQL.Query
62 Squeal.PostgreSQL.Schema
30 Squeal.PostgreSQL.Schema
63− Squeal.PostgreSQL.Transaction
64 default-language: Haskell2010
31 default-language: Haskell2010
65− ghc-options: -Wall
32+ ghc-options: -Wall -Werror -fprint-explicit-kinds
66 build-depends:
33 build-depends:
67− aeson >= 1.2.4.0
34+ aeson >= 1.2.1.0 && < 2
68− , base >= 4.11.1.0 && < 5.0
35+ , base >= 4.10.0.0 && < 5
69− , binary-parser >= 0.5.5
70− , bytestring >= 0.10.8.2
36+ , bytestring >= 0.10.8.2 && < 1
71− , bytestring-strict-builder >= 0.4.5
72− , deepseq >= 1.4.3.0
37+ , deepseq >= 1.4.3.0 && < 2
73− , free-categories >= 0.1.0.0
74− , generics-sop >= 0.3.2.0 && < 0.5.0.0
38+ , generics-sop >= 0.3.1.0 && < 1
75− , mmorph >= 1.1.1
39+ , lifted-base >= 0.2.3.11 && < 1
40+ , monad-control >= 1.0.2.2 && < 2
76− , mtl >= 2.2.2
41+ , mtl >= 2.2.1 && < 3
77− , network-ip >= 0.3.0.2
42+ , network-ip >= 0.3.0.2 && < 1
78− , postgresql-binary >= 0.12.1
43+ , postgresql-binary >= 0.12.1 && < 1
79− , postgresql-libpq >= 0.9.4.1
44+ , postgresql-libpq >= 0.9.3.1 && < 1
80− , records-sop >= 0.1.0.0
81− , resource-pool >= 0.2.3.2
82− , scientific >= 0.3.5.3
45+ , scientific >= 0.3.5.1 && < 1
83− , text >= 1.2.3.0
46+ , text >= 1.2.2.2 && < 2
84− , time >= 1.8.0.2
47+ , time >= 1.8.0.2 && < 2
85− , transformers >= 0.5.2.0
48+ , transformers >= 0.5.2.0 && < 1
86− , unliftio >= 0.2.10
49+ , transformers-base >= 0.4.4 && < 1
87− , unliftio-pool >= 0.2.1.0
88− , uuid-types >= 1.0.3
50+ , uuid >= 1.3.13 && < 2
89− , vector >= 0.12.0.1
90
51
91−test-suite doctest
52+test-suite squeal-postgresql-spec
92 default-language: Haskell2010
53 default-language: Haskell2010
93 type: exitcode-stdio-1.0
54 type: exitcode-stdio-1.0
94 hs-source-dirs: test
55 hs-source-dirs: test
95− ghc-options: -Wall
56+ ghc-options: -Wall -Werror
96− main-is: Doc.hs
57+ main-is: Spec.hs
97− build-depends:
58+ other-modules:
98− base >= 4.10.0.0
59+ Squeal.PostgreSQL.DefinitionSpec
99− , doctest >= 0.11.4
60+ Squeal.PostgreSQL.ManipulationSpec
100− , squeal-postgresql
61+ Squeal.PostgreSQL.QuerySpec
101−
102−test-suite properties
103− default-language: Haskell2010
104− type: exitcode-stdio-1.0
105− hs-source-dirs: test
106− ghc-options: -Wall
107− main-is: Property.hs
108 build-depends:
62 build-depends:
109− base >= 4.10.0.0
63+ base >= 4.10.0.0 && < 5
110− , bytestring >= 0.10.8.2
64+ , generics-sop >= 0.3.1.0 && < 1
111− , hedgehog >= 1.0
65+ , hspec >= 2.4.4 && < 3
112− , mtl >= 2.2.2
113− , scientific >= 0.3.5.3
114 , squeal-postgresql
66 , squeal-postgresql
115− , time >= 1.8.0.2
116
67
117−test-suite spec
68+test-suite squeal-postgresql-doctest
118 default-language: Haskell2010
69 default-language: Haskell2010
119 type: exitcode-stdio-1.0
70 type: exitcode-stdio-1.0
120 hs-source-dirs: test
71 hs-source-dirs: test
121− ghc-options: -Wall
72+ ghc-options: -Wall -Werror
122− main-is: Spec.hs
73+ main-is: DocTest.hs
123 build-depends:
74 build-depends:
124− base >= 4.10.0.0
75+ base >= 4.10.0.0 && < 5
125− , async >= 2.2.2
76+ , doctest >= 0.11.4 && < 1
126− , bytestring >= 0.10.8.2
127− , generics-sop >= 0.3.1.0
128− , hspec >= 2.4.8
129− , mtl >= 2.2.2
130− , squeal-postgresql
131− , text >= 1.2.2.2
132− , vector >= 0.12.0.1
133
77
134−executable example
78+executable squeal-postgresql-example
135 default-language: Haskell2010
79 default-language: Haskell2010
136 hs-source-dirs: exe
80 hs-source-dirs: exe
137− ghc-options: -Wall
81+ ghc-options: -Wall -Werror
138 main-is: Example.hs
82 main-is: Example.hs
139 build-depends:
83 build-depends:
140− base >= 4.10.0.0 && < 5.0
84+ base >= 4.10.0.0 && < 5
141− , bytestring >= 0.10.8.2
85+ , bytestring >= 0.10.8.2 && < 1
142− , generics-sop >= 0.3.1.0
86+ , generics-sop >= 0.3.1.0 && < 1
143− , mtl >= 2.2.1
87+ , mtl >= 2.2.1 && < 3
144 , squeal-postgresql
88 , squeal-postgresql
145− , text >= 1.2.2.2
146− , transformers >= 0.5.2.0
89+ , transformers >= 0.5.2.0 && < 1
147− , vector >= 0.12.0.1
90+ , transformers-base >= 0.4.4 && < 1
squeal-postgresql/src/Squeal/PostgreSQL.hs+20−226
@@ -1,233 +1,27 @@
1{-|
1{-|
2Module: Squeal.PostgreSQL
2Module: Squeal.PostgreSQL
3−Description: Squeal export module
3+Description: Squeel export module
4−Copyright: (c) Eitan Chatav, 2019
4+Copyright: (c) Eitan Chatav, 2017
5Maintainer: eitan@morphism.tech
5Maintainer: eitan@morphism.tech
6Stability: experimental
6Stability: experimental
7
7
8−Squeal is a deep embedding of [PostgreSQL](https://www.postgresql.org) in Haskell.
8+`Squeal.PostgreSQL` re-exports @squeel-postgresql@'s main modules.
9−Let's see an example!
10−
11−First, we need some language extensions because Squeal uses modern GHC
12−features.
13−
14−>>> :set -XDataKinds -XDeriveGeneric -XOverloadedLabels -XFlexibleContexts
15−>>> :set -XOverloadedStrings -XTypeApplications -XTypeOperators -XGADTs
16−
17−We'll need some imports.
18−
19−>>> import Control.Monad.IO.Class (liftIO)
20−>>> import Data.Int (Int32)
21−>>> import Data.Text (Text)
22−>>> import Squeal.PostgreSQL
23−
24−We'll use generics to easily convert between Haskell and PostgreSQL values.
25−
26−>>> import qualified Generics.SOP as SOP
27−>>> import qualified GHC.Generics as GHC
28−
29−The first step is to define the schema of our database. This is where
30−we use @DataKinds@ and @TypeOperators@.
31−
32−>>> :{
33−type UsersColumns =
34− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
35− , "name" ::: 'NoDef :=> 'NotNull 'PGtext ]
36−type UsersConstraints = '[ "pk_users" ::: 'PrimaryKey '["id"] ]
37−type EmailsColumns =
38− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
39− , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
40− , "email" ::: 'NoDef :=> 'Null 'PGtext ]
41−type EmailsConstraints =
42− '[ "pk_emails" ::: 'PrimaryKey '["id"]
43− , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"] ]
44−type Schema =
45− '[ "users" ::: 'Table (UsersConstraints :=> UsersColumns)
46− , "emails" ::: 'Table (EmailsConstraints :=> EmailsColumns) ]
47−type Schemas = Public Schema
48−:}
49−
50−Notice the use of type operators.
51−
52−`:::` is used to pair an alias `GHC.TypeLits.Symbol` with a `SchemasType`, a `SchemumType`,
53−a `TableConstraint` or a `ColumnType`. It is intended to connote Haskell's @::@
54−operator.
55−
56−`:=>` is used to pair `TableConstraints` with a `ColumnsType`,
57−yielding a `TableType`, or to pair a `ColumnConstraint` with a `NullityType`,
58−yielding a `ColumnType`. It is intended to connote Haskell's @=>@ operator
59−
60−Next, we'll write `Definition`s to set up and tear down the schema. In
61−Squeal, a `Definition` like `createTable`, `alterTable` or `dropTable`
62−has two type parameters, corresponding to the schema
63−before being run and the schema after. We can compose definitions using `>>>`.
64−Here and in the rest of our commands we make use of overloaded
65−labels to refer to named tables and columns in our schema.
66−
67−>>> :{
68−let
69− setup :: Definition (Public '[]) Schemas
70− setup =
71− createTable #users
72− ( serial `as` #id :*
73− (text & notNullable) `as` #name )
74− ( primaryKey #id `as` #pk_users ) >>>
75− createTable #emails
76− ( serial `as` #id :*
77− (int & notNullable) `as` #user_id :*
78− (text & nullable) `as` #email )
79− ( primaryKey #id `as` #pk_emails :*
80− foreignKey #user_id #users #id
81− OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
82−:}
83−
84−We can easily see the generated SQL is unsurprising looking.
85−
86−>>> printSQL setup
87−CREATE TABLE "users" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_users" PRIMARY KEY ("id"));
88−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);
89−
90−Notice that @setup@ starts with an empty public schema @(Public '[])@ and produces @Schemas@.
91−In our `createTable` commands we included `TableConstraint`s to define
92−primary and foreign keys, making them somewhat complex. Our @teardown@
93−`Definition` is simpler.
94−
95−>>> :{
96−let
97− teardown :: Definition Schemas (Public '[])
98− teardown = dropTable #emails >>> dropTable #users
99−:}
100−
101−>>> printSQL teardown
102−DROP TABLE "emails";
103−DROP TABLE "users";
104−
105−We'll need a Haskell type for @User@s. We give the type `Generics.SOP.Generic` and
106−`Generics.SOP.HasDatatypeInfo` instances so that we can encode and decode @User@s.
107−
108−>>> data User = User { userName :: Text, userEmail :: Maybe Text } deriving (Show, GHC.Generic)
109−>>> instance SOP.Generic User
110−>>> instance SOP.HasDatatypeInfo User
111−
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−
123−>>> :{
124−let
125− insertUser :: Manipulation_ Schemas User ()
126− insertUser = with (u `as` #u) e
127− where
128− u = insertInto #users
129− (Values_ (Default `as` #id :* Set (param @1) `as` #name))
130− OnConflictDoRaise (Returning_ (#id :* param @2 `as` #email))
131− e = insertInto_ #emails $ Select
132− (Default `as` #id :* Set (#u ! #id) `as` #user_id :* Set (#u ! #email) `as` #email)
133− (from (common #u))
134−:}
135−
136−>>> printSQL insertUser
137−WITH "u" AS (INSERT INTO "users" ("id", "name") VALUES (DEFAULT, ($1 :: text)) RETURNING "id" AS "id", ($2 :: text) AS "email") INSERT INTO "emails" ("user_id", "email") SELECT "u"."id", "u"."email" FROM "u" AS "u"
138−
139−Next we write a `Query_` to retrieve users from the database. We're not
140−interested in the ids here, just the usernames and email addresses. We
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.
143−
144−>>> :{
145−let
146− getUsers :: Query_ Schemas () User
147− getUsers = select_
148− (#u ! #name `as` #userName :* #e ! #email `as` #userEmail)
149− ( from (table (#users `as` #u)
150− & innerJoin (table (#emails `as` #e))
151− (#u ! #id .== #e ! #user_id)) )
152−:}
153−
154−>>> printSQL getUsers
155−SELECT "u"."name" AS "userName", "e"."email" AS "userEmail" FROM "users" AS "u" INNER JOIN "emails" AS "e" ON ("u"."id" = "e"."user_id")
156−
157−Let's create some users to add to the database.
158−
159−>>> :{
160−let
161− users :: [User]
162− users =
163− [ User "Alice" (Just "alice@gmail.com")
164− , User "Bob" Nothing
165− , User "Carole" (Just "carole@hotmail.com")
166− ]
167−:}
168−
169−Now we can put together all the pieces into a program. The program
170−connects to the database, sets up the schema, inserts the user data
171−(using prepared statements as an optimization), queries the user
172−data and prints it out and finally closes the connection. We can thread
173−the changing schema information through by using the indexed `PQ` monad
174−transformer and when the schema doesn't change we can use `Monad` and
175−`MonadPQ` functionality.
176−
177−>>> :{
178−let
179− session :: PQ Schemas Schemas IO ()
180− session = do
181− _ <- traversePrepared_ insertUser users
182− usersResult <- runQuery getUsers
183− usersRows <- getRows usersResult
184− liftIO $ print (usersRows :: [User])
185−in
186− withConnection "host=localhost port=5432 dbname=exampledb" $
187− define setup
188− & pqThen session
189− & pqThen (define teardown)
190−:}
191−[User {userName = "Alice", userEmail = Just "alice@gmail.com"},User {userName = "Bob", userEmail = Nothing},User {userName = "Carole", userEmail = Just "carole@hotmail.com"}]
192-}
9-}
193−module Squeal.PostgreSQL (module X, RenderSQL(..), printSQL) where
194
10
195−import Squeal.PostgreSQL.Alias as X
11+module Squeal.PostgreSQL
196−import Squeal.PostgreSQL.Binary as X
12+ ( module Squeal.PostgreSQL.Binary
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
13+ , module Squeal.PostgreSQL.Definition
204−import Squeal.PostgreSQL.Definition.View as X
205−import Squeal.PostgreSQL.Expression as X
14+ , module Squeal.PostgreSQL.Expression
206−import Squeal.PostgreSQL.Expression.Aggregate as X
207−import Squeal.PostgreSQL.Expression.Collection as X
15+ , module Squeal.PostgreSQL.Manipulation
208−import Squeal.PostgreSQL.Expression.Comparison as X
209−import Squeal.PostgreSQL.Expression.Json as X
16+ , module Squeal.PostgreSQL.PQ
210−import Squeal.PostgreSQL.Expression.Literal as X
211−import Squeal.PostgreSQL.Expression.Logic as X
17+ , module Squeal.PostgreSQL.Query
212−import Squeal.PostgreSQL.Expression.Math as X
213−import Squeal.PostgreSQL.Expression.Null as X
18+ , module Squeal.PostgreSQL.Schema
214−import Squeal.PostgreSQL.Expression.Parameter as X
19+ ) where
215−import Squeal.PostgreSQL.Expression.Range as X
20+
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
21+import Squeal.PostgreSQL.Binary
222−import Squeal.PostgreSQL.Expression.Type as X
22+import Squeal.PostgreSQL.Definition
223−import Squeal.PostgreSQL.Expression.Window as X
23+import Squeal.PostgreSQL.Expression
224−import Squeal.PostgreSQL.List as X
225−import Squeal.PostgreSQL.Manipulation as X
24+import Squeal.PostgreSQL.Manipulation
226−import Squeal.PostgreSQL.Migration as X
227−import Squeal.PostgreSQL.PG as X
228−import Squeal.PostgreSQL.Pool as X
25+import Squeal.PostgreSQL.PQ
229−import Squeal.PostgreSQL.PQ as X
230−import Squeal.PostgreSQL.Query as X
26+import Squeal.PostgreSQL.Query
231−import Squeal.PostgreSQL.Render (RenderSQL(..), printSQL)
27+import Squeal.PostgreSQL.Schema
232−import Squeal.PostgreSQL.Schema as X
233−import Squeal.PostgreSQL.Transaction as X
squeal-postgresql/src/Squeal/PostgreSQL/Alias.hsdeleted−249
@@ -1,249 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Alias
3−Description: Aliases
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−This module embeds Postgres's alias system in Haskell in
9−a typesafe fashion. Thanks to GHC's @OverloadedLabels@ extension,
10−Squeal can reference aliases by prepending with a @#@.
11−-}
12−
13−{-# LANGUAGE
14− AllowAmbiguousTypes
15− , ConstraintKinds
16− , DeriveAnyClass
17− , DeriveGeneric
18− , FlexibleContexts
19− , FlexibleInstances
20− , FunctionalDependencies
21− , GADTs
22− , LambdaCase
23− , OverloadedStrings
24− , QuantifiedConstraints
25− , RankNTypes
26− , ScopedTypeVariables
27− , StandaloneDeriving
28− , TypeApplications
29− , TypeFamilyDependencies
30− , TypeInType
31− , TypeOperators
32− , UndecidableInstances
33− , UndecidableSuperClasses
34−#-}
35−
36−module Squeal.PostgreSQL.Alias
37− ( (:::)
38− , Alias (..)
39− , IsLabel (..)
40− , Aliased (As)
41− , Aliasable (as)
42− , renderAliased
43− , Has
44− , HasUnique
45− , HasAll
46− , HasIn
47− , QualifiedAlias (..)
48− , IsQualified (..)
49− -- * Grouping
50− , Grouping (..)
51− , GroupedBy
52− ) where
53−
54−import Control.DeepSeq
55−import Data.ByteString (ByteString)
56−import Data.String (fromString)
57−import GHC.OverloadedLabels
58−import GHC.TypeLits
59−
60−import qualified Generics.SOP as SOP
61−import qualified GHC.Generics as GHC
62−
63−import Squeal.PostgreSQL.List
64−import Squeal.PostgreSQL.Render
65−
66−-- $setup
67−-- >>> import Squeal.PostgreSQL
68−
69−-- | The alias operator `:::` is like a promoted version of `As`,
70−-- a type level pair between an alias and some type.
71−type (:::) (alias :: Symbol) ty = '(alias,ty)
72−infixr 6 :::
73−
74−
75−-- | `Grouping` is an auxiliary namespace, created by
76−-- @GROUP BY@ clauses (`Squeal.PostgreSQL.Query.group`), and used
77−-- for typesafe aggregation
78−data Grouping
79− = Ungrouped -- ^ no aggregation permitted
80− | Grouped [(Symbol,Symbol)] -- ^ aggregation required for any column which is not grouped
81−
82−{- | A `GroupedBy` constraint indicates that a table qualified column is
83−a member of the auxiliary namespace created by @GROUP BY@ clauses and thus,
84−may be called in an output `Squeal.PostgreSQL.Expression.Expression` without aggregating.
85−-}
86−class (KnownSymbol table, KnownSymbol column)
87− => GroupedBy table column bys where
88−instance {-# OVERLAPPING #-} (KnownSymbol table, KnownSymbol column)
89− => GroupedBy table column ('(table,column) ': bys)
90−instance {-# OVERLAPPABLE #-}
91− ( KnownSymbol table
92− , KnownSymbol column
93− , GroupedBy table column bys
94− ) => GroupedBy table column (tabcol ': bys)
95−
96−-- | `Alias`es are proxies for a type level string or `Symbol`
97−-- and have an `IsLabel` instance so that with @-XOverloadedLabels@
98−--
99−-- >>> :set -XOverloadedLabels
100−-- >>> #foobar :: Alias "foobar"
101−-- Alias
102−data Alias (alias :: Symbol) = Alias
103− deriving (Eq,GHC.Generic,Ord,Show,NFData)
104−instance alias1 ~ alias2 => IsLabel alias1 (Alias alias2) where
105− fromLabel = Alias
106−instance aliases ~ '[alias] => IsLabel alias (NP Alias aliases) where
107− fromLabel = fromLabel SOP.:* Nil
108−-- | >>> printSQL (#jimbob :: Alias "jimbob")
109−-- "jimbob"
110−instance KnownSymbol alias => RenderSQL (Alias alias) where
111− renderSQL = doubleQuoted . fromString . symbolVal
112−
113−-- >>> printSQL (#jimbob :* #kandi :: NP Alias '["jimbob", "kandi"])
114−-- "jimbob", "kandi"
115−instance SOP.All KnownSymbol aliases => RenderSQL (NP Alias aliases) where
116− renderSQL
117− = commaSeparated
118− . SOP.hcollapse
119− . SOP.hcmap (SOP.Proxy @KnownSymbol) (SOP.K . renderSQL)
120−
121−-- | The `As` operator is used to name an expression. `As` is like a demoted
122−-- version of `:::`.
123−--
124−-- >>> Just "hello" `As` #hi :: Aliased Maybe ("hi" ::: String)
125−-- As (Just "hello") Alias
126−data Aliased expression aliased where
127− As
128− :: KnownSymbol alias
129− => expression ty
130− -> Alias alias
131− -> Aliased expression (alias ::: ty)
132−deriving instance Show (expression ty)
133− => Show (Aliased expression (alias ::: ty))
134−deriving instance Eq (expression ty)
135− => Eq (Aliased expression (alias ::: ty))
136−deriving instance Ord (expression ty)
137− => Ord (Aliased expression (alias ::: ty))
138−instance (alias0 ~ alias1, alias0 ~ alias2, KnownSymbol alias2)
139− => IsLabel alias0 (Aliased Alias (alias1 ::: alias2)) where
140− fromLabel = fromLabel @alias2 `As` fromLabel @alias1
141−
142−-- | The `Aliasable` class provides a way to scrap your `Nil`s
143−-- in an `NP` list of `Aliased` expressions.
144−class KnownSymbol alias => Aliasable alias expression aliased
145− | aliased -> expression
146− , aliased -> alias
147− where as :: expression -> Alias alias -> aliased
148−instance (KnownSymbol alias, aliased ~ (alias ::: ty)) => Aliasable alias
149− (expression ty)
150− (Aliased expression aliased)
151− where
152− as = As
153−instance (KnownSymbol alias, tys ~ '[alias ::: ty]) => Aliasable alias
154− (expression ty)
155− (NP (Aliased expression) tys)
156− where
157− expression `as` alias = expression `As` alias SOP.:* Nil
158−
159−-- | >>> let renderMaybe = fromString . maybe "Nothing" (const "Just")
160−-- >>> renderAliased renderMaybe (Just (3::Int) `As` #an_int)
161−-- "Just AS \"an_int\""
162−renderAliased
163− :: (forall ty. expression ty -> ByteString)
164− -> Aliased expression aliased
165− -> ByteString
166−renderAliased render (expression `As` alias) =
167− render expression <> " AS " <> renderSQL alias
168−
169−-- | @HasUnique alias fields field@ is a constraint that proves that
170−-- @fields@ is a singleton of @alias ::: field@.
171−type HasUnique alias fields field = fields ~ '[alias ::: field]
172−
173−-- | @Has alias fields field@ is a constraint that proves that
174−-- @fields@ has a field of @alias ::: field@, inferring @field@
175−-- from @alias@ and @fields@.
176−class KnownSymbol alias =>
177− Has (alias :: Symbol) (fields :: [(Symbol,kind)]) (field :: kind)
178− | alias fields -> field where
179−instance {-# OVERLAPPING #-} KnownSymbol alias
180− => Has alias (alias ::: field ': fields) field
181−instance {-# OVERLAPPABLE #-} (KnownSymbol alias, Has alias fields field)
182− => Has alias (field' ': fields) field
183−
184−{-| @HasIn fields (alias ::: field)@ is a constraint that proves that
185−@fields@ has a field of @alias ::: field@. It is used in @UPDATE@s to
186−choose which subfields to update.
187−-}
188−class HasIn fields field where
189−instance (Has alias fields field) => HasIn fields (alias ::: field) where
190−
191−-- | `HasAll` extends `Has` to take lists of @aliases@ and @fields@ and infer
192−-- a list of @subfields@.
193−class
194− ( SOP.All KnownSymbol aliases
195− ) => HasAll
196− (aliases :: [Symbol])
197− (fields :: [(Symbol,kind)])
198− (subfields :: [(Symbol,kind)])
199− | aliases fields -> subfields where
200−instance {-# OVERLAPPING #-} HasAll '[] fields '[]
201−instance {-# OVERLAPPABLE #-}
202− (Has alias fields field, HasAll aliases fields subfields)
203− => HasAll (alias ': aliases) fields (alias ::: field ': subfields)
204−
205−-- | Analagous to `IsLabel`, the constraint
206−-- `IsQualified` defines `!` for a column alias qualified
207−-- by a table alias.
208−class IsQualified table column expression where
209− (!) :: Alias table -> Alias column -> expression
210− infixl 9 !
211−instance IsQualified table column (Alias table, Alias column) where (!) = (,)
212−
213−{-| `QualifiedAlias`es enables multi-schema support by allowing a reference
214−to a `Squeal.PostgreSQL.Schema.Table`, `Squeal.PostgreSQL.Schema.Typedef`
215−or `Squeal.PostgreSQL.Schema.View` to be qualified by their schemas. By default,
216−a qualifier of @public@ is provided.
217−
218−>>> :{
219−let
220− alias1 :: QualifiedAlias "sch" "tab"
221− alias1 = #sch ! #tab
222− alias2 :: QualifiedAlias "public" "vw"
223− alias2 = #vw
224−in printSQL alias1 >> printSQL alias2
225−:}
226−"sch"."tab"
227−"vw"
228−-}
229−data QualifiedAlias (qualifier :: Symbol) (alias :: Symbol) = QualifiedAlias
230− deriving (Eq,GHC.Generic,Ord,Show,NFData)
231−instance (q ~ q', a ~ a') => IsQualified q a (QualifiedAlias q' a') where
232− _!_ = QualifiedAlias
233−instance (q' ~ "public", a ~ a') => IsLabel a (QualifiedAlias q' a') where
234− fromLabel = QualifiedAlias
235−instance (q0 ~ q1, a0 ~ a1, a1 ~ a2, KnownSymbol a2) =>
236− IsQualified q0 a0 (Aliased (QualifiedAlias q1) (a1 ::: a2)) where
237− _!_ = QualifiedAlias `As` Alias
238−instance (q ~ "public", a0 ~ a1, a1 ~ a2, KnownSymbol a2) =>
239− IsLabel a0 (Aliased (QualifiedAlias q) (a1 ::: a2)) where
240− fromLabel = QualifiedAlias `As` Alias
241−
242−instance (KnownSymbol q, KnownSymbol a)
243− => RenderSQL (QualifiedAlias q a) where
244− renderSQL _ =
245− let
246− qualifier = renderSQL (Alias @q)
247− alias = renderSQL (Alias @a)
248− in
249− if qualifier == "\"public\"" then alias else qualifier <> "." <> alias
squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs+124−714
@@ -5,192 +5,22 @@ Copyright: (c) Eitan Chatav, 2017
5Maintainer: eitan@morphism.tech
5Maintainer: eitan@morphism.tech
6Stability: experimental
6Stability: experimental
7
7
8−This module provides binary encoding and decoding between Haskell and PostgreSQL types.
8+Binary encoding and decoding between Haskell and PostgreSQL types.
9−
10−Instances are governed by the `SOP.Generic` and `SOP.HasDatatypeInfo` typeclasses, so you absolutely
11−do not need to define your own instances to decode retrieved rows into Haskell values or
12−to encode Haskell values into statement parameters.
13−
14−Let's see some examples. We'll need some imports
15−
16−>>> import Data.Int (Int16)
17−>>> import Data.Text (Text)
18−>>> import Control.Monad (void)
19−>>> import Control.Monad.IO.Class (liftIO)
20−>>> import Squeal.PostgreSQL
21−
22−Define a Haskell datatype @Row@ that will serve as both the input and output of a simple
23−round trip query.
24−
25−>>> data Row = Row { col1 :: Int16, col2 :: Text, col3 :: Maybe Bool } deriving (Eq, GHC.Generic)
26−>>> instance Generic Row
27−>>> instance HasDatatypeInfo Row
28−>>> :{
29−let
30− roundTrip :: Query_ (Public '[]) Row Row
31− roundTrip = values_ $
32− parameter @1 int2 `as` #col1 :*
33− parameter @2 text `as` #col2 :*
34− parameter @3 bool `as` #col3
35−:}
36−
37−So long as we can encode the parameters and then decode the result of the query,
38−the input and output should be equal.
39−
40−>>> let input = Row 2 "hi" (Just True)
41−>>> :{
42−withConnection "host=localhost port=5432 dbname=exampledb" $ do
43− result <- runQueryParams roundTrip input
44− Just output <- firstRow result
45− liftIO . print $ input == output
46−:}
47−True
48−
49−In addition to being able to encode and decode basic Haskell types
50−like `Int16` and `Data.Text.Text`, Squeal permits you to encode and decode Haskell types to
51−Postgres array, enumerated and composite types and json. Let's see another example,
52−this time using the `Vector` type which corresponds to variable length arrays
53−and homogeneous tuples which correspond to fixed length arrays. We can even
54−create multi-dimensional fixed length arrays.
55−
56−>>> :{
57−data Row = Row
58− { col1 :: VarArray (Vector Int16)
59− , col2 :: FixArray (Maybe Int16,Maybe Int16)
60− , col3 :: FixArray ((Int16,Int16),(Int16,Int16),(Int16,Int16))
61− } deriving (Eq, GHC.Generic)
62−:}
63−
64−>>> instance Generic Row
65−>>> instance HasDatatypeInfo Row
66−
67−Once again, we define a simple round trip query.
68−
69−>>> :{
70−let
71− roundTrip :: Query_ (Public '[]) Row Row
72− roundTrip = values_ $
73− parameter @1 (int2 & vararray) `as` #col1 :*
74− parameter @2 (int2 & fixarray @'[2]) `as` #col2 :*
75− parameter @3 (int2 & fixarray @'[3,2]) `as` #col3
76−:}
77−
78−>>> :set -XOverloadedLists
79−>>> let input = Row (VarArray [1,2]) (FixArray (Just 1,Nothing)) (FixArray ((1,2),(3,4),(5,6)))
80−>>> :{
81−withConnection "host=localhost port=5432 dbname=exampledb" $ do
82− result <- runQueryParams roundTrip input
83− Just output <- firstRow result
84− liftIO . print $ input == output
85−:}
86−True
87−
88−Enumerated (enum) types are data types that comprise a static, ordered set of values.
89−They are equivalent to Haskell algebraic data types whose constructors are nullary.
90−An example of an enum type might be the days of the week,
91−or a set of status values for a piece of data.
92−
93−>>> data Schwarma = Beef | Lamb | Chicken deriving (Eq, Show, GHC.Generic)
94−>>> instance Generic Schwarma
95−>>> instance HasDatatypeInfo Schwarma
96−
97−A composite type represents the structure of a row or record;
98−it is essentially just a list of field names and their data types.
99−
100−>>> data Person = Person {name :: Text, age :: Int32} deriving (Eq, Show, GHC.Generic)
101−>>> instance Generic Person
102−>>> instance HasDatatypeInfo Person
103−>>> instance Aeson.FromJSON Person
104−>>> instance Aeson.ToJSON Person
105−
106−We can create the equivalent Postgres types directly from their Haskell types.
107−
108−>>> :{
109−type Schema =
110− '[ "schwarma" ::: 'Typedef (PG (Enumerated Schwarma))
111− , "person" ::: 'Typedef (PG (Composite Person))
112− ]
113−:}
114−
115−>>> :{
116−let
117− setup :: Definition (Public '[]) (Public Schema)
118− setup =
119− createTypeEnumFrom @Schwarma #schwarma >>>
120− createTypeCompositeFrom @Person #person
121−:}
122−
123−Let's demonstrate how to associate our Haskell types @Schwarma@ and @Person@
124−with enumerated, composite or json types in Postgres. First create a Haskell
125−@Row@ type using the `Enumerated`, `Composite` and `Json` newtypes as fields.
126−
127−>>> :{
128−data Row = Row
129− { schwarma :: Enumerated Schwarma
130− , person1 :: Composite Person
131− , person2 :: Json Person
132− } deriving (Eq, GHC.Generic)
133−:}
134−
135−>>> instance Generic Row
136−>>> instance HasDatatypeInfo Row
137−>>> :{
138−let
139− input = Row
140− (Enumerated Chicken)
141− (Composite (Person "Faisal" 24))
142− (Json (Person "Ahmad" 48))
143−:}
144−
145−Once again, define a round trip query.
146−
147−>>> :{
148−let
149− roundTrip :: Query_ (Public Schema) Row Row
150− roundTrip = values_ $
151− parameter @1 (typedef #schwarma) `as` #schwarma :*
152− parameter @2 (typedef #person) `as` #person1 :*
153− parameter @3 json `as` #person2
154−:}
155−
156−Finally, we can drop our type definitions.
157−
158−>>> :{
159−let
160− teardown :: Definition (Public Schema) (Public '[])
161− teardown = dropType #schwarma >>> dropType #person
162−:}
163−
164−Now let's run it.
165−
166−>>> :{
167−let
168− session = do
169− result <- runQueryParams roundTrip input
170− Just output <- firstRow result
171− liftIO . print $ input == output
172−in
173− withConnection "host=localhost port=5432 dbname=exampledb" $
174− define setup
175− & pqThen session
176− & pqThen (define teardown)
177−:}
178−True
179-}
9-}
180
10
181{-# LANGUAGE
11{-# LANGUAGE
182− AllowAmbiguousTypes
12+ ConstraintKinds
13+ , DataKinds
14+ , DefaultSignatures
183 , DeriveFoldable
15 , DeriveFoldable
184 , DeriveFunctor
16 , DeriveFunctor
185 , DeriveGeneric
17 , DeriveGeneric
186 , DeriveTraversable
18 , DeriveTraversable
187− , DefaultSignatures
188 , FlexibleContexts
19 , FlexibleContexts
189 , FlexibleInstances
20 , FlexibleInstances
190− , FunctionalDependencies
191 , GADTs
21 , GADTs
192 , LambdaCase
22 , LambdaCase
193− , OverloadedStrings
23+ , KindSignatures
194 , MultiParamTypeClasses
24 , MultiParamTypeClasses
195 , ScopedTypeVariables
25 , ScopedTypeVariables
196 , TypeApplications
26 , TypeApplications
@@ -198,62 +28,40 @@ True
198 , TypeInType
28 , TypeInType
199 , TypeOperators
29 , TypeOperators
200 , UndecidableInstances
30 , UndecidableInstances
201− , UndecidableSuperClasses
202#-}
31#-}
203
32
204module Squeal.PostgreSQL.Binary
33module Squeal.PostgreSQL.Binary
205 ( -- * Encoding
34 ( -- * Encoding
206 ToParam (..)
35 ToParam (..)
36+ , ToColumnParam (..)
207 , ToParams (..)
37 , ToParams (..)
208− , ToNullityParam (..)
209− , ToField (..)
210− , ToFixArray (..)
211 -- * Decoding
38 -- * Decoding
212 , FromValue (..)
39 , FromValue (..)
40+ , FromColumnValue (..)
213 , FromRow (..)
41 , FromRow (..)
214− , FromField (..)
215− , FromFixArray (..)
216 -- * Only
42 -- * Only
217 , Only (..)
43 , Only (..)
218− -- * Oid
219− , OidOf (..)
220− , OidOfParam (..)
221− , OidOfField (..)
222 ) where
44 ) where
223
45
224−import BinaryParser
46+import Data.Aeson hiding (Null)
225−import ByteString.StrictBuilder (builderLength, int32BE, int64BE, word32BE)
226−import Control.Arrow (left)
227−import Control.Monad
228import Data.Int
47import Data.Int
229import Data.Kind
48import Data.Kind
230import Data.Scientific
49import Data.Scientific
231import Data.Time
50import Data.Time
232−import Data.UUID.Types
51+import Data.UUID
233−import Data.Vector (Vector)
234import Data.Word
52import Data.Word
235−import Foreign.C.Types (CUInt(CUInt))
236import Generics.SOP
53import Generics.SOP
237−import Generics.SOP.Record
238import GHC.TypeLits
54import GHC.TypeLits
239import Network.IP.Addr
55import Network.IP.Addr
240
56
241−import qualified Data.Aeson as Aeson
57+import qualified Data.ByteString.Lazy as Lazy
242−import qualified Data.ByteString.Lazy as Lazy (ByteString)
243−import qualified Data.ByteString.Lazy as Lazy.ByteString
58+import qualified Data.ByteString as Strict hiding (unpack)
244−import qualified Data.ByteString as Strict (ByteString)
245−import qualified Data.Text.Lazy as Lazy (Text)
59+import qualified Data.Text.Lazy as Lazy
246−import qualified Data.Text as Strict (Text)
247−import qualified Data.Text as Strict.Text
60+import qualified Data.Text as Strict
248−import qualified Data.Vector as Vector
249−import qualified Database.PostgreSQL.LibPQ as LibPQ
250import qualified GHC.Generics as GHC
61import qualified GHC.Generics as GHC
251import qualified PostgreSQL.Binary.Decoding as Decoding
62import qualified PostgreSQL.Binary.Decoding as Decoding
252import qualified PostgreSQL.Binary.Encoding as Encoding
63import qualified PostgreSQL.Binary.Encoding as Encoding
253
64
254−import Squeal.PostgreSQL.Alias
255−import Squeal.PostgreSQL.List
256−import Squeal.PostgreSQL.PG
257import Squeal.PostgreSQL.Schema
65import Squeal.PostgreSQL.Schema
258
66
259-- | A `ToParam` constraint gives an encoding of a Haskell `Type` into
67-- | A `ToParam` constraint gives an encoding of a Haskell `Type` into
@@ -277,20 +85,19 @@ class ToParam (x :: Type) (pg :: PGType) where
277 toParam :: x -> K Encoding.Encoding pg
85 toParam :: x -> K Encoding.Encoding pg
278instance ToParam Bool 'PGbool where toParam = K . Encoding.bool
86instance ToParam Bool 'PGbool where toParam = K . Encoding.bool
279instance ToParam Int16 'PGint2 where toParam = K . Encoding.int2_int16
87instance ToParam Int16 'PGint2 where toParam = K . Encoding.int2_int16
88+instance ToParam Word16 'PGint2 where toParam = K . Encoding.int2_word16
280instance ToParam Int32 'PGint4 where toParam = K . Encoding.int4_int32
89instance ToParam Int32 'PGint4 where toParam = K . Encoding.int4_int32
90+instance ToParam Word32 'PGint4 where toParam = K . Encoding.int4_word32
281instance ToParam Int64 'PGint8 where toParam = K . Encoding.int8_int64
91instance ToParam Int64 'PGint8 where toParam = K . Encoding.int8_int64
282−instance ToParam Oid 'PGoid where toParam = K . Encoding.int4_word32 . getOid
92+instance ToParam Word64 'PGint8 where toParam = K . Encoding.int8_word64
283instance ToParam Float 'PGfloat4 where toParam = K . Encoding.float4
93instance ToParam Float 'PGfloat4 where toParam = K . Encoding.float4
284instance ToParam Double 'PGfloat8 where toParam = K . Encoding.float8
94instance ToParam Double 'PGfloat8 where toParam = K . Encoding.float8
285instance ToParam Scientific 'PGnumeric where toParam = K . Encoding.numeric
95instance ToParam Scientific 'PGnumeric where toParam = K . Encoding.numeric
286−instance ToParam Money 'PGmoney where toParam = K . Encoding.int8_int64 . cents
287instance ToParam UUID 'PGuuid where toParam = K . Encoding.uuid
96instance ToParam UUID 'PGuuid where toParam = K . Encoding.uuid
288instance ToParam (NetAddr IP) 'PGinet where toParam = K . Encoding.inet
97instance ToParam (NetAddr IP) 'PGinet where toParam = K . Encoding.inet
289instance ToParam Char ('PGchar 1) where toParam = K . Encoding.char_utf8
98instance ToParam Char ('PGchar 1) where toParam = K . Encoding.char_utf8
290instance ToParam Strict.Text 'PGtext where toParam = K . Encoding.text_strict
99instance ToParam Strict.Text 'PGtext where toParam = K . Encoding.text_strict
291instance ToParam Lazy.Text 'PGtext where toParam = K . Encoding.text_lazy
100instance ToParam Lazy.Text 'PGtext where toParam = K . Encoding.text_lazy
292−instance ToParam String 'PGtext where
293− toParam = K . Encoding.text_strict . Strict.Text.pack
294instance ToParam Strict.ByteString 'PGbytea where
101instance ToParam Strict.ByteString 'PGbytea where
295 toParam = K . Encoding.bytea_strict
102 toParam = K . Encoding.bytea_strict
296instance ToParam Lazy.ByteString 'PGbytea where
103instance ToParam Lazy.ByteString 'PGbytea where
@@ -304,545 +111,148 @@ instance ToParam LocalTime 'PGtimestamp where
304instance ToParam UTCTime 'PGtimestamptz where
111instance ToParam UTCTime 'PGtimestamptz where
305 toParam = K . Encoding.timestamptz_int
112 toParam = K . Encoding.timestamptz_int
306instance ToParam DiffTime 'PGinterval where toParam = K . Encoding.interval_int
113instance ToParam DiffTime 'PGinterval where toParam = K . Encoding.interval_int
307−instance ToParam Aeson.Value 'PGjson where toParam = K . Encoding.json_ast
114+instance ToParam Value 'PGjson where toParam = K . Encoding.json_ast
308−instance ToParam Aeson.Value 'PGjsonb where toParam = K . Encoding.jsonb_ast
115+instance ToParam Value 'PGjsonb where toParam = K . Encoding.jsonb_ast
309−instance Aeson.ToJSON x => ToParam (Json x) 'PGjson where
116+
310− toParam = K . Encoding.json_bytes
117+-- | A `ToColumnParam` constraint lifts the `ToParam` encoding
311− . Lazy.ByteString.toStrict . Aeson.encode . getJson
118+-- of a `Type` to a `ColumnType`, encoding `Maybe`s to `Null`s.
312−instance Aeson.ToJSON x => ToParam (Jsonb x) 'PGjsonb where
119+class ToColumnParam (x :: Type) (ty :: ColumnType) where
313− toParam = K . Encoding.jsonb_bytes
120+ -- | >>> toColumnParam @Int16 @('Required ('NotNull 'PGint2)) 0
314− . Lazy.ByteString.toStrict . Aeson.encode . getJsonb
121+ -- K (Just "\NUL\NUL")
315−instance (ToNullityParam x ty, ty ~ nullity pg, OidOf pg)
122+ --
316− => ToParam (VarArray [x]) ('PGvararray ty) where
123+ -- >>> toColumnParam @(Maybe Int16) @('Required ('Null 'PGint2)) (Just 0)
317− toParam = K
124+ -- K (Just "\NUL\NUL")
318− . Encoding.array_foldable
125+ --
319− (getOid (oidOf @pg)) (unK . toNullityParam @x @ty)
126+ -- >>> toColumnParam @(Maybe Int16) @('Required ('Null 'PGint2)) Nothing
320− . getVarArray
127+ -- K Nothing
321−instance (ToParam x pg, OidOf pg)
128+ toColumnParam :: x -> K (Maybe Strict.ByteString) ty
322− => ToParam (VarArray (Vector x)) ('PGvararray ('NotNull pg)) where
323− toParam = K
324− . Encoding.array_vector (getOid (oidOf @pg)) (unK . toParam @x @pg)
325− . getVarArray
326−instance (ToParam x pg, OidOf pg)
327− => ToParam (VarArray (Vector (Maybe x))) ('PGvararray ('Null pg)) where
328− toParam = K
329− . Encoding.nullableArray_vector
330− (getOid (oidOf @pg)) (unK . toParam @x @pg)
331− . getVarArray
332−instance (ToFixArray x dims ty, ty ~ nullity pg, OidOf pg)
333− => ToParam (FixArray x) ('PGfixarray dims ty) where
334− toParam = K . Encoding.array (getOid (oidOf @pg))
335− . unK . unK . toFixArray @x @dims @ty . getFixArray
336−instance
337− ( IsEnumType x
338− , HasDatatypeInfo x
339− , LabelsPG x ~ labels
340− ) => ToParam (Enumerated x) ('PGenum labels) where
341− toParam =
342− let
343− gshowConstructor :: NP ConstructorInfo xss -> SOP I xss -> String
344− gshowConstructor Nil _ = ""
345− gshowConstructor (constructor :* _) (SOP (Z _)) =
346− constructorName constructor
347− gshowConstructor (_ :* constructors) (SOP (S xs)) =
348− gshowConstructor constructors (SOP xs)
349− in
350− K . Encoding.text_strict
351− . Strict.Text.pack
352− . gshowConstructor (constructorInfo (datatypeInfo (Proxy @x)))
353− . from
354− . getEnumerated
355−instance
356− ( SListI fields
357− , IsRecord x xs
358− , AllZip ToField xs fields
359− , All OidOfField fields
360− ) => ToParam (Composite x) ('PGcomposite fields) where
361− toParam =
362− let
363−
364− encoders = htrans (Proxy @ToField) toField
365−
366− composite
367− :: All OidOfField row
368− => NP (K (Maybe Encoding.Encoding)) row
369− -> K Encoding.Encoding ('PGcomposite row)
370− composite fields = K $
371− -- <number of fields: 4 bytes>
372− -- [for each field]
373− -- <OID of field's type: sizeof(Oid) bytes>
374− -- [if value is NULL]
375− -- <-1: 4 bytes>
376− -- [else]
377− -- <length of value: 4 bytes>
378− -- <value: <length> bytes>
379− -- [end if]
380− -- [end for]
381− int32BE (fromIntegral (lengthSList (Proxy @xs))) <>
382− let
383− each
384− :: OidOfField field
385− => K (Maybe Encoding.Encoding) field
386− -> Encoding.Encoding
387− each (K field :: K (Maybe Encoding.Encoding) field) =
388− word32BE (getOid (oidOfField @field))
389− <> case field of
390− Nothing -> int64BE (-1)
391− Just value ->
392− int32BE (fromIntegral (builderLength value))
393− <> value
394− in
395− hcfoldMap (Proxy @OidOfField) each fields
396−
397− in
398− composite . encoders . toRecord . getComposite
399−
400−-- | The object identifier of a `PGType`.
401−--
402−-- >>> :set -XTypeApplications
403−-- >>> oidOf @'PGbool
404−-- Oid 16
405−class OidOf (ty :: PGType) where oidOf :: LibPQ.Oid
406−instance OidOf 'PGbool where oidOf = LibPQ.Oid 16
407−instance OidOf ('PGfixarray ns (null 'PGbool)) where oidOf = LibPQ.Oid 1000
408−instance OidOf ('PGvararray (null 'PGbool)) where oidOf = LibPQ.Oid 1000
409−instance OidOf 'PGint2 where oidOf = LibPQ.Oid 21
410−instance OidOf ('PGfixarray ns (null 'PGint2)) where oidOf = LibPQ.Oid 1005
411−instance OidOf ('PGvararray (null 'PGint2)) where oidOf = LibPQ.Oid 1005
412−instance OidOf 'PGint4 where oidOf = LibPQ.Oid 23
413−instance OidOf ('PGfixarray ns (null 'PGint4)) where oidOf = LibPQ.Oid 1007
414−instance OidOf ('PGvararray (null 'PGint4)) where oidOf = LibPQ.Oid 1007
415−instance OidOf 'PGint8 where oidOf = LibPQ.Oid 20
416−instance OidOf ('PGfixarray ns (null 'PGint8)) where oidOf = LibPQ.Oid 1016
417−instance OidOf ('PGvararray (null 'PGint8)) where oidOf = LibPQ.Oid 1016
418−instance OidOf 'PGnumeric where oidOf = LibPQ.Oid 1700
419−instance OidOf ('PGfixarray ns (null 'PGnumeric)) where oidOf = LibPQ.Oid 1231
420−instance OidOf ('PGvararray (null 'PGnumeric)) where oidOf = LibPQ.Oid 1231
421−instance OidOf 'PGfloat4 where oidOf = LibPQ.Oid 700
422−instance OidOf ('PGfixarray ns (null 'PGfloat4)) where oidOf = LibPQ.Oid 1021
423−instance OidOf ('PGvararray (null 'PGfloat4)) where oidOf = LibPQ.Oid 1021
424−instance OidOf 'PGfloat8 where oidOf = LibPQ.Oid 701
425−instance OidOf ('PGfixarray ns (null 'PGfloat8)) where oidOf = LibPQ.Oid 1022
426−instance OidOf ('PGvararray (null 'PGfloat8)) where oidOf = LibPQ.Oid 1022
427−instance OidOf 'PGmoney where oidOf = LibPQ.Oid 790
428−instance OidOf ('PGfixarray ns (null 'PGmoney)) where oidOf = LibPQ.Oid 791
429−instance OidOf ('PGvararray (null 'PGmoney)) where oidOf = LibPQ.Oid 791
430−instance OidOf ('PGchar n) where oidOf = LibPQ.Oid 18
431−instance OidOf ('PGfixarray ns (null ('PGchar n))) where oidOf = LibPQ.Oid 1002
432−instance OidOf ('PGvararray (null ('PGchar n))) where oidOf = LibPQ.Oid 1002
433−instance OidOf ('PGvarchar n) where oidOf = LibPQ.Oid 1043
434−instance OidOf ('PGfixarray ns (null ('PGvarchar n))) where oidOf = LibPQ.Oid 1015
435−instance OidOf ('PGvararray (null ('PGvarchar n))) where oidOf = LibPQ.Oid 1015
436−instance OidOf 'PGtext where oidOf = LibPQ.Oid 25
437−instance OidOf ('PGfixarray ns (null 'PGtext)) where oidOf = LibPQ.Oid 1009
438−instance OidOf ('PGvararray (null 'PGtext)) where oidOf = LibPQ.Oid 1009
439−instance OidOf 'PGbytea where oidOf = LibPQ.Oid 17
440−instance OidOf ('PGfixarray ns (null 'PGbytea)) where oidOf = LibPQ.Oid 1001
441−instance OidOf ('PGvararray (null 'PGbytea)) where oidOf = LibPQ.Oid 1001
442−instance OidOf 'PGtimestamp where oidOf = LibPQ.Oid 1114
443−instance OidOf ('PGfixarray ns (null 'PGtimestamp)) where oidOf = LibPQ.Oid 1115
444−instance OidOf ('PGvararray (null 'PGtimestamp)) where oidOf = LibPQ.Oid 1115
445−instance OidOf 'PGtimestamptz where oidOf = LibPQ.Oid 1184
446−instance OidOf ('PGfixarray ns (null 'PGtimestamptz)) where oidOf = LibPQ.Oid 1185
447−instance OidOf ('PGvararray (null 'PGtimestamptz)) where oidOf = LibPQ.Oid 1185
448−instance OidOf 'PGdate where oidOf = LibPQ.Oid 1082
449−instance OidOf ('PGfixarray ns (null 'PGdate)) where oidOf = LibPQ.Oid 1182
450−instance OidOf ('PGvararray (null 'PGdate)) where oidOf = LibPQ.Oid 1182
451−instance OidOf 'PGtime where oidOf = LibPQ.Oid 1083
452−instance OidOf ('PGfixarray ns (null 'PGtime)) where oidOf = LibPQ.Oid 1183
453−instance OidOf ('PGvararray (null 'PGtime)) where oidOf = LibPQ.Oid 1183
454−instance OidOf 'PGtimetz where oidOf = LibPQ.Oid 1266
455−instance OidOf ('PGfixarray ns (null 'PGtimetz)) where oidOf = LibPQ.Oid 1270
456−instance OidOf ('PGvararray (null 'PGtimetz)) where oidOf = LibPQ.Oid 1270
457−instance OidOf 'PGinterval where oidOf = LibPQ.Oid 1186
458−instance OidOf ('PGfixarray ns (null 'PGinterval)) where oidOf = LibPQ.Oid 1187
459−instance OidOf ('PGvararray (null 'PGinterval)) where oidOf = LibPQ.Oid 1187
460−instance OidOf 'PGuuid where oidOf = LibPQ.Oid 2950
461−instance OidOf ('PGfixarray ns (null 'PGuuid)) where oidOf = LibPQ.Oid 2951
462−instance OidOf ('PGvararray (null 'PGuuid)) where oidOf = LibPQ.Oid 2951
463−instance OidOf 'PGinet where oidOf = LibPQ.Oid 869
464−instance OidOf ('PGfixarray ns (null 'PGinet)) where oidOf = LibPQ.Oid 1041
465−instance OidOf ('PGvararray (null 'PGinet)) where oidOf = LibPQ.Oid 1041
466−instance OidOf 'PGjson where oidOf = LibPQ.Oid 114
467−instance OidOf ('PGfixarray ns (null 'PGjson)) where oidOf = LibPQ.Oid 199
468−instance OidOf ('PGvararray (null 'PGjson)) where oidOf = LibPQ.Oid 199
469−instance OidOf 'PGjsonb where oidOf = LibPQ.Oid 3802
470−instance OidOf ('PGfixarray ns (null 'PGjsonb)) where oidOf = LibPQ.Oid 3807
471−instance OidOf ('PGvararray (null 'PGjsonb)) where oidOf = LibPQ.Oid 3807
472−instance OidOf 'PGtsvector where oidOf = LibPQ.Oid 3614
473−instance OidOf ('PGfixarray ns (null 'PGtsvector)) where oidOf = LibPQ.Oid 3643
474−instance OidOf ('PGvararray (null 'PGtsvector)) where oidOf = LibPQ.Oid 3643
475−instance OidOf 'PGtsquery where oidOf = LibPQ.Oid 3615
476−instance OidOf ('PGfixarray ns (null 'PGtsquery)) where oidOf = LibPQ.Oid 3645
477−instance OidOf ('PGvararray (null 'PGtsquery)) where oidOf = LibPQ.Oid 3645
478−instance OidOf 'PGoid where oidOf = LibPQ.Oid 26
479−instance OidOf ('PGfixarray ns (null 'PGoid)) where oidOf = LibPQ.Oid 1028
480−instance OidOf ('PGvararray (null 'PGoid)) where oidOf = LibPQ.Oid 1028
481−instance OidOf ('PGrange 'PGint4) where oidOf = LibPQ.Oid 3904
482−instance OidOf ('PGfixarray ns (null ('PGrange 'PGint4))) where oidOf = LibPQ.Oid 3905
483−instance OidOf ('PGvararray (null ('PGrange 'PGint4))) where oidOf = LibPQ.Oid 3905
484−instance OidOf ('PGrange 'PGint8) where oidOf = LibPQ.Oid 3926
485−instance OidOf ('PGfixarray ns (null ('PGrange 'PGint8))) where oidOf = LibPQ.Oid 3927
486−instance OidOf ('PGvararray (null ('PGrange 'PGint8))) where oidOf = LibPQ.Oid 3927
487−instance OidOf ('PGrange 'PGnumeric) where oidOf = LibPQ.Oid 3906
488−instance OidOf ('PGfixarray ns (null ('PGrange 'PGnumeric))) where oidOf = LibPQ.Oid 3907
489−instance OidOf ('PGvararray (null ('PGrange 'PGnumeric))) where oidOf = LibPQ.Oid 3907
490−instance OidOf ('PGrange 'PGtimestamp) where oidOf = LibPQ.Oid 3908
491−instance OidOf ('PGfixarray ns (null ('PGrange 'PGtimestamp))) where oidOf = LibPQ.Oid 3909
492−instance OidOf ('PGvararray (null ('PGrange 'PGtimestamp))) where oidOf = LibPQ.Oid 3909
493−instance OidOf ('PGrange 'PGtimestamptz) where oidOf = LibPQ.Oid 3910
494−instance OidOf ('PGfixarray ns (null ('PGrange 'PGtimestamptz))) where oidOf = LibPQ.Oid 3911
495−instance OidOf ('PGvararray (null ('PGrange 'PGtimestamptz))) where oidOf = LibPQ.Oid 3911
496−instance OidOf ('PGrange 'PGdate) where oidOf = LibPQ.Oid 3912
497−instance OidOf ('PGfixarray ns (null ('PGrange 'PGdate))) where oidOf = LibPQ.Oid 3913
498−instance OidOf ('PGvararray (null ('PGrange 'PGdate))) where oidOf = LibPQ.Oid 3913
499−instance {-# OVERLAPPABLE #-} OidOf ('PGrange ty) where oidOf = LibPQ.invalidOid
500−instance {-# OVERLAPPABLE #-} OidOf ('PGfixarray ns (null ('PGrange ty))) where oidOf = LibPQ.invalidOid
501−instance {-# OVERLAPPABLE #-} OidOf ('PGvararray (null ('PGrange ty))) where oidOf = LibPQ.invalidOid
502−instance {-# OVERLAPPABLE #-} OidOf ('PGcomposite row) where oidOf = LibPQ.invalidOid
503−instance {-# OVERLAPPABLE #-} OidOf ('PGfixarray ns (null ('PGcomposite row))) where oidOf = LibPQ.invalidOid
504−instance {-# OVERLAPPABLE #-} OidOf ('PGvararray (null ('PGcomposite row))) where oidOf = LibPQ.invalidOid
505−instance {-# OVERLAPPABLE #-} OidOf ('PGenum labels) where oidOf = LibPQ.invalidOid
506−instance {-# OVERLAPPABLE #-} OidOf ('PGfixarray ns (null ('PGenum labels))) where oidOf = LibPQ.invalidOid
507−instance {-# OVERLAPPABLE #-} OidOf ('PGvararray (null ('PGenum labels))) where oidOf = LibPQ.invalidOid
508−
509−class OidOfParam (ty :: NullityType) where oidOfParam :: Oid
510−instance OidOf ty => OidOfParam (null ty) where oidOfParam = oidOf @ty
511−
512−-- | Lifts a `OidOf` constraint to a field.
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`.
520−class ToNullityParam (x :: Type) (ty :: NullityType) where
521− toNullityParam :: x -> K (Maybe Encoding.Encoding) ty
522−instance ToParam x pg => ToNullityParam x ('NotNull pg) where
129+instance ToParam x pg => ToColumnParam x (optionality ('NotNull pg)) where
523− toNullityParam = K . Just . unK . toParam @x @pg
130+ toColumnParam = K . Just . Encoding.encodingBytes . unK . toParam @x @pg
524−instance ToParam x pg => ToNullityParam (Maybe x) ('Null pg) where
131+instance ToParam x pg => ToColumnParam (Maybe x) (optionality ('Null pg)) where
525− toNullityParam = K . fmap (unK . toParam @x @pg)
132+ toColumnParam = K . fmap (Encoding.encodingBytes . unK . toParam @x @pg)
526−
527−-- | A `ToField` constraint lifts the `ToParam` parser
528−-- to an encoding of a @(Symbol, Type)@ to a @(Symbol, NullityType)@,
529−-- encoding `Null`s to `Maybe`s. You should not define instances for
530−-- `FromField`, just use the provided instances.
531−class ToField (x :: (Symbol, Type)) (field :: (Symbol, NullityType)) where
532− toField :: P x -> K (Maybe Encoding.Encoding) field
533−instance ToNullityParam x ty => ToField (alias ::: x) (alias ::: ty) where
534− toField (P x) = K . unK $ toNullityParam @x @ty x
535−
536−-- | A `ToFixArray` constraint gives an encoding of a Haskell `Type`
537−-- into the binary format of a PostgreSQL fixed-length array.
538−-- You should not define instances for
539−-- `ToFixArray`, just use the provided instances.
540−class ToFixArray (x :: Type) (dims :: [Nat]) (array :: NullityType) where
541− toFixArray :: x -> K (K Encoding.Array dims) array
542−instance ToNullityParam x ty => ToFixArray x '[] ty where
543− toFixArray = K . K . maybe Encoding.nullArray Encoding.encodingArray . unK
544− . toNullityParam @x @ty
545−instance
546− ( IsProductType product xs
547− , Length xs ~ dim
548− , All ((~) x) xs
549− , ToFixArray x dims ty )
550− => ToFixArray product (dim ': dims) ty where
551− toFixArray = K . K . Encoding.dimensionArray foldlN
552− (unK . unK . toFixArray @x @dims @ty) . unZ . unSOP . from
553
133
554-- | A `ToParams` constraint generically sequences the encodings of `Type`s
134-- | A `ToParams` constraint generically sequences the encodings of `Type`s
555−-- of the fields of a tuple or record to a row of `ColumnType`s. You should
135+-- of the fields of a tuple or record to a row of `ColumnType`s.
556−-- not define instances of `ToParams`. Instead define `SOP.Generic` instances
557−-- which in turn provide `ToParams` instances.
558−class SListI tys => ToParams (x :: Type) (tys :: [NullityType]) where
136+class SListI tys => ToParams (x :: Type) (tys :: [ColumnType]) where
559− -- | >>> type Params = '[ 'NotNull 'PGbool, 'Null 'PGint2]
137+ -- | >>> type PGparams = '[ 'Required ('NotNull 'PGbool), 'Required ('Null 'PGint2)]
560− -- >>> toParams @(Bool, Maybe Int16) @'[ 'NotNull 'PGbool, 'Null 'PGint2] (False, Just 0)
138+ -- >>> toParams @(Bool, Maybe Int16) @PGparams (False, Just 0)
561− -- K (Just "\NUL") :* K (Just "\NUL\NUL") :* Nil
139+ -- K (Just "\NUL") :* (K (Just "\NUL\NUL") :* Nil)
562 --
140 --
563 -- >>> :set -XDeriveGeneric
141 -- >>> :set -XDeriveGeneric
564− -- >>> data Tuple = Tuple { p1 :: Bool, p2 :: Maybe Int16} deriving GHC.Generic
142+ -- >>> data Hparams = Hparams { col1 :: Bool, col2 :: Maybe Int16} deriving GHC.Generic
565− -- >>> instance Generic Tuple
143+ -- >>> instance Generic Hparams
566− -- >>> toParams @Tuple @Params (Tuple False (Just 0))
144+ -- >>> toParams @Hparams @PGparams (Hparams False (Just 0))
567− -- K (Just "\NUL") :* K (Just "\NUL\NUL") :* Nil
145+ -- K (Just "\NUL") :* (K (Just "\NUL\NUL") :* Nil)
568− toParams :: x -> NP (K (Maybe Encoding.Encoding)) tys
146+ toParams :: x -> NP (K (Maybe Strict.ByteString)) tys
569−instance (SListI tys, IsProductType x xs, AllZip ToNullityParam xs tys)
147+instance (SListI tys, IsProductType x xs, AllZip ToColumnParam xs tys)
570 => ToParams x tys where
148 => ToParams x tys where
571 toParams
149 toParams
572− = htrans (Proxy @ToNullityParam) (toNullityParam . unI)
150+ = htrans (Proxy @ToColumnParam) (toColumnParam . unI)
573 . unZ . unSOP . from
151 . unZ . unSOP . from
574
152
575-- | A `FromValue` constraint gives a parser from the binary format of
153-- | A `FromValue` constraint gives a parser from the binary format of
576-- a PostgreSQL `PGType` into a Haskell `Type`.
154-- a PostgreSQL `PGType` into a Haskell `Type`.
577class FromValue (pg :: PGType) (y :: Type) where
155class FromValue (pg :: PGType) (y :: Type) where
578 -- | >>> newtype Id = Id { getId :: Int16 } deriving Show
156 -- | >>> newtype Id = Id { getId :: Int16 } deriving Show
579− -- >>> instance FromValue 'PGint2 Id where fromValue = Id <$> fromValue @'PGint2
157+ -- >>> instance FromValue 'PGint2 Id where fromValue = fmap Id . fromValue
580− fromValue :: Decoding.Value y
158+ fromValue :: proxy pg -> Decoding.Value y
581−instance FromValue 'PGbool Bool where fromValue = Decoding.bool
159+instance FromValue 'PGbool Bool where fromValue _ = Decoding.bool
582−instance FromValue 'PGint2 Int16 where fromValue = Decoding.int
160+instance FromValue 'PGint2 Int16 where fromValue _ = Decoding.int
583−instance FromValue 'PGint4 Int32 where fromValue = Decoding.int
161+instance FromValue 'PGint4 Int32 where fromValue _ = Decoding.int
584−instance FromValue 'PGint8 Int64 where fromValue = Decoding.int
162+instance FromValue 'PGint8 Int64 where fromValue _ = Decoding.int
585−instance FromValue 'PGoid Word32 where fromValue = Decoding.int
586−instance FromValue 'PGfloat4 Float where fromValue = Decoding.float4
163+instance FromValue 'PGfloat4 Float where fromValue _ = Decoding.float4
587−instance FromValue 'PGfloat8 Double where fromValue = Decoding.float8
164+instance FromValue 'PGfloat8 Double where fromValue _ = Decoding.float8
588−instance FromValue 'PGnumeric Scientific where fromValue = Decoding.numeric
165+instance FromValue 'PGnumeric Scientific where fromValue _ = Decoding.numeric
589−instance FromValue 'PGmoney Money where fromValue = Money <$> Decoding.int
590−instance FromValue 'PGuuid UUID where fromValue = Decoding.uuid
166+instance FromValue 'PGuuid UUID where fromValue _ = Decoding.uuid
591−instance FromValue 'PGinet (NetAddr IP) where fromValue = Decoding.inet
167+instance FromValue 'PGinet (NetAddr IP) where fromValue _ = Decoding.inet
592−instance FromValue ('PGchar 1) Char where fromValue = Decoding.char
168+instance FromValue ('PGchar 1) Char where fromValue _ = Decoding.char
593−instance FromValue 'PGtext Strict.Text where fromValue = Decoding.text_strict
169+instance FromValue 'PGtext Strict.Text where fromValue _ = Decoding.text_strict
594−instance FromValue 'PGtext Lazy.Text where fromValue = Decoding.text_lazy
170+instance FromValue 'PGtext Lazy.Text where fromValue _ = Decoding.text_lazy
595−instance FromValue 'PGtext String where
596− fromValue = Strict.Text.unpack <$> Decoding.text_strict
597instance FromValue 'PGbytea Strict.ByteString where
171instance FromValue 'PGbytea Strict.ByteString where
598− fromValue = Decoding.bytea_strict
172+ fromValue _ = Decoding.bytea_strict
599instance FromValue 'PGbytea Lazy.ByteString where
173instance FromValue 'PGbytea Lazy.ByteString where
600− fromValue = Decoding.bytea_lazy
174+ fromValue _ = Decoding.bytea_lazy
601−instance FromValue 'PGdate Day where fromValue = Decoding.date
175+instance FromValue 'PGdate Day where fromValue _ = Decoding.date
602−instance FromValue 'PGtime TimeOfDay where fromValue = Decoding.time_int
176+instance FromValue 'PGtime TimeOfDay where fromValue _ = Decoding.time_int
603instance FromValue 'PGtimetz (TimeOfDay, TimeZone) where
177instance FromValue 'PGtimetz (TimeOfDay, TimeZone) where
604− fromValue = Decoding.timetz_int
178+ fromValue _ = Decoding.timetz_int
605instance FromValue 'PGtimestamp LocalTime where
179instance FromValue 'PGtimestamp LocalTime where
606− fromValue = Decoding.timestamp_int
180+ fromValue _ = Decoding.timestamp_int
607instance FromValue 'PGtimestamptz UTCTime where
181instance FromValue 'PGtimestamptz UTCTime where
608− fromValue = Decoding.timestamptz_int
182+ fromValue _ = Decoding.timestamptz_int
609instance FromValue 'PGinterval DiffTime where
183instance FromValue 'PGinterval DiffTime where
610− fromValue = Decoding.interval_int
184+ fromValue _ = Decoding.interval_int
611−instance FromValue 'PGjson Aeson.Value where fromValue = Decoding.json_ast
185+instance FromValue 'PGjson Value where fromValue _ = Decoding.json_ast
612−instance FromValue 'PGjsonb Aeson.Value where fromValue = Decoding.jsonb_ast
186+instance FromValue 'PGjsonb Value where fromValue _ = Decoding.jsonb_ast
613−instance Aeson.FromJSON x => FromValue 'PGjson (Json x) where
187+
614− fromValue = Json <$>
615− Decoding.json_bytes (left Strict.Text.pack . Aeson.eitherDecodeStrict)
616−instance Aeson.FromJSON x => FromValue 'PGjsonb (Jsonb x) where
617− fromValue = Jsonb <$>
618− Decoding.jsonb_bytes (left Strict.Text.pack . Aeson.eitherDecodeStrict)
619−instance FromValue pg y
620− => FromValue ('PGvararray ('NotNull pg)) (VarArray (Vector y)) where
621− fromValue =
622− let
623− rep n x = VarArray <$> Vector.replicateM n x
624− in
625− Decoding.array $ Decoding.dimensionArray rep
626− (fromFixArray @'[] @('NotNull pg))
627−instance FromValue pg y
628− => FromValue ('PGvararray ('Null pg)) (VarArray (Vector (Maybe y))) where
629− fromValue =
630− let
631− rep n x = VarArray <$> Vector.replicateM n x
632− in
633− Decoding.array $ Decoding.dimensionArray rep
634− (fromFixArray @'[] @('Null pg))
635−instance FromValue pg y
636− => FromValue ('PGvararray ('NotNull pg)) (VarArray [y]) where
637− fromValue =
638− let
639− rep n x = VarArray <$> replicateM n x
640− in
641− Decoding.array $ Decoding.dimensionArray rep
642− (fromFixArray @'[] @('NotNull pg))
643−instance FromValue pg y
644− => FromValue ('PGvararray ('Null pg)) (VarArray [Maybe y]) where
645− fromValue =
646− let
647− rep n x = VarArray <$> replicateM n x
648− in
649− Decoding.array $ Decoding.dimensionArray rep
650− (fromFixArray @'[] @('Null pg))
651−instance FromFixArray dims ty y
652− => FromValue ('PGfixarray dims ty) (FixArray y) where
653− fromValue = FixArray <$> Decoding.array (fromFixArray @dims @ty @y)
654−instance
655− ( IsEnumType y
656− , HasDatatypeInfo y
657− , LabelsPG y ~ labels
658− ) => FromValue ('PGenum labels) (Enumerated y) where
659− fromValue =
660− let
661− greadConstructor
662− :: All ((~) '[]) xss
663− => NP ConstructorInfo xss
664− -> String
665− -> Maybe (SOP I xss)
666− greadConstructor Nil _ = Nothing
667− greadConstructor (constructor :* constructors) name =
668− if name == constructorName constructor
669− then Just (SOP (Z Nil))
670− else SOP . S . unSOP <$> greadConstructor constructors name
671− in
672− fmap Enumerated
673− . Decoding.enum
674− $ fmap to
675− . greadConstructor (constructorInfo (datatypeInfo (Proxy @y)))
676− . Strict.Text.unpack
677−instance
678− ( FromRow fields y
679− ) => FromValue ('PGcomposite fields) (Composite y) where
680− fromValue =
681− let
682− -- <number of fields: 4 bytes>
683− -- [for each field]
684− -- <OID of field's type: sizeof(Oid) bytes>
685− -- [if value is NULL]
686− -- <-1: 4 bytes>
687− -- [else]
688− -- <length of value: 4 bytes>
689− -- <value: <length> bytes>
690− -- [end if]
691− -- [end for]
692− composite = Decoding.valueParser $ do
693− unitOfSize 4
694− hsequence' $ hpure $ Comp $ do
695− unitOfSize 4
696− len <- sized 4 Decoding.int
697− if len == -1
698− then return (K Nothing)
699− else K . Just <$> bytesOfSize len
700− in
701− fmap Composite (Decoding.fn (fromRow @fields <=< composite))
702−
703−-- | A `FromField` constraint lifts the `FromValue` parser
188+-- | A `FromColumnValue` constraint lifts the `FromValue` parser
704−-- to a decoding of a @(Symbol, NullityType)@ to a `Type`,
189+-- to a decoding of a `(Symbol,ColumnType)` to a `Type`,
705−-- decoding `Null`s to `Maybe`s. You should not define instances for
190+-- decoding `Null`s to `Maybe`s.
706−-- `FromField`, just use the provided instances.
191+class FromColumnValue (colty :: (Symbol,ColumnType)) (y :: Type) where
707−class FromField (pg :: (Symbol, NullityType)) (y :: (Symbol, Type)) where
192+ -- | >>> :set -XTypeOperators -XOverloadedStrings
708− fromField
193+ -- >>> newtype Id = Id { getId :: Int16 } deriving Show
194+ -- >>> instance FromValue 'PGint2 Id where fromValue = fmap Id . fromValue
195+ -- >>> fromColumnValue @("col" ::: 'Required ('NotNull 'PGint2)) @Id (K (Just "\NUL\SOH"))
196+ -- Id {getId = 1}
197+ --
198+ -- >>> fromColumnValue @("col" ::: 'Required ('Null 'PGint2)) @(Maybe Id) (K (Just "\NUL\SOH"))
199+ -- Just (Id {getId = 1})
709− :: K (Maybe Strict.ByteString) pg
200+ fromColumnValue :: K (Maybe Strict.ByteString) colty -> y
710− -> (Either Strict.Text :.: P) y
711instance FromValue pg y
201instance FromValue pg y
712− => FromField (column ::: ('NotNull pg)) (column ::: y) where
202+ => FromColumnValue (column ::: ('Required ('NotNull pg))) y where
713− fromField = Comp . \case
203+ fromColumnValue = \case
714− K Nothing -> Left "fromField: saw NULL when expecting NOT NULL"
204+ K Nothing -> error "fromColumnValue: saw NULL when expecting NOT NULL"
715− K (Just bytestring) -> P <$>
205+ K (Just bytes) ->
206+ let
207+ errOrValue =
716− Decoding.valueParser (fromValue @pg) bytestring
208+ Decoding.valueParser (fromValue @pg @y Proxy) bytes
209+ err str = error $ "fromColumnValue: " ++ Strict.unpack str
210+ in
211+ either err id errOrValue
717instance FromValue pg y
212instance FromValue pg y
718− => FromField (column ::: 'Null pg) (column ::: Maybe y) where
213+ => FromColumnValue (column ::: ('Required ('Null pg))) (Maybe y) where
719− fromField = Comp . \case
214+ fromColumnValue (K nullOrBytes)
720− K Nothing -> Right $ P Nothing
215+ = either err id
721− K (Just bytestring) -> P . Just <$>
216+ . Decoding.valueParser (fromValue @pg @y Proxy)
722− Decoding.valueParser (fromValue @pg) bytestring
217+ <$> nullOrBytes
723−
218+ where
724−-- | A `FromFixArray` constraint gives a decoding to a Haskell `Type`
219+ err str = error $ "fromColumnValue: " ++ Strict.unpack str
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.
728−class FromFixArray (dims :: [Nat]) (ty :: NullityType) (y :: Type) where
729− fromFixArray :: Decoding.Array y
730−instance FromValue pg y => FromFixArray '[] ('NotNull pg) y where
731− fromFixArray = Decoding.valueArray (fromValue @pg @y)
732−instance FromValue pg y => FromFixArray '[] ('Null pg) (Maybe y) where
733− fromFixArray = Decoding.nullableValueArray (fromValue @pg @y)
734−instance
735− ( IsProductType product ys
736− , Length ys ~ dim
737− , All ((~) y) ys
738− , FromFixArray dims ty y )
739− => FromFixArray (dim ': dims) ty product where
740− fromFixArray =
741− let
742− rep _ = fmap (to . SOP . Z) . replicateMN
743− in
744− Decoding.dimensionArray rep (fromFixArray @dims @ty @y)
745
220
746-- | A `FromRow` constraint generically sequences the parsings of the columns
221-- | A `FromRow` constraint generically sequences the parsings of the columns
747−-- of a `RowType` into the fields of a record `Type` provided they have
222+-- of a `ColumnsType` into the fields of a record `Type` provided they have
748−-- the same field names. You should not define instances of `FromRow`.
223+-- the same field names.
749−-- Instead define `SOP.Generic` and `SOP.HasDatatypeInfo` instances which in turn
750−-- provide `FromRow` instances.
751−class SListI result => FromRow (result :: RowType) y where
224+class SListI results => FromRow (results :: ColumnsType) y where
752 -- | >>> :set -XOverloadedStrings
225 -- | >>> :set -XOverloadedStrings
753 -- >>> import Data.Text
226 -- >>> import Data.Text
754− -- >>> newtype UserId = UserId { getUserId :: Int16 } deriving Show
227+ -- >>> newtype Id = Id { getId :: Int16 } deriving Show
755− -- >>> instance FromValue 'PGint2 UserId where fromValue = UserId <$> fromValue @'PGint2
228+ -- >>> instance FromValue 'PGint2 Id where fromValue = fmap Id . fromValue
756− -- >>> data UserRow = UserRow { userId :: UserId, userName :: Maybe Text } deriving (Show, GHC.Generic)
229+ -- >>> data Hrow = Hrow { userId :: Id, userName :: Maybe Text } deriving (Show, GHC.Generic)
757− -- >>> instance Generic UserRow
230+ -- >>> instance Generic Hrow
758− -- >>> instance HasDatatypeInfo UserRow
231+ -- >>> instance HasDatatypeInfo Hrow
759− -- >>> type User = '["userId" ::: 'NotNull 'PGint2, "userName" ::: 'Null 'PGtext]
232+ -- >>> type PGrow = '["userId" ::: 'Required ('NotNull 'PGint2), "userName" ::: 'Required ('Null 'PGtext)]
760− -- >>> fromRow @User @UserRow (K (Just "\NUL\SOH") :* K (Just "bloodninja") :* Nil)
233+ -- >>> fromRow @PGrow @Hrow (K (Just "\NUL\SOH") :* K (Just "bloodninja") :* Nil)
761− -- Right (UserRow {userId = UserId {getUserId = 1}, userName = Just "bloodninja"})
234+ -- Hrow {userId = Id {getId = 1}, userName = Just "bloodninja"}
762− fromRow :: NP (K (Maybe Strict.ByteString)) result -> Either Strict.Text y
235+ fromRow :: NP (K (Maybe Strict.ByteString)) results -> y
763instance
236instance
764− ( SListI result
237+ ( SListI results
765− , IsRecord y ys
238+ , IsProductType y ys
766− , AllZip FromField result ys
239+ , AllZip FromColumnValue results ys
240+ , SameFields (DatatypeInfoOf y) results
767− ) => FromRow result y where
241+ ) => FromRow results y where
768 fromRow
242 fromRow
769− = fmap fromRecord
243+ = to . SOP . Z . htrans (Proxy @FromColumnValue) (I . fromColumnValue)
770− . hsequence'
771− . htrans (Proxy @FromField) fromField
772−------------------------------------------------------
773−-- P records
774−------------------------------------------------------
775−-- instance (FromField (col ::: pg) (col ::: hask))
776−-- => FromRow '[col ::: pg] (P (col ::: hask)) where
777−-- fromRow (pg :* Nil) = (unComp . fromField) pg
778−-- instance
779−-- ( row ~ Join row1 row2
780−-- , FromRow row1 hask1
781−-- , FromRow row2 hask2
782−-- , SListI row
783−-- ) => FromRow row (hask1, hask2) where
784−-- fromRow row = case disjoin @row1 @row2 row of
785−-- (row1, row2) -> (,) <$> fromRow row1 <*> fromRow row2
786−-- instance
787−-- ( row ~ Join row1 row23
788−-- , FromRow row1 hask1
789−-- , FromRow row23 (hask2, hask3)
790−-- , SListI row
791−-- ) => FromRow row (hask1, hask2, hask3) where
792−-- fromRow row = case disjoin @row1 @row23 row of
793−-- (row1, row23) -> do
794−-- hask1 <- fromRow row1
795−-- (hask2, hask3) <- fromRow row23
796−-- return (hask1, hask2, hask3)
797−-- instance
798−-- ( row ~ Join row1 row234
799−-- , FromRow row1 hask1
800−-- , FromRow row234 (hask2, hask3, hask4)
801−-- , SListI row
802−-- ) => FromRow row (hask1, hask2, hask3, hask4) where
803−-- fromRow row = case disjoin @row1 @row234 row of
804−-- (row1, row234) -> do
805−-- hask1 <- fromRow row1
806−-- (hask2, hask3, hask4) <- fromRow row234
807−-- return (hask1, hask2, hask3, hask4)
808−-- instance
809−-- ( row ~ Join row1 row2345
810−-- , FromRow row1 hask1
811−-- , FromRow row2345 (hask2, hask3, hask4, hask5)
812−-- , SListI row
813−-- ) => FromRow row (hask1, hask2, hask3, hask4, hask5) where
814−-- fromRow row = case disjoin @row1 @row2345 row of
815−-- (row1, row2345) -> do
816−-- hask1 <- fromRow row1
817−-- (hask2, hask3, hask4, hask5) <- fromRow row2345
818−-- return (hask1, hask2, hask3, hask4, hask5)
819
244
820-- | `Only` is a 1-tuple type, useful for encoding a single parameter with
245-- | `Only` is a 1-tuple type, useful for encoding a single parameter with
821-- `toParams` or decoding a single value with `fromRow`.
246-- `toParams` or decoding a single value with `fromRow`.
822--
247--
823-- >>> import Data.Text
248-- >>> import Data.Text
824−-- >>> toParams @(Only (Maybe Text)) @'[ 'Null 'PGtext] (Only (Just "foo"))
249+-- >>> toParams @(Only (Maybe Text)) @'[ 'Required ('Null 'PGtext)] (Only (Just "foo"))
825-- K (Just "foo") :* Nil
250-- K (Just "foo") :* Nil
826--
251--
252+-- >>> type PGShortRow = '["fromOnly" ::: 'Required ('Null 'PGtext)]
827−-- >>> fromRow @'["fromOnly" ::: 'Null 'PGtext] @(Only (Maybe Text)) (K (Just "bar") :* Nil)
253+-- >>> fromRow @PGShortRow @(Only (Maybe Text)) (K (Just "bar") :* Nil)
828−-- Right (Only {fromOnly = Just "bar"})
254+-- Only {fromOnly = Just "bar"}
829newtype Only x = Only { fromOnly :: x }
255newtype Only x = Only { fromOnly :: x }
830 deriving (Functor,Foldable,Traversable,Eq,Ord,Read,Show,GHC.Generic)
256 deriving (Functor,Foldable,Traversable,Eq,Ord,Read,Show,GHC.Generic)
831instance Generic (Only x)
257instance Generic (Only x)
832instance HasDatatypeInfo (Only x)
258instance HasDatatypeInfo (Only x)
833−
834−foldlN
835− :: All ((~) x) xs
836− => (z -> x -> z) -> z -> NP I xs -> z
837−foldlN f z = \case
838− Nil -> z
839− I x :* xs -> let z' = f z x in seq z' $ foldlN f z' xs
840−
841−replicateMN
842− :: forall x xs m. (All ((~) x) xs, Monad m, SListI xs)
843− => m x -> m (NP I xs)
844−replicateMN mx = hsequence' $
845− hcpure (Proxy :: Proxy ((~) x)) (Comp (I <$> mx))
846−
847−getOid :: LibPQ.Oid -> Word32
848−getOid (LibPQ.Oid (CUInt oid)) = oid
squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs+526−36
@@ -9,74 +9,564 @@ Squeal data definition language.
9-}
9-}
10
10
11{-# LANGUAGE
11{-# LANGUAGE
12− AllowAmbiguousTypes
12+ DataKinds
13− , ConstraintKinds
13+ , DeriveDataTypeable
14− , DeriveAnyClass
15 , DeriveGeneric
14 , DeriveGeneric
16− , DerivingStrategies
17− , FlexibleContexts
18− , FlexibleInstances
19 , GADTs
15 , GADTs
16+ , GeneralizedNewtypeDeriving
17+ , KindSignatures
20 , LambdaCase
18 , LambdaCase
21− , MultiParamTypeClasses
22− , OverloadedLabels
23 , OverloadedStrings
19 , OverloadedStrings
24 , RankNTypes
20 , RankNTypes
25− , ScopedTypeVariables
21+ , StandaloneDeriving
26− , TypeApplications
27 , TypeInType
22 , TypeInType
28 , TypeOperators
23 , TypeOperators
29− , UndecidableSuperClasses
30− , UndecidableInstances
31#-}
24#-}
32
25
33module Squeal.PostgreSQL.Definition
26module Squeal.PostgreSQL.Definition
34− ( -- * Definition
27+ ( -- * Definition
35− Definition (..)
28+ Definition (UnsafeDefinition, renderDefinition)
36− , (>>>)
29+ -- * Create
37− , manipDefinition
30+ , createTable
31+ , TableConstraint (UnsafeTableConstraint, renderTableConstraint)
32+ , check
33+ , unique
34+ , primaryKey
35+ , foreignKey
36+ , OnDeleteClause (OnDeleteNoAction, OnDeleteRestrict, OnDeleteCascade)
37+ , renderOnDeleteClause
38+ , OnUpdateClause (OnUpdateNoAction, OnUpdateRestrict, OnUpdateCascade)
39+ , renderOnUpdateClause
40+ -- * Drop
41+ , dropTable
42+ -- * Alter
43+ , alterTable
44+ , alterTableRename
45+ , alterTableAddConstraint
46+ , AlterColumns (UnsafeAlterColumns, renderAlterColumns)
47+ , addColumnDefault
48+ , addColumnNull
49+ , dropColumn
50+ , dropColumnCascade
51+ , renameColumn
52+ , alterColumn
53+ , AlterColumn (UnsafeAlterColumn, renderAlterColumn)
54+ , setDefault
55+ , dropDefault
56+ , setNotNull
57+ , dropNotNull
58+ , alterType
38 ) where
59 ) where
39
60
40import Control.Category
61import Control.Category
41import Control.DeepSeq
62import Control.DeepSeq
42import Data.ByteString
63import Data.ByteString
43import Data.Monoid
64import Data.Monoid
65+import GHC.TypeLits
44import Prelude hiding ((.), id)
66import Prelude hiding ((.), id)
45
67
68+import qualified Generics.SOP as SOP
46import qualified GHC.Generics as GHC
69import qualified GHC.Generics as GHC
47
70
48−import Squeal.PostgreSQL.Manipulation
71+import Squeal.PostgreSQL.Expression
49−import Squeal.PostgreSQL.Render
72+import Squeal.PostgreSQL.Prettyprint
50import Squeal.PostgreSQL.Schema
73import Squeal.PostgreSQL.Schema
51
74
52−-- $setup
53−-- >>> import Squeal.PostgreSQL
54−
55{-----------------------------------------
75{-----------------------------------------
56statements
76statements
57-----------------------------------------}
77-----------------------------------------}
58
78
59−-- | A `Definition` is a statement that changes the schemas of the
79+-- | A `Definition` is a statement that changes the schema of the
60-- database, like a `createTable`, `dropTable`, or `alterTable` command.
80-- database, like a `createTable`, `dropTable`, or `alterTable` command.
61-- `Definition`s may be composed using the `>>>` operator.
81-- `Definition`s may be composed using the `>>>` operator.
62newtype Definition
82newtype Definition
63− (schemas0 :: SchemasType)
83+ (schema0 :: TablesType)
64− (schemas1 :: SchemasType)
84+ (schema1 :: TablesType)
65 = UnsafeDefinition { renderDefinition :: ByteString }
85 = UnsafeDefinition { renderDefinition :: ByteString }
66 deriving (GHC.Generic,Show,Eq,Ord,NFData)
86 deriving (GHC.Generic,Show,Eq,Ord,NFData)
67
87
68−instance RenderSQL (Definition schemas0 schemas1) where
69− renderSQL = renderDefinition
70−
71instance Category Definition where
88instance Category Definition where
72 id = UnsafeDefinition ";"
89 id = UnsafeDefinition ";"
73 ddl1 . ddl0 = UnsafeDefinition $
90 ddl1 . ddl0 = UnsafeDefinition $
74− renderSQL ddl0 <> "\n" <> renderSQL ddl1
91+ renderDefinition ddl0 <+> renderDefinition ddl1
75−
92+
76−-- | A `Manipulation` without input or output can be run as a statement
93+{-----------------------------------------
77−-- along with other `Definition`s, by embedding it using `manipDefinition`.
94+CREATE statements
78−manipDefinition
95+-----------------------------------------}
79− :: Manipulation '[] schemas '[] '[]
96+
80− -- ^ no input or output
97+-- | `createTable` adds a table to the schema.
81− -> Definition schemas schemas
98+--
82−manipDefinition = UnsafeDefinition . (<> ";") . renderSQL
99+-- >>> :set -XOverloadedLabels
100+-- >>> :{
101+-- renderDefinition $
102+-- createTable #tab (int `As` #a :* real `As` #b :* Nil) []
103+-- :}
104+-- "CREATE TABLE tab (a int, b real);"
105+createTable
106+ :: (KnownSymbol table, SOP.SListI columns)
107+ => Alias table -- ^ the name of the table to add
108+ -> NP (Aliased TypeExpression) (column ': columns)
109+ -- ^ the names and datatype of each column
110+ -> [TableConstraint schema (column ': columns)]
111+ -- ^ constraints that must hold for the table
112+ -> Definition schema (Create table (column ': columns) schema)
113+createTable table columns constraints = UnsafeDefinition $
114+ "CREATE TABLE" <+> renderAlias table
115+ <+> parenthesized
116+ ( renderCommaSeparated renderColumnDef columns
117+ <> renderConstraints constraints )
118+ <> ";"
119+ where
120+ renderColumnDef :: Aliased TypeExpression x -> ByteString
121+ renderColumnDef (ty `As` column) =
122+ renderAlias column <+> renderTypeExpression ty
123+ renderConstraints :: [TableConstraint schema columns] -> ByteString
124+ renderConstraints = \case
125+ [] -> ""
126+ _ -> ", " <> commaSeparated (renderTableConstraint <$> constraints)
127+
128+-- | Data types are a way to limit the kind of data that can be stored in a
129+-- table. For many applications, however, the constraint they provide is
130+-- too coarse. For example, a column containing a product price should
131+-- probably only accept positive values. But there is no standard data type
132+-- that accepts only positive numbers. Another issue is that you might want
133+-- to constrain column data with respect to other columns or rows.
134+-- For example, in a table containing product information,
135+-- there should be only one row for each product number.
136+-- `TableConstraint`s give you as much control over the data in your tables
137+-- as you wish. If a user attempts to store data in a column that would
138+-- violate a constraint, an error is raised. This applies
139+-- even if the value came from the default value definition.
140+newtype TableConstraint
141+ (schema :: TablesType)
142+ (columns :: ColumnsType)
143+ = UnsafeTableConstraint { renderTableConstraint :: ByteString }
144+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
145+
146+-- | A `check` constraint is the most generic `TableConstraint` type.
147+-- It allows you to specify that the value in a certain column must satisfy
148+-- a Boolean (truth-value) expression.
149+--
150+-- >>> :{
151+-- renderDefinition $
152+-- createTable #tab
153+-- ( (int & notNull) `As` #a :*
154+-- (int & notNull) `As` #b :* Nil )
155+-- [ check (#a .> #b) ]
156+-- :}
157+-- "CREATE TABLE tab (a int NOT NULL, b int NOT NULL, CHECK ((a > b)));"
158+check
159+ :: Condition '[table ::: columns] 'Ungrouped '[]
160+ -- ^ condition to check
161+ -> TableConstraint schema columns
162+check condition = UnsafeTableConstraint $
163+ "CHECK" <+> parenthesized (renderExpression condition)
164+
165+-- | A `unique` constraint ensure that the data contained in a column,
166+-- or a group of columns, is unique among all the rows in the table.
167+--
168+-- >>> :{
169+-- renderDefinition $
170+-- createTable #tab
171+-- ( int `As` #a :*
172+-- int `As` #b :* Nil )
173+-- [ unique (Column #a :* Column #b :* Nil) ]
174+-- :}
175+-- "CREATE TABLE tab (a int, b int, UNIQUE (a, b));"
176+unique
177+ :: SOP.SListI subcolumns
178+ => NP (Column columns) subcolumns
179+ -- ^ unique column or group of columns
180+ -> TableConstraint schema columns
181+unique columns = UnsafeTableConstraint $
182+ "UNIQUE" <+> parenthesized (renderCommaSeparated renderColumn columns)
183+
184+-- | A `primaryKey` constraint indicates that a column, or group of columns,
185+-- can be used as a unique identifier for rows in the table.
186+-- This requires that the values be both unique and not null.
187+--
188+-- >>> :{
189+-- renderDefinition $
190+-- createTable #tab
191+-- ( serial `As` #id :*
192+-- (text & notNull) `As` #name :* Nil )
193+-- [ primaryKey (Column #id :* Nil) ]
194+-- :}
195+-- "CREATE TABLE tab (id serial, name text NOT NULL, PRIMARY KEY (id));"
196+primaryKey
197+ :: (SOP.SListI subcolumns, AllNotNull subcolumns)
198+ => NP (Column columns) subcolumns
199+ -- ^ identifying column or group of columns
200+ -> TableConstraint schema columns
201+primaryKey columns = UnsafeTableConstraint $
202+ "PRIMARY KEY" <+> parenthesized (renderCommaSeparated renderColumn columns)
203+
204+-- | A `foreignKey` specifies that the values in a column
205+-- (or a group of columns) must match the values appearing in some row of
206+-- another table. We say this maintains the referential integrity
207+-- between two related tables.
208+--
209+-- >>> :{
210+-- let
211+-- definition :: Definition '[]
212+-- '[ "users" :::
213+-- '[ "id" ::: 'Optional ('NotNull 'PGint4)
214+-- , "username" ::: 'Required ('NotNull 'PGtext)
215+-- ]
216+-- , "emails" :::
217+-- '[ "id" ::: 'Optional ('NotNull 'PGint4)
218+-- , "userid" ::: 'Required ('NotNull 'PGint4)
219+-- , "email" ::: 'Required ('NotNull 'PGtext)
220+-- ]
221+-- ]
222+-- definition =
223+-- createTable #users
224+-- (serial `As` #id :* (text & notNull) `As` #username :* Nil)
225+-- [primaryKey (Column #id :* Nil)] >>>
226+-- createTable #emails
227+-- ( serial `As` #id :*
228+-- (integer & notNull) `As` #userid :*
229+-- (text & notNull) `As` #email :* Nil )
230+-- [ primaryKey (Column #id :* Nil)
231+-- , foreignKey (Column #userid :* Nil) #users (Column #id :* Nil)
232+-- OnDeleteCascade OnUpdateRestrict
233+-- ]
234+-- in renderDefinition definition
235+-- :}
236+-- "CREATE TABLE users (id serial, username text NOT NULL, PRIMARY KEY (id)); CREATE TABLE emails (id serial, userid integer NOT NULL, email text NOT NULL, PRIMARY KEY (id), FOREIGN KEY (userid) REFERENCES users (id) ON DELETE CASCADE ON UPDATE RESTRICT);"
237+foreignKey
238+ :: ( HasTable reftable schema refcolumns
239+ , SameTypes subcolumns refsubcolumns
240+ , NotAllNull subcolumns
241+ , SOP.SListI subcolumns
242+ , SOP.SListI refsubcolumns)
243+ => NP (Column columns) subcolumns
244+ -- ^ column or columns in the table
245+ -> Alias reftable
246+ -- ^ reference table
247+ -> NP (Column refcolumns) refsubcolumns
248+ -- ^ reference column or columns in the reference table
249+ -> OnDeleteClause
250+ -- ^ what to do when reference is deleted
251+ -> OnUpdateClause
252+ -- ^ what to do when reference is updated
253+ -> TableConstraint schema columns
254+foreignKey columns reftable refcolumns onDelete onUpdate =
255+ UnsafeTableConstraint $
256+ "FOREIGN KEY" <+> parenthesized (renderCommaSeparated renderColumn columns)
257+ <+> "REFERENCES" <+> renderAlias reftable
258+ <+> parenthesized (renderCommaSeparated renderColumn refcolumns)
259+ <+> renderOnDeleteClause onDelete
260+ <+> renderOnUpdateClause onUpdate
261+
262+-- | `OnDelete` indicates what to do with rows that reference a deleted row.
263+data OnDeleteClause
264+ = OnDeleteNoAction
265+ -- ^ if any referencing rows still exist when the constraint is checked,
266+ -- an error is raised
267+ | OnDeleteRestrict -- ^ prevents deletion of a referenced row
268+ | OnDeleteCascade
269+ -- ^ specifies that when a referenced row is deleted,
270+ -- row(s) referencing it should be automatically deleted as well
271+ deriving (GHC.Generic,Show,Eq,Ord)
272+instance NFData OnDeleteClause
273+
274+-- | Render `OnDeleteClause`.
275+renderOnDeleteClause :: OnDeleteClause -> ByteString
276+renderOnDeleteClause = \case
277+ OnDeleteNoAction -> "ON DELETE NO ACTION"
278+ OnDeleteRestrict -> "ON DELETE RESTRICT"
279+ OnDeleteCascade -> "ON DELETE CASCADE"
280+
281+-- | Analagous to `OnDelete` there is also `OnUpdate` which is invoked
282+-- when a referenced column is changed (updated).
283+data OnUpdateClause
284+ = OnUpdateNoAction
285+ -- ^ if any referencing rows has not changed when the constraint is checked,
286+ -- an error is raised
287+ | OnUpdateRestrict -- ^ prevents update of a referenced row
288+ | OnUpdateCascade
289+ -- ^ the updated values of the referenced column(s) should be copied
290+ -- into the referencing row(s)
291+ deriving (GHC.Generic,Show,Eq,Ord)
292+instance NFData OnUpdateClause
293+
294+-- | Render `OnUpdateClause`.
295+renderOnUpdateClause :: OnUpdateClause -> ByteString
296+renderOnUpdateClause = \case
297+ OnUpdateNoAction -> "ON UPDATE NO ACTION"
298+ OnUpdateRestrict -> "ON UPDATE RESTRICT"
299+ OnUpdateCascade -> "ON UPDATE CASCADE"
300+
301+{-----------------------------------------
302+DROP statements
303+-----------------------------------------}
304+
305+-- | `dropTable` removes a table from the schema.
306+--
307+-- >>> renderDefinition $ dropTable #muh_table
308+-- "DROP TABLE muh_table;"
309+dropTable
310+ :: KnownSymbol table
311+ => Alias table -- ^ table to remove
312+ -> Definition schema (Drop table schema)
313+dropTable table = UnsafeDefinition $ "DROP TABLE" <+> renderAlias table <> ";"
314+
315+{-----------------------------------------
316+ALTER statements
317+-----------------------------------------}
318+
319+-- | `alterTable` changes the definition of a table from the schema.
320+alterTable
321+ :: HasTable table schema columns0
322+ => Alias table -- ^ table to alter
323+ -> AlterColumns columns0 columns1 -- ^ alteration to perform
324+ -> Definition schema (Alter table schema columns1)
325+alterTable table alteration = UnsafeDefinition $
326+ "ALTER TABLE"
327+ <+> renderAlias table
328+ <+> renderAlterColumns alteration
329+ <> ";"
330+
331+-- | `alterTableRename` changes the name of a table from the schema.
332+--
333+-- >>> renderDefinition $ alterTableRename #foo #bar
334+-- "ALTER TABLE foo RENAME TO bar;"
335+alterTableRename
336+ :: (KnownSymbol table0, KnownSymbol table1)
337+ => Alias table0 -- ^ table to rename
338+ -> Alias table1 -- ^ what to rename it
339+ -> Definition schema (Rename table0 table1 schema)
340+alterTableRename table0 table1 = UnsafeDefinition $
341+ "ALTER TABLE" <+> renderAlias table0
342+ <+> "RENAME TO" <+> renderAlias table1 <> ";"
343+
344+-- | An `alterTableAddConstraint` adds a table constraint.
345+--
346+-- >>> :{
347+-- let
348+-- definition :: Definition
349+-- '["tab" ::: '["col" ::: 'Required ('NotNull 'PGint4)]]
350+-- '["tab" ::: '["col" ::: 'Required ('NotNull 'PGint4)]]
351+-- definition = alterTableAddConstraint #tab (check (#col .> 0))
352+-- in renderDefinition definition
353+-- :}
354+-- "ALTER TABLE tab ADD CHECK ((col > 0));"
355+alterTableAddConstraint
356+ :: HasTable table schema columns
357+ => Alias table -- ^ table to constrain
358+ -> TableConstraint schema columns -- ^ what constraint to add
359+ -> Definition schema schema
360+alterTableAddConstraint table constraint = UnsafeDefinition $
361+ "ALTER TABLE" <+> renderAlias table
362+ <+> "ADD" <+> renderTableConstraint constraint <> ";"
363+
364+-- | An `AlterColumns` describes the alteration to perform on the columns
365+-- of a table.
366+newtype AlterColumns
367+ (columns0 :: ColumnsType)
368+ (columns1 :: ColumnsType) =
369+ UnsafeAlterColumns {renderAlterColumns :: ByteString}
370+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
371+
372+-- | An `addColumnDefault` adds a new `Optional` column. The new column is
373+-- initially filled with whatever default value is given.
374+--
375+-- >>> :{
376+-- let
377+-- definition :: Definition
378+-- '["tab" ::: '["col1" ::: 'Required ('Null 'PGint4)]]
379+-- '["tab" :::
380+-- '[ "col1" ::: 'Required ('Null 'PGint4)
381+-- , "col2" ::: 'Optional ('Null 'PGtext) ]]
382+-- definition = alterTable #tab
383+-- (addColumnDefault #col2 (text & default_ "foo"))
384+-- in renderDefinition definition
385+-- :}
386+-- "ALTER TABLE tab ADD COLUMN col2 text DEFAULT E'foo';"
387+addColumnDefault
388+ :: KnownSymbol column
389+ => Alias column -- ^ column to add
390+ -> TypeExpression ('Optional ty) -- ^ type of the new column
391+ -> AlterColumns columns (Create column ('Optional ty) columns)
392+addColumnDefault column ty = UnsafeAlterColumns $
393+ "ADD COLUMN" <+> renderAlias column <+> renderTypeExpression ty
394+
395+-- | An `addColumnDefault` adds a new `Null` column. The new column is
396+-- initially filled with %NULL%s.
397+--
398+-- >>> :{
399+-- let
400+-- definition :: Definition
401+-- '["tab" ::: '["col1" ::: 'Required ('Null 'PGint4)]]
402+-- '["tab" :::
403+-- '[ "col1" ::: 'Required ('Null 'PGint4)
404+-- , "col2" ::: 'Required ('Null 'PGtext) ]]
405+-- definition = alterTable #tab (addColumnNull #col2 text)
406+-- in renderDefinition definition
407+-- :}
408+-- "ALTER TABLE tab ADD COLUMN col2 text;"
409+addColumnNull
410+ :: KnownSymbol column
411+ => Alias column -- ^ column to add
412+ -> TypeExpression ('Required ('Null ty)) -- ^ type of the new column
413+ -> AlterColumns columns (Create column ('Required ('Null ty)) columns)
414+addColumnNull column ty = UnsafeAlterColumns $
415+ "ADD COLUMN" <+> renderAlias column <+> renderTypeExpression ty
416+
417+-- | A `dropColumn` removes a column. Whatever data was in the column
418+-- disappears. Table constraints involving the column are dropped, too.
419+-- However, if the column is referenced by a foreign key constraint of
420+-- another table, PostgreSQL will not silently drop that constraint.
421+--
422+-- >>> :{
423+-- let
424+-- definition :: Definition
425+-- '["tab" :::
426+-- '[ "col1" ::: 'Required ('Null 'PGint4)
427+-- , "col2" ::: 'Required ('Null 'PGtext) ]]
428+-- '["tab" ::: '["col1" ::: 'Required ('Null 'PGint4)]]
429+-- definition = alterTable #tab (dropColumn #col2)
430+-- in renderDefinition definition
431+-- :}
432+-- "ALTER TABLE tab DROP COLUMN col2;"
433+dropColumn
434+ :: KnownSymbol column
435+ => Alias column -- ^ column to remove
436+ -> AlterColumns columns (Drop column columns)
437+dropColumn column = UnsafeAlterColumns $
438+ "DROP COLUMN" <+> renderAlias column
439+
440+-- | Like `dropColumn` but authorizes dropping everything that depends
441+-- on the column.
442+--
443+-- >>> :{
444+-- let
445+-- definition :: Definition
446+-- '["tab" :::
447+-- '[ "col1" ::: 'Required ('Null 'PGint4)
448+-- , "col2" ::: 'Required ('Null 'PGtext) ]]
449+-- '["tab" ::: '["col1" ::: 'Required ('Null 'PGint4)]]
450+-- definition = alterTable #tab (dropColumnCascade #col2)
451+-- in renderDefinition definition
452+-- :}
453+-- "ALTER TABLE tab DROP COLUMN col2 CASCADE;"
454+dropColumnCascade
455+ :: KnownSymbol column
456+ => Alias column -- ^ column to remove
457+ -> AlterColumns columns (Drop column columns)
458+dropColumnCascade column = UnsafeAlterColumns $
459+ "DROP COLUMN" <+> renderAlias column <+> "CASCADE"
460+
461+-- | A `renameColumn` renames a column.
462+--
463+-- >>> :{
464+-- let
465+-- definition :: Definition
466+-- '["tab" ::: '["foo" ::: 'Required ('Null 'PGint4)]]
467+-- '["tab" ::: '["bar" ::: 'Required ('Null 'PGint4)]]
468+-- definition = alterTable #tab (renameColumn #foo #bar)
469+-- in renderDefinition definition
470+-- :}
471+-- "ALTER TABLE tab RENAME COLUMN foo TO bar;"
472+renameColumn
473+ :: (KnownSymbol column0, KnownSymbol column1)
474+ => Alias column0
475+ -> Alias column1
476+ -> AlterColumns columns (Rename column0 column1 columns)
477+renameColumn column0 column1 = UnsafeAlterColumns $
478+ "RENAME COLUMN" <+> renderAlias column0 <+> "TO" <+> renderAlias column1
479+
480+-- | An `alterColumn` alters a single column.
481+alterColumn
482+ :: (KnownSymbol column, HasColumn column columns ty0)
483+ => Alias column -- ^ column to alter
484+ -> AlterColumn ty0 ty1 -- ^ alteration to perform
485+ -> AlterColumns columns (Alter column columns ty1)
486+alterColumn column alteration = UnsafeAlterColumns $
487+ "ALTER COLUMN" <+> renderAlias column <+> renderAlterColumn alteration
488+
489+-- | An `AlterColumn` describes the alteration to perform on a single column.
490+newtype AlterColumn (ty0 :: ColumnType) (ty1 :: ColumnType) =
491+ UnsafeAlterColumn {renderAlterColumn :: ByteString}
492+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
493+
494+-- | A `setDefault` sets a new default for a column. Note that this doesn't
495+-- affect any existing rows in the table, it just changes the default for
496+-- future `insertTable` and `updateTable` commands.
497+--
498+-- >>> :{
499+-- let
500+-- definition :: Definition
501+-- '["tab" ::: '["col" ::: 'Required ('Null 'PGint4)]]
502+-- '["tab" ::: '["col" ::: 'Optional ('Null 'PGint4)]]
503+-- definition = alterTable #tab (alterColumn #col (setDefault 5))
504+-- in renderDefinition definition
505+-- :}
506+-- "ALTER TABLE tab ALTER COLUMN col SET DEFAULT 5;"
507+setDefault
508+ :: Expression '[] 'Ungrouped '[] ('Required ty) -- ^ default value to set
509+ -> AlterColumn (optionality ty) ('Optional ty)
510+setDefault expression = UnsafeAlterColumn $
511+ "SET DEFAULT" <+> renderExpression expression
512+
513+-- | A `dropDefault` removes any default value for a column.
514+--
515+-- >>> :{
516+-- let
517+-- definition :: Definition
518+-- '["tab" ::: '["col" ::: 'Optional ('Null 'PGint4)]]
519+-- '["tab" ::: '["col" ::: 'Required ('Null 'PGint4)]]
520+-- definition = alterTable #tab (alterColumn #col dropDefault)
521+-- in renderDefinition definition
522+-- :}
523+-- "ALTER TABLE tab ALTER COLUMN col DROP DEFAULT;"
524+dropDefault :: AlterColumn (optionality ty) ('Required ty)
525+dropDefault = UnsafeAlterColumn $ "DROP DEFAULT"
526+
527+-- | A `setNotNull` adds a @NOT NULL@ constraint to a column.
528+-- The constraint will be checked immediately, so the table data must satisfy
529+-- the constraint before it can be added.
530+--
531+-- >>> :{
532+-- let
533+-- definition :: Definition
534+-- '["tab" ::: '["col" ::: 'Required ('Null 'PGint4)]]
535+-- '["tab" ::: '["col" ::: 'Required ('NotNull 'PGint4)]]
536+-- definition = alterTable #tab (alterColumn #col setNotNull)
537+-- in renderDefinition definition
538+-- :}
539+-- "ALTER TABLE tab ALTER COLUMN col SET NOT NULL;"
540+setNotNull :: AlterColumn (optionality ('Null ty)) (optionality ('NotNull ty))
541+setNotNull = UnsafeAlterColumn $ "SET NOT NULL"
542+
543+-- | A `dropNotNull` drops a @NOT NULL@ constraint from a column.
544+--
545+-- >>> :{
546+-- let
547+-- definition :: Definition
548+-- '["tab" ::: '["col" ::: 'Required ('NotNull 'PGint4)]]
549+-- '["tab" ::: '["col" ::: 'Required ('Null 'PGint4)]]
550+-- definition = alterTable #tab (alterColumn #col dropNotNull)
551+-- in renderDefinition definition
552+-- :}
553+-- "ALTER TABLE tab ALTER COLUMN col DROP NOT NULL;"
554+dropNotNull :: AlterColumn (optionality ('NotNull ty)) (optionality ('Null ty))
555+dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL"
556+
557+-- | An `alterType` converts a column to a different data type.
558+-- This will succeed only if each existing entry in the column can be
559+-- converted to the new type by an implicit cast.
560+--
561+-- >>> :{
562+-- let
563+-- definition :: Definition
564+-- '["tab" ::: '["col" ::: 'Required ('NotNull 'PGint4)]]
565+-- '["tab" ::: '["col" ::: 'Required ('NotNull 'PGnumeric)]]
566+-- definition =
567+-- alterTable #tab (alterColumn #col (alterType (numeric & notNull)))
568+-- in renderDefinition definition
569+-- :}
570+-- "ALTER TABLE tab ALTER COLUMN col TYPE numeric NOT NULL;"
571+alterType :: TypeExpression ty -> AlterColumn ty0 ty1
572+alterType ty = UnsafeAlterColumn $ "TYPE" <+> renderTypeExpression ty
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Function.hsdeleted−238
@@ -1,238 +0,0 @@
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.hsdeleted−159
@@ -1,159 +0,0 @@
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.hsdeleted−96
@@ -1,96 +0,0 @@
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.hsdeleted−500
@@ -1,500 +0,0 @@
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.hsdeleted−339
@@ -1,339 +0,0 @@
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.hsdeleted−229
@@ -1,229 +0,0 @@
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.hsdeleted−104
@@ -1,104 +0,0 @@
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+1034−366
@@ -1,17 +1,19 @@
1{-|
1{-|
2−Module: Squeal.PostgreSQL.Expression
2+Module: Squeal.PostgreSQL.Query
3Description: Squeal expressions
3Description: Squeal expressions
4−Copyright: (c) Eitan Chatav, 2019
4+Copyright: (c) Eitan Chatav, 2017
5Maintainer: eitan@morphism.tech
5Maintainer: eitan@morphism.tech
6Stability: experimental
6Stability: experimental
7
7
8Squeal expressions are the atoms used to build statements.
8Squeal expressions are the atoms used to build statements.
9-}
9-}
10
10
11+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
11{-# LANGUAGE
12{-# LANGUAGE
12 AllowAmbiguousTypes
13 AllowAmbiguousTypes
13− , ConstraintKinds
14+ , DataKinds
14 , DeriveGeneric
15 , DeriveGeneric
16+ , DeriveDataTypeable
15 , FlexibleContexts
17 , FlexibleContexts
16 , FlexibleInstances
18 , FlexibleInstances
17 , FunctionalDependencies
19 , FunctionalDependencies
@@ -20,6 +22,8 @@ Squeal expressions are the atoms used to build statements.
20 , LambdaCase
22 , LambdaCase
21 , MagicHash
23 , MagicHash
22 , OverloadedStrings
24 , OverloadedStrings
25+ , PolyKinds
26+ , RankNTypes
23 , ScopedTypeVariables
27 , ScopedTypeVariables
24 , StandaloneDeriving
28 , StandaloneDeriving
25 , TypeApplications
29 , TypeApplications
@@ -27,356 +31,426 @@ Squeal expressions are the atoms used to build statements.
27 , TypeInType
31 , TypeInType
28 , TypeOperators
32 , TypeOperators
29 , UndecidableInstances
33 , UndecidableInstances
30− , RankNTypes
31#-}
34#-}
32
35
33−module Squeal.PostgreSQL.Expression
36+module Squeal.PostgreSQL.Expression
34 ( -- * Expression
37 ( -- * Expression
35− Expression (..)
38+ Expression (UnsafeExpression, renderExpression)
36− , Expr
39+ , HasParameter (param)
37− , type (-->)
40+ , HasColumn (getColumn)
38− , FunctionDB
41+ , Column (Column)
39− , unsafeFunction
42+ , renderColumn
40− , function
43+ , GroupedBy (getGroup1, getGroup2)
41− , unsafeLeftOp
44+ -- ** Default
42− , leftOp
45+ , def
43− , unsafeRightOp
46+ , unDef
44− , rightOp
47+ -- ** Null
45− , Operator
48+ , null_
46− , OperatorDB
49+ , unNull
50+ , coalesce
51+ , fromNull
52+ , isNull
53+ , isn'tNull
54+ , matchNull
55+ , nullIf
56+ -- ** Functions
47 , unsafeBinaryOp
57 , unsafeBinaryOp
48− , binaryOp
58+ , unsafeUnaryOp
49− , FunctionVar
59+ , unsafeFunction
50− , unsafeFunctionVar
60+ , atan2_
51− , type (--->)
61+ , cast
52− , FunctionNDB
62+ , quot_
53− , unsafeFunctionN
63+ , rem_
54− , functionN
64+ , trunc
55− , PGSubset (..)
65+ , round_
56− , PGIntersect (..)
66+ , ceiling_
67+ , greatest
68+ , least
69+ -- ** Conditions
70+ , Condition
71+ , true
72+ , false
73+ , not_
74+ , (.&&)
75+ , (.||)
76+ , caseWhenThenElse
77+ , ifThenElse
78+ , (.==)
79+ , (./=)
80+ , (.>=)
81+ , (.<)
82+ , (.<=)
83+ , (.>)
84+ -- ** Time
85+ , currentDate
86+ , currentTime
87+ , currentTimestamp
88+ , localTime
89+ , localTimestamp
90+ -- ** Text
91+ , lower
92+ , upper
93+ , charLength
94+ , like
95+ -- ** Aggregation
96+ , unsafeAggregate, unsafeAggregateDistinct
97+ , sum_, sumDistinct
98+ , PGAvg (avg, avgDistinct)
99+ , bitAnd, bitOr, boolAnd, boolOr
100+ , bitAndDistinct, bitOrDistinct, boolAndDistinct, boolOrDistinct
101+ , countStar
102+ , count, countDistinct
103+ , every, everyDistinct
104+ , max_, maxDistinct, min_, minDistinct
105+ -- * Tables
106+ , Table (UnsafeTable, renderTable)
107+ , HasTable (getTable)
108+ -- * TypeExpression
109+ , TypeExpression (UnsafeTypeExpression, renderTypeExpression)
110+ , PGTyped (pgtype)
111+ , bool
112+ , int2
113+ , smallint
114+ , int4
115+ , int
116+ , integer
117+ , int8
118+ , bigint
119+ , numeric
120+ , float4
121+ , real
122+ , float8
123+ , doublePrecision
124+ , serial2
125+ , smallserial
126+ , serial4
127+ , serial
128+ , serial8
129+ , bigserial
130+ , text
131+ , char
132+ , character
133+ , varchar
134+ , characterVarying
135+ , bytea
136+ , timestamp
137+ , timestampWithTimeZone
138+ , date
139+ , time
140+ , timeWithTimeZone
141+ , interval
142+ , uuid
143+ , inet
144+ , json
145+ , jsonb
146+ , notNull
147+ , default_
57 -- * Re-export
148 -- * Re-export
58 , (&)
149 , (&)
59− , K (..)
150+ , NP ((:*), Nil)
60− , unK
61 ) where
151 ) where
62
152
63import Control.Category
153import Control.Category
64import Control.DeepSeq
154import Control.DeepSeq
65import Data.ByteString (ByteString)
155import Data.ByteString (ByteString)
66import Data.Function ((&))
156import Data.Function ((&))
67−import Data.Semigroup hiding (All)
157+import Data.Monoid hiding (All)
158+import Data.Ratio
68import Data.String
159import Data.String
69−import Generics.SOP hiding (All, from)
160+import Generics.SOP hiding (from)
70import GHC.OverloadedLabels
161import GHC.OverloadedLabels
71import GHC.TypeLits
162import GHC.TypeLits
72−import Numeric
73import Prelude hiding (id, (.))
163import Prelude hiding (id, (.))
74
164
75import qualified GHC.Generics as GHC
165import qualified GHC.Generics as GHC
76
166
77−import Squeal.PostgreSQL.Alias
167+import Squeal.PostgreSQL.Prettyprint
78−import Squeal.PostgreSQL.List
79−import Squeal.PostgreSQL.Render
80import Squeal.PostgreSQL.Schema
168import Squeal.PostgreSQL.Schema
81
169
82−-- $setup
83−-- >>> import Squeal.PostgreSQL
84−
85{-----------------------------------------
170{-----------------------------------------
86column expressions
171column expressions
87-----------------------------------------}
172-----------------------------------------}
88
173
89{- | `Expression`s are used in a variety of contexts,
174{- | `Expression`s are used in a variety of contexts,
90−such as in the target `Squeal.PostgreSQL.Query.List` of the
175+such as in the target list of the `select` command,
91−`Squeal.PostgreSQL.Query.select` command,
92−as new column values in `Squeal.PostgreSQL.Manipulation.insertRow` or
176+as new column values in `insertInto` or `update`,
93−`Squeal.PostgreSQL.Manipulation.update`,
94−or in search `Squeal.PostgreSQL.Logic.Condition`s in a number of commands.
177+or in search `Condition`s in a number of commands.
95
178
96The expression syntax allows the calculation of
179The expression syntax allows the calculation of
97values from primitive expression using arithmetic, logical,
180values from primitive expression using arithmetic, logical,
98and other operations.
181and other operations.
99−
100−The type parameters of `Expression` are
101−
102−* @outer :: @ `FromType`, the @from@ clauses of any outer queries in which
103− the `Expression` is a correlated subquery expression;
104−* @commons :: @ `FromType`, the `Squeal.PostgreSQL.Query.CommonTableExpression`s
105− that are in scope for the `Expression`;
106−* @grp :: @ `Grouping`, the `Grouping` of the @from@ clause which may limit
107− which columns may be referenced by alias;
108−* @schemas :: @ `SchemasType`, the schemas of your database that are in
109− scope for the `Expression`;
110−* @from :: @ `FromType`, the @from@ clause which the `Expression` may use
111− to reference columns by alias;
112−* @ty :: @ `NullityType`, the type of the `Expression`.
113-}
182-}
114newtype Expression
183newtype Expression
115− (outer :: FromType)
184+ (tables :: TablesType)
116− (commons :: FromType)
117− (grp :: Grouping)
185+ (grouping :: Grouping)
118− (schemas :: SchemasType)
186+ (params :: [ColumnType])
119− (params :: [NullityType])
187+ (ty :: ColumnType)
120− (from :: FromType)
121− (ty :: NullityType)
122 = UnsafeExpression { renderExpression :: ByteString }
188 = UnsafeExpression { renderExpression :: ByteString }
123 deriving (GHC.Generic,Show,Eq,Ord,NFData)
189 deriving (GHC.Generic,Show,Eq,Ord,NFData)
124−instance RenderSQL (Expression outer commons grp schemas params from ty) where
190+
125− renderSQL = renderExpression
191+{- | A `HasParameter` constraint is used to indicate a value that is
126−
192+supplied externally to a SQL statement.
127−-- | An `Expr` is a closed `Expression`.
193+`Squeal.PostgreSQL.PQ.manipulateParams`,
128−-- It is a F@RankNType@ but don't be scared.
194+`Squeal.PostgreSQL.PQ.queryParams` and
129−-- Think of it as an expression which sees no
195+`Squeal.PostgreSQL.PQ.traversePrepared` support specifying data values
130−-- namespaces, so you can't use parameters
196+separately from the SQL command string, in which case `param`s are used to
131−-- or alias references. It can be used as
197+refer to the out-of-line data values.
132−-- a simple piece of more complex `Expression`s.
133−type Expr x
134− = forall outer commons grp schemas params from
135− . Expression outer commons grp schemas params from x
136− -- ^ cannot reference aliases
137−
138−-- | A @RankNType@ for binary operators.
139−type Operator x1 x2 y
140− = forall outer commons grp schemas params from
141− . Expression outer commons grp schemas params from x1
142− -- ^ left input
143− -> Expression outer commons grp schemas params from x2
144− -- ^ right input
145− -> Expression outer commons grp schemas params from y
146− -- ^ output
147−
148−type OperatorDB schemas x1 x2 y
149− = forall outer commons grp params from
150− . Expression outer commons grp schemas params from x1
151− -- ^ left input
152− -> Expression outer commons grp schemas params from x2
153− -- ^ right input
154− -> Expression outer commons grp schemas params from y
155− -- ^ output
156−
157−-- | A @RankNType@ for functions with a single argument.
158−-- These could be either function calls or unary operators.
159−-- This is a subtype of the usual Haskell function type `Prelude.->`,
160−-- indeed a subcategory as it is closed under the usual
161−-- `Prelude..` and `Prelude.id`.
162−type (-->) x y
163− = forall outer commons grp schemas params from
164− . Expression outer commons grp schemas params from x
165− -- ^ input
166− -> Expression outer commons grp schemas params from y
167− -- ^ output
168−
169−type FunctionDB schemas x y
170− = forall outer commons grp params from
171− . Expression outer commons grp schemas params from x
172− -- ^ input
173− -> Expression outer commons grp schemas params from y
174− -- ^ output
175−
176−{- | A @RankNType@ for functions with a fixed-length list of heterogeneous arguments.
177−Use the `*:` operator to end your argument lists, like so.
178−
179−>>> printSQL (unsafeFunctionN "fun" (true :* false :* localTime *: true))
180−fun(TRUE, FALSE, LOCALTIME, TRUE)
181−-}
182−type (--->) xs y
183− = forall outer commons grp schemas params from
184− . NP (Expression outer commons grp schemas params from) xs
185− -- ^ inputs
186− -> Expression outer commons grp schemas params from y
187− -- ^ output
188−
189−type FunctionNDB schemas xs y
190− = forall outer commons grp params from
191− . NP (Expression outer commons grp schemas params from) xs
192− -- ^ inputs
193− -> Expression outer commons grp schemas params from y
194− -- ^ output
195−
196−{- | A @RankNType@ for functions with a variable-length list of
197−homogeneous arguments and at least 1 more argument.
198-}
198-}
199−type FunctionVar x0 x1 y
199+class (PGTyped (BaseType ty), KnownNat n)
200− = forall outer commons grp schemas params from
200+ => HasParameter (n :: Nat) params ty | n params -> ty where
201− . [Expression outer commons grp schemas params from x0]
201+ param :: Expression tables grouping params ty
202− -- ^ inputs
202+ param = UnsafeExpression $ parenthesized $
203− -> Expression outer commons grp schemas params from x1
203+ "$" <> renderNat (Proxy @n) <+> "::"
204− -- ^ must have at least 1 input
204+ <+> renderTypeExpression (pgtype @(BaseType ty))
205− -> Expression outer commons grp schemas params from y
205+instance {-# OVERLAPPING #-} PGTyped (BaseType ty1)
206− -- ^ output
206+ => HasParameter 1 (ty1:tys) ty1
207−
207+instance {-# OVERLAPPABLE #-} (KnownNat n, HasParameter (n-1) params ty)
208−{- | >>> printSQL (unsafeFunctionVar "greatest" [true, null_] false)
208+ => HasParameter n (ty' : params) ty
209−greatest(TRUE, NULL, FALSE)
209+
210+{- | A `HasColumn` constraint indicates an unqualified column reference.
211+`getColumn` can only be unambiguous when the `TableExpression` the column
212+references is unique, in which case the column may be referenced using
213+@-XOverloadedLabels@. Otherwise, combined with a `HasTable` constraint, the
214+qualified column reference operator `!` may be used.
210-}
215-}
211−unsafeFunctionVar :: ByteString -> FunctionVar x0 x1 y
216+class KnownSymbol column => HasColumn column columns ty
212−unsafeFunctionVar fun xs x = UnsafeExpression $ fun <> parenthesized
217+ | column columns -> ty where
213− (commaSeparated (renderSQL <$> xs) <> ", " <> renderSQL x)
218+ getColumn
214−
219+ :: HasUnique table tables columns
215−instance (HasUnique tab (Join outer from) row, Has col row ty)
220+ => Alias column
216− => IsLabel col (Expression outer commons 'Ungrouped schemas params from ty) where
221+ -> Expression tables 'Ungrouped params ty
217− fromLabel = UnsafeExpression $ renderSQL (Alias @col)
222+ getColumn column = UnsafeExpression $ renderAlias column
218−instance (HasUnique tab (Join outer from) row, Has col row ty, tys ~ '[ty])
223+instance {-# OVERLAPPING #-} KnownSymbol column
219− => IsLabel col (NP (Expression outer commons 'Ungrouped schemas params from) tys) where
224+ => HasColumn column ((column ::: optionality ty) ': tys) ('Required ty)
220− fromLabel = fromLabel @col :* Nil
225+instance {-# OVERLAPPABLE #-} (KnownSymbol column, HasColumn column table ty)
221−instance (HasUnique tab (Join outer from) row, Has col row ty, column ~ (col ::: ty))
226+ => HasColumn column (ty' ': table) ty
222− => IsLabel col
223− (Aliased (Expression outer commons 'Ungrouped schemas params from) column) where
224− fromLabel = fromLabel @col `As` Alias
225−instance (HasUnique tab (Join outer from) row, Has col row ty, columns ~ '[col ::: ty])
226− => IsLabel col
227− (NP (Aliased (Expression outer commons 'Ungrouped schemas params from)) columns) where
228− fromLabel = fromLabel @col :* Nil
229−
230−instance (Has tab (Join outer from) row, Has col row ty)
231− => IsQualified tab col (Expression outer commons 'Ungrouped schemas params from ty) where
232− tab ! col = UnsafeExpression $
233− renderSQL tab <> "." <> renderSQL col
234−instance (Has tab (Join outer from) row, Has col row ty, tys ~ '[ty])
235− => IsQualified tab col (NP (Expression outer commons 'Ungrouped schemas params from) tys) where
236− tab ! col = tab ! col :* Nil
237−instance (Has tab (Join outer from) row, Has col row ty, column ~ (col ::: ty))
238− => IsQualified tab col
239− (Aliased (Expression outer commons 'Ungrouped schemas params from) column) where
240− tab ! col = tab ! col `As` col
241−instance (Has tab (Join outer from) row, Has col row ty, columns ~ '[col ::: ty])
242− => IsQualified tab col
243− (NP (Aliased (Expression outer commons 'Ungrouped schemas params from)) columns) where
244− tab ! col = tab ! col :* Nil
245
227
246−instance
228+instance (HasColumn column columns ty, HasUnique table tables columns)
247− ( HasUnique tab (Join outer from) row
248− , Has col row ty
249− , GroupedBy tab col bys
250− ) => IsLabel col
251− (Expression outer commons ('Grouped bys) schemas params from ty) where
229+ => IsLabel column (Expression tables 'Ungrouped params ty) where
252− fromLabel = UnsafeExpression $ renderSQL (Alias @col)
230+ fromLabel = getColumn (Alias @column)
253−instance
254− ( HasUnique tab (Join outer from) row
255− , Has col row ty
256− , GroupedBy tab col bys
257− , tys ~ '[ty]
258− ) => IsLabel col
259− (NP (Expression outer commons ('Grouped bys) schemas params from) tys) where
260− fromLabel = fromLabel @col :* Nil
261−instance
262− ( HasUnique tab (Join outer from) row
263− , Has col row ty
264− , GroupedBy tab col bys
265− , column ~ (col ::: ty)
266− ) => IsLabel col
267− (Aliased (Expression outer commons ('Grouped bys) schemas params from) column) where
268− fromLabel = fromLabel @col `As` Alias
269−instance
270− ( HasUnique tab (Join outer from) row
271− , Has col row ty
272− , GroupedBy tab col bys
273− , columns ~ '[col ::: ty]
274− ) => IsLabel col
275− (NP (Aliased (Expression outer commons ('Grouped bys) schemas params from)) columns) where
276− fromLabel = fromLabel @col :* Nil
277
231
232+instance (HasTable table tables columns, HasColumn column columns ty)
233+ => IsTableColumn table column (Expression tables 'Ungrouped params ty) where
234+ table ! column = UnsafeExpression $
235+ renderAlias table <> "." <> renderAlias column
236+
237+-- | A `Column` is a witness to a `HasColumn` constraint. It's used
238+-- in `Squeel.PostgreSQL.Definition.unique` and other
239+-- `Squeel.PostgreSQL.Definition.TableConstraint`s to witness a
240+-- subcolumns relationship.
241+data Column
242+ (columns :: ColumnsType)
243+ (columnty :: (Symbol,ColumnType))
244+ where
245+ Column
246+ :: HasColumn column columns ty
247+ => Alias column
248+ -> Column columns (column ::: ty)
249+deriving instance Show (Column columns columnty)
250+deriving instance Eq (Column columns columnty)
251+deriving instance Ord (Column columns columnty)
252+
253+-- | Render a `Column`.
254+renderColumn :: Column columns columnty -> ByteString
255+renderColumn (Column column) = renderAlias column
256+
257+{- | A `GroupedBy` constraint indicates that a table qualified column is
258+a member of the auxiliary namespace created by @GROUP BY@ clauses and thus,
259+may be called in an output `Expression` without aggregating.
260+-}
261+class (KnownSymbol table, KnownSymbol column)
262+ => GroupedBy table column bys where
263+ getGroup1
264+ :: (HasUnique table tables columns, HasColumn column columns ty)
265+ => Alias column
266+ -> Expression tables ('Grouped bys) params ty
267+ getGroup1 column = UnsafeExpression $ renderAlias column
268+ getGroup2
269+ :: (HasTable table tables columns, HasColumn column columns ty)
270+ => Alias table
271+ -> Alias column
272+ -> Expression tables ('Grouped bys) params ty
273+ getGroup2 table column = UnsafeExpression $
274+ renderAlias table <> "." <> renderAlias column
275+instance {-# OVERLAPPING #-} (KnownSymbol table, KnownSymbol column)
276+ => GroupedBy table column ('(table,column) ': bys)
277+instance {-# OVERLAPPABLE #-}
278+ ( KnownSymbol table
279+ , KnownSymbol column
280+ , GroupedBy table column bys
281+ ) => GroupedBy table column (tabcol ': bys)
282+
278instance
283instance
279− ( Has tab (Join outer from) row
284+ ( HasUnique table tables columns
280− , Has col row ty
285+ , HasColumn column columns ty
281− , GroupedBy tab col bys
286+ , GroupedBy table column bys
282− ) => IsQualified tab col
287+ ) => IsLabel column
283− (Expression outer commons ('Grouped bys) schemas params from ty) where
288+ (Expression tables ('Grouped bys) params ty) where
284− tab ! col = UnsafeExpression $
289+ fromLabel = getGroup1 (Alias @column)
285− renderSQL tab <> "." <> renderSQL col
290+
286−instance
287− ( Has tab (Join outer from) row
288− , Has col row ty
289− , GroupedBy tab col bys
290− , tys ~ '[ty]
291− ) => IsQualified tab col
292− (NP (Expression outer commons ('Grouped bys) schemas params from) tys) where
293− tab ! col = tab ! col :* Nil
294−instance
295− ( Has tab (Join outer from) row
296− , Has col row ty
297− , GroupedBy tab col bys
298− , column ~ (col ::: ty)
299− ) => IsQualified tab col
300− (Aliased (Expression outer commons ('Grouped bys) schemas params from) column) where
301− tab ! col = tab ! col `As` col
302instance
291instance
303− ( Has tab (Join outer from) row
292+ ( HasTable table tables columns
304− , Has col row ty
293+ , HasColumn column columns ty
305− , GroupedBy tab col bys
294+ , GroupedBy table column bys
306− , columns ~ '[col ::: ty]
295+ ) => IsTableColumn table column
307− ) => IsQualified tab col
296+ (Expression tables ('Grouped bys) params ty) where (!) = getGroup2
308− (NP (Aliased (Expression outer commons ('Grouped bys) schemas params from)) columns) where
297+
309− tab ! col = tab ! col :* Nil
298+-- | >>> renderExpression def
310−
299+-- "DEFAULT"
311−instance (KnownSymbol label, label `In` labels) => IsPGlabel label
300+def :: Expression '[] 'Ungrouped params ('Optional (nullity ty))
312− (Expression outer commons grp schemas params from (null ('PGenum labels))) where
301+def = UnsafeExpression "DEFAULT"
313− label = UnsafeExpression $ renderSQL (PGlabel @label)
302+
314−
303+-- | >>> renderExpression $ unDef false
315−-- | >>> printSQL $ unsafeBinaryOp "OR" true false
304+-- "FALSE"
316−-- (TRUE OR FALSE)
305+unDef
317−unsafeBinaryOp :: ByteString -> Operator ty0 ty1 ty2
306+ :: Expression '[] 'Ungrouped params ('Required (nullity ty))
307+ -- ^ not @DEFAULT@
308+ -> Expression '[] 'Ungrouped params ('Optional (nullity ty))
309+unDef = UnsafeExpression . renderExpression
310+
311+-- | analagous to `Nothing`
312+--
313+-- >>> renderExpression $ null_
314+-- "NULL"
315+null_ :: Expression tables grouping params (optionality ('Null ty))
316+null_ = UnsafeExpression "NULL"
317+
318+-- | analagous to `Just`
319+--
320+-- >>> renderExpression $ unNull true
321+-- "TRUE"
322+unNull
323+ :: Expression tables grouping params (optionality ('NotNull ty))
324+ -- ^ not @NULL@
325+ -> Expression tables grouping params (optionality ('Null ty))
326+unNull = UnsafeExpression . renderExpression
327+
328+-- | return the leftmost value which is not NULL
329+--
330+-- >>> renderExpression $ coalesce [null_, unNull true] false
331+-- "COALESCE(NULL, TRUE, FALSE)"
332+coalesce
333+ :: [Expression tables grouping params ('Required ('Null ty))]
334+ -- ^ @NULL@s may be present
335+ -> Expression tables grouping params ('Required ('NotNull ty))
336+ -- ^ @NULL@ is absent
337+ -> Expression tables grouping params ('Required ('NotNull ty))
338+coalesce nullxs notNullx = UnsafeExpression $
339+ "COALESCE" <> parenthesized (commaSeparated
340+ ((renderExpression <$> nullxs) <> [renderExpression notNullx]))
341+
342+-- | analagous to `fromMaybe` using @COALESCE@
343+--
344+-- >>> renderExpression $ fromNull true null_
345+-- "COALESCE(NULL, TRUE)"
346+fromNull
347+ :: Expression tables grouping params ('Required ('NotNull ty))
348+ -- ^ what to convert @NULL@ to
349+ -> Expression tables grouping params ('Required ('Null ty))
350+ -> Expression tables grouping params ('Required ('NotNull ty))
351+fromNull notNullx nullx = coalesce [nullx] notNullx
352+
353+-- | >>> renderExpression $ null_ & isNull
354+-- "NULL IS NULL"
355+isNull
356+ :: Expression tables grouping params ('Required ('Null ty))
357+ -- ^ possibly @NULL@
358+ -> Condition tables grouping params
359+isNull x = UnsafeExpression $ renderExpression x <+> "IS NULL"
360+
361+-- | >>> renderExpression $ null_ & isn'tNull
362+-- "NULL IS NOT NULL"
363+isn'tNull
364+ :: Expression tables grouping params ('Required ('Null ty))
365+ -- ^ possibly @NULL@
366+ -> Condition tables grouping params
367+isn'tNull x = UnsafeExpression $ renderExpression x <+> "IS NOT NULL"
368+
369+-- | analagous to `maybe` using @IS NULL@
370+--
371+-- >>> renderExpression $ matchNull true not_ null_
372+-- "CASE WHEN NULL IS NULL THEN TRUE ELSE (NOT NULL) END"
373+matchNull
374+ :: Expression tables grouping params ('Required nullty)
375+ -- ^ what to convert @NULL@ to
376+ -> ( Expression tables grouping params ('Required ('NotNull ty))
377+ -> Expression tables grouping params ('Required nullty) )
378+ -- ^ function to perform when @NULL@ is absent
379+ -> Expression tables grouping params ('Required ('Null ty))
380+ -> Expression tables grouping params ('Required nullty)
381+matchNull y f x = ifThenElse (isNull x) y
382+ (f (UnsafeExpression (renderExpression x)))
383+
384+-- | right inverse to `fromNull`, if its arguments are equal then
385+-- `nullIf` gives @NULL@.
386+--
387+-- >>> :set -XTypeApplications -XDataKinds
388+-- >>> renderExpression @_ @_ @'[_] $ fromNull false (nullIf false (param @1))
389+-- "COALESCE(NULL IF (FALSE, ($1 :: bool)), FALSE)"
390+nullIf
391+ :: Expression tables grouping params ('Required ('NotNull ty))
392+ -- ^ @NULL@ is absent
393+ -> Expression tables grouping params ('Required ('NotNull ty))
394+ -- ^ @NULL@ is absent
395+ -> Expression tables grouping params ('Required ('Null ty))
396+nullIf x y = UnsafeExpression $ "NULL IF" <+> parenthesized
397+ (renderExpression x <> ", " <> renderExpression y)
398+
399+-- | >>> renderExpression @_ @_ @'[_] $ greatest currentTimestamp [param @1]
400+-- "GREATEST(CURRENT_TIMESTAMP, ($1 :: timestamp with time zone))"
401+greatest
402+ :: Expression tables grouping params ('Required nullty)
403+ -- ^ needs at least 1 argument
404+ -> [Expression tables grouping params ('Required nullty)]
405+ -- ^ or more
406+ -> Expression tables grouping params ('Required nullty)
407+greatest x xs = UnsafeExpression $ "GREATEST("
408+ <> commaSeparated (renderExpression <$> (x:xs)) <> ")"
409+
410+-- | >>> renderExpression $ least currentTimestamp [null_]
411+-- "LEAST(CURRENT_TIMESTAMP, NULL)"
412+least
413+ :: Expression tables grouping params ('Required nullty)
414+ -- ^ needs at least 1 argument
415+ -> [Expression tables grouping params ('Required nullty)]
416+ -- ^ or more
417+ -> Expression tables grouping params ('Required nullty)
418+least x xs = UnsafeExpression $ "LEAST("
419+ <> commaSeparated (renderExpression <$> (x:xs)) <> ")"
420+
421+-- | >>> renderExpression $ unsafeBinaryOp "OR" true false
422+-- "(TRUE OR FALSE)"
423+unsafeBinaryOp
424+ :: ByteString
425+ -- ^ operator
426+ -> Expression tables grouping params ('Required ty0)
427+ -> Expression tables grouping params ('Required ty1)
428+ -> Expression tables grouping params ('Required ty2)
318unsafeBinaryOp op x y = UnsafeExpression $ parenthesized $
429unsafeBinaryOp op x y = UnsafeExpression $ parenthesized $
319− renderSQL x <+> op <+> renderSQL y
430+ renderExpression x <+> op <+> renderExpression y
320−
431+
321−binaryOp
432+-- | >>> renderExpression $ unsafeUnaryOp "NOT" true
322− :: forall op sch schemas schema x y z.
433+-- "(NOT TRUE)"
323− ( Has sch schemas schema
434+unsafeUnaryOp
324− , Has op schema ('Operator ('BinaryOp x y z)) )
435+ :: ByteString
325− => OperatorDB schemas x y z
436+ -- ^ operator
326−binaryOp = unsafeBinaryOp $ renderSymbol @op
437+ -> Expression tables grouping params ('Required ty0)
327−
438+ -> Expression tables grouping params ('Required ty1)
328−-- | >>> printSQL $ unsafeLeftOp "NOT" true
439+unsafeUnaryOp op x = UnsafeExpression $ parenthesized $
329−-- (NOT TRUE)
440+ op <+> renderExpression x
330−unsafeLeftOp :: ByteString -> x --> y
441+
331−unsafeLeftOp op x = UnsafeExpression $ parenthesized $ op <+> renderSQL x
442+-- | >>> renderExpression $ unsafeFunction "f" true
332−
443+-- "f(TRUE)"
333−leftOp
444+unsafeFunction
334− :: forall op sch schemas schema x y.
445+ :: ByteString
335− ( Has sch schemas schema
446+ -- ^ function
336− , Has op schema ('Operator ('LeftOp x y)) )
447+ -> Expression tables grouping params ('Required xty)
337− => FunctionDB schemas x y
448+ -> Expression tables grouping params ('Required yty)
338−leftOp = unsafeLeftOp $ renderSymbol @op
339−
340−-- | >>> printSQL $ true & unsafeRightOp "IS NOT TRUE"
341−-- (TRUE IS NOT TRUE)
342−unsafeRightOp :: ByteString -> x --> y
343−unsafeRightOp op x = UnsafeExpression $ parenthesized $ renderSQL x <+> op
344−
345−rightOp
346− :: forall op sch schemas schema x y.
347− ( Has sch schemas schema
348− , Has op schema ('Operator ('RightOp x y)) )
349− => FunctionDB schemas x y
350−rightOp = unsafeRightOp $ renderSymbol @op
351−
352−-- | >>> printSQL $ unsafeFunction "f" true
353−-- f(TRUE)
354−unsafeFunction :: ByteString -> x --> y
355unsafeFunction fun x = UnsafeExpression $
449unsafeFunction fun x = UnsafeExpression $
356− fun <> parenthesized (renderSQL x)
450+ fun <> parenthesized (renderExpression x)
357−
451+
358−function
452+instance PGNum ty
359− :: (Has sch schemas schema, Has fun schema ('Function ('[x] :=> 'Returns y)))
453+ => Num (Expression tables grouping params ('Required (nullity ty))) where
360− => QualifiedAlias sch fun
361− -> FunctionDB schemas x y
362−function = unsafeFunction . renderSQL
363−
364−-- | >>> printSQL $ unsafeFunctionN "f" (currentTime :* localTimestamp :* false *: literal 'a')
365−-- f(CURRENT_TIME, LOCALTIMESTAMP, FALSE, E'a')
366−unsafeFunctionN :: SListI xs => ByteString -> xs ---> y
367−unsafeFunctionN fun xs = UnsafeExpression $
368− fun <> parenthesized (renderCommaSeparated renderSQL xs)
369−
370−functionN
371− :: ( Has sch schemas schema
372− , Has fun schema ('Function (xs :=> 'Returns y))
373− , SListI xs )
374− => QualifiedAlias sch fun
375− -> FunctionNDB schemas xs y
376−functionN = unsafeFunctionN . renderSQL
377−
378−instance ty `In` PGNum
379− => Num (Expression outer commons grp schemas params from (null ty)) where
380 (+) = unsafeBinaryOp "+"
454 (+) = unsafeBinaryOp "+"
381 (-) = unsafeBinaryOp "-"
455 (-) = unsafeBinaryOp "-"
382 (*) = unsafeBinaryOp "*"
456 (*) = unsafeBinaryOp "*"
@@ -387,24 +461,19 @@ instance ty `In` PGNum
387 . fromString
461 . fromString
388 . show
462 . show
389
463
390−instance (ty `In` PGNum, ty `In` PGFloating) => Fractional
464+instance (PGNum ty, PGFloating ty) => Fractional
391− (Expression outer commons grp schemas params from (null ty)) where
465+ (Expression tables grouping params ('Required (nullity ty))) where
392 (/) = unsafeBinaryOp "/"
466 (/) = unsafeBinaryOp "/"
393− fromRational
467+ fromRational x = fromInteger (numerator x) / fromInteger (denominator x)
394− = UnsafeExpression
395− . fromString
396− . ($ "")
397− . showFFloat Nothing
398− . fromRat @Double
399
468
400−instance (ty `In` PGNum, ty `In` PGFloating) => Floating
469+instance (PGNum ty, PGFloating ty) => Floating
401− (Expression outer commons grp schemas params from (null ty)) where
470+ (Expression tables grouping params ('Required (nullity ty))) where
402 pi = UnsafeExpression "pi()"
471 pi = UnsafeExpression "pi()"
403 exp = unsafeFunction "exp"
472 exp = unsafeFunction "exp"
404 log = unsafeFunction "ln"
473 log = unsafeFunction "ln"
405 sqrt = unsafeFunction "sqrt"
474 sqrt = unsafeFunction "sqrt"
406 b ** x = UnsafeExpression $
475 b ** x = UnsafeExpression $
407− "power(" <> renderSQL b <> ", " <> renderSQL x <> ")"
476+ "power(" <> renderExpression b <> ", " <> renderExpression x <> ")"
408 logBase b y = log y / log b
477 logBase b y = log y / log b
409 sin = unsafeFunction "sin"
478 sin = unsafeFunction "sin"
410 cos = unsafeFunction "cos"
479 cos = unsafeFunction "cos"
@@ -419,54 +488,653 @@ instance (ty `In` PGNum, ty `In` PGFloating) => Floating
419 acosh x = log (x + sqrt (x*x - 1))
488 acosh x = log (x + sqrt (x*x - 1))
420 atanh x = log ((1 + x) / (1 - x)) / 2
489 atanh x = log ((1 + x) / (1 - x)) / 2
421
490
422−-- | Contained by operators
491+-- | >>> renderExpression @_ @_ @_ @(_ (_ 'PGfloat4)) $ atan2_ pi 2
423−class PGSubset ty where
492+-- "atan2(pi(), 2)"
424− (@>) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
493+atan2_
425− (@>) = unsafeBinaryOp "@>"
494+ :: PGFloating float
426− (<@) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
495+ => Expression tables grouping params ('Required (nullity float))
427− (<@) = unsafeBinaryOp "<@"
496+ -- ^ numerator
428−instance PGSubset 'PGjsonb
497+ -> Expression tables grouping params ('Required (nullity float))
429−instance PGSubset 'PGtsquery
498+ -- ^ denominator
430−instance PGSubset ('PGvararray ty)
499+ -> Expression tables grouping params ('Required (nullity float))
431−instance PGSubset ('PGrange ty)
500+atan2_ y x = UnsafeExpression $
432−
501+ "atan2(" <> renderExpression y <> ", " <> renderExpression x <> ")"
433−class PGIntersect ty where
502+
434− (@&&) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
503+-- When a `cast` is applied to an `Expression` of a known type, it
435− (@&&) = unsafeBinaryOp "&&"
504+-- represents a run-time type conversion. The cast will succeed only if a
436−instance PGIntersect ('PGvararray ty)
505+-- suitable type conversion operation has been defined.
437−instance PGIntersect ('PGrange ty)
506+--
507+-- | >>> renderExpression $ true & cast int4
508+-- "(TRUE :: int4)"
509+cast
510+ :: TypeExpression ('Required ('Null ty1))
511+ -- ^ type to cast as
512+ -> Expression tables grouping params ('Required (nullity ty0))
513+ -- ^ value to convert
514+ -> Expression tables grouping params ('Required (nullity ty1))
515+cast ty x = UnsafeExpression $ parenthesized $
516+ renderExpression x <+> "::" <+> renderTypeExpression ty
517+
518+-- | integer division, truncates the result
519+--
520+-- >>> renderExpression @_ @_ @_ @(_(_ 'PGint2)) $ 5 `quot_` 2
521+-- "(5 / 2)"
522+quot_
523+ :: PGIntegral int
524+ => Expression tables grouping params ('Required (nullity int))
525+ -- ^ numerator
526+ -> Expression tables grouping params ('Required (nullity int))
527+ -- ^ denominator
528+ -> Expression tables grouping params ('Required (nullity int))
529+quot_ = unsafeBinaryOp "/"
530+
531+-- | remainder upon integer division
532+--
533+-- >>> renderExpression @_ @_ @_ @(_ (_ 'PGint2)) $ 5 `rem_` 2
534+-- "(5 % 2)"
535+rem_
536+ :: PGIntegral int
537+ => Expression tables grouping params ('Required (nullity int))
538+ -- ^ numerator
539+ -> Expression tables grouping params ('Required (nullity int))
540+ -- ^ denominator
541+ -> Expression tables grouping params ('Required (nullity int))
542+rem_ = unsafeBinaryOp "%"
543+
544+-- | >>> renderExpression @_ @_ @_ @(_ (_ 'PGfloat4)) $ trunc pi
545+-- "trunc(pi())"
546+trunc
547+ :: PGFloating frac
548+ => Expression tables grouping params ('Required (nullity frac))
549+ -- ^ fractional number
550+ -> Expression tables grouping params ('Required (nullity frac))
551+trunc = unsafeFunction "trunc"
552+
553+-- | >>> renderExpression @_ @_ @_ @(_ (_ 'PGfloat4)) $ round_ pi
554+-- "round(pi())"
555+round_
556+ :: PGFloating frac
557+ => Expression tables grouping params ('Required (nullity frac))
558+ -- ^ fractional number
559+ -> Expression tables grouping params ('Required (nullity frac))
560+round_ = unsafeFunction "round"
561+
562+-- | >>> renderExpression @_ @_ @_ @(_ (_ 'PGfloat4)) $ ceiling_ pi
563+-- "ceiling(pi())"
564+ceiling_
565+ :: PGFloating frac
566+ => Expression tables grouping params ('Required (nullity frac))
567+ -- ^ fractional number
568+ -> Expression tables grouping params ('Required (nullity frac))
569+ceiling_ = unsafeFunction "ceiling"
570+
571+-- | A `Condition` is a boolean valued `Expression`. While SQL allows
572+-- conditions to have @NULL@, squeal instead chooses to disallow @NULL@,
573+-- forcing one to handle the case of @NULL@ explicitly to produce
574+-- a `Condition`.
575+type Condition tables grouping params =
576+ Expression tables grouping params ('Required ('NotNull 'PGbool))
577+
578+-- | >>> renderExpression true
579+-- "TRUE"
580+true :: Condition tables grouping params
581+true = UnsafeExpression "TRUE"
582+
583+-- | >>> renderExpression false
584+-- "FALSE"
585+false :: Condition tables grouping params
586+false = UnsafeExpression "FALSE"
587+
588+-- | >>> renderExpression $ not_ true
589+-- "(NOT TRUE)"
590+not_
591+ :: Condition tables grouping params
592+ -> Condition tables grouping params
593+not_ = unsafeUnaryOp "NOT"
594+
595+-- | >>> renderExpression $ true .&& false
596+-- "(TRUE AND FALSE)"
597+(.&&)
598+ :: Condition tables grouping params
599+ -> Condition tables grouping params
600+ -> Condition tables grouping params
601+(.&&) = unsafeBinaryOp "AND"
602+
603+-- | >>> renderExpression $ true .|| false
604+-- "(TRUE OR FALSE)"
605+(.||)
606+ :: Condition tables grouping params
607+ -> Condition tables grouping params
608+ -> Condition tables grouping params
609+(.||) = unsafeBinaryOp "OR"
610+
611+-- | >>> renderExpression @_ @_ @_ @(_ (_ 'PGint2)) $ caseWhenThenElse [(true, 1), (false, 2)] 3
612+-- "CASE WHEN TRUE THEN 1 WHEN FALSE THEN 2 ELSE 3 END"
613+caseWhenThenElse
614+ :: [ ( Condition tables grouping params
615+ , Expression tables grouping params ('Required ty)
616+ ) ]
617+ -> Expression tables grouping params ('Required ty)
618+ -> Expression tables grouping params ('Required ty)
619+caseWhenThenElse whenThens else_ = UnsafeExpression $ mconcat
620+ [ "CASE"
621+ , mconcat
622+ [ mconcat
623+ [ " WHEN ", renderExpression when_
624+ , " THEN ", renderExpression then_
625+ ]
626+ | (when_,then_) <- whenThens
627+ ]
628+ , " ELSE ", renderExpression else_
629+ , " END"
630+ ]
631+
632+-- | >>> renderExpression @_ @_ @_ @(_ (_ 'PGint2)) $ ifThenElse true 1 0
633+-- "CASE WHEN TRUE THEN 1 ELSE 0 END"
634+ifThenElse
635+ :: Condition tables grouping params
636+ -> Expression tables grouping params ('Required ty)
637+ -> Expression tables grouping params ('Required ty)
638+ -> Expression tables grouping params ('Required ty)
639+ifThenElse if_ then_ else_ = caseWhenThenElse [(if_,then_)] else_
640+
641+-- | Comparison operations like `.==`, `./=`, `.>`, `.>=`, `.<` and `.<=`
642+-- will produce @NULL@s if one of their arguments is @NULL@.
643+--
644+-- >>> renderExpression $ unNull true .== null_
645+-- "(TRUE = NULL)"
646+(.==)
647+ :: Expression tables grouping params ('Required (nullity ty)) -- ^ lhs
648+ -> Expression tables grouping params ('Required (nullity ty)) -- ^ rhs
649+ -> Expression tables grouping params ('Required (nullity 'PGbool))
650+(.==) = unsafeBinaryOp "="
651+infix 4 .==
652+
653+-- | >>> renderExpression $ unNull true ./= null_
654+-- "(TRUE <> NULL)"
655+(./=)
656+ :: Expression tables grouping params ('Required (nullity ty)) -- ^ lhs
657+ -> Expression tables grouping params ('Required (nullity ty)) -- ^ rhs
658+ -> Expression tables grouping params ('Required (nullity 'PGbool))
659+(./=) = unsafeBinaryOp "<>"
660+infix 4 ./=
661+
662+-- | >>> renderExpression $ unNull true .>= null_
663+-- "(TRUE >= NULL)"
664+(.>=)
665+ :: Expression tables grouping params ('Required (nullity ty)) -- ^ lhs
666+ -> Expression tables grouping params ('Required (nullity ty)) -- ^ rhs
667+ -> Expression tables grouping params ('Required (nullity 'PGbool))
668+(.>=) = unsafeBinaryOp ">="
669+infix 4 .>=
670+
671+-- | >>> renderExpression $ unNull true .< null_
672+-- "(TRUE < NULL)"
673+(.<)
674+ :: Expression tables grouping params ('Required (nullity ty)) -- ^ lhs
675+ -> Expression tables grouping params ('Required (nullity ty)) -- ^ rhs
676+ -> Expression tables grouping params ('Required (nullity 'PGbool))
677+(.<) = unsafeBinaryOp "<"
678+infix 4 .<
679+
680+-- | >>> renderExpression $ unNull true .<= null_
681+-- "(TRUE <= NULL)"
682+(.<=)
683+ :: Expression tables grouping params ('Required (nullity ty)) -- ^ lhs
684+ -> Expression tables grouping params ('Required (nullity ty)) -- ^ rhs
685+ -> Expression tables grouping params ('Required (nullity 'PGbool))
686+(.<=) = unsafeBinaryOp "<="
687+infix 4 .<=
688+
689+-- | >>> renderExpression $ unNull true .> null_
690+-- "(TRUE > NULL)"
691+(.>)
692+ :: Expression tables grouping params ('Required (nullity ty)) -- ^ lhs
693+ -> Expression tables grouping params ('Required (nullity ty)) -- ^ rhs
694+ -> Expression tables grouping params ('Required (nullity 'PGbool))
695+(.>) = unsafeBinaryOp ">"
696+infix 4 .>
697+
698+-- | >>> renderExpression $ currentDate
699+-- "CURRENT_DATE"
700+currentDate
701+ :: Expression tables grouping params ('Required (nullity 'PGdate))
702+currentDate = UnsafeExpression "CURRENT_DATE"
703+
704+-- | >>> renderExpression $ currentTime
705+-- "CURRENT_TIME"
706+currentTime
707+ :: Expression tables grouping params ('Required (nullity 'PGtimetz))
708+currentTime = UnsafeExpression "CURRENT_TIME"
709+
710+-- | >>> renderExpression $ currentTimestamp
711+-- "CURRENT_TIMESTAMP"
712+currentTimestamp
713+ :: Expression tables grouping params ('Required (nullity 'PGtimestamptz))
714+currentTimestamp = UnsafeExpression "CURRENT_TIMESTAMP"
715+
716+-- | >>> renderExpression $ localTime
717+-- "LOCALTIME"
718+localTime
719+ :: Expression tables grouping params ('Required (nullity 'PGtime))
720+localTime = UnsafeExpression "LOCALTIME"
721+
722+-- | >>> renderExpression $ localTimestamp
723+-- "LOCALTIMESTAMP"
724+localTimestamp
725+ :: Expression tables grouping params ('Required (nullity 'PGtimestamp))
726+localTimestamp = UnsafeExpression "LOCALTIMESTAMP"
727+
728+{-----------------------------------------
729+text
730+-----------------------------------------}
438
731
439instance IsString
732instance IsString
440− (Expression outer commons grp schemas params from (null 'PGtext)) where
733+ (Expression tables grouping params ('Required (nullity 'PGtext))) where
441 fromString str = UnsafeExpression $
734 fromString str = UnsafeExpression $
442 "E\'" <> fromString (escape =<< str) <> "\'"
735 "E\'" <> fromString (escape =<< str) <> "\'"
443−instance IsString
736+ where
444− (Expression outer commons grp schemas params from (null 'PGtsvector)) where
737+ escape = \case
445− fromString str = UnsafeExpression . parenthesized . (<> " :: tsvector") $
738+ '\NUL' -> "\\0"
446− "E\'" <> fromString (escape =<< str) <> "\'"
739+ '\'' -> "''"
447−instance IsString
740+ '"' -> "\\\""
448− (Expression outer commons grp schemas params from (null 'PGtsquery)) where
741+ '\b' -> "\\b"
449− fromString str = UnsafeExpression . parenthesized . (<> " :: tsquery") $
742+ '\n' -> "\\n"
450− "E\'" <> fromString (escape =<< str) <> "\'"
743+ '\r' -> "\\r"
451−
744+ '\t' -> "\\t"
452−instance Semigroup
745+ '\\' -> "\\\\"
453− (Expression outer commons grp schemas params from (null ('PGvararray ty))) where
746+ c -> [c]
454− (<>) = unsafeBinaryOp "||"
455−instance Semigroup
456− (Expression outer commons grp schemas params from (null 'PGjsonb)) where
457− (<>) = unsafeBinaryOp "||"
458−instance Semigroup
459− (Expression outer commons grp schemas params from (null 'PGtext)) where
460− (<>) = unsafeBinaryOp "||"
461−instance Semigroup
462− (Expression outer commons grp schemas params from (null 'PGtsvector)) where
463− (<>) = unsafeBinaryOp "||"
464
747
465instance Monoid
748instance Monoid
466− (Expression outer commons grp schemas params from (null 'PGtext)) where
749+ (Expression tables grouping params ('Required (nullity 'PGtext))) where
467− mempty = fromString ""
468− mappend = (<>)
469−instance Monoid
470− (Expression outer commons grp schemas params from (null 'PGtsvector)) where
471 mempty = fromString ""
750 mempty = fromString ""
472− mappend = (<>)
751+ mappend = unsafeBinaryOp "||"
752+
753+-- | >>> renderExpression $ lower "ARRRGGG"
754+-- "lower(E'ARRRGGG')"
755+lower
756+ :: Expression tables grouping params ('Required (nullity 'PGtext))
757+ -- ^ string to lower case
758+ -> Expression tables grouping params ('Required (nullity 'PGtext))
759+lower = unsafeFunction "lower"
760+
761+-- | >>> renderExpression $ upper "eeee"
762+-- "upper(E'eeee')"
763+upper
764+ :: Expression tables grouping params ('Required (nullity 'PGtext))
765+ -- ^ string to upper case
766+ -> Expression tables grouping params ('Required (nullity 'PGtext))
767+upper = unsafeFunction "upper"
768+
769+-- | >>> renderExpression $ charLength "four"
770+-- "char_length(E'four')"
771+charLength
772+ :: Expression tables grouping params ('Required (nullity 'PGtext))
773+ -- ^ string to measure
774+ -> Expression tables grouping params ('Required (nullity 'PGint4))
775+charLength = unsafeFunction "char_length"
776+
777+-- | The `like` expression returns true if the @string@ matches
778+-- the supplied @pattern@. If @pattern@ does not contain percent signs
779+-- or underscores, then the pattern only represents the string itself;
780+-- in that case `like` acts like the equals operator. An underscore (_)
781+-- in pattern stands for (matches) any single character; a percent sign (%)
782+-- matches any sequence of zero or more characters.
783+--
784+-- >>> renderExpression $ "abc" `like` "a%"
785+-- "(E'abc' LIKE E'a%')"
786+like
787+ :: Expression tables grouping params ('Required (nullity 'PGtext))
788+ -- ^ string
789+ -> Expression tables grouping params ('Required (nullity 'PGtext))
790+ -- ^ pattern
791+ -> Expression tables grouping params ('Required (nullity 'PGbool))
792+like = unsafeBinaryOp "LIKE"
793+
794+{-----------------------------------------
795+aggregation
796+-----------------------------------------}
797+
798+-- | escape hatch to define aggregate functions
799+unsafeAggregate
800+ :: ByteString -- ^ aggregate function
801+ -> Expression tables 'Ungrouped params ('Required xty)
802+ -> Expression tables ('Grouped bys) params ('Required yty)
803+unsafeAggregate fun x = UnsafeExpression $ mconcat
804+ [fun, "(", renderExpression x, ")"]
805+
806+-- | escape hatch to define aggregate functions over distinct values
807+unsafeAggregateDistinct
808+ :: ByteString -- ^ aggregate function
809+ -> Expression tables 'Ungrouped params ('Required xty)
810+ -> Expression tables ('Grouped bys) params ('Required yty)
811+unsafeAggregateDistinct fun x = UnsafeExpression $ mconcat
812+ [fun, "(DISTINCT ", renderExpression x, ")"]
813+
814+-- | >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGnumeric)]] $ sum_ #col
815+-- "sum(col)"
816+sum_
817+ :: PGNum ty
818+ => Expression tables 'Ungrouped params ('Required (nullity ty))
819+ -- ^ what to sum
820+ -> Expression tables ('Grouped bys) params ('Required (nullity ty))
821+sum_ = unsafeAggregate "sum"
822+
823+-- | >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGnumeric)]] $ sumDistinct #col
824+-- "sum(DISTINCT col)"
825+sumDistinct
826+ :: PGNum ty
827+ => Expression tables 'Ungrouped params ('Required (nullity ty))
828+ -- ^ what to sum
829+ -> Expression tables ('Grouped bys) params ('Required (nullity ty))
830+sumDistinct = unsafeAggregateDistinct "sum"
831+
832+-- | A constraint for `PGType`s that you can take averages of and the resulting
833+-- `PGType`.
834+class PGAvg ty avg | ty -> avg where
835+ avg, avgDistinct
836+ :: Expression tables 'Ungrouped params ('Required (nullity ty))
837+ -- ^ what to average
838+ -> Expression tables ('Grouped bys) params ('Required (nullity avg))
839+ avg = unsafeAggregate "avg"
840+ avgDistinct = unsafeAggregateDistinct "avg"
841+instance PGAvg 'PGint2 'PGnumeric
842+instance PGAvg 'PGint4 'PGnumeric
843+instance PGAvg 'PGint8 'PGnumeric
844+instance PGAvg 'PGnumeric 'PGnumeric
845+instance PGAvg 'PGfloat4 'PGfloat8
846+instance PGAvg 'PGfloat8 'PGfloat8
847+instance PGAvg 'PGinterval 'PGinterval
848+
849+-- | >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGint4)]] $ bitAnd #col
850+-- "bit_and(col)"
851+bitAnd
852+ :: PGIntegral int
853+ => Expression tables 'Ungrouped params ('Required (nullity int))
854+ -- ^ what to aggregate
855+ -> Expression tables ('Grouped bys) params ('Required (nullity int))
856+bitAnd = unsafeAggregate "bit_and"
857+
858+-- | >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGint4)]] $ bitOr #col
859+-- "bit_or(col)"
860+bitOr
861+ :: PGIntegral int
862+ => Expression tables 'Ungrouped params ('Required (nullity int))
863+ -- ^ what to aggregate
864+ -> Expression tables ('Grouped bys) params ('Required (nullity int))
865+bitOr = unsafeAggregate "bit_or"
866+
867+-- | >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGint4)]] $ bitAndDistinct #col
868+-- "bit_and(DISTINCT col)"
869+bitAndDistinct
870+ :: PGIntegral int
871+ => Expression tables 'Ungrouped params ('Required (nullity int))
872+ -- ^ what to aggregate
873+ -> Expression tables ('Grouped bys) params ('Required (nullity int))
874+bitAndDistinct = unsafeAggregateDistinct "bit_and"
875+
876+-- | >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGint4)]] $ bitOrDistinct #col
877+-- "bit_or(DISTINCT col)"
878+bitOrDistinct
879+ :: PGIntegral int
880+ => Expression tables 'Ungrouped params ('Required (nullity int))
881+ -- ^ what to aggregate
882+ -> Expression tables ('Grouped bys) params ('Required (nullity int))
883+bitOrDistinct = unsafeAggregateDistinct "bit_or"
884+
885+-- | >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGbool)]] $ boolAnd #col
886+-- "bool_and(col)"
887+boolAnd
888+ :: Expression tables 'Ungrouped params ('Required (nullity 'PGbool))
889+ -- ^ what to aggregate
890+ -> Expression tables ('Grouped bys) params ('Required (nullity 'PGbool))
891+boolAnd = unsafeAggregate "bool_and"
892+
893+-- | >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGbool)]] $ boolOr #col
894+-- "bool_or(col)"
895+boolOr
896+ :: Expression tables 'Ungrouped params ('Required (nullity 'PGbool))
897+ -- ^ what to aggregate
898+ -> Expression tables ('Grouped bys) params ('Required (nullity 'PGbool))
899+boolOr = unsafeAggregate "bool_or"
900+
901+-- | >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGbool)]] $ boolAndDistinct #col
902+-- "bool_and(DISTINCT col)"
903+boolAndDistinct
904+ :: Expression tables 'Ungrouped params ('Required (nullity 'PGbool))
905+ -- ^ what to aggregate
906+ -> Expression tables ('Grouped bys) params ('Required (nullity 'PGbool))
907+boolAndDistinct = unsafeAggregateDistinct "bool_and"
908+
909+-- | >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGbool)]] $ boolOrDistinct #col
910+-- "bool_or(DISTINCT col)"
911+boolOrDistinct
912+ :: Expression tables 'Ungrouped params ('Required (nullity 'PGbool))
913+ -- ^ what to aggregate
914+ -> Expression tables ('Grouped bys) params ('Required (nullity 'PGbool))
915+boolOrDistinct = unsafeAggregateDistinct "bool_or"
916+
917+-- | A special aggregation that does not require an input
918+--
919+-- >>> renderExpression countStar
920+-- "count(*)"
921+countStar
922+ :: Expression tables ('Grouped bys) params ('Required ('NotNull 'PGint8))
923+countStar = UnsafeExpression $ "count(*)"
924+
925+-- | >>> renderExpression @'[_ ::: '["col" ::: 'Optional _]] $ count #col
926+-- "count(col)"
927+count
928+ :: Expression tables 'Ungrouped params ('Required ty)
929+ -- ^ what to count
930+ -> Expression tables ('Grouped bys) params ('Required ('NotNull 'PGint8))
931+count = unsafeAggregate "count"
932+
933+-- | >>> renderExpression @'[_ ::: '["col" ::: 'Required _]] $ countDistinct #col
934+-- "count(DISTINCT col)"
935+countDistinct
936+ :: Expression tables 'Ungrouped params ('Required ty)
937+ -- ^ what to count
938+ -> Expression tables ('Grouped bys) params ('Required ('NotNull 'PGint8))
939+countDistinct = unsafeAggregateDistinct "count"
940+
941+-- | synonym for `boolAnd`
942+--
943+-- >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGbool)]] $ every #col
944+-- "every(col)"
945+every
946+ :: Expression tables 'Ungrouped params ('Required (nullity 'PGbool))
947+ -- ^ what to aggregate
948+ -> Expression tables ('Grouped bys) params ('Required (nullity 'PGbool))
949+every = unsafeAggregate "every"
950+
951+-- | synonym for `boolAndDistinct`
952+--
953+-- >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGbool)]] $ everyDistinct #col
954+-- "every(DISTINCT col)"
955+everyDistinct
956+ :: Expression tables 'Ungrouped params ('Required (nullity 'PGbool))
957+ -- ^ what to aggregate
958+ -> Expression tables ('Grouped bys) params ('Required (nullity 'PGbool))
959+everyDistinct = unsafeAggregateDistinct "every"
960+
961+-- | minimum and maximum aggregation
962+max_, min_, maxDistinct, minDistinct
963+ :: Expression tables 'Ungrouped params ('Required (nullity ty))
964+ -- ^ what to aggregate
965+ -> Expression tables ('Grouped bys) params ('Required (nullity ty))
966+max_ = unsafeAggregate "max"
967+min_ = unsafeAggregate "min"
968+maxDistinct = unsafeAggregateDistinct "max"
969+minDistinct = unsafeAggregateDistinct "min"
970+
971+{-----------------------------------------
972+tables
973+-----------------------------------------}
974+
975+-- | A `Table` from a schema without its alias with an `IsLabel` instance
976+-- to call a table reference by its alias.
977+newtype Table
978+ (schema :: TablesType)
979+ (columns :: ColumnsType)
980+ = UnsafeTable { renderTable :: ByteString }
981+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
982+
983+-- | A `HasTable` constraint indicates a table reference.
984+class KnownSymbol table => HasTable table tables columns
985+ | table tables -> columns where
986+ getTable :: Alias table -> Table tables columns
987+ getTable table = UnsafeTable $ renderAlias table
988+instance {-# OVERLAPPING #-} KnownSymbol table
989+ => HasTable table ((table ::: columns) ': tables) columns
990+instance {-# OVERLAPPABLE #-}
991+ (KnownSymbol table, HasTable table schema columns)
992+ => HasTable table (table' ': schema) columns
993+
994+instance HasTable table schema columns
995+ => IsLabel table (Table schema columns) where
996+ fromLabel = getTable (Alias @table)
997+
998+{-----------------------------------------
999+type expressions
1000+-----------------------------------------}
1001+
1002+-- | `TypeExpression`s are used in `cast`s and `createTable` commands.
1003+newtype TypeExpression (ty :: ColumnType)
1004+ = UnsafeTypeExpression { renderTypeExpression :: ByteString }
1005+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
1006+
1007+-- | logical Boolean (true/false)
1008+bool :: TypeExpression ('Required ('Null 'PGbool))
1009+bool = UnsafeTypeExpression "bool"
1010+-- | signed two-byte integer
1011+int2, smallint :: TypeExpression ('Required ('Null 'PGint2))
1012+int2 = UnsafeTypeExpression "int2"
1013+smallint = UnsafeTypeExpression "smallint"
1014+-- | signed four-byte integer
1015+int4, int, integer :: TypeExpression ('Required ('Null 'PGint4))
1016+int4 = UnsafeTypeExpression "int4"
1017+int = UnsafeTypeExpression "int"
1018+integer = UnsafeTypeExpression "integer"
1019+-- | signed eight-byte integer
1020+int8, bigint :: TypeExpression ('Required ('Null 'PGint8))
1021+int8 = UnsafeTypeExpression "int8"
1022+bigint = UnsafeTypeExpression "bigint"
1023+-- | arbitrary precision numeric type
1024+numeric :: TypeExpression ('Required ('Null 'PGnumeric))
1025+numeric = UnsafeTypeExpression "numeric"
1026+-- | single precision floating-point number (4 bytes)
1027+float4, real :: TypeExpression ('Required ('Null 'PGfloat4))
1028+float4 = UnsafeTypeExpression "float4"
1029+real = UnsafeTypeExpression "real"
1030+-- | double precision floating-point number (8 bytes)
1031+float8, doublePrecision :: TypeExpression ('Required ('Null 'PGfloat8))
1032+float8 = UnsafeTypeExpression "float8"
1033+doublePrecision = UnsafeTypeExpression "double precision"
1034+-- | not a true type, but merely a notational convenience for creating
1035+-- unique identifier columns with type `'PGint2`
1036+serial2, smallserial :: TypeExpression ('Optional ('NotNull 'PGint2))
1037+serial2 = UnsafeTypeExpression "serial2"
1038+smallserial = UnsafeTypeExpression "smallserial"
1039+-- | not a true type, but merely a notational convenience for creating
1040+-- unique identifier columns with type `'PGint4`
1041+serial4, serial :: TypeExpression ('Optional ('NotNull 'PGint4))
1042+serial4 = UnsafeTypeExpression "serial4"
1043+serial = UnsafeTypeExpression "serial"
1044+-- | not a true type, but merely a notational convenience for creating
1045+-- unique identifier columns with type `'PGint8`
1046+serial8, bigserial :: TypeExpression ('Optional ('NotNull 'PGint8))
1047+serial8 = UnsafeTypeExpression "serial8"
1048+bigserial = UnsafeTypeExpression "bigserial"
1049+-- | variable-length character string
1050+text :: TypeExpression ('Required ('Null 'PGtext))
1051+text = UnsafeTypeExpression "text"
1052+-- | fixed-length character string
1053+char, character
1054+ :: (KnownNat n, 1 <= n)
1055+ => proxy n
1056+ -> TypeExpression ('Required ('Null ('PGchar n)))
1057+char p = UnsafeTypeExpression $ "char(" <> renderNat p <> ")"
1058+character p = UnsafeTypeExpression $ "character(" <> renderNat p <> ")"
1059+-- | variable-length character string
1060+varchar, characterVarying
1061+ :: (KnownNat n, 1 <= n)
1062+ => proxy n
1063+ -> TypeExpression ('Required ('Null ('PGvarchar n)))
1064+varchar p = UnsafeTypeExpression $ "varchar(" <> renderNat p <> ")"
1065+characterVarying p = UnsafeTypeExpression $
1066+ "character varying(" <> renderNat p <> ")"
1067+-- | binary data ("byte array")
1068+bytea :: TypeExpression ('Required ('Null 'PGbytea))
1069+bytea = UnsafeTypeExpression "bytea"
1070+-- | date and time (no time zone)
1071+timestamp :: TypeExpression ('Required ('Null 'PGtimestamp))
1072+timestamp = UnsafeTypeExpression "timestamp"
1073+-- | date and time, including time zone
1074+timestampWithTimeZone :: TypeExpression ('Required ('Null 'PGtimestamptz))
1075+timestampWithTimeZone = UnsafeTypeExpression "timestamp with time zone"
1076+-- | calendar date (year, month, day)
1077+date :: TypeExpression ('Required ('Null 'PGdate))
1078+date = UnsafeTypeExpression "date"
1079+-- | time of day (no time zone)
1080+time :: TypeExpression ('Required ('Null 'PGtime))
1081+time = UnsafeTypeExpression "time"
1082+-- | time of day, including time zone
1083+timeWithTimeZone :: TypeExpression ('Required ('Null 'PGtimetz))
1084+timeWithTimeZone = UnsafeTypeExpression "time with time zone"
1085+-- | time span
1086+interval :: TypeExpression ('Required ('Null 'PGinterval))
1087+interval = UnsafeTypeExpression "interval"
1088+-- | universally unique identifier
1089+uuid :: TypeExpression ('Required ('Null 'PGuuid))
1090+uuid = UnsafeTypeExpression "uuid"
1091+-- | IPv4 or IPv6 host address
1092+inet :: TypeExpression ('Required ('Null 'PGinet))
1093+inet = UnsafeTypeExpression "inet"
1094+-- | textual JSON data
1095+json :: TypeExpression ('Required ('Null 'PGjson))
1096+json = UnsafeTypeExpression "json"
1097+-- | binary JSON data, decomposed
1098+jsonb :: TypeExpression ('Required ('Null 'PGjsonb))
1099+jsonb = UnsafeTypeExpression "jsonb"
1100+
1101+-- | used in `createTable` commands as a column constraint to ensure
1102+-- @NULL@ is not present
1103+notNull
1104+ :: TypeExpression (optionality ('Null ty))
1105+ -> TypeExpression (optionality ('NotNull ty))
1106+notNull ty = UnsafeTypeExpression $ renderTypeExpression ty <+> "NOT NULL"
1107+
1108+-- | used in `createTable` commands as a column constraint to give a default
1109+default_
1110+ :: Expression '[] 'Ungrouped '[] ('Required ty)
1111+ -> TypeExpression ('Required ty)
1112+ -> TypeExpression ('Optional ty)
1113+default_ x ty = UnsafeTypeExpression $
1114+ renderTypeExpression ty <+> "DEFAULT" <+> renderExpression x
1115+
1116+-- | `pgtype` is a demoted version of a `PGType`
1117+class PGTyped (ty :: PGType) where
1118+ pgtype :: TypeExpression ('Required ('Null ty))
1119+instance PGTyped 'PGbool where pgtype = bool
1120+instance PGTyped 'PGint2 where pgtype = int2
1121+instance PGTyped 'PGint4 where pgtype = int4
1122+instance PGTyped 'PGint8 where pgtype = int8
1123+instance PGTyped 'PGnumeric where pgtype = numeric
1124+instance PGTyped 'PGfloat4 where pgtype = float4
1125+instance PGTyped 'PGfloat8 where pgtype = float8
1126+instance PGTyped 'PGtext where pgtype = text
1127+instance (KnownNat n, 1 <= n)
1128+ => PGTyped ('PGchar n) where pgtype = char (Proxy @n)
1129+instance (KnownNat n, 1 <= n)
1130+ => PGTyped ('PGvarchar n) where pgtype = varchar (Proxy @n)
1131+instance PGTyped 'PGbytea where pgtype = bytea
1132+instance PGTyped 'PGtimestamp where pgtype = timestamp
1133+instance PGTyped 'PGtimestamptz where pgtype = timestampWithTimeZone
1134+instance PGTyped 'PGdate where pgtype = date
1135+instance PGTyped 'PGtime where pgtype = time
1136+instance PGTyped 'PGtimetz where pgtype = timeWithTimeZone
1137+instance PGTyped 'PGinterval where pgtype = interval
1138+instance PGTyped 'PGuuid where pgtype = uuid
1139+instance PGTyped 'PGjson where pgtype = json
1140+instance PGTyped 'PGjsonb where pgtype = jsonb
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Aggregate.hsdeleted−462
@@ -1,462 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Expression.Aggregate
3−Description: Aggregate functions
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Aggregate functions
9−-}
10−
11−{-# LANGUAGE
12− DataKinds
13− , DeriveGeneric
14− , FlexibleContexts
15− , FlexibleInstances
16− , FunctionalDependencies
17− , LambdaCase
18− , MultiParamTypeClasses
19− , OverloadedStrings
20− , PolyKinds
21− , TypeFamilies
22− , TypeOperators
23− , UndecidableInstances
24−#-}
25−
26−module Squeal.PostgreSQL.Expression.Aggregate
27− ( Aggregate (..)
28− , Distinction (..)
29− , PGSum
30− , PGAvg
31− ) where
32−
33−import Control.DeepSeq
34−import Data.ByteString (ByteString)
35−import Data.Kind
36−import GHC.TypeLits
37−
38−import qualified GHC.Generics as GHC
39−import qualified Generics.SOP as SOP
40−
41−import Squeal.PostgreSQL.Alias
42−import Squeal.PostgreSQL.Expression
43−import Squeal.PostgreSQL.List
44−import Squeal.PostgreSQL.Render
45−import Squeal.PostgreSQL.Schema
46−
47−-- $setup
48−-- >>> import Squeal.PostgreSQL
49−
50−{- |
51−`Aggregate` functions compute a single result from a set of input values.
52−`Aggregate` functions can be used as `GroupedBy` `Expression`s as well
53−as `Squeal.PostgreSQL.Expression.Window.WindowFunction`s.
54−-}
55−class Aggregate expr1 exprN aggr
56− | aggr -> expr1, aggr -> exprN where
57−
58− -- | A special aggregation that does not require an input
59− --
60− -- >>> :{
61− -- let
62− -- expression :: Expression '[] commons ('Grouped bys) schemas params from ('NotNull 'PGint8)
63− -- expression = countStar
64− -- in printSQL expression
65− -- :}
66− -- count(*)
67− countStar :: aggr ('NotNull 'PGint8)
68−
69− -- | >>> :{
70− -- let
71− -- expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: null ty]] ('NotNull 'PGint8)
72− -- expression = count (All #col)
73− -- in printSQL expression
74− -- :}
75− -- count(ALL "col")
76− count
77− :: expr1 ty
78− -- ^ what to count
79− -> aggr ('NotNull 'PGint8)
80−
81− -- | >>> :{
82− -- let
83− -- expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: 'Null 'PGnumeric]] ('Null 'PGnumeric)
84− -- expression = sum_ (Distinct #col)
85− -- in printSQL expression
86− -- :}
87− -- sum(DISTINCT "col")
88− sum_
89− :: expr1 (null ty)
90− -> aggr ('Null (PGSum ty))
91−
92− -- | input values, including nulls, concatenated into an array
93− arrayAgg
94− :: expr1 ty
95− -> aggr ('Null ('PGvararray ty))
96−
97− -- | aggregates values as a JSON array
98− jsonAgg
99− :: expr1 ty
100− -> aggr ('Null 'PGjson)
101−
102− -- | aggregates values as a JSON array
103− jsonbAgg
104− :: expr1 ty
105− -> aggr ('Null 'PGjsonb)
106−
107− {- |
108− the bitwise AND of all non-null input values, or null if none
109−
110− >>> :{
111− let
112− expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: null 'PGint4]] ('Null 'PGint4)
113− expression = bitAnd (Distinct #col)
114− in printSQL expression
115− :}
116− bit_and(DISTINCT "col")
117− -}
118− bitAnd
119− :: int `In` PGIntegral
120− => expr1 (null int)
121− -- ^ what to aggregate
122− -> aggr ('Null int)
123−
124− {- |
125− the bitwise OR of all non-null input values, or null if none
126−
127− >>> :{
128− let
129− expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: null 'PGint4]] ('Null 'PGint4)
130− expression = bitOr (All #col)
131− in printSQL expression
132− :}
133− bit_or(ALL "col")
134− -}
135− bitOr
136− :: int `In` PGIntegral
137− => expr1 (null int)
138− -- ^ what to aggregate
139− -> aggr ('Null int)
140−
141− {- |
142− true if all input values are true, otherwise false
143−
144− >>> :{
145− let
146− winFun :: WindowFunction '[] commons 'Ungrouped schemas params '[tab ::: '["col" ::: null 'PGbool]] ('Null 'PGbool)
147− winFun = boolAnd #col
148− in printSQL winFun
149− :}
150− bool_and("col")
151− -}
152− boolAnd
153− :: expr1 (null 'PGbool)
154− -- ^ what to aggregate
155− -> aggr ('Null 'PGbool)
156−
157− {- |
158− true if at least one input value is true, otherwise false
159−
160− >>> :{
161− let
162− expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: null 'PGbool]] ('Null 'PGbool)
163− expression = boolOr (All #col)
164− in printSQL expression
165− :}
166− bool_or(ALL "col")
167− -}
168− boolOr
169− :: expr1 (null 'PGbool)
170− -- ^ what to aggregate
171− -> aggr ('Null 'PGbool)
172−
173− {- |
174− equivalent to `boolAnd`
175−
176− >>> :{
177− let
178− expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: null 'PGbool]] ('Null 'PGbool)
179− expression = every (Distinct #col)
180− in printSQL expression
181− :}
182− every(DISTINCT "col")
183− -}
184− every
185− :: expr1 (null 'PGbool)
186− -- ^ what to aggregate
187− -> aggr ('Null 'PGbool)
188−
189− {- |maximum value of expression across all input values-}
190− max_
191− :: expr1 (null ty)
192− -- ^ what to maximize
193− -> aggr ('Null ty)
194−
195− -- | minimum value of expression across all input values
196− min_
197− :: expr1 (null ty)
198− -- ^ what to minimize
199− -> aggr ('Null ty)
200−
201− -- | the average (arithmetic mean) of all input values
202− avg
203− :: expr1 (null ty)
204− -- ^ what to average
205− -> aggr ('Null (PGAvg ty))
206−
207− {- | correlation coefficient
208−
209− >>> :{
210− let
211− expression :: Expression '[] c ('Grouped g) s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)
212− expression = corr (All (#y *: #x))
213− in printSQL expression
214− :}
215− corr(ALL "y", "x")
216− -}
217− corr
218− :: exprN '[null 'PGfloat8, null 'PGfloat8]
219− -> aggr ('Null 'PGfloat8)
220−
221− {- | population covariance
222−
223− >>> :{
224− let
225− expression :: Expression '[] c ('Grouped g) s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)
226− expression = covarPop (All (#y *: #x))
227− in printSQL expression
228− :}
229− covar_pop(ALL "y", "x")
230− -}
231− covarPop
232− :: exprN '[null 'PGfloat8, null 'PGfloat8]
233− -> aggr ('Null 'PGfloat8)
234−
235− {- | sample covariance
236−
237− >>> :{
238− let
239− winFun :: WindowFunction '[] c 'Ungrouped s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)
240− winFun = covarSamp (#y *: #x)
241− in printSQL winFun
242− :}
243− covar_samp("y", "x")
244− -}
245− covarSamp
246− :: exprN '[null 'PGfloat8, null 'PGfloat8]
247− -> aggr ('Null 'PGfloat8)
248−
249− {- | average of the independent variable (sum(X)/N)
250−
251− >>> :{
252− let
253− expression :: Expression '[] c ('Grouped g) s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)
254− expression = regrAvgX (All (#y *: #x))
255− in printSQL expression
256− :}
257− regr_avgx(ALL "y", "x")
258− -}
259− regrAvgX
260− :: exprN '[null 'PGfloat8, null 'PGfloat8]
261− -> aggr ('Null 'PGfloat8)
262−
263− {- | average of the dependent variable (sum(Y)/N)
264−
265− >>> :{
266− let
267− winFun :: WindowFunction '[] c 'Ungrouped s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)
268− winFun = regrAvgY (#y *: #x)
269− in printSQL winFun
270− :}
271− regr_avgy("y", "x")
272− -}
273− regrAvgY
274− :: exprN '[null 'PGfloat8, null 'PGfloat8]
275− -> aggr ('Null 'PGfloat8)
276−
277− {- | number of input rows in which both expressions are nonnull
278−
279− >>> :{
280− let
281− winFun :: WindowFunction '[] c 'Ungrouped s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGint8)
282− winFun = regrCount (#y *: #x)
283− in printSQL winFun
284− :}
285− regr_count("y", "x")
286− -}
287− regrCount
288− :: exprN '[null 'PGfloat8, null 'PGfloat8]
289− -> aggr ('Null 'PGint8)
290−
291− {- | y-intercept of the least-squares-fit linear equation determined by the (X, Y) pairs
292− >>> :{
293− let
294− expression :: Expression '[] c ('Grouped g) s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)
295− expression = regrIntercept (All (#y *: #x))
296− in printSQL expression
297− :}
298− regr_intercept(ALL "y", "x")
299− -}
300− regrIntercept
301− :: exprN '[null 'PGfloat8, null 'PGfloat8]
302− -> aggr ('Null 'PGfloat8)
303−
304− -- | @regr_r2(Y, X)@, square of the correlation coefficient
305− regrR2
306− :: exprN '[null 'PGfloat8, null 'PGfloat8]
307− -> aggr ('Null 'PGfloat8)
308−
309− -- | @regr_slope(Y, X)@, slope of the least-squares-fit linear equation
310− -- determined by the (X, Y) pairs
311− regrSlope
312− :: exprN '[null 'PGfloat8, null 'PGfloat8]
313− -> aggr ('Null 'PGfloat8)
314−
315− -- | @regr_sxx(Y, X)@, sum(X^2) - sum(X)^2/N
316− -- (“sum of squares” of the independent variable)
317− regrSxx
318− :: exprN '[null 'PGfloat8, null 'PGfloat8]
319− -> aggr ('Null 'PGfloat8)
320−
321− -- | @regr_sxy(Y, X)@, sum(X*Y) - sum(X) * sum(Y)/N
322− -- (“sum of products” of independent times dependent variable)
323− regrSxy
324− :: exprN '[null 'PGfloat8, null 'PGfloat8]
325− -> aggr ('Null 'PGfloat8)
326−
327− -- | @regr_syy(Y, X)@, sum(Y^2) - sum(Y)^2/N
328− -- (“sum of squares” of the dependent variable)
329− regrSyy
330− :: exprN '[null 'PGfloat8, null 'PGfloat8]
331− -> aggr ('Null 'PGfloat8)
332−
333− -- | historical alias for `stddevSamp`
334− stddev
335− :: expr1 (null ty)
336− -> aggr ('Null (PGAvg ty))
337−
338− -- | population standard deviation of the input values
339− stddevPop
340− :: expr1 (null ty)
341− -> aggr ('Null (PGAvg ty))
342−
343− -- | sample standard deviation of the input values
344− stddevSamp
345− :: expr1 (null ty)
346− -> aggr ('Null (PGAvg ty))
347−
348− -- | historical alias for `varSamp`
349− variance
350− :: expr1 (null ty)
351− -> aggr ('Null (PGAvg ty))
352−
353− -- | population variance of the input values
354− -- (square of the population standard deviation)
355− varPop
356− :: expr1 (null ty)
357− -> aggr ('Null (PGAvg ty))
358−
359− -- | sample variance of the input values
360− -- (square of the sample standard deviation)
361− varSamp
362− :: expr1 (null ty)
363− -> aggr ('Null (PGAvg ty))
364−
365−{- |
366−`Distinction`s are used for the input of `Aggregate` `Expression`s.
367−`All` invokes the aggregate once for each input row.
368−`Distinct` invokes the aggregate once for each distinct value of the expression
369−(or distinct set of values, for multiple expressions) found in the input
370−-}
371−data Distinction (expr :: kind -> Type) (ty :: kind)
372− = All (expr ty)
373− | Distinct (expr ty)
374− deriving (GHC.Generic,Show,Eq,Ord)
375−instance NFData (Distinction (Expression outer commons grp schemas params from) ty)
376−instance RenderSQL (Distinction (Expression outer commons grp schemas params from) ty) where
377− renderSQL = \case
378− All x -> "ALL" <+> renderSQL x
379− Distinct x -> "DISTINCT" <+> renderSQL x
380−instance SOP.SListI tys => RenderSQL
381− (Distinction (NP (Expression outer commons grp schemas params from)) tys) where
382− renderSQL = \case
383− All xs -> "ALL" <+> renderCommaSeparated renderSQL xs
384− Distinct xs -> "DISTINCT" <+> renderCommaSeparated renderSQL xs
385−
386−instance Aggregate
387− (Distinction (Expression outer commons 'Ungrouped schemas params from))
388− (Distinction (NP (Expression outer commons 'Ungrouped schemas params from)))
389− (Expression outer commons ('Grouped bys) schemas params from) where
390− countStar = UnsafeExpression "count(*)"
391− count = unsafeAggregate1 "count"
392− sum_ = unsafeAggregate1 "sum"
393− arrayAgg = unsafeAggregate1 "array_agg"
394− jsonAgg = unsafeAggregate1 "json_agg"
395− jsonbAgg = unsafeAggregate1 "jsonb_agg"
396− bitAnd = unsafeAggregate1 "bit_and"
397− bitOr = unsafeAggregate1 "bit_or"
398− boolAnd = unsafeAggregate1 "bool_and"
399− boolOr = unsafeAggregate1 "bool_or"
400− every = unsafeAggregate1 "every"
401− max_ = unsafeAggregate1 "max"
402− min_ = unsafeAggregate1 "min"
403− avg = unsafeAggregate1 "avg"
404− corr = unsafeAggregateN "corr"
405− covarPop = unsafeAggregateN "covar_pop"
406− covarSamp = unsafeAggregateN "covar_samp"
407− regrAvgX = unsafeAggregateN "regr_avgx"
408− regrAvgY = unsafeAggregateN "regr_avgy"
409− regrCount = unsafeAggregateN "regr_count"
410− regrIntercept = unsafeAggregateN "regr_intercept"
411− regrR2 = unsafeAggregateN "regr_r2"
412− regrSlope = unsafeAggregateN "regr_slope"
413− regrSxx = unsafeAggregateN "regr_sxx"
414− regrSxy = unsafeAggregateN "regr_sxy"
415− regrSyy = unsafeAggregateN "regr_syy"
416− stddev = unsafeAggregate1 "stddev"
417− stddevPop = unsafeAggregate1 "stddev_pop"
418− stddevSamp = unsafeAggregate1 "stddev_samp"
419− variance = unsafeAggregate1 "variance"
420− varPop = unsafeAggregate1 "var_pop"
421− varSamp = unsafeAggregate1 "var_samp"
422−
423−-- | escape hatch to define aggregate functions
424−unsafeAggregate1
425− :: ByteString -- ^ aggregate function
426− -> Distinction (Expression outer commons 'Ungrouped schemas params from) x
427− -> Expression outer commons ('Grouped bys) schemas params from y
428−unsafeAggregate1 fun x = UnsafeExpression $ fun <> parenthesized (renderSQL x)
429−
430−unsafeAggregateN
431− :: SOP.SListI xs
432− => ByteString -- ^ function
433− -> Distinction (NP (Expression outer commons 'Ungrouped schemas params from)) xs
434− -> Expression outer commons ('Grouped bys) schemas params from y
435−unsafeAggregateN fun xs = UnsafeExpression $ fun <> parenthesized (renderSQL xs)
436−
437−-- | A type family that calculates `PGSum``PGType` of
438−-- a given argument `PGType`.
439−type family PGSum ty where
440− PGSum 'PGint2 = 'PGint8
441− PGSum 'PGint4 = 'PGint8
442− PGSum 'PGint8 = 'PGnumeric
443− PGSum 'PGfloat4 = 'PGfloat4
444− PGSum 'PGfloat8 = 'PGfloat8
445− PGSum 'PGnumeric = 'PGnumeric
446− PGSum 'PGinterval = 'PGinterval
447− PGSum 'PGmoney = 'PGmoney
448− PGSum pg = TypeError
449− ( 'Text "Squeal type error: Cannot sum with argument type "
450− ':<>: 'ShowType pg )
451−
452−-- | A type family that calculates `PGAvg` type of a `PGType`.
453−type family PGAvg ty where
454− PGAvg 'PGint2 = 'PGnumeric
455− PGAvg 'PGint4 = 'PGnumeric
456− PGAvg 'PGint8 = 'PGnumeric
457− PGAvg 'PGnumeric = 'PGnumeric
458− PGAvg 'PGfloat4 = 'PGfloat8
459− PGAvg 'PGfloat8 = 'PGfloat8
460− PGAvg 'PGinterval = 'PGinterval
461− PGAvg pg = TypeError
462− ('Text "Squeal type error: No average for " ':<>: 'ShowType pg)
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Collection.hsdeleted−169
@@ -1,169 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Expression.Collection
3−Description: Array and composite functions
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Array and composite functions
9−-}
10−
11−{-# LANGUAGE
12− AllowAmbiguousTypes
13− , DataKinds
14− , FlexibleContexts
15− , FlexibleInstances
16− , MultiParamTypeClasses
17− , OverloadedLabels
18− , OverloadedStrings
19− , RankNTypes
20− , ScopedTypeVariables
21− , TypeApplications
22− , TypeFamilies
23− , TypeOperators
24− , UndecidableInstances
25−#-}
26−
27−module Squeal.PostgreSQL.Expression.Collection
28− ( array
29− , array1
30− , array2
31− , cardinality
32− , index
33− , unnest
34− , row
35− , field
36− ) where
37−
38−import Data.String
39−import Data.Word (Word64)
40−
41−import qualified Generics.SOP as SOP
42−
43−import Squeal.PostgreSQL.Alias
44−import Squeal.PostgreSQL.Expression
45−import Squeal.PostgreSQL.Expression.Set
46−import Squeal.PostgreSQL.List
47−import Squeal.PostgreSQL.Render
48−import Squeal.PostgreSQL.Schema
49−
50−-- $setup
51−-- >>> import Squeal.PostgreSQL
52−
53−-- | >>> printSQL $ array [null_, false, true]
54−-- ARRAY[NULL, FALSE, TRUE]
55−array
56− :: [Expression outer commons grp schemas params from ty]
57− -- ^ array elements
58− -> Expression outer commons grp schemas params from (null ('PGvararray ty))
59−array xs = UnsafeExpression $ "ARRAY" <>
60− bracketed (commaSeparated (renderSQL <$> xs))
61−
62−{- | construct a 1-dimensional fixed length array
63−
64−>>> printSQL $ array1 (null_ :* false *: true)
65−ARRAY[NULL, FALSE, TRUE]
66−
67−>>> :type array1 (null_ :* false *: true)
68−array1 (null_ :* false *: true)
69− :: Expression
70− outer
71− commons
72− grp
73− schemas
74− params
75− from
76− (null ('PGfixarray '[3] ('Null 'PGbool)))
77−-}
78−array1
79− :: (n ~ Length tys, SOP.All ((~) ty) tys)
80− => NP (Expression outer commons grp schemas params from) tys
81− -> Expression outer commons grp schemas params from (null ('PGfixarray '[n] ty))
82−array1 xs = UnsafeExpression $ "ARRAY" <>
83− bracketed (renderCommaSeparated renderSQL xs)
84−
85−{- | construct a 2-dimensional fixed length array
86−
87−>>> printSQL $ array2 ((null_ :* false *: true) *: (false :* null_ *: true))
88−ARRAY[[NULL, FALSE, TRUE], [FALSE, NULL, TRUE]]
89−
90−>>> :type array2 ((null_ :* false *: true) *: (false :* null_ *: true))
91−array2 ((null_ :* false *: true) *: (false :* null_ *: true))
92− :: Expression
93− outer
94− commons
95− grp
96− schemas
97− params
98− from
99− (null ('PGfixarray '[2, 3] ('Null 'PGbool)))
100−-}
101−array2
102− :: ( SOP.All ((~) tys) tyss
103− , SOP.All SOP.SListI tyss
104− , Length tyss ~ n1
105− , SOP.All ((~) ty) tys
106− , Length tys ~ n2 )
107− => NP (NP (Expression outer commons grp schemas params from)) tyss
108− -> Expression outer commons grp schemas params from (null ('PGfixarray '[n1,n2] ty))
109−array2 xss = UnsafeExpression $ "ARRAY" <>
110− bracketed (renderCommaSeparatedConstraint @SOP.SListI (bracketed . renderCommaSeparated renderSQL) xss)
111−
112−-- | >>> printSQL $ cardinality (array [null_, false, true])
113−-- cardinality(ARRAY[NULL, FALSE, TRUE])
114−cardinality :: null ('PGvararray ty) --> null 'PGint8
115−cardinality = unsafeFunction "cardinality"
116−
117−-- | >>> printSQL $ array [null_, false, true] & index 2
118−-- (ARRAY[NULL, FALSE, TRUE])[2]
119−index
120− :: Word64 -- ^ index
121− -> null ('PGvararray ty) --> NullifyType ty
122−index n expr = UnsafeExpression $
123− parenthesized (renderSQL expr) <> "[" <> fromString (show n) <> "]"
124−
125−-- | Expand an array to a set of rows
126−unnest :: SetFunction "unnest" (null ('PGvararray ty)) '["unnest" ::: ty]
127−unnest = unsafeSetFunction
128−
129−-- | A row constructor is an expression that builds a row value
130−-- (also called a composite value) using values for its member fields.
131−--
132−-- >>> :{
133−-- type Complex = 'PGcomposite
134−-- '[ "real" ::: 'NotNull 'PGfloat8
135−-- , "imaginary" ::: 'NotNull 'PGfloat8 ]
136−-- :}
137−--
138−-- >>> let i = row (0 `as` #real :* 1 `as` #imaginary) :: Expression outer commons grp schemas params from ('NotNull Complex)
139−-- >>> printSQL i
140−-- ROW(0, 1)
141−row
142− :: SOP.SListI row
143− => NP (Aliased (Expression outer commons grp schemas params from)) row
144− -- ^ zero or more expressions for the row field values
145− -> Expression outer commons grp schemas params from (null ('PGcomposite row))
146−row exprs = UnsafeExpression $ "ROW" <> parenthesized
147− (renderCommaSeparated (\ (expr `As` _) -> renderSQL expr) exprs)
148−
149−-- | >>> :{
150−-- type Complex = 'PGcomposite
151−-- '[ "real" ::: 'NotNull 'PGfloat8
152−-- , "imaginary" ::: 'NotNull 'PGfloat8 ]
153−-- type Schema = '["complex" ::: 'Typedef Complex]
154−-- :}
155−--
156−-- >>> let i = row (0 `as` #real :* 1 `as` #imaginary) :: Expression outer '[] grp (Public Schema) from params ('NotNull Complex)
157−-- >>> printSQL $ i & field #complex #imaginary
158−-- (ROW(0, 1)::"complex")."imaginary"
159−field
160− :: ( Has sch schemas schema
161− , Has tydef schema ('Typedef ('PGcomposite row))
162− , Has field row ty)
163− => QualifiedAlias sch tydef -- ^ row type
164− -> Alias field -- ^ field name
165− -> Expression outer commons grp schemas params from ('NotNull ('PGcomposite row))
166− -> Expression outer commons grp schemas params from ty
167−field td fld expr = UnsafeExpression $
168− parenthesized (renderSQL expr <> "::" <> renderSQL td)
169− <> "." <> renderSQL fld
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Comparison.hsdeleted−206
@@ -1,206 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Expression.Comparison
3−Description: Comparison expressions
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Comparison functions and operators
9−-}
10−
11−{-# LANGUAGE
12− OverloadedStrings
13− , RankNTypes
14− , TypeInType
15− , TypeOperators
16−#-}
17−
18−module Squeal.PostgreSQL.Expression.Comparison
19− ( (.==)
20− , (./=)
21− , (.>=)
22− , (.<)
23− , (.<=)
24− , (.>)
25− , greatest
26− , least
27− , BetweenExpr
28− , between
29− , notBetween
30− , betweenSymmetric
31− , notBetweenSymmetric
32− , isDistinctFrom
33− , isNotDistinctFrom
34− , isTrue
35− , isNotTrue
36− , isFalse
37− , isNotFalse
38− , isUnknown
39− , isNotUnknown
40− ) where
41−
42−import Data.ByteString
43−
44−import Squeal.PostgreSQL.Expression
45−import Squeal.PostgreSQL.Expression.Logic
46−import Squeal.PostgreSQL.Render
47−import Squeal.PostgreSQL.Schema
48−
49−-- $setup
50−-- >>> import Squeal.PostgreSQL
51−
52−-- | Comparison operations like `.==`, `./=`, `.>`, `.>=`, `.<` and `.<=`
53−-- will produce @NULL@s if one of their arguments is @NULL@.
54−--
55−-- >>> printSQL $ true .== null_
56−-- (TRUE = NULL)
57−(.==) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
58−(.==) = unsafeBinaryOp "="
59−infix 4 .==
60−
61−-- | >>> printSQL $ true ./= null_
62−-- (TRUE <> NULL)
63−(./=) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
64−(./=) = unsafeBinaryOp "<>"
65−infix 4 ./=
66−
67−-- | >>> printSQL $ true .>= null_
68−-- (TRUE >= NULL)
69−(.>=) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
70−(.>=) = unsafeBinaryOp ">="
71−infix 4 .>=
72−
73−-- | >>> printSQL $ true .< null_
74−-- (TRUE < NULL)
75−(.<) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
76−(.<) = unsafeBinaryOp "<"
77−infix 4 .<
78−
79−-- | >>> printSQL $ true .<= null_
80−-- (TRUE <= NULL)
81−(.<=) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
82−(.<=) = unsafeBinaryOp "<="
83−infix 4 .<=
84−
85−-- | >>> printSQL $ true .> null_
86−-- (TRUE > NULL)
87−(.>) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
88−(.>) = unsafeBinaryOp ">"
89−infix 4 .>
90−
91−-- | >>> let expr = greatest [param @1] currentTimestamp :: Expression outer commons grp schemas '[ 'NotNull 'PGtimestamptz] from ('NotNull 'PGtimestamptz)
92−-- >>> printSQL expr
93−-- GREATEST(($1 :: timestamp with time zone), CURRENT_TIMESTAMP)
94−greatest :: FunctionVar ty ty ty
95−greatest = unsafeFunctionVar "GREATEST"
96−
97−-- | >>> printSQL $ least [null_] currentTimestamp
98−-- LEAST(NULL, CURRENT_TIMESTAMP)
99−least :: FunctionVar ty ty ty
100−least = unsafeFunctionVar "LEAST"
101−
102−{- |
103−A @RankNType@ for comparison expressions like `between`.
104−-}
105−type BetweenExpr
106− = forall outer commons grp schemas params from ty
107− . Expression outer commons grp schemas params from ty
108− -> ( Expression outer commons grp schemas params from ty
109− , Expression outer commons grp schemas params from ty ) -- ^ bounds
110− -> Condition outer commons grp schemas params from
111−
112−unsafeBetweenExpr :: ByteString -> BetweenExpr
113−unsafeBetweenExpr fun a (x,y) = UnsafeExpression $
114− renderSQL a <+> fun <+> renderSQL x <+> "AND" <+> renderSQL y
115−
116−{- | >>> printSQL $ true `between` (null_, false)
117−TRUE BETWEEN NULL AND FALSE
118−-}
119−between :: BetweenExpr
120−between = unsafeBetweenExpr "BETWEEN"
121−
122−{- | >>> printSQL $ true `notBetween` (null_, false)
123−TRUE NOT BETWEEN NULL AND FALSE
124−-}
125−notBetween :: BetweenExpr
126−notBetween = unsafeBetweenExpr "NOT BETWEEN"
127−
128−{- | between, after sorting the comparison values
129−
130−>>> printSQL $ true `betweenSymmetric` (null_, false)
131−TRUE BETWEEN SYMMETRIC NULL AND FALSE
132−-}
133−betweenSymmetric :: BetweenExpr
134−betweenSymmetric = unsafeBetweenExpr "BETWEEN SYMMETRIC"
135−
136−{- | not between, after sorting the comparison values
137−
138−>>> printSQL $ true `notBetweenSymmetric` (null_, false)
139−TRUE NOT BETWEEN SYMMETRIC NULL AND FALSE
140−-}
141−notBetweenSymmetric :: BetweenExpr
142−notBetweenSymmetric = unsafeBetweenExpr "NOT BETWEEN SYMMETRIC"
143−
144−{- | not equal, treating null like an ordinary value
145−
146−>>> printSQL $ true `isDistinctFrom` null_
147−(TRUE IS DISTINCT FROM NULL)
148−-}
149−isDistinctFrom :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
150−isDistinctFrom = unsafeBinaryOp "IS DISTINCT FROM"
151−
152−{- | equal, treating null like an ordinary value
153−
154−>>> printSQL $ true `isNotDistinctFrom` null_
155−(TRUE IS NOT DISTINCT FROM NULL)
156−-}
157−isNotDistinctFrom :: Operator (null0 ty) (null1 ty) ('NotNull 'PGbool)
158−isNotDistinctFrom = unsafeBinaryOp "IS NOT DISTINCT FROM"
159−
160−{- | is true
161−
162−>>> printSQL $ true & isTrue
163−(TRUE IS TRUE)
164−-}
165−isTrue :: null0 'PGbool --> null1 'PGbool
166−isTrue = unsafeRightOp "IS TRUE"
167−
168−{- | is false or unknown
169−
170−>>> printSQL $ true & isNotTrue
171−(TRUE IS NOT TRUE)
172−-}
173−isNotTrue :: null0 'PGbool --> null1 'PGbool
174−isNotTrue = unsafeRightOp "IS NOT TRUE"
175−
176−{- | is false
177−
178−>>> printSQL $ true & isFalse
179−(TRUE IS FALSE)
180−-}
181−isFalse :: null0 'PGbool --> null1 'PGbool
182−isFalse = unsafeRightOp "IS FALSE"
183−
184−{- | is true or unknown
185−
186−>>> printSQL $ true & isNotFalse
187−(TRUE IS NOT FALSE)
188−-}
189−isNotFalse :: null0 'PGbool --> null1 'PGbool
190−isNotFalse = unsafeRightOp "IS NOT FALSE"
191−
192−{- | is unknown
193−
194−>>> printSQL $ true & isUnknown
195−(TRUE IS UNKNOWN)
196−-}
197−isUnknown :: null0 'PGbool --> null1 'PGbool
198−isUnknown = unsafeRightOp "IS UNKNOWN"
199−
200−{- | is true or false
201−
202−>>> printSQL $ true & isNotUnknown
203−(TRUE IS NOT UNKNOWN)
204−-}
205−isNotUnknown :: null0 'PGbool --> null1 'PGbool
206−isNotUnknown = unsafeRightOp "IS NOT UNKNOWN"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Json.hsdeleted−462
@@ -1,462 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Expression.Json
3−Description: Json and Jsonb functions and operators
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Json and Jsonb functions and operators
9−-}
10−
11−{-# LANGUAGE
12− DataKinds
13− , FlexibleContexts
14− , FlexibleInstances
15− , GADTs
16− , OverloadedLabels
17− , OverloadedStrings
18− , PolyKinds
19− , RankNTypes
20− , ScopedTypeVariables
21− , TypeApplications
22− , TypeOperators
23− , UndecidableInstances
24− , UndecidableSuperClasses
25−#-}
26−
27−module Squeal.PostgreSQL.Expression.Json
28− ( -- * Json and Jsonb operators
29− (.->)
30− , (.->>)
31− , (.#>)
32− , (.#>>)
33− -- * Jsonb operators
34− , (.?)
35− , (.?|)
36− , (.?&)
37− , (.-.)
38− , (#-.)
39− -- * Json and Jsonb functions
40− , toJson
41− , toJsonb
42− , arrayToJson
43− , rowToJson
44− , jsonBuildArray
45− , jsonbBuildArray
46− , JsonBuildObject (..)
47− , jsonObject
48− , jsonbObject
49− , jsonZipObject
50− , jsonbZipObject
51− , jsonArrayLength
52− , jsonbArrayLength
53− , jsonTypeof
54− , jsonbTypeof
55− , jsonStripNulls
56− , jsonbStripNulls
57− , jsonbSet
58− , jsonbInsert
59− , jsonbPretty
60− -- * Json and Jsonb set returning functions
61− , jsonEach
62− , jsonbEach
63− , jsonEachText
64− , jsonbEachText
65− , jsonObjectKeys
66− , jsonbObjectKeys
67− , JsonPopulateFunction
68− , jsonPopulateRecord
69− , jsonbPopulateRecord
70− , jsonPopulateRecordSet
71− , jsonbPopulateRecordSet
72− , JsonToRecordFunction
73− , jsonToRecord
74− , jsonbToRecord
75− , jsonToRecordSet
76− , jsonbToRecordSet
77− ) where
78−
79−import Data.ByteString (ByteString)
80−import GHC.TypeLits
81−
82−import Squeal.PostgreSQL.Alias
83−import Squeal.PostgreSQL.Expression
84−import Squeal.PostgreSQL.Expression.Set
85−import Squeal.PostgreSQL.Expression.Type
86−import Squeal.PostgreSQL.List
87−import Squeal.PostgreSQL.Query
88−import Squeal.PostgreSQL.Render
89−import Squeal.PostgreSQL.Schema
90−
91−import qualified Generics.SOP as SOP
92−
93−-- $setup
94−-- >>> import Squeal.PostgreSQL
95−-- >>> import Data.Aeson
96−
97−{-----------------------------------------
98− -- json and jsonb support
99−
100−See https://www.postgresql.org/docs/10/static/functions-json.html -- most
101−comments lifted directly from this page.
102−
103−Table 9.44: json and jsonb operators
104−-----------------------------------------}
105−
106−-- | Get JSON value (object field or array element) at a key.
107−(.->)
108− :: (json `In` PGJsonType, key `In` PGJsonKey)
109− => Operator (null json) (null key) ('Null json)
110−infixl 8 .->
111−(.->) = unsafeBinaryOp "->"
112−
113−-- | Get JSON value (object field or array element) at a key, as text.
114−(.->>)
115− :: (json `In` PGJsonType, key `In` PGJsonKey)
116− => Operator (null json) (null key) ('Null 'PGtext)
117−infixl 8 .->>
118−(.->>) = unsafeBinaryOp "->>"
119−
120−-- | Get JSON value at a specified path.
121−(.#>)
122− :: json `In` PGJsonType
123− => Operator (null json) (null ('PGvararray ('NotNull 'PGtext))) ('Null json)
124−infixl 8 .#>
125−(.#>) = unsafeBinaryOp "#>"
126−
127−-- | Get JSON value at a specified path as text.
128−(.#>>)
129− :: json `In` PGJsonType
130− => Operator (null json) (null ('PGvararray ('NotNull 'PGtext))) ('Null 'PGtext)
131−infixl 8 .#>>
132−(.#>>) = unsafeBinaryOp "#>>"
133−
134−-- Additional jsonb operators
135−
136−-- | Does the string exist as a top-level key within the JSON value?
137−(.?) :: Operator (null 'PGjsonb) (null 'PGtext) ('Null 'PGbool)
138−infixl 9 .?
139−(.?) = unsafeBinaryOp "?"
140−
141−-- | Do any of these array strings exist as top-level keys?
142−(.?|) :: Operator
143− (null 'PGjsonb)
144− (null ('PGvararray ('NotNull 'PGtext)))
145− ('Null 'PGbool)
146−infixl 9 .?|
147−(.?|) = unsafeBinaryOp "?|"
148−
149−-- | Do all of these array strings exist as top-level keys?
150−(.?&) :: Operator
151− (null 'PGjsonb)
152− (null ('PGvararray ('NotNull 'PGtext)))
153− ('Null 'PGbool)
154−infixl 9 .?&
155−(.?&) = unsafeBinaryOp "?&"
156−
157−-- | Delete a key or keys from a JSON object, or remove an array element.
158−--
159−-- If the right operand is
160−--
161−-- @ text @: Delete key / value pair or string element from left operand.
162−-- Key / value pairs are matched based on their key value,
163−--
164−-- @ text[] @: Delete multiple key / value pairs or string elements
165−-- from left operand. Key / value pairs are matched based on their key value,
166−--
167−-- @ integer @: Delete the array element with specified index (Negative integers
168−-- count from the end). Throws an error if top level container is not an array.
169−(.-.)
170− :: key `In` '[ 'PGtext, 'PGvararray ('NotNull 'PGtext), 'PGint4, 'PGint2 ]
171− => Operator (null 'PGjsonb) (null key) (null 'PGjsonb)
172−infixl 6 .-.
173−(.-.) = unsafeBinaryOp "-"
174−
175−-- | Delete the field or element with specified path (for JSON arrays, negative
176−-- integers count from the end)
177−(#-.) :: Operator (null 'PGjsonb) (null ('PGvararray ('NotNull 'PGtext))) (null 'PGjsonb)
178−infixl 6 #-.
179−(#-.) = unsafeBinaryOp "#-"
180−
181−{-----------------------------------------
182−Table 9.45: JSON creation functions
183−-----------------------------------------}
184−
185−-- | Returns the value as json. Arrays and composites are converted
186−-- (recursively) to arrays and objects; otherwise, if there is a cast from the
187−-- type to json, the cast function will be used to perform the conversion;
188−-- otherwise, a scalar value is produced. For any scalar type other than a
189−-- number, a Boolean, or a null value, the text representation will be used, in
190−-- such a fashion that it is a valid json value.
191−toJson :: null ty --> null 'PGjson
192−toJson = unsafeFunction "to_json"
193−
194−-- | Returns the value as jsonb. Arrays and composites are converted
195−-- (recursively) to arrays and objects; otherwise, if there is a cast from the
196−-- type to json, the cast function will be used to perform the conversion;
197−-- otherwise, a scalar value is produced. For any scalar type other than a
198−-- number, a Boolean, or a null value, the text representation will be used, in
199−-- such a fashion that it is a valid jsonb value.
200−toJsonb :: null ty --> null 'PGjsonb
201−toJsonb = unsafeFunction "to_jsonb"
202−
203−-- | Returns the array as a JSON array. A PostgreSQL multidimensional array
204−-- becomes a JSON array of arrays.
205−arrayToJson :: null ('PGvararray ty) --> null 'PGjson
206−arrayToJson = unsafeFunction "array_to_json"
207−
208−-- | Returns the row as a JSON object.
209−rowToJson :: null ('PGcomposite ty) --> null 'PGjson
210−rowToJson = unsafeFunction "row_to_json"
211−
212−-- | Builds a possibly-heterogeneously-typed JSON array out of a variadic
213−-- argument list.
214−jsonBuildArray :: SOP.SListI tuple => tuple ---> null 'PGjson
215−jsonBuildArray = unsafeFunctionN "json_build_array"
216−
217−-- | Builds a possibly-heterogeneously-typed (binary) JSON array out of a
218−-- variadic argument list.
219−jsonbBuildArray :: SOP.SListI tuple => tuple ---> null 'PGjsonb
220−jsonbBuildArray = unsafeFunctionN "jsonb_build_array"
221−
222−-- | Builds a possibly-heterogeneously-typed JSON object out of a variadic
223−-- argument list. The elements of the argument list must alternate between text
224−-- and values.
225−class SOP.SListI tys => JsonBuildObject tys where
226−
227− jsonBuildObject :: tys ---> null 'PGjson
228− jsonBuildObject = unsafeFunctionN "json_build_object"
229−
230− jsonbBuildObject :: tys ---> null 'PGjsonb
231− jsonbBuildObject = unsafeFunctionN "jsonb_build_object"
232−
233−instance JsonBuildObject '[]
234−instance (JsonBuildObject tys, key `In` PGJsonKey)
235− => JsonBuildObject ('NotNull key ': value ': tys)
236−
237−-- | Builds a JSON object out of a text array.
238−-- The array must have two dimensions
239−-- such that each inner array has exactly two elements,
240−-- which are taken as a key/value pair.
241−jsonObject
242− :: null ('PGfixarray '[n,2] ('NotNull 'PGtext))
243− --> null 'PGjson
244−jsonObject = unsafeFunction "json_object"
245−
246−-- | Builds a binary JSON object out of a text array.
247−-- The array must have two dimensions
248−-- such that each inner array has exactly two elements,
249−-- which are taken as a key/value pair.
250−jsonbObject
251− :: null ('PGfixarray '[n,2] ('NotNull 'PGtext))
252− --> null 'PGjsonb
253−jsonbObject = unsafeFunction "jsonb_object"
254−
255−-- | This is an alternate form of 'jsonObject' that takes two arrays; one for
256−-- keys and one for values, that are zipped pairwise to create a JSON object.
257−jsonZipObject ::
258− '[ null ('PGvararray ('NotNull 'PGtext))
259− , null ('PGvararray ('NotNull 'PGtext)) ]
260− ---> null 'PGjson
261−jsonZipObject = unsafeFunctionN "json_object"
262−
263−-- | This is an alternate form of 'jsonbObject' that takes two arrays; one for
264−-- keys and one for values, that are zipped pairwise to create a binary JSON
265−-- object.
266−jsonbZipObject ::
267− '[ null ('PGvararray ('NotNull 'PGtext))
268− , null ('PGvararray ('NotNull 'PGtext)) ]
269− ---> null 'PGjsonb
270−jsonbZipObject = unsafeFunctionN "jsonb_object"
271−
272−{-----------------------------------------
273−Table 9.46: JSON processing functions
274−-----------------------------------------}
275−
276−-- | Returns the number of elements in the outermost JSON array.
277−jsonArrayLength :: null 'PGjson --> null 'PGint4
278−jsonArrayLength = unsafeFunction "json_array_length"
279−
280−-- | Returns the number of elements in the outermost binary JSON array.
281−jsonbArrayLength :: null 'PGjsonb --> null 'PGint4
282−jsonbArrayLength = unsafeFunction "jsonb_array_length"
283−
284−-- | Returns the type of the outermost JSON value as a text string. Possible
285−-- types are object, array, string, number, boolean, and null.
286−jsonTypeof :: null 'PGjson --> null 'PGtext
287−jsonTypeof = unsafeFunction "json_typeof"
288−
289−-- | Returns the type of the outermost binary JSON value as a text string.
290−-- Possible types are object, array, string, number, boolean, and null.
291−jsonbTypeof :: null 'PGjsonb --> null 'PGtext
292−jsonbTypeof = unsafeFunction "jsonb_typeof"
293−
294−-- | Returns its argument with all object fields that have null values omitted.
295−-- Other null values are untouched.
296−jsonStripNulls :: null 'PGjson --> null 'PGjson
297−jsonStripNulls = unsafeFunction "json_strip_nulls"
298−
299−-- | Returns its argument with all object fields that have null values omitted.
300−-- Other null values are untouched.
301−jsonbStripNulls :: null 'PGjsonb --> null 'PGjsonb
302−jsonbStripNulls = unsafeFunction "jsonb_strip_nulls"
303−
304−-- | @ jsonbSet target path new_value create_missing @
305−--
306−-- Returns target with the section designated by path replaced by @new_value@,
307−-- or with @new_value@ added if create_missing is
308−-- `Squeal.PostgreSQL.Expression.Logic.true` and the
309−-- item designated by path does not exist. As with the path orientated
310−-- operators, negative integers that appear in path count from the end of JSON
311−-- arrays.
312−jsonbSet ::
313− '[ null 'PGjsonb, null ('PGvararray ('NotNull 'PGtext))
314− , null 'PGjsonb, null 'PGbool ] ---> null 'PGjsonb
315−jsonbSet = unsafeFunctionN "jsonbSet"
316−
317−-- | @ jsonbInsert target path new_value insert_after @
318−--
319−-- Returns target with @new_value@ inserted. If target section designated by
320−-- path is in a JSONB array, @new_value@ will be inserted before target or after
321−-- if @insert_after@ is `Squeal.PostgreSQL.Expression.Logic.true`.
322−-- If target section designated by
323−-- path is in JSONB object, @new_value@ will be inserted only if target does not
324−-- exist. As with the path orientated operators, negative integers that appear
325−-- in path count from the end of JSON arrays.
326−jsonbInsert ::
327− '[ null 'PGjsonb, null ('PGvararray ('NotNull 'PGtext))
328− , null 'PGjsonb, null 'PGbool ] ---> null 'PGjsonb
329−jsonbInsert = unsafeFunctionN "jsonb_insert"
330−
331−-- | Returns its argument as indented JSON text.
332−jsonbPretty :: null 'PGjsonb --> null 'PGtext
333−jsonbPretty = unsafeFunction "jsonb_pretty"
334−
335−{- | Expands the outermost JSON object into a set of key/value pairs.
336−
337−>>> printSQL (select Star (from (jsonEach (literal (Json (object ["a" .= "foo", "b" .= "bar"]))))))
338−SELECT * FROM json_each(('{"a":"foo","b":"bar"}' :: json))
339−-}
340−jsonEach :: SetFunction "json_each" (null 'PGjson)
341− '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGjson]
342−jsonEach = unsafeSetFunction
343−
344−{- | Expands the outermost binary JSON object into a set of key/value pairs.
345−
346−>>> printSQL (select Star (from (jsonbEach (literal (Jsonb (object ["a" .= "foo", "b" .= "bar"]))))))
347−SELECT * FROM jsonb_each(('{"a":"foo","b":"bar"}' :: jsonb))
348−-}
349−jsonbEach
350− :: SetFunction "jsonb_each" (nullity 'PGjsonb)
351− '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGjson]
352−jsonbEach = unsafeSetFunction
353−
354−{- | Expands the outermost JSON object into a set of key/value pairs.
355−
356−>>> printSQL (select Star (from (jsonEachText (literal (Json (object ["a" .= "foo", "b" .= "bar"]))))))
357−SELECT * FROM json_each_text(('{"a":"foo","b":"bar"}' :: json))
358−-}
359−jsonEachText
360− :: SetFunction "json_each_text" (null 'PGjson)
361− '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext]
362−jsonEachText = unsafeSetFunction
363−
364−{- | Expands the outermost binary JSON object into a set of key/value pairs.
365−
366−>>> printSQL (select Star (from (jsonbEachText (literal (Jsonb (object ["a" .= "foo", "b" .= "bar"]))))))
367−SELECT * FROM jsonb_each_text(('{"a":"foo","b":"bar"}' :: jsonb))
368−-}
369−jsonbEachText
370− :: SetFunction "jsonb_each_text" (null 'PGjsonb)
371− '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext]
372−jsonbEachText = unsafeSetFunction
373−
374−{- | Returns set of keys in the outermost JSON object.
375−
376−>>> printSQL (jsonObjectKeys (literal (Json (object ["a" .= "foo", "b" .= "bar"]))))
377−json_object_keys(('{"a":"foo","b":"bar"}' :: json))
378−-}
379−jsonObjectKeys
380− :: SetFunction "json_object_keys" (nullity 'PGjson)
381− '["json_object_keys" ::: 'NotNull 'PGtext]
382−jsonObjectKeys = unsafeSetFunction
383−
384−{- | Returns set of keys in the outermost JSON object.
385−
386−>>> printSQL (jsonbObjectKeys (literal (Jsonb (object ["a" .= "foo", "b" .= "bar"]))))
387−jsonb_object_keys(('{"a":"foo","b":"bar"}' :: jsonb))
388−-}
389−jsonbObjectKeys
390− :: SetFunction "jsonb_object_keys" (null 'PGjsonb)
391− '["jsonb_object_keys" ::: 'NotNull 'PGtext]
392−jsonbObjectKeys = unsafeSetFunction
393−
394−-- | Build rows from Json types.
395−type JsonPopulateFunction fun json
396− = forall schemas row outer commons params
397− . json `In` PGJsonType
398− => TypeExpression schemas ('NotNull ('PGcomposite row)) -- ^ row type
399− -> Expression outer commons 'Ungrouped schemas params '[] ('NotNull json)
400− -- ^ json type
401− -> FromClause outer commons schemas params '[fun ::: row]
402−
403−unsafePopulateFunction
404− :: forall fun ty
405− . KnownSymbol fun => Alias fun -> JsonPopulateFunction fun ty
406−unsafePopulateFunction _fun ty expr = UnsafeFromClause $ renderSymbol @fun
407− <> parenthesized ("null::" <> renderSQL ty <> ", " <> renderSQL expr)
408−
409−-- | Expands the JSON expression to a row whose columns match the record
410−-- type defined by the given table.
411−jsonPopulateRecord :: JsonPopulateFunction "json_populate_record" 'PGjson
412−jsonPopulateRecord = unsafePopulateFunction #json_populate_record
413−
414−-- | Expands the binary JSON expression to a row whose columns match the record
415−-- type defined by the given table.
416−jsonbPopulateRecord :: JsonPopulateFunction "jsonb_populate_record" 'PGjsonb
417−jsonbPopulateRecord = unsafePopulateFunction #jsonb_populate_record
418−
419−-- | Expands the outermost array of objects in the given JSON expression to a
420−-- set of rows whose columns match the record type defined by the given table.
421−jsonPopulateRecordSet :: JsonPopulateFunction "json_populate_record_set" 'PGjson
422−jsonPopulateRecordSet = unsafePopulateFunction #json_populate_record_set
423−
424−-- | Expands the outermost array of objects in the given binary JSON expression
425−-- to a set of rows whose columns match the record type defined by the given
426−-- table.
427−jsonbPopulateRecordSet :: JsonPopulateFunction "jsonb_populate_record_set" 'PGjsonb
428−jsonbPopulateRecordSet = unsafePopulateFunction #jsonb_populate_record_set
429−
430−-- | Build rows from Json types.
431−type JsonToRecordFunction json
432− = forall outer commons schemas params tab row
433− . (SOP.SListI row, json `In` PGJsonType)
434− => Expression outer commons 'Ungrouped schemas params '[] ('NotNull json)
435− -- ^ json type
436− -> Aliased (NP (Aliased (TypeExpression schemas))) (tab ::: row)
437− -- ^ row type
438− -> FromClause outer commons schemas params '[tab ::: row]
439−
440−unsafeRecordFunction :: ByteString -> JsonToRecordFunction json
441−unsafeRecordFunction fun expr (types `As` tab) = UnsafeFromClause $
442− fun <> parenthesized (renderSQL expr) <+> "AS" <+> renderSQL tab
443− <> parenthesized (renderCommaSeparated renderTy types)
444− where
445− renderTy :: Aliased (TypeExpression schemas) ty -> ByteString
446− renderTy (ty `As` alias) = renderSQL alias <+> renderSQL ty
447−
448−-- | Builds an arbitrary record from a JSON object.
449−jsonToRecord :: JsonToRecordFunction 'PGjson
450−jsonToRecord = unsafeRecordFunction "json_to_record"
451−
452−-- | Builds an arbitrary record from a binary JSON object.
453−jsonbToRecord :: JsonToRecordFunction 'PGjsonb
454−jsonbToRecord = unsafeRecordFunction "jsonb_to_record"
455−
456−-- | Builds an arbitrary set of records from a JSON array of objects.
457−jsonToRecordSet :: JsonToRecordFunction 'PGjson
458−jsonToRecordSet = unsafeRecordFunction "json_to_record_set"
459−
460−-- | Builds an arbitrary set of records from a binary JSON array of objects.
461−jsonbToRecordSet :: JsonToRecordFunction 'PGjsonb
462−jsonbToRecordSet = unsafeRecordFunction "jsonb_to_record_set"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Literal.hsdeleted−87
@@ -1,87 +0,0 @@
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.hsdeleted−105
@@ -1,105 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Expression.Logic
3−Description: Logical expressions
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Logical expressions and operators
9−-}
10−
11−{-# LANGUAGE
12− DataKinds
13− , OverloadedStrings
14− , TypeOperators
15−#-}
16−
17−module Squeal.PostgreSQL.Expression.Logic
18− ( Condition
19− , true
20− , false
21− , not_
22− , (.&&)
23− , (.||)
24− , caseWhenThenElse
25− , ifThenElse
26− ) where
27−
28−import Squeal.PostgreSQL.Expression
29−import Squeal.PostgreSQL.Render
30−import Squeal.PostgreSQL.Schema
31−
32−-- | A `Condition` is an `Expression`, which can evaluate
33−-- to `true`, `false` or `Squeal.PostgreSQL.Null.null_`. This is because SQL uses
34−-- a three valued logic.
35−type Condition outer commons grp schemas params from =
36− Expression outer commons grp schemas params from ('Null 'PGbool)
37−
38−-- | >>> printSQL true
39−-- TRUE
40−true :: Expr (null 'PGbool)
41−true = UnsafeExpression "TRUE"
42−
43−-- | >>> printSQL false
44−-- FALSE
45−false :: Expr (null 'PGbool)
46−false = UnsafeExpression "FALSE"
47−
48−-- | >>> printSQL $ not_ true
49−-- (NOT TRUE)
50−not_ :: null 'PGbool --> null 'PGbool
51−not_ = unsafeLeftOp "NOT"
52−
53−-- | >>> printSQL $ true .&& false
54−-- (TRUE AND FALSE)
55−(.&&) :: Operator (null 'PGbool) (null 'PGbool) (null 'PGbool)
56−infixr 3 .&&
57−(.&&) = unsafeBinaryOp "AND"
58−
59−-- | >>> printSQL $ true .|| false
60−-- (TRUE OR FALSE)
61−(.||) :: Operator (null 'PGbool) (null 'PGbool) (null 'PGbool)
62−infixr 2 .||
63−(.||) = unsafeBinaryOp "OR"
64−
65−-- | >>> :{
66−-- let
67−-- expression :: Expression outer commons grp schemas params from (null 'PGint2)
68−-- expression = caseWhenThenElse [(true, 1), (false, 2)] 3
69−-- in printSQL expression
70−-- :}
71−-- CASE WHEN TRUE THEN 1 WHEN FALSE THEN 2 ELSE 3 END
72−caseWhenThenElse
73− :: [ ( Condition outer commons grp schemas params from
74− , Expression outer commons grp schemas params from ty
75− ) ]
76− -- ^ whens and thens
77− -> Expression outer commons grp schemas params from ty
78− -- ^ else
79− -> Expression outer commons grp schemas params from ty
80−caseWhenThenElse whenThens else_ = UnsafeExpression $ mconcat
81− [ "CASE"
82− , mconcat
83− [ mconcat
84− [ " WHEN ", renderSQL when_
85− , " THEN ", renderSQL then_
86− ]
87− | (when_,then_) <- whenThens
88− ]
89− , " ELSE ", renderSQL else_
90− , " END"
91− ]
92−
93−-- | >>> :{
94−-- let
95−-- expression :: Expression outer commons grp schemas params from (null 'PGint2)
96−-- expression = ifThenElse true 1 0
97−-- in printSQL expression
98−-- :}
99−-- CASE WHEN TRUE THEN 1 ELSE 0 END
100−ifThenElse
101− :: Condition outer commons grp schemas params from
102− -> Expression outer commons grp schemas params from ty -- ^ then
103− -> Expression outer commons grp schemas params from ty -- ^ else
104− -> Expression outer commons grp schemas params from ty
105−ifThenElse if_ then_ else_ = caseWhenThenElse [(if_,then_)] else_
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Math.hsdeleted−100
@@ -1,100 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Expression.Math
3−Description: Math expressions
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Mathematical functions and operators
9−-}
10−
11−{-# LANGUAGE
12− DataKinds
13− , OverloadedStrings
14− , TypeOperators
15−#-}
16−
17−module Squeal.PostgreSQL.Expression.Math
18− ( atan2_
19− , quot_
20− , rem_
21− , trunc
22− , round_
23− , ceiling_
24− ) where
25−
26−import Squeal.PostgreSQL.Expression
27−import Squeal.PostgreSQL.List
28−import Squeal.PostgreSQL.Schema
29−
30−-- $setup
31−-- >>> import Squeal.PostgreSQL
32−
33−-- | >>> :{
34−-- let
35−-- expression :: Expr (null 'PGfloat4)
36−-- expression = atan2_ (pi *: 2)
37−-- in printSQL expression
38−-- :}
39−-- atan2(pi(), 2)
40−atan2_ :: float `In` PGFloating => '[ null float, null float] ---> null float
41−atan2_ = unsafeFunctionN "atan2"
42−
43−
44−-- | integer division, truncates the result
45−--
46−-- >>> :{
47−-- let
48−-- expression :: Expression outer commons grp schemas params from (null 'PGint2)
49−-- expression = 5 `quot_` 2
50−-- in printSQL expression
51−-- :}
52−-- (5 / 2)
53−quot_
54− :: int `In` PGIntegral
55− => Operator (null int) (null int) (null int)
56−quot_ = unsafeBinaryOp "/"
57−
58−-- | remainder upon integer division
59−--
60−-- >>> :{
61−-- let
62−-- expression :: Expression outer commons grp schemas params from (null 'PGint2)
63−-- expression = 5 `rem_` 2
64−-- in printSQL expression
65−-- :}
66−-- (5 % 2)
67−rem_
68− :: int `In` PGIntegral
69− => Operator (null int) (null int) (null int)
70−rem_ = unsafeBinaryOp "%"
71−
72−-- | >>> :{
73−-- let
74−-- expression :: Expression outer commons grp schemas params from (null 'PGfloat4)
75−-- expression = trunc pi
76−-- in printSQL expression
77−-- :}
78−-- trunc(pi())
79−trunc :: frac `In` PGFloating => null frac --> null frac
80−trunc = unsafeFunction "trunc"
81−
82−-- | >>> :{
83−-- let
84−-- expression :: Expression outer commons grp schemas params from (null 'PGfloat4)
85−-- expression = round_ pi
86−-- in printSQL expression
87−-- :}
88−-- round(pi())
89−round_ :: frac `In` PGFloating => null frac --> null frac
90−round_ = unsafeFunction "round"
91−
92−-- | >>> :{
93−-- let
94−-- expression :: Expression outer commons grp schemas params from (null 'PGfloat4)
95−-- expression = ceiling_ pi
96−-- in printSQL expression
97−-- :}
98−-- ceiling(pi())
99−ceiling_ :: frac `In` PGFloating => null frac --> null frac
100−ceiling_ = unsafeFunction "ceiling"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Null.hsdeleted−104
@@ -1,104 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Expression.Null
3−Description: Null
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Null values and null handling functions
9−-}
10−
11−{-# LANGUAGE
12− DataKinds
13− , OverloadedStrings
14− , TypeOperators
15−#-}
16−
17−module Squeal.PostgreSQL.Expression.Null
18− ( null_
19− , notNull
20− , coalesce
21− , fromNull
22− , isNull
23− , isNotNull
24− , matchNull
25− , nullIf
26− ) where
27−
28−import Squeal.PostgreSQL.Expression
29−import Squeal.PostgreSQL.Expression.Logic
30−import Squeal.PostgreSQL.Render
31−import Squeal.PostgreSQL.Schema
32−
33−-- $setup
34−-- >>> import Squeal.PostgreSQL
35−
36−-- | analagous to `Nothing`
37−--
38−-- >>> printSQL null_
39−-- NULL
40−null_ :: Expr ('Null ty)
41−null_ = UnsafeExpression "NULL"
42−
43−-- | analagous to `Just`
44−--
45−-- >>> printSQL $ notNull true
46−-- TRUE
47−notNull :: 'NotNull ty --> 'Null ty
48−notNull = UnsafeExpression . renderSQL
49−
50−-- | return the leftmost value which is not NULL
51−--
52−-- >>> printSQL $ coalesce [null_, true] false
53−-- COALESCE(NULL, TRUE, FALSE)
54−coalesce :: FunctionVar ('Null ty) ('NotNull ty) ('NotNull ty)
55−coalesce nullxs notNullx = UnsafeExpression $
56− "COALESCE" <> parenthesized (commaSeparated
57− ((renderSQL <$> nullxs) <> [renderSQL notNullx]))
58−
59−-- | analagous to `Data.Maybe.fromMaybe` using @COALESCE@
60−--
61−-- >>> printSQL $ fromNull true null_
62−-- COALESCE(NULL, TRUE)
63−fromNull
64− :: Expression outer commons grp schemas params from ('NotNull ty)
65− -- ^ what to convert @NULL@ to
66− -> Expression outer commons grp schemas params from ('Null ty)
67− -> Expression outer commons grp schemas params from ('NotNull ty)
68−fromNull notNullx nullx = coalesce [nullx] notNullx
69−
70−-- | >>> printSQL $ null_ & isNull
71−-- NULL IS NULL
72−isNull :: 'Null ty --> null 'PGbool
73−isNull x = UnsafeExpression $ renderSQL x <+> "IS NULL"
74−
75−-- | >>> printSQL $ null_ & isNotNull
76−-- NULL IS NOT NULL
77−isNotNull :: 'Null ty --> null 'PGbool
78−isNotNull x = UnsafeExpression $ renderSQL x <+> "IS NOT NULL"
79−
80−-- | analagous to `maybe` using @IS NULL@
81−--
82−-- >>> printSQL $ matchNull true not_ null_
83−-- CASE WHEN NULL IS NULL THEN TRUE ELSE (NOT NULL) END
84−matchNull
85− :: Expression outer commons grp schemas params from (nullty)
86− -- ^ what to convert @NULL@ to
87− -> ( Expression outer commons grp schemas params from ('NotNull ty)
88− -> Expression outer commons grp schemas params from (nullty) )
89− -- ^ function to perform when @NULL@ is absent
90− -> Expression outer commons grp schemas params from ('Null ty)
91− -> Expression outer commons grp schemas params from (nullty)
92−matchNull y f x = ifThenElse (isNull x) y
93− (f (UnsafeExpression (renderSQL x)))
94−
95−{-| right inverse to `fromNull`, if its arguments are equal then
96−`nullIf` gives @NULL@.
97−
98−>>> :set -XTypeApplications -XDataKinds
99−>>> let expr = nullIf (false *: param @1) :: Expression outer commons grp schemas '[ 'NotNull 'PGbool] from ('Null 'PGbool)
100−>>> printSQL expr
101−NULLIF(FALSE, ($1 :: bool))
102−-}
103−nullIf :: '[ 'NotNull ty, 'NotNull ty] ---> 'Null ty
104−nullIf = unsafeFunctionN "NULLIF"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Parameter.hsdeleted−80
@@ -1,80 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Expression.Parameter
3−Description: Parameters
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Parameters, out-of-line data values
9−-}
10−
11−{-# LANGUAGE
12− AllowAmbiguousTypes
13− , DataKinds
14− , FlexibleContexts
15− , FlexibleInstances
16− , FunctionalDependencies
17− , KindSignatures
18− , MultiParamTypeClasses
19− , OverloadedStrings
20− , RankNTypes
21− , ScopedTypeVariables
22− , TypeApplications
23− , TypeOperators
24− , UndecidableInstances
25−#-}
26−
27−module Squeal.PostgreSQL.Expression.Parameter
28− ( HasParameter (parameter)
29− , param
30− ) where
31−
32−import GHC.TypeLits
33−
34−import Squeal.PostgreSQL.Expression
35−import Squeal.PostgreSQL.Expression.Type
36−import Squeal.PostgreSQL.Render
37−import Squeal.PostgreSQL.Schema
38−
39−-- $setup
40−-- >>> import Squeal.PostgreSQL
41−
42−{- | A `HasParameter` constraint is used to indicate a value that is
43−supplied externally to a SQL statement.
44−`Squeal.PostgreSQL.PQ.manipulateParams`,
45−`Squeal.PostgreSQL.PQ.queryParams` and
46−`Squeal.PostgreSQL.PQ.traversePrepared` support specifying data values
47−separately from the SQL command string, in which case `param`s are used to
48−refer to the out-of-line data values.
49−-}
50−class KnownNat n => HasParameter
51− (n :: Nat)
52− (params :: [NullityType])
53− (ty :: NullityType)
54− | n params -> ty where
55− -- | `parameter` takes a `Nat` using type application and a `TypeExpression`.
56− --
57− -- >>> let expr = parameter @1 int4 :: Expression outer '[] grp schemas '[ 'Null 'PGint4] from ('Null 'PGint4)
58− -- >>> printSQL expr
59− -- ($1 :: int4)
60− parameter
61− :: TypeExpression schemas ty
62− -> Expression outer commons grp schemas params from ty
63− parameter ty = UnsafeExpression $ parenthesized $
64− "$" <> renderNat @n <+> "::"
65− <+> renderSQL ty
66−instance {-# OVERLAPPING #-} HasParameter 1 (ty1:tys) ty1
67−instance {-# OVERLAPPABLE #-} (KnownNat n, HasParameter (n-1) params ty)
68− => HasParameter n (ty' : params) ty
69−
70−-- | `param` takes a `Nat` using type application and for basic types,
71−-- infers a `TypeExpression`.
72−--
73−-- >>> let expr = param @1 :: Expression outer commons grp schemas '[ 'Null 'PGint4] from ('Null 'PGint4)
74−-- >>> printSQL expr
75−-- ($1 :: int4)
76−param
77− :: forall n outer commons schemas params from grp ty
78− . (PGTyped schemas ty, HasParameter n params ty)
79− => Expression outer commons grp schemas params from ty -- ^ param
80−param = parameter @n (pgtype @schemas)
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Range.hsdeleted−230
@@ -1,230 +0,0 @@
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.hsdeleted−139
@@ -1,139 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Expression.Set
3−Description: Set returning functions
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Set returning functions
9−-}
10−
11−{-# LANGUAGE
12− AllowAmbiguousTypes
13− , DataKinds
14− , FlexibleContexts
15− , OverloadedStrings
16− , PolyKinds
17− , RankNTypes
18− , ScopedTypeVariables
19− , TypeApplications
20− , TypeOperators
21−#-}
22−
23−module Squeal.PostgreSQL.Expression.Set
24− ( generateSeries
25− , generateSeriesStep
26− , generateSeriesTimestamp
27− , SetFunction
28− , unsafeSetFunction
29− , SetFunctionDB
30− , setFunction
31− , SetFunctionN
32− , unsafeSetFunctionN
33− , SetFunctionNDB
34− , setFunctionN
35− ) where
36−
37−import GHC.TypeLits
38−
39−import qualified Generics.SOP as SOP
40−
41−import Squeal.PostgreSQL.Alias
42−import Squeal.PostgreSQL.Expression
43−import Squeal.PostgreSQL.List
44−import Squeal.PostgreSQL.Render
45−import Squeal.PostgreSQL.Query
46−import Squeal.PostgreSQL.Schema
47−
48−{- |
49−A @RankNType@ for set returning functions with 1 argument.
50−-}
51−type SetFunction fun ty row
52− = forall outer commons schemas params
53− . Expression outer commons 'Ungrouped schemas params '[] ty
54− -- ^ input
55− -> FromClause outer commons schemas params '[fun ::: row]
56− -- ^ output
57−
58−type SetFunctionDB fun schemas ty row
59− = forall outer commons params
60− . Expression outer commons 'Ungrouped schemas params '[] ty
61− -- ^ input
62− -> FromClause outer commons schemas params '[fun ::: row]
63− -- ^ output
64−
65−-- | Escape hatch for a set returning function with 1 argument.
66−unsafeSetFunction
67− :: forall fun ty row. KnownSymbol fun
68− => SetFunction fun ty row -- ^ set returning function
69−unsafeSetFunction x = UnsafeFromClause $
70− renderSymbol @fun <> parenthesized (renderSQL x)
71−
72−setFunction
73− :: ( Has sch schemas schema
74− , Has fun schema ('Function ('[ty] :=> 'ReturnsTable row)) )
75− => QualifiedAlias sch fun
76− -> SetFunctionDB fun schemas ty row
77−setFunction _ = unsafeSetFunction
78−
79−{- |
80−A @RankNType@ for set returning functions with multiple argument.
81−-}
82−type SetFunctionN fun tys row
83− = forall outer commons schemas params
84− . NP (Expression outer commons 'Ungrouped schemas params '[]) tys
85− -- ^ inputs
86− -> FromClause outer commons schemas params '[fun ::: row]
87− -- ^ output
88−
89−-- | Escape hatch for a set returning function with multiple argument.
90−unsafeSetFunctionN
91− :: forall fun tys row. (SOP.SListI tys, KnownSymbol fun)
92− => SetFunctionN fun tys row -- ^ set returning function
93−unsafeSetFunctionN xs = UnsafeFromClause $
94− renderSymbol @fun <> parenthesized (renderCommaSeparated renderSQL xs)
95−
96−type SetFunctionNDB fun schemas tys row
97− = forall outer commons params
98− . NP (Expression outer commons 'Ungrouped schemas params '[]) tys
99− -- ^ inputs
100− -> FromClause outer commons schemas params '[fun ::: row]
101− -- ^ output
102−
103−setFunctionN
104− :: ( Has sch schemas schema
105− , Has fun schema ('Function (tys :=> 'ReturnsTable row))
106− , SOP.SListI tys )
107− => QualifiedAlias sch fun
108− -> SetFunctionNDB fun schemas tys row
109−setFunctionN _ = unsafeSetFunctionN
110−
111−{- | @generateSeries (start *: stop)@
112−
113−Generate a series of values, from @start@ to @stop@ with a step size of one
114−-}
115−generateSeries
116− :: ty `In` '[ 'PGint4, 'PGint8, 'PGnumeric]
117− => SetFunctionN "generate_series" '[ null ty, null ty]
118− '["generate_series" ::: null ty] -- ^ set returning function
119−generateSeries = unsafeSetFunctionN
120−
121−{- | @generateSeries (start :* stop *: step)@
122−
123−Generate a series of values, from @start@ to @stop@ with a step size of @step@
124−-}
125−generateSeriesStep
126− :: ty `In` '[ 'PGint4, 'PGint8, 'PGnumeric]
127− => SetFunctionN "generate_series" '[null ty, null ty, null ty]
128− '["generate_series" ::: null ty] -- ^ set returning function
129−generateSeriesStep = unsafeSetFunctionN
130−
131−{- | @generateSeries (start :* stop *: step)@
132−
133−Generate a series of values, from @start@ to @stop@ with a step size of @step@
134−-}
135−generateSeriesTimestamp
136− :: ty `In` '[ 'PGtimestamp, 'PGtimestamptz]
137− => SetFunctionN "generate_series" '[null ty, null ty, null 'PGinterval]
138− '["generate_series" ::: null ty] -- ^ set returning function
139−generateSeriesTimestamp = unsafeSetFunctionN
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Sort.hsdeleted−85
@@ -1,85 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Expression.Sort
3−Description: Sort expressions
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Sort expressions
9−-}
10−
11−{-# LANGUAGE
12− DataKinds
13− , GADTs
14− , LambdaCase
15− , OverloadedStrings
16− , StandaloneDeriving
17−#-}
18−
19−module Squeal.PostgreSQL.Expression.Sort
20− ( SortExpression (..)
21− , OrderBy (..)
22− ) where
23−
24−import Squeal.PostgreSQL.Expression
25−import Squeal.PostgreSQL.Render
26−import Squeal.PostgreSQL.Schema
27−
28−-- | `SortExpression`s are used by `orderBy` to optionally sort the results
29−-- of a `Squeal.PostgreSQL.Query.Query`. `Asc` or `Desc`
30−-- set the sort direction of a `NotNull` result
31−-- column to ascending or descending. Ascending order puts smaller values
32−-- first, where "smaller" is defined in terms of the
33−-- `Squeal.PostgreSQL.Expression.Comparison..<` operator. Similarly,
34−-- descending order is determined with the
35−-- `Squeal.PostgreSQL.Expression.Comparison..>` operator. `AscNullsFirst`,
36−-- `AscNullsLast`, `DescNullsFirst` and `DescNullsLast` options are used to
37−-- determine whether nulls appear before or after non-null values in the sort
38−-- ordering of a `Null` result column.
39−data SortExpression outer commons grp schemas params from where
40− Asc
41− :: Expression outer commons grp schemas params from ('NotNull ty)
42− -> SortExpression outer commons grp schemas params from
43− Desc
44− :: Expression outer commons grp schemas params from ('NotNull ty)
45− -> SortExpression outer commons grp schemas params from
46− AscNullsFirst
47− :: Expression outer commons grp schemas params from ('Null ty)
48− -> SortExpression outer commons grp schemas params from
49− AscNullsLast
50− :: Expression outer commons grp schemas params from ('Null ty)
51− -> SortExpression outer commons grp schemas params from
52− DescNullsFirst
53− :: Expression outer commons grp schemas params from ('Null ty)
54− -> SortExpression outer commons grp schemas params from
55− DescNullsLast
56− :: Expression outer commons grp schemas params from ('Null ty)
57− -> SortExpression outer commons grp schemas params from
58−deriving instance Show (SortExpression outer commons grp schemas params from)
59−instance RenderSQL (SortExpression outer commons grp schemas params from) where
60− renderSQL = \case
61− Asc expression -> renderSQL expression <+> "ASC"
62− Desc expression -> renderSQL expression <+> "DESC"
63− AscNullsFirst expression -> renderSQL expression
64− <+> "ASC NULLS FIRST"
65− DescNullsFirst expression -> renderSQL expression
66− <+> "DESC NULLS FIRST"
67− AscNullsLast expression -> renderSQL expression <+> "ASC NULLS LAST"
68− DescNullsLast expression -> renderSQL expression <+> "DESC NULLS LAST"
69−
70−{- |
71−The `orderBy` clause causes the result rows of a `Squeal.PostgreSQL.Query.TableExpression`
72−to be sorted according to the specified `SortExpression`(s).
73−If two rows are equal according to the leftmost expression,
74−they are compared according to the next expression and so on.
75−If they are equal according to all specified expressions,
76−they are returned in an implementation-dependent order.
77−
78−You can also control the order in which rows are processed by window functions
79−using `orderBy` within `Squeal.PostgreSQL.Query.Over`.
80−-}
81−class OrderBy expr where
82− orderBy
83− :: [SortExpression outer commons grp schemas params from]
84− -> expr outer commons grp schemas params from
85− -> expr outer commons grp schemas params from
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Subquery.hsdeleted−120
@@ -1,120 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Expression.Subquery
3−Description: Subquery expressions
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Subquery expressions
9−-}
10−
11−{-# LANGUAGE
12− DataKinds
13− , OverloadedStrings
14− , RankNTypes
15− , TypeOperators
16−#-}
17−
18−module Squeal.PostgreSQL.Expression.Subquery
19− ( exists
20− , in_
21− , notIn
22− , subAll
23− , subAny
24− ) where
25−
26−import Squeal.PostgreSQL.Alias
27−import Squeal.PostgreSQL.Expression
28−import Squeal.PostgreSQL.Expression.Logic
29−import Squeal.PostgreSQL.List
30−import Squeal.PostgreSQL.Query
31−import Squeal.PostgreSQL.Render
32−import Squeal.PostgreSQL.Schema
33−
34−-- $setup
35−-- >>> import Squeal.PostgreSQL
36−
37−{- |
38−The argument of `exists` is an arbitrary subquery. The subquery is evaluated
39−to determine whether it returns any rows. If it returns at least one row,
40−the result of `exists` is `true`; if the subquery returns no rows,
41−the result of `exists` is `false`.
42−
43−The subquery can refer to variables from the surrounding query,
44−which will act as constants during any one evaluation of the subquery.
45−
46−The subquery will generally only be executed long enough to determine whether
47−at least one row is returned, not all the way to completion.
48−-}
49−exists
50− :: Query (Join outer from) commons schemas params row
51− -> Condition outer commons grp schemas params from
52−exists query = UnsafeExpression $ "EXISTS" <+> parenthesized (renderSQL query)
53−
54−{- |
55−The right-hand side is a parenthesized subquery, which must return
56−exactly one column. The left-hand expression is evaluated and compared to each
57−row of the subquery result using the given `Operator`,
58−which must yield a Boolean result. The result of `subAll` is `true`
59−if all rows yield true (including the case where the subquery returns no rows).
60−The result is `false` if any `false` result is found.
61−The result is `Squeal.PostgreSQL.Expression.Null.null_` if
62− no comparison with a subquery row returns `false`,
63−and at least one comparison returns `Squeal.PostgreSQL.Expression.Null.null_`.
64−
65−>>> printSQL $ subAll true (.==) (values_ (true `as` #foo))
66−(TRUE = ALL (SELECT * FROM (VALUES (TRUE)) AS t ("foo")))
67−-}
68−subAll
69− :: Expression outer commons grp schemas params from ty1 -- ^ expression
70− -> Operator ty1 ty2 ('Null 'PGbool) -- ^ operator
71− -> Query (Join outer from) commons schemas params '[col ::: ty2] -- ^ subquery
72− -> Condition outer commons grp schemas params from
73−subAll expr (?) qry = expr ?
74− (UnsafeExpression $ "ALL" <+> parenthesized (renderSQL qry))
75−
76−{- |
77−The right-hand side is a parenthesized subquery, which must return exactly one column.
78−The left-hand expression is evaluated and compared to each row of the subquery result
79−using the given `Operator`, which must yield a Boolean result. The result of `subAny` is `true`
80−if any `true` result is obtained. The result is `false` if no true result is found
81−(including the case where the subquery returns no rows).
82−
83−>>> printSQL $ subAny "foo" like (values_ ("foobar" `as` #foo))
84−(E'foo' LIKE ANY (SELECT * FROM (VALUES (E'foobar')) AS t ("foo")))
85−-}
86−subAny
87− :: Expression outer commons grp schemas params from ty1 -- ^ expression
88− -> Operator ty1 ty2 ('Null 'PGbool) -- ^ operator
89− -> Query (Join outer from) commons schemas params '[col ::: ty2] -- ^ subquery
90− -> Condition outer commons grp schemas params from
91−subAny expr (?) qry = expr ?
92− (UnsafeExpression $ "ANY" <+> parenthesized (renderSQL qry))
93−
94−{- |
95−The result is `true` if the left-hand expression's result is equal
96−to any of the right-hand expressions.
97−
98−>>> printSQL $ true `in_` [true, false, null_]
99−TRUE IN (TRUE, FALSE, NULL)
100−-}
101−in_
102− :: Expression outer commons grp schemas params from ty -- ^ expression
103− -> [Expression outer commons grp schemas params from ty]
104− -> Condition outer commons grp schemas params from
105−expr `in_` exprs = UnsafeExpression $ renderSQL expr <+> "IN"
106− <+> parenthesized (commaSeparated (renderSQL <$> exprs))
107−
108−{- |
109−The result is `true` if the left-hand expression's result is not equal
110−to any of the right-hand expressions.
111−
112−>>> printSQL $ true `notIn` [false, null_]
113−TRUE NOT IN (FALSE, NULL)
114−-}
115−notIn
116− :: Expression outer commons grp schemas params from ty -- ^ expression
117− -> [Expression outer commons grp schemas params from ty]
118− -> Condition outer commons grp schemas params from
119−expr `notIn` exprs = UnsafeExpression $ renderSQL expr <+> "NOT IN"
120− <+> parenthesized (commaSeparated (renderSQL <$> exprs))
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Text.hsdeleted−64
@@ -1,64 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Expression.Text
3−Description: Text expressions
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−String functions and operators
9−-}
10−
11−{-# LANGUAGE
12− DataKinds
13− , OverloadedStrings
14− , TypeOperators
15−#-}
16−
17−module Squeal.PostgreSQL.Expression.Text
18− ( lower
19− , upper
20− , charLength
21− , like
22− , ilike
23− ) where
24−
25−import Squeal.PostgreSQL.Expression
26−import Squeal.PostgreSQL.Schema
27−
28−-- $setup
29−-- >>> import Squeal.PostgreSQL
30−
31−-- | >>> printSQL $ lower "ARRRGGG"
32−-- lower(E'ARRRGGG')
33−lower :: null 'PGtext --> null 'PGtext
34−lower = unsafeFunction "lower"
35−
36−-- | >>> printSQL $ upper "eeee"
37−-- upper(E'eeee')
38−upper :: null 'PGtext --> null 'PGtext
39−upper = unsafeFunction "upper"
40−
41−-- | >>> printSQL $ charLength "four"
42−-- char_length(E'four')
43−charLength :: null 'PGtext --> null 'PGint4
44−charLength = unsafeFunction "char_length"
45−
46−-- | The `like` expression returns true if the @string@ matches
47−-- the supplied @pattern@. If @pattern@ does not contain percent signs
48−-- or underscores, then the pattern only represents the string itself;
49−-- in that case `like` acts like the equals operator. An underscore (_)
50−-- in pattern stands for (matches) any single character; a percent sign (%)
51−-- matches any sequence of zero or more characters.
52−--
53−-- >>> printSQL $ "abc" `like` "a%"
54−-- (E'abc' LIKE E'a%')
55−like :: Operator (null 'PGtext) (null 'PGtext) ('Null 'PGbool)
56−like = unsafeBinaryOp "LIKE"
57−
58−-- | The key word ILIKE can be used instead of LIKE to make the
59−-- match case-insensitive according to the active locale.
60−--
61−-- >>> printSQL $ "abc" `ilike` "a%"
62−-- (E'abc' ILIKE E'a%')
63−ilike :: Operator (null 'PGtext) (null 'PGtext) ('Null 'PGbool)
64−ilike = unsafeBinaryOp "ILIKE"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/TextSearch.hsdeleted−157
@@ -1,157 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Expression.TextSearch
3−Description: Text search expressions
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Text search functions and operators
9−-}
10−
11−{-# LANGUAGE
12− DataKinds
13− , OverloadedStrings
14− , TypeOperators
15−#-}
16−
17−module Squeal.PostgreSQL.Expression.TextSearch
18− ( (@@)
19− , (.&)
20− , (.|)
21− , (.!)
22− , (<->)
23− , arrayToTSvector
24− , tsvectorLength
25− , numnode
26− , plainToTSquery
27− , phraseToTSquery
28− , websearchToTSquery
29− , queryTree
30− , toTSquery
31− , toTSvector
32− , setWeight
33− , strip
34− , jsonToTSvector
35− , jsonbToTSvector
36− , tsDelete
37− , tsFilter
38− , tsHeadline
39− ) where
40−
41−import Squeal.PostgreSQL.Expression
42−import Squeal.PostgreSQL.List
43−import Squeal.PostgreSQL.Schema
44−
45−-- | `Squeal.PostgreSQL.Expression.Type.tsvector` matches tsquery ?
46−(@@) :: Operator (null 'PGtsvector) (null 'PGtsquery) ('Null 'PGbool)
47−(@@) = unsafeBinaryOp "@@"
48−
49−-- | AND `Squeal.PostgreSQL.Expression.Type.tsquery`s together
50−(.&) :: Operator (null 'PGtsquery) (null 'PGtsquery) (null 'PGtsquery)
51−(.&) = unsafeBinaryOp "&&"
52−
53−-- | OR `Squeal.PostgreSQL.Expression.Type.tsquery`s together
54−(.|) :: Operator (null 'PGtsquery) (null 'PGtsquery) (null 'PGtsquery)
55−(.|) = unsafeBinaryOp "||"
56−
57−-- | negate a `Squeal.PostgreSQL.Expression.Type.tsquery`
58−(.!) :: null 'PGtsquery --> null 'PGtsquery
59−(.!) = unsafeLeftOp "!!"
60−
61−-- | `Squeal.PostgreSQL.Expression.Type.tsquery` followed by
62−-- `Squeal.PostgreSQL.Expression.Type.tsquery`
63−(<->) :: Operator (null 'PGtsquery) (null 'PGtsquery) (null 'PGtsquery)
64−(<->) = unsafeBinaryOp "<->"
65−
66−-- | convert array of lexemes to `Squeal.PostgreSQL.Expression.Type.tsvector`
67−arrayToTSvector
68− :: null ('PGvararray ('NotNull 'PGtext))
69− --> null 'PGtsvector
70−arrayToTSvector = unsafeFunction "array_to_tsvector"
71−
72−-- | number of lexemes in `Squeal.PostgreSQL.Expression.Type.tsvector`
73−tsvectorLength :: null 'PGtsvector --> null 'PGint4
74−tsvectorLength = unsafeFunction "length"
75−
76−-- | number of lexemes plus operators in `Squeal.PostgreSQL.Expression.Type.tsquery`
77−numnode :: null 'PGtsquery --> null 'PGint4
78−numnode = unsafeFunction "numnode"
79−
80−-- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` ignoring punctuation
81−plainToTSquery :: null 'PGtext --> null 'PGtsquery
82−plainToTSquery = unsafeFunction "plainto_tsquery"
83−
84−-- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` that searches for a phrase,
85−-- ignoring punctuation
86−phraseToTSquery :: null 'PGtext --> null 'PGtsquery
87−phraseToTSquery = unsafeFunction "phraseto_tsquery"
88−
89−-- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` from a web search style query
90−websearchToTSquery :: null 'PGtext --> null 'PGtsquery
91−websearchToTSquery = unsafeFunction "websearch_to_tsquery"
92−
93−-- | get indexable part of a `Squeal.PostgreSQL.Expression.Type.tsquery`
94−queryTree :: null 'PGtsquery --> null 'PGtext
95−queryTree = unsafeFunction "query_tree"
96−
97−-- | normalize words and convert to `Squeal.PostgreSQL.Expression.Type.tsquery`
98−toTSquery :: null 'PGtext --> null 'PGtsquery
99−toTSquery = unsafeFunction "to_tsquery"
100−
101−-- | reduce document text to `Squeal.PostgreSQL.Expression.Type.tsvector`
102−toTSvector
103− :: ty `In` '[ 'PGtext, 'PGjson, 'PGjsonb]
104− => null ty --> null 'PGtsvector
105−toTSvector = unsafeFunction "to_tsvector"
106−
107−-- | assign weight to each element of `Squeal.PostgreSQL.Expression.Type.tsvector`
108−setWeight :: '[null 'PGtsvector, null ('PGchar 1)] ---> null 'PGtsvector
109−setWeight = unsafeFunctionN "set_weight"
110−
111−-- | remove positions and weights from `Squeal.PostgreSQL.Expression.Type.tsvector`
112−strip :: null 'PGtsvector --> null 'PGtsvector
113−strip = unsafeFunction "strip"
114−
115−-- | @jsonToTSvector (document *: filter)@
116−-- reduce each value in the document, specified by filter to a `Squeal.PostgreSQL.Expression.Type.tsvector`,
117−-- and then concatenate those in document order to produce a single `Squeal.PostgreSQL.Expression.Type.tsvector`.
118−-- filter is a `Squeal.PostgreSQL.Expression.Type.json` array, that enumerates what kind of elements
119−-- need to be included into the resulting `Squeal.PostgreSQL.Expression.Type.tsvector`.
120−-- Possible values for filter are "string" (to include all string values),
121−-- "numeric" (to include all numeric values in the string format),
122−-- "boolean" (to include all Boolean values in the string format "true"/"false"),
123−-- "key" (to include all keys) or "all" (to include all above).
124−-- These values can be combined together to include, e.g. all string and numeric values.
125−jsonToTSvector :: '[null 'PGjson, null 'PGjson] ---> null 'PGtsvector
126−jsonToTSvector = unsafeFunctionN "json_to_tsvector"
127−
128−-- | @jsonbToTSvector (document *: filter)@
129−-- reduce each value in the document, specified by filter to a `Squeal.PostgreSQL.Expression.Type.tsvector`,
130−-- and then concatenate those in document order to produce a single `Squeal.PostgreSQL.Expression.Type.tsvector`.
131−-- filter is a `Squeal.PostgreSQL.Expression.Type.jsonb` array, that enumerates what kind of elements
132−-- need to be included into the resulting `Squeal.PostgreSQL.Expression.Type.tsvector`.
133−-- Possible values for filter are "string" (to include all string values),
134−-- "numeric" (to include all numeric values in the string format),
135−-- "boolean" (to include all Boolean values in the string format "true"/"false"),
136−-- "key" (to include all keys) or "all" (to include all above).
137−-- These values can be combined together to include, e.g. all string and numeric values.
138−jsonbToTSvector :: '[null 'PGjsonb, null 'PGjsonb] ---> null 'PGtsvector
139−jsonbToTSvector = unsafeFunctionN "jsonb_to_tsvector"
140−
141−-- | remove given lexeme from `Squeal.PostgreSQL.Expression.Type.tsvector`
142−tsDelete ::
143− '[null 'PGtsvector, null ('PGvararray ('NotNull 'PGtext))]
144− ---> null 'PGtsvector
145−tsDelete = unsafeFunctionN "ts_delete"
146−
147−-- | select only elements with given weights from `Squeal.PostgreSQL.Expression.Type.tsvector`
148−tsFilter ::
149− '[null 'PGtsvector, null ('PGvararray ('NotNull ('PGchar 1)))]
150− ---> null 'PGtsvector
151−tsFilter = unsafeFunctionN "ts_filter"
152−
153−-- | display a `Squeal.PostgreSQL.Expression.Type.tsquery` match
154−tsHeadline
155− :: document `In` '[ 'PGtext, 'PGjson, 'PGjsonb]
156− => '[null document, null 'PGtsquery] ---> null 'PGtext
157−tsHeadline = unsafeFunctionN "ts_headline"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Time.hsdeleted−192
@@ -1,192 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Expression.Time
3−Description: Date/Time expressions
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Date/Time functions and operators
9−-}
10−
11−{-# LANGUAGE
12− DataKinds
13− , DeriveGeneric
14− , FunctionalDependencies
15− , LambdaCase
16− , MultiParamTypeClasses
17− , OverloadedStrings
18− , PolyKinds
19− , RankNTypes
20− , TypeOperators
21−#-}
22−
23−module Squeal.PostgreSQL.Expression.Time
24− ( TimeOp (..)
25− , currentDate
26− , currentTime
27− , currentTimestamp
28− , localTime
29− , localTimestamp
30− , now
31− , makeDate
32− , makeTime
33− , makeTimestamp
34− , makeTimestamptz
35− , interval_
36− , TimeUnit (..)
37− ) where
38−
39−import Data.String
40−
41−import qualified GHC.Generics as GHC
42−import qualified Generics.SOP as SOP
43−
44−import Squeal.PostgreSQL.Expression
45−import Squeal.PostgreSQL.Render
46−import Squeal.PostgreSQL.Schema
47−
48−-- $setup
49−-- >>> import Squeal.PostgreSQL
50−
51−-- | >>> printSQL currentDate
52−-- CURRENT_DATE
53−currentDate :: Expr (null 'PGdate)
54−currentDate = UnsafeExpression "CURRENT_DATE"
55−
56−-- | >>> printSQL currentTime
57−-- CURRENT_TIME
58−currentTime :: Expr (null 'PGtimetz)
59−currentTime = UnsafeExpression "CURRENT_TIME"
60−
61−-- | >>> printSQL currentTimestamp
62−-- CURRENT_TIMESTAMP
63−currentTimestamp :: Expr (null 'PGtimestamptz)
64−currentTimestamp = UnsafeExpression "CURRENT_TIMESTAMP"
65−
66−-- | >>> printSQL localTime
67−-- LOCALTIME
68−localTime :: Expr (null 'PGtime)
69−localTime = UnsafeExpression "LOCALTIME"
70−
71−-- | >>> printSQL localTimestamp
72−-- LOCALTIMESTAMP
73−localTimestamp :: Expr (null 'PGtimestamp)
74−localTimestamp = UnsafeExpression "LOCALTIMESTAMP"
75−
76−-- | Current date and time (equivalent to `currentTimestamp`)
77−--
78−-- >>> printSQL now
79−-- now()
80−now :: Expr (null 'PGtimestamptz)
81−now = UnsafeExpression "now()"
82−
83−{-|
84−Create date from year, month and day fields
85−
86−>>> printSQL (makeDate (1984 :* 7 *: 3))
87−make_date(1984, 7, 3)
88−-}
89−makeDate :: '[ null 'PGint4, null 'PGint4, null 'PGint4 ] ---> null 'PGdate
90−makeDate = unsafeFunctionN "make_date"
91−
92−{-|
93−Create time from hour, minute and seconds fields
94−
95−>>> printSQL (makeTime (8 :* 15 *: 23.5))
96−make_time(8, 15, 23.5)
97−-}
98−makeTime :: '[ null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtime
99−makeTime = unsafeFunctionN "make_time"
100−
101−{-|
102−Create timestamp from year, month, day, hour, minute and seconds fields
103−
104−>>> printSQL (makeTimestamp (2013 :* 7 :* 15 :* 8 :* 15 *: 23.5))
105−make_timestamp(2013, 7, 15, 8, 15, 23.5)
106−-}
107−makeTimestamp ::
108− '[ null 'PGint4, null 'PGint4, null 'PGint4
109− , null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtimestamp
110−makeTimestamp = unsafeFunctionN "make_timestamp"
111−
112−{-|
113−Create timestamp with time zone from
114−year, month, day, hour, minute and seconds fields;
115−the current time zone is used
116−
117−>>> printSQL (makeTimestamptz (2013 :* 7 :* 15 :* 8 :* 15 *: 23.5))
118−make_timestamptz(2013, 7, 15, 8, 15, 23.5)
119−-}
120−makeTimestamptz ::
121− '[ null 'PGint4, null 'PGint4, null 'PGint4
122− , null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtimestamptz
123−makeTimestamptz = unsafeFunctionN "make_timestamptz"
124−
125−{-|
126−Affine space operations on time types.
127−-}
128−class TimeOp time diff | time -> diff where
129− {-|
130− >>> printSQL (makeDate (1984 :* 7 *: 3) !+ 365)
131− (make_date(1984, 7, 3) + 365)
132− -}
133− (!+) :: Operator (null time) (null diff) (null time)
134− (!+) = unsafeBinaryOp "+"
135− {-|
136− >>> printSQL (365 +! makeDate (1984 :* 7 *: 3))
137− (365 + make_date(1984, 7, 3))
138− -}
139− (+!) :: Operator (null diff) (null time) (null time)
140− (+!) = unsafeBinaryOp "+"
141− {-|
142− >>> printSQL (makeDate (1984 :* 7 *: 3) !- 365)
143− (make_date(1984, 7, 3) - 365)
144− -}
145− (!-) :: Operator (null time) (null diff) (null time)
146− (!-) = unsafeBinaryOp "-"
147− {-|
148− >>> printSQL (makeDate (1984 :* 7 *: 3) !-! currentDate)
149− (make_date(1984, 7, 3) - CURRENT_DATE)
150− -}
151− (!-!) :: Operator (null time) (null time) (null diff)
152− (!-!) = unsafeBinaryOp "-"
153−instance TimeOp 'PGtimestamp 'PGinterval
154−instance TimeOp 'PGtimestamptz 'PGinterval
155−instance TimeOp 'PGtime 'PGinterval
156−instance TimeOp 'PGtimetz 'PGinterval
157−instance TimeOp 'PGinterval 'PGinterval
158−instance TimeOp 'PGdate 'PGint4
159−infixl 6 !+
160−infixl 6 +!
161−infixl 6 !-
162−infixl 6 !-!
163−
164−-- | A `TimeUnit` to use in `interval_` construction.
165−data TimeUnit
166− = Years | Months | Weeks | Days
167− | Hours | Minutes | Seconds
168− | Microseconds | Milliseconds
169− | Decades | Centuries | Millennia
170− deriving (Eq, Ord, Show, Read, Enum, GHC.Generic)
171−instance SOP.Generic TimeUnit
172−instance SOP.HasDatatypeInfo TimeUnit
173−instance RenderSQL TimeUnit where
174− renderSQL = \case
175− Years -> "years"
176− Months -> "months"
177− Weeks -> "weeks"
178− Days -> "days"
179− Hours -> "hours"
180− Minutes -> "minutes"
181− Seconds -> "seconds"
182− Microseconds -> "microseconds"
183− Milliseconds -> "milliseconds"
184− Decades -> "decades"
185− Centuries -> "centuries"
186− Millennia -> "millennia"
187−
188−-- | >>> printSQL $ interval_ 7 Days
189−-- (INTERVAL '7.0 days')
190−interval_ :: Double -> TimeUnit -> Expr (null 'PGinterval)
191−interval_ num unit = UnsafeExpression . parenthesized $ "INTERVAL" <+>
192− "'" <> fromString (show num) <+> renderSQL unit <> "'"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Type.hsdeleted−446
@@ -1,446 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Expression
3−Description: Type expressions
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Type expressions.
9−-}
10−
11−{-# LANGUAGE
12− AllowAmbiguousTypes
13− , DataKinds
14− , DeriveGeneric
15− , FlexibleContexts
16− , FlexibleInstances
17− , GADTs
18− , GeneralizedNewtypeDeriving
19− , KindSignatures
20− , MultiParamTypeClasses
21− , OverloadedStrings
22− , RankNTypes
23− , ScopedTypeVariables
24− , TypeApplications
25− , TypeOperators
26− , UndecidableInstances
27−#-}
28−
29−module Squeal.PostgreSQL.Expression.Type
30− ( -- * type casting
31− cast
32− , astype
33− , inferredtype
34− -- * type expressions
35− , TypeExpression (..)
36− , typedef
37− , typetable
38− , typeview
39− , bool
40− , int2
41− , smallint
42− , int4
43− , int
44− , integer
45− , int8
46− , bigint
47− , numeric
48− , float4
49− , real
50− , float8
51− , doublePrecision
52− , money
53− , text
54− , char
55− , character
56− , varchar
57− , characterVarying
58− , bytea
59− , timestamp
60− , timestampWithTimeZone
61− , timestamptz
62− , date
63− , time
64− , timeWithTimeZone
65− , timetz
66− , interval
67− , uuid
68− , inet
69− , json
70− , jsonb
71− , vararray
72− , fixarray
73− , tsvector
74− , tsquery
75− , oid
76− , int4range
77− , int8range
78− , numrange
79− , tsrange
80− , tstzrange
81− , daterange
82− -- * column type definitions
83− , ColumnTypeExpression (..)
84− , nullable
85− , notNullable
86− , default_
87− , serial2
88− , smallserial
89− , serial4
90− , serial
91− , serial8
92− , bigserial
93− , hask
94− -- * type inference
95− , PGTyped (..)
96− , PGNullityTyped (..)
97− , FieldTyped (..)
98− ) where
99−
100−import Control.DeepSeq
101−import Data.ByteString
102−import Data.String
103−import GHC.TypeLits
104−
105−import qualified Data.ByteString as ByteString
106−import qualified GHC.Generics as GHC
107−import qualified Generics.SOP as SOP
108−
109−import Squeal.PostgreSQL.Alias
110−import Squeal.PostgreSQL.Expression
111−import Squeal.PostgreSQL.PG
112−import Squeal.PostgreSQL.Render
113−import Squeal.PostgreSQL.Schema
114−
115−-- $setup
116−-- >>> import Squeal.PostgreSQL
117−
118−-- When a `cast` is applied to an `Expression` of a known type, it
119−-- represents a run-time type conversion. The cast will succeed only if a
120−-- suitable type conversion operation has been defined.
121−--
122−-- | >>> printSQL $ true & cast int4
123−-- (TRUE :: int4)
124−cast
125− :: TypeExpression schemas ty1
126− -- ^ type to cast as
127− -> Expression outer commons grp schemas params from ty0
128− -- ^ value to convert
129− -> Expression outer commons grp schemas params from ty1
130−cast ty x = UnsafeExpression $ parenthesized $
131− renderSQL x <+> "::" <+> renderSQL ty
132−
133−-- | A safe version of `cast` which just matches a value with its type.
134−--
135−-- >>> printSQL (1 & astype int)
136−-- (1 :: int)
137−astype
138− :: TypeExpression schemas ty
139− -- ^ type to specify as
140− -> Expression outer commons grp schemas params from ty
141− -- ^ value
142− -> Expression outer commons grp schemas params from ty
143−astype = cast
144−
145−-- | `inferredtype` will add a type annotation to an `Expression`
146−-- which can be useful for fixing the storage type of a value.
147−--
148−-- >>> printSQL (inferredtype true)
149−-- (TRUE :: bool)
150−inferredtype
151− :: PGTyped schemas ty
152− => Expression outer common grp schemas params from ty
153− -- ^ value
154− -> Expression outer common grp schemas params from ty
155−inferredtype = astype pgtype
156−
157−{-----------------------------------------
158−type expressions
159−-----------------------------------------}
160−
161−-- | `TypeExpression`s are used in `cast`s and
162−-- `Squeal.PostgreSQL.Definition.createTable` commands.
163−newtype TypeExpression (schemas :: SchemasType) (ty :: NullityType)
164− = UnsafeTypeExpression { renderTypeExpression :: ByteString }
165− deriving (GHC.Generic,Show,Eq,Ord,NFData)
166−instance RenderSQL (TypeExpression schemas ty) where
167− renderSQL = renderTypeExpression
168−
169−-- | The enum or composite type in a `Typedef` can be expressed by its alias.
170−typedef
171− :: (Has sch schemas schema, Has td schema ('Typedef ty))
172− => QualifiedAlias sch td
173− -- ^ type alias
174− -> TypeExpression schemas (null ty)
175−typedef = UnsafeTypeExpression . renderSQL
176−
177−-- | The composite type corresponding to a `Table` definition can be expressed
178−-- by its alias.
179−typetable
180− :: (Has sch schemas schema, Has tab schema ('Table table))
181− => QualifiedAlias sch tab
182− -- ^ table alias
183− -> TypeExpression schemas (null ('PGcomposite (TableToRow table)))
184−typetable = UnsafeTypeExpression . renderSQL
185−
186−-- | The composite type corresponding to a `View` definition can be expressed
187−-- by its alias.
188−typeview
189− :: (Has sch schemas schema, Has vw schema ('View view))
190− => QualifiedAlias sch vw
191− -- ^ view alias
192− -> TypeExpression schemas (null ('PGcomposite view))
193−typeview = UnsafeTypeExpression . renderSQL
194−
195−-- | logical Boolean (true/false)
196−bool :: TypeExpression schemas (null 'PGbool)
197−bool = UnsafeTypeExpression "bool"
198−-- | signed two-byte integer
199−int2, smallint :: TypeExpression schemas (null 'PGint2)
200−int2 = UnsafeTypeExpression "int2"
201−smallint = UnsafeTypeExpression "smallint"
202−-- | signed four-byte integer
203−int4, int, integer :: TypeExpression schemas (null 'PGint4)
204−int4 = UnsafeTypeExpression "int4"
205−int = UnsafeTypeExpression "int"
206−integer = UnsafeTypeExpression "integer"
207−-- | signed eight-byte integer
208−int8, bigint :: TypeExpression schemas (null 'PGint8)
209−int8 = UnsafeTypeExpression "int8"
210−bigint = UnsafeTypeExpression "bigint"
211−-- | arbitrary precision numeric type
212−numeric :: TypeExpression schemas (null 'PGnumeric)
213−numeric = UnsafeTypeExpression "numeric"
214−-- | single precision floating-point number (4 bytes)
215−float4, real :: TypeExpression schemas (null 'PGfloat4)
216−float4 = UnsafeTypeExpression "float4"
217−real = UnsafeTypeExpression "real"
218−-- | double precision floating-point number (8 bytes)
219−float8, doublePrecision :: TypeExpression schemas (null 'PGfloat8)
220−float8 = UnsafeTypeExpression "float8"
221−doublePrecision = UnsafeTypeExpression "double precision"
222−-- | currency amount
223−money :: TypeExpression schema (null 'PGmoney)
224−money = UnsafeTypeExpression "money"
225−-- | variable-length character string
226−text :: TypeExpression schemas (null 'PGtext)
227−text = UnsafeTypeExpression "text"
228−-- | fixed-length character string
229−char, character
230− :: forall n schemas null. (KnownNat n, 1 <= n)
231− => TypeExpression schemas (null ('PGchar n))
232−char = UnsafeTypeExpression $ "char(" <> renderNat @n <> ")"
233−character = UnsafeTypeExpression $ "character(" <> renderNat @n <> ")"
234−-- | variable-length character string
235−varchar, characterVarying
236− :: forall n schemas null. (KnownNat n, 1 <= n)
237− => TypeExpression schemas (null ('PGvarchar n))
238−varchar = UnsafeTypeExpression $ "varchar(" <> renderNat @n <> ")"
239−characterVarying = UnsafeTypeExpression $
240− "character varying(" <> renderNat @n <> ")"
241−-- | binary data ("byte array")
242−bytea :: TypeExpression schemas (null 'PGbytea)
243−bytea = UnsafeTypeExpression "bytea"
244−-- | date and time (no time zone)
245−timestamp :: TypeExpression schemas (null 'PGtimestamp)
246−timestamp = UnsafeTypeExpression "timestamp"
247−-- | date and time, including time zone
248−timestampWithTimeZone, timestamptz :: TypeExpression schemas (null 'PGtimestamptz)
249−timestampWithTimeZone = UnsafeTypeExpression "timestamp with time zone"
250−timestamptz = UnsafeTypeExpression "timestamptz"
251−-- | calendar date (year, month, day)
252−date :: TypeExpression schemas (null 'PGdate)
253−date = UnsafeTypeExpression "date"
254−-- | time of day (no time zone)
255−time :: TypeExpression schemas (null 'PGtime)
256−time = UnsafeTypeExpression "time"
257−-- | time of day, including time zone
258−timeWithTimeZone, timetz :: TypeExpression schemas (null 'PGtimetz)
259−timeWithTimeZone = UnsafeTypeExpression "time with time zone"
260−timetz = UnsafeTypeExpression "timetz"
261−-- | time span
262−interval :: TypeExpression schemas (null 'PGinterval)
263−interval = UnsafeTypeExpression "interval"
264−-- | universally unique identifier
265−uuid :: TypeExpression schemas (null 'PGuuid)
266−uuid = UnsafeTypeExpression "uuid"
267−-- | IPv4 or IPv6 host address
268−inet :: TypeExpression schemas (null 'PGinet)
269−inet = UnsafeTypeExpression "inet"
270−-- | textual JSON data
271−json :: TypeExpression schemas (null 'PGjson)
272−json = UnsafeTypeExpression "json"
273−-- | binary JSON data, decomposed
274−jsonb :: TypeExpression schemas (null 'PGjsonb)
275−jsonb = UnsafeTypeExpression "jsonb"
276−-- | variable length array
277−vararray
278− :: TypeExpression schemas pg
279− -> TypeExpression schemas (null ('PGvararray pg))
280−vararray ty = UnsafeTypeExpression $ renderSQL ty <> "[]"
281−-- | fixed length array
282−--
283−-- >>> renderSQL (fixarray @'[2] json)
284−-- "json[2]"
285−fixarray
286− :: forall dims schemas null pg. SOP.All KnownNat dims
287− => TypeExpression schemas pg
288− -> TypeExpression schemas (null ('PGfixarray dims pg))
289−fixarray ty = UnsafeTypeExpression $
290− renderSQL ty <> renderDims @dims
291− where
292− renderDims :: forall ns. SOP.All KnownNat ns => ByteString
293− renderDims =
294− ("[" <>)
295− . (<> "]")
296− . ByteString.intercalate "]["
297− . SOP.hcollapse
298− $ SOP.hcmap (SOP.Proxy @KnownNat)
299− (K . fromString . show . natVal)
300− (SOP.hpure SOP.Proxy :: SOP.NP SOP.Proxy ns)
301−-- | text search query
302−tsvector :: TypeExpression schemas (null 'PGtsvector)
303−tsvector = UnsafeTypeExpression "tsvector"
304−-- | text search document
305−tsquery :: TypeExpression schemas (null 'PGtsquery)
306−tsquery = UnsafeTypeExpression "tsquery"
307−-- | Object identifiers (OIDs) are used internally by PostgreSQL
308−-- as primary keys for various system tables.
309−oid :: TypeExpression schemas (null 'PGoid)
310−oid = UnsafeTypeExpression "oid"
311−-- | Range of integer
312−int4range :: TypeExpression schemas (null ('PGrange 'PGint4))
313−int4range = UnsafeTypeExpression "int4range"
314−-- | Range of bigint
315−int8range :: TypeExpression schemas (null ('PGrange 'PGint8))
316−int8range = UnsafeTypeExpression "int8range"
317−-- | Range of numeric
318−numrange :: TypeExpression schemas (null ('PGrange 'PGnumeric))
319−numrange = UnsafeTypeExpression "numrange"
320−-- | Range of timestamp without time zone
321−tsrange :: TypeExpression schemas (null ('PGrange 'PGtimestamp))
322−tsrange = UnsafeTypeExpression "tsrange"
323−-- | Range of timestamp with time zone
324−tstzrange :: TypeExpression schemas (null ('PGrange 'PGtimestamptz))
325−tstzrange = UnsafeTypeExpression "tstzrange"
326−-- | Range of date
327−daterange :: TypeExpression schemas (null ('PGrange 'PGdate))
328−daterange = UnsafeTypeExpression "daterange"
329−
330−-- | `pgtype` is a demoted version of a `PGType`
331−class PGTyped schemas (ty :: NullityType) where
332− pgtype :: TypeExpression schemas ty
333−instance PGTyped schemas (null 'PGbool) where pgtype = bool
334−instance PGTyped schemas (null 'PGint2) where pgtype = int2
335−instance PGTyped schemas (null 'PGint4) where pgtype = int4
336−instance PGTyped schemas (null 'PGint8) where pgtype = int8
337−instance PGTyped schemas (null 'PGnumeric) where pgtype = numeric
338−instance PGTyped schemas (null 'PGfloat4) where pgtype = float4
339−instance PGTyped schemas (null 'PGfloat8) where pgtype = float8
340−instance PGTyped schemas (null 'PGmoney) where pgtype = money
341−instance PGTyped schemas (null 'PGtext) where pgtype = text
342−instance (KnownNat n, 1 <= n)
343− => PGTyped schemas (null ('PGchar n)) where pgtype = char @n
344−instance (KnownNat n, 1 <= n)
345− => PGTyped schemas (null ('PGvarchar n)) where pgtype = varchar @n
346−instance PGTyped schemas (null 'PGbytea) where pgtype = bytea
347−instance PGTyped schemas (null 'PGtimestamp) where pgtype = timestamp
348−instance PGTyped schemas (null 'PGtimestamptz) where pgtype = timestampWithTimeZone
349−instance PGTyped schemas (null 'PGdate) where pgtype = date
350−instance PGTyped schemas (null 'PGtime) where pgtype = time
351−instance PGTyped schemas (null 'PGtimetz) where pgtype = timeWithTimeZone
352−instance PGTyped schemas (null 'PGinterval) where pgtype = interval
353−instance PGTyped schemas (null 'PGuuid) where pgtype = uuid
354−instance PGTyped schemas (null 'PGjson) where pgtype = json
355−instance PGTyped schemas (null 'PGjsonb) where pgtype = jsonb
356−instance PGTyped schemas ty
357− => PGTyped schemas (null ('PGvararray ty)) where
358− pgtype = vararray (pgtype @schemas @ty)
359−instance (SOP.All KnownNat dims, PGTyped schemas ty)
360− => PGTyped schemas (null ('PGfixarray dims ty)) where
361− pgtype = fixarray @dims (pgtype @schemas @ty)
362−instance PGTyped schemas (null 'PGtsvector) where pgtype = tsvector
363−instance PGTyped schemas (null 'PGtsquery) where pgtype = tsquery
364−instance PGTyped schemas (null 'PGoid) where pgtype = oid
365−instance PGTyped schemas (null ('PGrange 'PGint4)) where pgtype = int4range
366−instance PGTyped schemas (null ('PGrange 'PGint8)) where pgtype = int8range
367−instance PGTyped schemas (null ('PGrange 'PGnumeric)) where pgtype = numrange
368−instance PGTyped schemas (null ('PGrange 'PGtimestamp)) where pgtype = tsrange
369−instance PGTyped schemas (null ('PGrange 'PGtimestamptz)) where pgtype = tstzrange
370−instance PGTyped schemas (null ('PGrange 'PGdate)) where pgtype = daterange
371−
372−-- | Lift `PGTyped` to a field
373−class FieldTyped schemas ty where
374− fieldtype :: Aliased (TypeExpression schemas) ty
375−instance (KnownSymbol alias, PGTyped schemas ty)
376− => FieldTyped schemas (alias ::: ty) where
377− fieldtype = pgtype `As` Alias
378−
379−-- | `ColumnTypeExpression`s are used in `createTable` commands.
380−newtype ColumnTypeExpression (schemas :: SchemasType) (ty :: ColumnType)
381− = UnsafeColumnTypeExpression { renderColumnTypeExpression :: ByteString }
382− deriving (GHC.Generic,Show,Eq,Ord,NFData)
383−instance RenderSQL (ColumnTypeExpression schemas ty) where
384− renderSQL = renderColumnTypeExpression
385−
386−-- | used in `createTable` commands as a column constraint to note that
387−-- @NULL@ may be present in a column
388−nullable
389− :: TypeExpression schemas (nullity ty)
390− -> ColumnTypeExpression schemas ('NoDef :=> 'Null ty)
391−nullable ty = UnsafeColumnTypeExpression $ renderSQL ty <+> "NULL"
392−
393−-- | used in `createTable` commands as a column constraint to ensure
394−-- @NULL@ is not present in a column
395−notNullable
396− :: TypeExpression schemas (nullity ty)
397− -> ColumnTypeExpression schemas ('NoDef :=> 'NotNull ty)
398−notNullable ty = UnsafeColumnTypeExpression $ renderSQL ty <+> "NOT NULL"
399−
400−-- | used in `createTable` commands as a column constraint to give a default
401−default_
402− :: Expression '[] '[] 'Ungrouped schemas '[] '[] ty
403− -> ColumnTypeExpression schemas ('NoDef :=> ty)
404− -> ColumnTypeExpression schemas ('Def :=> ty)
405−default_ x ty = UnsafeColumnTypeExpression $
406− renderSQL ty <+> "DEFAULT" <+> renderExpression x
407−
408−-- | not a true type, but merely a notational convenience for creating
409−-- unique identifier columns with type `PGint2`
410−serial2, smallserial
411− :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint2)
412−serial2 = UnsafeColumnTypeExpression "serial2"
413−smallserial = UnsafeColumnTypeExpression "smallserial"
414−-- | not a true type, but merely a notational convenience for creating
415−-- unique identifier columns with type `PGint4`
416−serial4, serial
417− :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint4)
418−serial4 = UnsafeColumnTypeExpression "serial4"
419−serial = UnsafeColumnTypeExpression "serial"
420−-- | not a true type, but merely a notational convenience for creating
421−-- unique identifier columns with type `PGint8`
422−serial8, bigserial
423− :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint8)
424−serial8 = UnsafeColumnTypeExpression "serial8"
425−bigserial = UnsafeColumnTypeExpression "bigserial"
426−
427−-- | Like @PGTyped@ but also accounts for nullity.
428−class PGNullityTyped schemas (nullty :: NullityType) where
429− pgNullityType :: ColumnTypeExpression schemas ('NoDef :=> nullty)
430−
431−instance PGTyped schemas ('Null ty) => PGNullityTyped schemas ('Null ty) where
432− pgNullityType = nullable (pgtype @_ @('Null ty))
433−
434−instance PGTyped schemas ('NotNull ty) => PGNullityTyped schemas ('NotNull ty) where
435− pgNullityType = notNullable (pgtype @_ @('NotNull ty))
436−
437−-- | Allow you to specify pg column types in relation to haskell types.
438−-- >>> printSQL $ hask @(Maybe String)
439−-- text NULL
440−--
441−-- >>> printSQL $ hask @Double
442−-- float8 NOT NULL
443−hask
444− :: forall hask schemas. PGNullityTyped schemas (NullPG hask)
445− => ColumnTypeExpression schemas ('NoDef :=> NullPG hask)
446−hask = pgNullityType
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Window.hsdeleted−284
@@ -1,284 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Expression.Window
3−Description: Window functions
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Window functions and definitions
9−-}
10−
11−{-# LANGUAGE
12− DataKinds
13− , DeriveGeneric
14− , FlexibleContexts
15− , FlexibleInstances
16− , GADTs
17− , GeneralizedNewtypeDeriving
18− , LambdaCase
19− , MultiParamTypeClasses
20− , OverloadedStrings
21− , RankNTypes
22− , KindSignatures
23−#-}
24−
25−module Squeal.PostgreSQL.Expression.Window
26− ( -- * functions
27− partitionBy
28− , rank
29− , rowNumber
30− , denseRank
31− , percentRank
32− , cumeDist
33− , ntile
34− , lag
35− , lead
36− , firstValue
37− , lastValue
38− , nthValue
39− , unsafeWindowFunction1
40− , unsafeWindowFunctionN
41− -- * types
42− , WindowFunction (..)
43− , WindowDefinition (..)
44− , WinFun0
45− , WinFun1
46− , WinFunN
47− ) where
48−
49−import Control.DeepSeq
50−import Data.ByteString
51−
52−import qualified GHC.Generics as GHC
53−import qualified Generics.SOP as SOP
54−
55−import Squeal.PostgreSQL.Alias
56−import Squeal.PostgreSQL.Expression
57−import Squeal.PostgreSQL.Expression.Aggregate
58−import Squeal.PostgreSQL.Expression.Sort
59−import Squeal.PostgreSQL.List
60−import Squeal.PostgreSQL.Render
61−import Squeal.PostgreSQL.Schema
62−
63−instance Aggregate
64− (Expression outer commons grp schemas params from)
65− (NP (Expression outer commons grp schemas params from))
66− (WindowFunction outer commons grp schemas params from) where
67− countStar = UnsafeWindowFunction "count(*)"
68− count = unsafeWindowFunction1 "count"
69− sum_ = unsafeWindowFunction1 "sum"
70− arrayAgg = unsafeWindowFunction1 "array_agg"
71− jsonAgg = unsafeWindowFunction1 "json_agg"
72− jsonbAgg = unsafeWindowFunction1 "jsonb_agg"
73− bitAnd = unsafeWindowFunction1 "bit_and"
74− bitOr = unsafeWindowFunction1 "bit_or"
75− boolAnd = unsafeWindowFunction1 "bool_and"
76− boolOr = unsafeWindowFunction1 "bool_or"
77− every = unsafeWindowFunction1 "every"
78− max_ = unsafeWindowFunction1 "max"
79− min_ = unsafeWindowFunction1 "min"
80− avg = unsafeWindowFunction1 "avg"
81− corr = unsafeWindowFunctionN "corr"
82− covarPop = unsafeWindowFunctionN "covar_pop"
83− covarSamp = unsafeWindowFunctionN "covar_samp"
84− regrAvgX = unsafeWindowFunctionN "regr_avgx"
85− regrAvgY = unsafeWindowFunctionN "regr_avgy"
86− regrCount = unsafeWindowFunctionN "regr_count"
87− regrIntercept = unsafeWindowFunctionN "regr_intercept"
88− regrR2 = unsafeWindowFunctionN "regr_r2"
89− regrSlope = unsafeWindowFunctionN "regr_slope"
90− regrSxx = unsafeWindowFunctionN "regr_sxx"
91− regrSxy = unsafeWindowFunctionN "regr_sxy"
92− regrSyy = unsafeWindowFunctionN "regr_syy"
93− stddev = unsafeWindowFunction1 "stddev"
94− stddevPop = unsafeWindowFunction1 "stddev_pop"
95− stddevSamp = unsafeWindowFunction1 "stddev_samp"
96− variance = unsafeWindowFunction1 "variance"
97− varPop = unsafeWindowFunction1 "var_pop"
98− varSamp = unsafeWindowFunction1 "var_samp"
99−
100−-- | A `WindowDefinition` is a set of table rows that are somehow related
101−-- to the current row
102−data WindowDefinition outer commons grp schemas params from where
103− WindowDefinition
104− :: SOP.SListI bys
105− => NP (Expression outer commons grp schemas params from) bys
106− -- ^ `partitionBy` clause
107− -> [SortExpression outer commons grp schemas params from]
108− -- ^ `Squeal.PostgreSQL.Expression.Sort.orderBy` clause
109− -> WindowDefinition outer commons grp schemas params from
110−
111−instance OrderBy WindowDefinition where
112− orderBy sortsR (WindowDefinition parts sortsL)
113− = WindowDefinition parts (sortsL ++ sortsR)
114−
115−instance RenderSQL (WindowDefinition outer commons schemas from grp params) where
116− renderSQL (WindowDefinition part ord) =
117− renderPartitionByClause part <> renderOrderByClause ord
118− where
119− renderPartitionByClause = \case
120− Nil -> ""
121− parts -> "PARTITION" <+> "BY" <+> renderCommaSeparated renderExpression parts
122− renderOrderByClause = \case
123− [] -> ""
124− srts -> " ORDER" <+> "BY"
125− <+> commaSeparated (renderSQL <$> srts)
126−
127−{- |
128−The `partitionBy` clause within `Squeal.PostgreSQL.Query.Over` divides the rows into groups,
129−or partitions, that share the same values of the `partitionBy` `Expression`(s).
130−For each row, the window function is computed across the rows that fall into
131−the same partition as the current row.
132−-}
133−partitionBy
134− :: SOP.SListI bys
135− => NP (Expression outer commons grp schemas params from) bys -- ^ partitions
136− -> WindowDefinition outer commons grp schemas params from
137−partitionBy bys = WindowDefinition bys []
138−
139−{- |
140−A window function performs a calculation across a set of table rows
141−that are somehow related to the current row. This is comparable to the type
142−of calculation that can be done with an aggregate function.
143−However, window functions do not cause rows to become grouped into a single
144−output row like non-window aggregate calls would.
145−Instead, the rows retain their separate identities.
146−Behind the scenes, the window function is able to access more than
147−just the current row of the query result.
148−-}
149−newtype WindowFunction
150− (outer :: FromType)
151− (commons :: FromType)
152− (grp :: Grouping)
153− (schemas :: SchemasType)
154− (params :: [NullityType])
155− (from :: FromType)
156− (ty :: NullityType)
157− = UnsafeWindowFunction { renderWindowFunction :: ByteString }
158− deriving (GHC.Generic,Show,Eq,Ord,NFData)
159−
160−instance RenderSQL (WindowFunction outer commons grp schemas params from ty) where
161− renderSQL = renderWindowFunction
162−
163−{- |
164−A @RankNType@ for window functions with no arguments.
165−-}
166−type WinFun0 x
167− = forall outer commons grp schemas params from
168− . WindowFunction outer commons grp schemas params from x
169− -- ^ cannot reference aliases
170−
171−{- |
172−A @RankNType@ for window functions with 1 argument.
173−-}
174−type WinFun1 x y
175− = forall outer commons grp schemas params from
176− . Expression outer commons grp schemas params from x
177− -- ^ input
178− -> WindowFunction outer commons grp schemas params from y
179− -- ^ output
180−
181−{- | A @RankNType@ for window functions with a fixed-length
182−list of heterogeneous arguments.
183−Use the `*:` operator to end your argument lists.
184−-}
185−type WinFunN xs y
186− = forall outer commons grp schemas params from
187− . NP (Expression outer commons grp schemas params from) xs
188− -- ^ inputs
189− -> WindowFunction outer commons grp schemas params from y
190− -- ^ output
191−
192−-- | escape hatch for defining window functions
193−unsafeWindowFunction1 :: ByteString -> WinFun1 x y
194−unsafeWindowFunction1 fun x
195− = UnsafeWindowFunction $ fun <> parenthesized (renderSQL x)
196−
197−-- | escape hatch for defining multi-argument window functions
198−unsafeWindowFunctionN :: SOP.SListI xs => ByteString -> WinFunN xs y
199−unsafeWindowFunctionN fun xs = UnsafeWindowFunction $ fun <>
200− parenthesized (renderCommaSeparated renderSQL xs)
201−
202−{- | rank of the current row with gaps; same as `rowNumber` of its first peer
203−
204−>>> printSQL rank
205−rank()
206−-}
207−rank :: WinFun0 ('NotNull 'PGint8)
208−rank = UnsafeWindowFunction "rank()"
209−
210−{- | number of the current row within its partition, counting from 1
211−
212−>>> printSQL rowNumber
213−row_number()
214−-}
215−rowNumber :: WinFun0 ('NotNull 'PGint8)
216−rowNumber = UnsafeWindowFunction "row_number()"
217−
218−{- | rank of the current row without gaps; this function counts peer groups
219−
220−>>> printSQL denseRank
221−dense_rank()
222−-}
223−denseRank :: WinFun0 ('NotNull 'PGint8)
224−denseRank = UnsafeWindowFunction "dense_rank()"
225−
226−{- | relative rank of the current row: (rank - 1) / (total partition rows - 1)
227−
228−>>> printSQL percentRank
229−percent_rank()
230−-}
231−percentRank :: WinFun0 ('NotNull 'PGfloat8)
232−percentRank = UnsafeWindowFunction "percent_rank()"
233−
234−{- | cumulative distribution: (number of partition rows
235−preceding or peer with current row) / total partition rows
236−
237−>>> printSQL cumeDist
238−cume_dist()
239−-}
240−cumeDist :: WinFun0 ('NotNull 'PGfloat8)
241−cumeDist = UnsafeWindowFunction "cume_dist()"
242−
243−{- | integer ranging from 1 to the argument value,
244−dividing the partition as equally as possible
245−
246−>>> printSQL $ ntile 5
247−ntile(5)
248−-}
249−ntile :: WinFun1 ('NotNull 'PGint4) ('NotNull 'PGint4)
250−ntile = unsafeWindowFunction1 "ntile"
251−
252−{- | returns value evaluated at the row that is offset rows before the current
253−row within the partition; if there is no such row, instead return default
254−(which must be of the same type as value). Both offset and default are
255−evaluated with respect to the current row.
256−-}
257−lag :: WinFunN '[ty, 'NotNull 'PGint4, ty] ty
258−lag = unsafeWindowFunctionN "lag"
259−
260−{- | returns value evaluated at the row that is offset rows after the current
261−row within the partition; if there is no such row, instead return default
262−(which must be of the same type as value). Both offset and default are
263−evaluated with respect to the current row.
264−-}
265−lead :: WinFunN '[ty, 'NotNull 'PGint4, ty] ty
266−lead = unsafeWindowFunctionN "lead"
267−
268−{- | returns value evaluated at the row that is the
269−first row of the window frame
270−-}
271−firstValue :: WinFun1 ty ty
272−firstValue = unsafeWindowFunction1 "first_value"
273−
274−{- | returns value evaluated at the row that is the
275−last row of the window frame
276−-}
277−lastValue :: WinFun1 ty ty
278−lastValue = unsafeWindowFunction1 "last_value"
279−
280−{- | returns value evaluated at the row that is the nth
281−row of the window frame (counting from 1); null if no such row
282−-}
283−nthValue :: WinFunN '[null ty, 'NotNull 'PGint4] ('Null ty)
284−nthValue = unsafeWindowFunctionN "nth_value"
squeal-postgresql/src/Squeal/PostgreSQL/List.hsdeleted−112
@@ -1,112 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.List
3−Description: List related types and functions
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Haskell singly-linked lists are very powerful. This module
9−provides functionality for type-level lists, heterogeneous
10−lists and type aligned lists.
11−-}
12−
13−{-# LANGUAGE
14− DataKinds
15− , FlexibleContexts
16− , GADTs
17− , LambdaCase
18− , MultiParamTypeClasses
19− , OverloadedStrings
20− , PolyKinds
21− , QuantifiedConstraints
22− , RankNTypes
23− , ScopedTypeVariables
24− , TypeApplications
25− , TypeFamilies
26− , TypeOperators
27− , UndecidableInstances
28−#-}
29−
30−module Squeal.PostgreSQL.List
31− ( SOP.NP (..)
32− , (*:)
33− , Join
34− , disjoin
35− , Additional (..)
36− , Path (..)
37− , CFunctor (..)
38− , CFoldable (..)
39− , CFree (..)
40− , Elem
41− , In
42− , Length
43− ) where
44−
45−import Control.Category.Free
46−import Data.Function ((&))
47−import Data.Kind
48−import Data.Type.Bool
49−import GHC.TypeLits
50−
51−import Generics.SOP as SOP
52−
53−-- | `Join` is simply promoted `++` and is used in @JOIN@s in
54−-- `Squeal.PostgreSQL.Query.FromClause`s.
55−type family Join xs ys where
56− Join '[] ys = ys
57− Join (x ': xs) ys = x ': Join xs ys
58−
59−-- | `disjoin` is a utility function for splitting an `NP` list into pieces.
60−disjoin
61− :: forall xs ys expr. SListI xs
62− => NP expr (Join xs ys)
63− -> (NP expr xs, NP expr ys)
64−disjoin = case sList @xs of
65− SNil -> \ys -> (Nil, ys)
66− SCons -> \(x :* xsys) ->
67− case disjoin xsys of (xs,ys) -> (x :* xs, ys)
68−
69−-- | The `Additional` class is for appending
70−-- type-level list parameterized constructors such as `NP`,
71−-- `Squeal.PostgreSQL.Query.Selection`, and `Squeal.PostgreSQL.Query.FromClause`.
72−class Additional expr where
73− also :: expr ys -> expr xs -> expr (Join xs ys)
74−instance Additional (NP expr) where
75− also ys = \case
76− Nil -> ys
77− x :* xs -> x :* (xs & also ys)
78−
79−-- | A useful operator for ending an `NP` list of length at least 2 without `Nil`.
80−(*:) :: f x -> f y -> NP f '[x,y]
81−x *: y = x :* y :* Nil
82−infixl 9 *:
83−
84−-- | @Elem@ is a promoted `Data.List.elem`.
85−type family Elem x xs where
86− Elem x '[] = 'False
87− Elem x (x ': _) = 'True
88− Elem x (_ ': x ': _) = 'True
89− Elem x (_ ': _ ': x ': _) = 'True
90− Elem x (_ ': _ ': _ ': x ': _) = 'True
91− Elem x (_ ': _ ': _ ': _ ': x ': _) = 'True
92− Elem x (_ ': _ ': _ ': _ ': _ ': x ': _) = 'True
93− Elem x (_ ': xs) = Elem x xs
94−
95−-- | @In x xs@ is a constraint that proves that @x@ is in @xs@.
96−type family In x xs :: Constraint where
97− In x xs = If (Elem x xs) (() :: Constraint)
98− (TypeError ('ShowType x ':<>: 'Text " is not in " ':<>: 'ShowType xs))
99−
100−{- | Calculate the `Length` of a type level list
101−
102−>>> :kind! Length '[Char,String,Bool,Double]
103−Length '[Char,String,Bool,Double] :: Nat
104−= 4
105−-}
106−type family Length (xs :: [k]) :: Nat where
107− Length (_ ': _ ': _ ': _ ': _ : xs) = 5 + Length xs
108− Length (_ ': _ ': _ ': _ : xs) = 4 + Length xs
109− Length (_ ': _ ': _ : xs) = 3 + Length xs
110− Length (_ ': _ : xs) = 2 + Length xs
111− Length (_ : xs) = 1 + Length xs
112− Length '[] = 0
squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs+253−463
@@ -9,371 +9,216 @@ Squeal data manipulation language.
9-}
9-}
10
10
11{-# LANGUAGE
11{-# LANGUAGE
12− DeriveGeneric
12+ DataKinds
13− , FlexibleContexts
13+ , DeriveDataTypeable
14− , FlexibleInstances
14+ , DeriveGeneric
15 , GADTs
15 , GADTs
16 , GeneralizedNewtypeDeriving
16 , GeneralizedNewtypeDeriving
17+ , KindSignatures
17 , LambdaCase
18 , LambdaCase
18− , MultiParamTypeClasses
19 , OverloadedStrings
19 , OverloadedStrings
20− , PatternSynonyms
21− , QuantifiedConstraints
22 , RankNTypes
20 , RankNTypes
23− , ScopedTypeVariables
21+ , StandaloneDeriving
24− , TypeApplications
25− , TypeFamilies
26 , TypeInType
22 , TypeInType
27 , TypeOperators
23 , TypeOperators
28− , UndecidableInstances
29#-}
24#-}
30
25
31module Squeal.PostgreSQL.Manipulation
26module Squeal.PostgreSQL.Manipulation
32 ( -- * Manipulation
27 ( -- * Manipulation
33− Manipulation_
28+ Manipulation (UnsafeManipulation, renderManipulation)
34− , Manipulation (..)
35 , queryStatement
29 , queryStatement
36 -- * Insert
30 -- * Insert
37 , insertInto
31 , insertInto
38− , insertInto_
32+ , ValuesClause (Values, ValuesQuery)
33+ , renderValuesClause
34+ , ReturningClause (ReturningStar, Returning)
35+ , renderReturningClause
36+ , ConflictClause (OnConflictDoRaise, OnConflictDoNothing, OnConflictDoUpdate)
37+ , renderConflictClause
39 -- * Update
38 -- * Update
40 , update
39 , update
41− , update_
40+ , UpdateExpression (Same, Set)
42− -- * Delete
41+ , renderUpdateExpression
43 , deleteFrom
42 , deleteFrom
44− , deleteFrom_
45− -- * Clauses
46− , Optional (..)
47− , QueryClause (..)
48− , pattern Values_
49− , ReturningClause (..)
50− , pattern Returning_
51− , ConflictClause (..)
52− , ConflictTarget (..)
53− , ConflictAction (..)
54− , UsingClause (..)
55 ) where
43 ) where
56
44
57import Control.DeepSeq
45import Control.DeepSeq
58−import Data.ByteString hiding (foldr)
46+import Data.ByteString
59−import Data.Kind (Type)
47+import Data.Monoid
60
48
61import qualified Generics.SOP as SOP
49import qualified Generics.SOP as SOP
62import qualified GHC.Generics as GHC
50import qualified GHC.Generics as GHC
63
51
64−import Squeal.PostgreSQL.Alias
65import Squeal.PostgreSQL.Expression
52import Squeal.PostgreSQL.Expression
66−import Squeal.PostgreSQL.Expression.Logic
53+import Squeal.PostgreSQL.Prettyprint
67−import Squeal.PostgreSQL.List
68−import Squeal.PostgreSQL.PG
69−import Squeal.PostgreSQL.Render
70import Squeal.PostgreSQL.Query
54import Squeal.PostgreSQL.Query
71import Squeal.PostgreSQL.Schema
55import Squeal.PostgreSQL.Schema
72
56
73−-- $setup
57+-- | A `Manipulation` is a statement which may modify data in the database,
74−-- >>> import Squeal.PostgreSQL
58+-- but does not alter the schema. Examples are `insertInto`, `update` and
75−-- >>> import Data.Int
59+-- `deleteFrom`. A `Query` is also considered a `Manipulation` even though
76−-- >>> import Data.Time
60+-- it does not modify data.
77−
78−{- |
79−A `Manipulation` is a statement which may modify data in the database,
80−but does not alter its schemas. Examples are inserts, updates and deletes.
81−A `Query` is also considered a `Manipulation` even though it does not modify data.
82−
83−The general `Manipulation` type is parameterized by
84−
85−* @commons :: FromType@ - scope for all `common` table expressions,
86−* @schemas :: SchemasType@ - scope for all `table`s and `view`s,
87−* @params :: [NullityType]@ - scope for all `Squeal.Expression.Parameter.parameter`s,
88−* @row :: RowType@ - return type of the `Query`.
89−-}
90newtype Manipulation
61newtype Manipulation
91− (commons :: FromType)
62+ (schema :: TablesType)
92− (schemas :: SchemasType)
63+ (params :: [ColumnType])
93− (params :: [NullityType])
64+ (columns :: ColumnsType)
94− (columns :: RowType)
95 = UnsafeManipulation { renderManipulation :: ByteString }
65 = UnsafeManipulation { renderManipulation :: ByteString }
96 deriving (GHC.Generic,Show,Eq,Ord,NFData)
66 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
67
104−{- |
68+-- | Convert a `Query` into a `Manipulation`.
105−The top level `Manipulation_` type is parameterized by a @schemas@ `SchemasType`,
69+queryStatement
106−against which the query is type-checked, an input @parameters@ Haskell `Type`,
70+ :: Query schema params columns
107−and an ouput row Haskell `Type`.
71+ -> Manipulation schema params columns
108−
72+queryStatement q = UnsafeManipulation $ renderQuery q <> ";"
109−A top-level `Manipulation_` can be run
110−using `Squeal.PostgreSQL.PQ.manipulateParams`, or if @parameters = ()@
111−using `Squeal.PostgreSQL.PQ.manipulate`.
112
73
113−Generally, @parameters@ will be a Haskell tuple or record whose entries
74+{-----------------------------------------
114−may be referenced using positional
75+INSERT statements
115−`Squeal.PostgreSQL.Expression.Parameter.parameter`s and @row@ will be a
76+-----------------------------------------}
116−Haskell record, whose entries will be targeted using overloaded labels.
117
77
118−>>> :set -XDeriveAnyClass -XDerivingStrategies
78+{- |
119−>>> :{
79+When a table is created, it contains no data. The first thing to do
120−data Row a b = Row { col1 :: a, col2 :: b }
80+before a database can be of much use is to insert data. Data is
121− deriving stock (GHC.Generic)
81+conceptually inserted one row at a time. Of course you can also insert
122− deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
82+more than one row, but there is no way to insert less than one row.
123−:}
83+Even if you know only some column values, a complete row must be created.
124
84
125simple insert:
85simple insert:
126
86
127−>>> type Columns = '["col1" ::: 'NoDef :=> 'Null 'PGint4, "col2" ::: 'Def :=> 'NotNull 'PGint4]
128−>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]
129>>> :{
87>>> :{
130let
88let
131− manipulation :: Manipulation_ (Public Schema) () ()
89+ manipulation :: Manipulation
90+ '[ "tab" :::
91+ '[ "col1" ::: 'Required ('NotNull 'PGint4)
92+ , "col2" ::: 'Required ('NotNull 'PGint4) ]] '[] '[]
132 manipulation =
93 manipulation =
133− insertInto_ #tab (Values_ (Set 2 `as` #col1 :* Default `as` #col2))
94+ insertInto #tab (Values (2 `As` #col1 :* 4 `As` #col2 :* Nil) [])
134−in printSQL manipulation
95+ OnConflictDoRaise (Returning Nil)
96+in renderManipulation manipulation
135:}
97:}
136−INSERT INTO "tab" ("col1", "col2") VALUES (2, DEFAULT)
98+"INSERT INTO tab (col1, col2) VALUES (2, 4);"
137
99
138parameterized insert:
100parameterized insert:
139
101
140−>>> type Columns = '["col1" ::: 'NoDef :=> 'NotNull 'PGint4, "col2" ::: 'NoDef :=> 'NotNull 'PGint4]
141−>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]
142>>> :{
102>>> :{
143let
103let
144− manipulation :: Manipulation_ (Public Schema) (Int32, Int32) ()
104+ manipulation :: Manipulation
105+ '[ "tab" :::
106+ '[ "col1" ::: 'Required ('NotNull 'PGint4)
107+ , "col2" ::: 'Required ('NotNull 'PGint4) ]]
108+ '[ 'Required ('NotNull 'PGint4)
109+ , 'Required ('NotNull 'PGint4) ] '[]
145 manipulation =
110 manipulation =
146− insertInto_ #tab (Values_ (Set (param @1) `as` #col1 :* Set (param @2) `as` #col2))
111+ insertInto #tab
147−in printSQL manipulation
112+ (Values (param @1 `As` #col1 :* param @2 `As` #col2 :* Nil) [])
113+ OnConflictDoRaise (Returning Nil)
114+in renderManipulation manipulation
148:}
115:}
149−INSERT INTO "tab" ("col1", "col2") VALUES (($1 :: int4), ($2 :: int4))
116+"INSERT INTO tab (col1, col2) VALUES (($1 :: int4), ($2 :: int4));"
150
117
151returning insert:
118returning insert:
152
119
153>>> :{
120>>> :{
154let
121let
155− manipulation :: Manipulation_ (Public Schema) () (Only Int32)
122+ manipulation :: Manipulation
123+ '[ "tab" :::
124+ '[ "col1" ::: 'Required ('NotNull 'PGint4)
125+ , "col2" ::: 'Required ('NotNull 'PGint4) ]] '[]
126+ '["fromOnly" ::: 'Required ('NotNull 'PGint4)]
156 manipulation =
127 manipulation =
157− insertInto #tab (Values_ (Set 2 `as` #col1 :* Set 3 `as` #col2))
128+ insertInto #tab (Values (2 `As` #col1 :* 4 `As` #col2 :* Nil) [])
158− OnConflictDoRaise (Returning (#col1 `as` #fromOnly))
129+ OnConflictDoRaise (Returning (#col1 `As` #fromOnly :* Nil))
159−in printSQL manipulation
130+in renderManipulation manipulation
160:}
131:}
161−INSERT INTO "tab" ("col1", "col2") VALUES (2, 3) RETURNING "col1" AS "fromOnly"
132+"INSERT INTO tab (col1, col2) VALUES (2, 4) RETURNING col1 AS fromOnly;"
162−
163−upsert:
164−
165−>>> type CustomersColumns = '["name" ::: 'NoDef :=> 'NotNull 'PGtext, "email" ::: 'NoDef :=> 'NotNull 'PGtext]
166−>>> type CustomersConstraints = '["uq" ::: 'Unique '["name"]]
167−>>> type CustomersSchema = '["customers" ::: 'Table (CustomersConstraints :=> CustomersColumns)]
168−>>> :{
169−let
170− manipulation :: Manipulation_ (Public CustomersSchema) () ()
171− manipulation =
172− insertInto #customers
173− (Values_ (Set "John Smith" `as` #name :* Set "john@smith.com" `as` #email))
174− (OnConflict (OnConstraint #uq)
175− (DoUpdate (Set (#excluded ! #email <> "; " <> #customers ! #email) `as` #email) []))
176− (Returning_ Nil)
177−in printSQL manipulation
178−:}
179−INSERT INTO "customers" ("name", "email") VALUES (E'John Smith', E'john@smith.com') ON CONFLICT ON CONSTRAINT "uq" DO UPDATE SET "email" = ("excluded"."email" || (E'; ' || "customers"."email"))
180
133
181query insert:
134query insert:
182
135
183>>> :{
136>>> :{
184let
137let
185− manipulation :: Manipulation_ (Public Schema) () ()
138+ manipulation :: Manipulation
186− manipulation = insertInto_ #tab (Subquery (select Star (from (table #tab))))
139+ '[ "tab" :::
187−in printSQL manipulation
140+ '[ "col1" ::: 'Required ('NotNull 'PGint4)
188−:}
141+ , "col2" ::: 'Required ('NotNull 'PGint4)
189−INSERT INTO "tab" SELECT * FROM "tab" AS "tab"
142+ ]
190−
143+ , "other_tab" :::
191−update:
144+ '[ "col1" ::: 'Required ('NotNull 'PGint4)
192−
145+ , "col2" ::: 'Required ('NotNull 'PGint4)
193−>>> :{
146+ ]
194−let
147+ ] '[] '[]
195− manipulation :: Manipulation_ (Public Schema) () ()
148+ manipulation =
196− manipulation = update_ #tab (Set 2 `as` #col1) (#col1 ./= #col2)
149+ insertInto #tab
197−in printSQL manipulation
150+ ( ValuesQuery $
198−:}
151+ selectStar (from (Table (#other_tab `As` #t))) )
199−UPDATE "tab" SET "col1" = 2 WHERE ("col1" <> "col2")
152+ OnConflictDoRaise (Returning Nil)
200−
153+in renderManipulation manipulation
201−delete:
202−
203−>>> :{
204−let
205− manipulation :: Manipulation_ (Public Schema) () (Row Int32 Int32)
206− manipulation = deleteFrom #tab NoUsing (#col1 .== #col2) (Returning Star)
207−in printSQL manipulation
208:}
154:}
209−DELETE FROM "tab" WHERE ("col1" = "col2") RETURNING *
155+"INSERT INTO tab SELECT * FROM other_tab AS t;"
210
156
211−delete and using clause:
157+upsert:
212−
213−>>> :{
214−type Schema3 =
215− '[ "tab" ::: 'Table ('[] :=> Columns)
216− , "other_tab" ::: 'Table ('[] :=> Columns)
217− , "third_tab" ::: 'Table ('[] :=> Columns) ]
218−:}
219
158
220>>> :{
159>>> :{
221let
160let
222− manipulation :: Manipulation_ (Public Schema3) () ()
161+ manipulation :: Manipulation
162+ '[ "tab" :::
163+ '[ "col1" ::: 'Required ('NotNull 'PGint4)
164+ , "col2" ::: 'Required ('NotNull 'PGint4) ]]
165+ '[] '[ "sum" ::: 'Required ('NotNull 'PGint4)]
223 manipulation =
166 manipulation =
224− deleteFrom #tab (Using (table #other_tab & also (table #third_tab)))
167+ insertInto #tab
225− ( (#tab ! #col2 .== #other_tab ! #col2)
168+ (Values
226− .&& (#tab ! #col2 .== #third_tab ! #col2) )
169+ (2 `As` #col1 :* 4 `As` #col2 :* Nil)
227− (Returning_ Nil)
170+ [6 `As` #col1 :* 8 `As` #col2 :* Nil])
228−in printSQL manipulation
171+ (OnConflictDoUpdate
229−:}
172+ (Set 2 `As` #col1 :* Same `As` #col2 :* Nil)
230−DELETE FROM "tab" USING "other_tab" AS "other_tab", "third_tab" AS "third_tab" WHERE (("tab"."col2" = "other_tab"."col2") AND ("tab"."col2" = "third_tab"."col2"))
173+ (Just (#col1 .== #col2)))
231−
174+ (Returning $ (#col1 + #col2) `As` #sum :* Nil)
232−with manipulation:
175+in renderManipulation manipulation
233−
234−>>> type ProductsColumns = '["product" ::: 'NoDef :=> 'NotNull 'PGtext, "date" ::: 'Def :=> 'NotNull 'PGdate]
235−>>> type ProductsSchema = '["products" ::: 'Table ('[] :=> ProductsColumns), "products_deleted" ::: 'Table ('[] :=> ProductsColumns)]
236−>>> :{
237−let
238− manipulation :: Manipulation_ (Public ProductsSchema) (Only Day) ()
239− manipulation = with
240− (deleteFrom #products NoUsing (#date .< param @1) (Returning Star) `as` #del)
241− (insertInto_ #products_deleted (Subquery (select Star (from (common #del)))))
242−in printSQL manipulation
243:}
176:}
244−WITH "del" AS (DELETE FROM "products" WHERE ("date" < ($1 :: date)) RETURNING *) INSERT INTO "products_deleted" SELECT * FROM "del" AS "del"
177+"INSERT INTO tab (col1, col2) VALUES (2, 4), (6, 8) ON CONFLICT DO UPDATE SET col1 = 2 WHERE (col1 = col2) RETURNING (col1 + col2) AS sum;"
245−-}
246−type family Manipulation_ (schemas :: SchemasType) (params :: Type) (row :: Type) where
247− Manipulation_ schemas params row = Manipulation '[] schemas (TuplePG params) (RowPG row)
248−
249−-- | Convert a `Query` into a `Manipulation`.
250−queryStatement
251− :: Query '[] commons schemas params columns
252− -- ^ `Query` to embed as a `Manipulation`
253− -> Manipulation commons schemas params columns
254−queryStatement q = UnsafeManipulation $ renderSQL q
255−
256−{-----------------------------------------
257−INSERT statements
258−-----------------------------------------}
259−
260−{- |
261−When a table is created, it contains no data. The first thing to do
262−before a database can be of much use is to insert data. Data is
263−conceptually inserted one row at a time. Of course you can also insert
264−more than one row, but there is no way to insert less than one row.
265−Even if you know only some column values, a complete row must be created.
266-}
178-}
267insertInto
179insertInto
268− :: ( Has sch schemas schema
180+ :: (SOP.SListI columns, SOP.SListI results, HasTable table schema columns)
269− , Has tab schema ('Table table)
181+ => Alias table -- ^ table to insert into
270− , columns ~ TableToColumns table
182+ -> ValuesClause schema params columns -- ^ values to insert
271− , row0 ~ TableToRow table
183+ -> ConflictClause columns params
272− , SOP.SListI columns
184+ -- ^ what to do in case of constraint conflict
273− , SOP.SListI row1 )
185+ -> ReturningClause columns params results -- ^ results to return
274− => QualifiedAlias sch tab
186+ -> Manipulation schema params results
275− -- ^ table
187+insertInto table insert conflict returning = UnsafeManipulation $
276− -> QueryClause commons schemas params columns
188+ "INSERT" <+> "INTO" <+> renderAlias table
277− -- ^ what to insert
189+ <+> renderValuesClause insert
278− -> ConflictClause tab commons schemas params table
190+ <> renderConflictClause conflict
279− -- ^ what to do in case of conflict
191+ <> renderReturningClause returning
280− -> ReturningClause commons schemas params '[tab ::: row0] row1
192+
281− -- ^ what to return
193+-- | A `ValuesClause` lets you insert either values, free `Expression`s,
282− -> Manipulation commons schemas params row1
194+-- or the result of a `Query`.
283−insertInto tab qry conflict ret = UnsafeManipulation $
195+data ValuesClause
284− "INSERT" <+> "INTO" <+> renderSQL tab
196+ (schema :: TablesType)
285− <+> renderSQL qry
197+ (params :: [ColumnType])
286− <> renderSQL conflict
198+ (columns :: ColumnsType)
287− <> renderSQL ret
199+ = Values
288−
200+ (NP (Aliased (Expression '[] 'Ungrouped params)) columns)
289−-- | Like `insertInto` but with `OnConflictDoRaise` and `no` `ReturningClause`.
201+ [NP (Aliased (Expression '[] 'Ungrouped params)) columns]
290−insertInto_
202+ -- ^ at least one row of values
291− :: ( Has sch schemas schema
203+ | ValuesQuery (Query schema params columns)
292− , Has tab schema ('Table table)
204+
293− , columns ~ TableToColumns table
205+-- | Render a `ValuesClause`.
294− , row ~ TableToRow table
206+renderValuesClause
295− , SOP.SListI columns )
296− => QualifiedAlias sch tab
297− -- ^ table
298− -> QueryClause commons schemas params columns
299− -- ^ what to insert
300− -> Manipulation commons schemas params '[]
301−insertInto_ tab qry =
302− insertInto tab qry OnConflictDoRaise (Returning_ Nil)
303−
304−-- | A `QueryClause` describes what to `insertInto` a table.
305−data QueryClause commons schemas params columns where
306− Values
307− :: SOP.SListI columns
308− => NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[]))) columns
309− -- ^ row of values
310− -> [NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[]))) columns]
311− -- ^ additional rows of values
312− -> QueryClause commons schemas params columns
313− Select
314− :: SOP.SListI columns
315− => NP (Aliased (Optional (Expression '[] commons grp schemas params from))) columns
316− -- ^ row of values
317− -> TableExpression '[] commons grp schemas params from
318− -- ^ from a table expression
319− -> QueryClause commons schemas params columns
320− Subquery
321− :: ColumnsToRow columns ~ row
322− => Query '[] commons schemas params row
323− -- ^ subquery to insert
324− -> QueryClause commons schemas params columns
325−
326−instance RenderSQL (QueryClause commons schemas params columns) where
327− renderSQL = \case
328− Values row0 rows ->
329− parenthesized (renderCommaSeparated renderSQLPart row0)
330− <+> "VALUES"
331− <+> commaSeparated
332− ( parenthesized
333− . renderCommaSeparated renderValuePart <$> row0 : rows )
334− Select row0 tab ->
335− parenthesized (renderCommaSeparatedMaybe renderSQLPartMaybe row0)
336− <+> "SELECT"
337− <+> renderCommaSeparatedMaybe renderValuePartMaybe row0
338− <+> renderSQL tab
339− Subquery qry -> renderQuery qry
340− where
341− renderSQLPartMaybe, renderValuePartMaybe
342− :: Aliased (Optional (Expression '[] commons grp schemas params from)) column
343− -> Maybe ByteString
344− renderSQLPartMaybe = \case
345− Default `As` _ -> Nothing
346− Set _ `As` name -> Just $ renderSQL name
347− renderValuePartMaybe = \case
348− Default `As` _ -> Nothing
349− Set value `As` _ -> Just $ renderExpression value
350− renderSQLPart, renderValuePart
351− :: Aliased (Optional (Expression '[] commons grp schemas params from)) column
352− -> ByteString
353− renderSQLPart (_ `As` name) = renderSQL name
354− renderValuePart (value `As` _) = renderSQL value
355−
356−-- | `Values_` describes a single `NP` list of `Aliased` `Optional` `Expression`s
357−-- whose `ColumnsType` must match the tables'.
358−pattern Values_
359 :: SOP.SListI columns
207 :: SOP.SListI columns
360− => NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[]))) columns
208+ => ValuesClause schema params columns
361− -- ^ row of values
209+ -> ByteString
362− -> QueryClause commons schemas params columns
210+renderValuesClause = \case
363−pattern Values_ vals = Values vals []
211+ Values row rows ->
364−
212+ parenthesized (renderCommaSeparated renderAliasPart row)
365−-- | `Optional` is either `Default` or a value, parameterized by an appropriate
213+ <+> "VALUES"
366−-- `ColumnConstraint`.
214+ <+> commaSeparated
367−data Optional expr ty where
215+ (parenthesized . renderCommaSeparated renderValuePart <$> row:rows)
368− -- | Use the `Default` value for a column.
216+ where
369− Default :: Optional expr ('Def :=> ty)
217+ renderAliasPart, renderValuePart
370− -- | `Set` a value for a column.
218+ :: Aliased (Expression '[] 'Ungrouped params) ty -> ByteString
371− Set :: expr ty -> Optional expr (def :=> ty)
219+ renderAliasPart (_ `As` name) = renderAlias name
372−
220+ renderValuePart (value `As` _) = renderExpression value
373−instance (forall x. RenderSQL (expr x)) => RenderSQL (Optional expr ty) where
221+ ValuesQuery q -> renderQuery q
374− renderSQL = \case
375− Default -> "DEFAULT"
376− Set expr -> renderSQL expr
377
222
378-- | A `ReturningClause` computes and return value(s) based
223-- | A `ReturningClause` computes and return value(s) based
379-- on each row actually inserted, updated or deleted. This is primarily
224-- on each row actually inserted, updated or deleted. This is primarily
@@ -381,100 +226,60 @@ instance (forall x. RenderSQL (expr x)) => RenderSQL (Optional expr ty) where
381-- serial sequence number. However, any expression using the table's columns
226-- serial sequence number. However, any expression using the table's columns
382-- is allowed. Only rows that were successfully inserted or updated or
227-- is allowed. Only rows that were successfully inserted or updated or
383-- deleted will be returned. For example, if a row was locked
228-- deleted will be returned. For example, if a row was locked
384−-- but not updated because an `OnConflict` `DoUpdate` condition was not satisfied,
229+-- but not updated because an `OnConflictDoUpdate` condition was not satisfied,
385−-- the row will not be returned. `Returning` `Star` will return all columns
230+-- the row will not be returned. `ReturningStar` will return all columns
386−-- in the row. Use `Returning` `Nil` in the common case where no return
231+-- in the row. Use `Returning Nil` in the common case where no return
387-- values are desired.
232-- values are desired.
388−newtype ReturningClause commons schemas params from row =
233+data ReturningClause
389− Returning (Selection '[] commons 'Ungrouped schemas params from row)
234+ (columns :: ColumnsType)
390−
235+ (params :: [ColumnType])
391−instance RenderSQL (ReturningClause commons schemas params from row) where
236+ (results :: ColumnsType)
392− renderSQL = \case
237+ where
393− Returning (List Nil) -> ""
238+ ReturningStar :: ReturningClause columns params columns
394− Returning selection -> " RETURNING" <+> renderSQL selection
239+ Returning
395−
240+ :: NP
396−-- | `Returning` a `List`
241+ (Aliased (Expression '[table ::: columns] 'Ungrouped params))
397−pattern Returning_
242+ results
398− :: SOP.SListI row
243+ -> ReturningClause columns params results
399− => NP (Aliased (Expression '[] commons 'Ungrouped schemas params from)) row
244+
400− -- ^ row of values
245+-- | Render a `ReturningClause`.
401− -> ReturningClause commons schemas params from row
246+renderReturningClause
402−pattern Returning_ list = Returning (List list)
247+ :: SOP.SListI results
248+ => ReturningClause params columns results
249+ -> ByteString
250+renderReturningClause = \case
251+ ReturningStar -> " RETURNING *;"
252+ Returning Nil -> ";"
253+ Returning results -> " RETURNING"
254+ <+> renderCommaSeparated (renderAliased renderExpression) results <> ";"
403
255
404-- | A `ConflictClause` specifies an action to perform upon a constraint
256-- | A `ConflictClause` specifies an action to perform upon a constraint
405-- violation. `OnConflictDoRaise` will raise an error.
257-- violation. `OnConflictDoRaise` will raise an error.
406−-- `OnConflict` `DoNothing` simply avoids inserting a row.
258+-- `OnConflictDoNothing` simply avoids inserting a row.
407−-- `OnConflict` `DoUpdate` updates the existing row that conflicts with the row
259+-- `OnConflictDoUpdate` updates the existing row that conflicts with the row
408-- proposed for insertion.
260-- proposed for insertion.
409−data ConflictClause tab commons schemas params table where
261+data ConflictClause columns params where
410− OnConflictDoRaise :: ConflictClause tab commons schemas params table
262+ OnConflictDoRaise :: ConflictClause columns params
411− OnConflict
263+ OnConflictDoNothing :: ConflictClause columns params
412− :: ConflictTarget constraints
264+ OnConflictDoUpdate
413− -- ^ conflict target
265+ :: NP (Aliased (UpdateExpression columns params)) columns
414− -> ConflictAction tab commons schemas params columns
266+ -> Maybe (Condition '[table ::: columns] 'Ungrouped params)
415− -- ^ conflict action
267+ -> ConflictClause columns params
416− -> ConflictClause tab commons schemas params (constraints :=> columns)
417
268
418-- | Render a `ConflictClause`.
269-- | Render a `ConflictClause`.
419−instance SOP.SListI (TableToColumns table)
270+renderConflictClause
420− => RenderSQL (ConflictClause tab commons schemas params table) where
271+ :: SOP.SListI columns
421− renderSQL = \case
272+ => ConflictClause columns params
422− OnConflictDoRaise -> ""
423− OnConflict target action -> " ON CONFLICT"
424− <+> renderSQL target <+> renderSQL action
425−
426−{- |
427−`ConflictAction` specifies an alternative `OnConflict` action.
428−It can be either `DoNothing`, or a `DoUpdate` clause specifying
429−the exact details of the `update` action to be performed in case of a conflict.
430−The `Set` and WHERE `Condition`s in `OnConflict` `DoUpdate` have access to the
431−existing row using the table's name (or an alias), and to rows proposed
432−for insertion using the special @#excluded@ table.
433−`OnConflict` `DoNothing` simply avoids inserting a row as its alternative action.
434−`OnConflict` `DoUpdate` updates the existing row that conflicts
435−with the row proposed for insertion as its alternative action.
436−-}
437−data ConflictAction tab commons schemas params columns where
438− DoNothing :: ConflictAction tab commons schemas params columns
439− DoUpdate
440− :: ( row ~ ColumnsToRow columns
441− , SOP.SListI columns
442− , columns ~ (col0 ': cols)
443− , SOP.All (HasIn columns) subcolumns
444− , AllUnique subcolumns )
445− => NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[tab ::: row, "excluded" ::: row]))) subcolumns
446− -> [Condition '[] commons 'Ungrouped schemas params '[tab ::: row, "excluded" ::: row]]
447− -- ^ WHERE `Condition`s
448− -> ConflictAction tab commons schemas params columns
449−
450−instance RenderSQL (ConflictAction tab commons schemas params columns) where
451− renderSQL = \case
452− DoNothing -> "DO NOTHING"
453− DoUpdate updates whs'
454− -> "DO UPDATE SET"
455− <+> renderCommaSeparated renderUpdate updates
456− <> case whs' of
457− [] -> ""
458− wh:whs -> " WHERE" <+> renderSQL (foldr (.&&) wh whs)
459−
460−renderUpdate
461− :: (forall x. RenderSQL (expr x))
462− => Aliased (Optional expr) ty
463 -> ByteString
273 -> ByteString
464−renderUpdate (expr `As` col) = renderSQL col <+> "=" <+> renderSQL expr
274+renderConflictClause = \case
465−
275+ OnConflictDoRaise -> ""
466−-- | A `ConflictTarget` specifies the constraint violation that triggers a
276+ OnConflictDoNothing -> " ON CONFLICT DO NOTHING"
467−-- `ConflictAction`.
277+ OnConflictDoUpdate updates whMaybe
468−data ConflictTarget constraints where
278+ -> " ON CONFLICT DO UPDATE SET"
469− OnConstraint
279+ <+> renderCommaSeparatedMaybe renderUpdateExpression updates
470− :: Has con constraints constraint
280+ <> case whMaybe of
471− => Alias con
281+ Nothing -> ""
472− -> ConflictTarget constraints
282+ Just wh -> " WHERE" <+> renderExpression wh
473−
474−-- | Render a `ConflictTarget`
475−instance RenderSQL (ConflictTarget constraints) where
476− renderSQL (OnConstraint con) =
477− "ON" <+> "CONSTRAINT" <+> renderSQL con
478
283
479{-----------------------------------------
284{-----------------------------------------
480UPDATE statements
285UPDATE statements
@@ -482,97 +287,82 @@ UPDATE statements
482
287
483-- | An `update` command changes the values of the specified columns
288-- | An `update` command changes the values of the specified columns
484-- in all rows that satisfy the condition.
289-- in all rows that satisfy the condition.
290+--
291+-- >>> :{
292+-- let
293+-- manipulation :: Manipulation
294+-- '[ "tab" :::
295+-- '[ "col1" ::: 'Required ('NotNull 'PGint4)
296+-- , "col2" ::: 'Required ('NotNull 'PGint4) ]] '[] '[]
297+-- manipulation =
298+-- update #tab (Set 2 `As` #col1 :* Same `As` #col2 :* Nil)
299+-- (#col1 ./= #col2) (Returning Nil)
300+-- in renderManipulation manipulation
301+-- :}
302+-- "UPDATE tab SET col1 = 2 WHERE (col1 <> col2);"
485update
303update
486− :: ( SOP.SListI columns
304+ :: (HasTable table schema columns, SOP.SListI columns, SOP.SListI results)
487− , SOP.SListI row1
305+ => Alias table -- ^ table to update
488− , Has sch schemas schema
306+ -> NP (Aliased (UpdateExpression columns params)) columns
489− , Has tab schema ('Table table)
490− , row0 ~ TableToRow table
491− , columns ~ TableToColumns table
492− , SOP.All (HasIn columns) subcolumns
493− , AllUnique subcolumns )
494− => QualifiedAlias sch tab -- ^ table to update
495− -> NP (Aliased (Optional (Expression '[] '[] 'Ungrouped schemas params '[tab ::: row0]))) subcolumns
496 -- ^ modified values to replace old values
307 -- ^ modified values to replace old values
497− -> Condition '[] commons 'Ungrouped schemas params '[tab ::: row0]
308+ -> Condition '[tab ::: columns] 'Ungrouped params
498 -- ^ condition under which to perform update on a row
309 -- ^ condition under which to perform update on a row
499− -> ReturningClause commons schemas params '[tab ::: row0] row1 -- ^ results to return
310+ -> ReturningClause columns params results -- ^ results to return
500− -> Manipulation commons schemas params row1
311+ -> Manipulation schema params results
501−update tab columns wh returning = UnsafeManipulation $
312+update table columns wh returning = UnsafeManipulation $
502 "UPDATE"
313 "UPDATE"
503− <+> renderSQL tab
314+ <+> renderAlias table
504 <+> "SET"
315 <+> "SET"
505− <+> renderCommaSeparated renderUpdate columns
316+ <+> renderCommaSeparatedMaybe renderUpdateExpression columns
506− <+> "WHERE" <+> renderSQL wh
317+ <+> "WHERE" <+> renderExpression wh
507− <> renderSQL returning
318+ <> renderReturningClause returning
508−
319+
509−-- | Update a row returning `Nil`.
320+-- | Columns to be updated are mentioned with `Set`; columns which are to
510−update_
321+-- remain the same are mentioned with `Same`.
511− :: ( SOP.SListI columns
322+data UpdateExpression columns params ty
512− , Has sch schemas schema
323+ = Same
513− , Has tab schema ('Table table)
324+ -- ^ column to remain the same upon update
514− , row ~ TableToRow table
325+ | Set (forall table. Expression '[table ::: columns] 'Ungrouped params ty)
515− , columns ~ TableToColumns table
326+ -- ^ column to be updated
516− , SOP.All (HasIn columns) subcolumns
327+deriving instance Show (UpdateExpression columns params ty)
517− , AllUnique subcolumns )
328+deriving instance Eq (UpdateExpression columns params ty)
518− => QualifiedAlias sch tab -- ^ table to update
329+deriving instance Ord (UpdateExpression columns params ty)
519− -> NP (Aliased (Optional (Expression '[] '[] 'Ungrouped schemas params '[tab ::: row]))) subcolumns
330+
520− -- ^ modified values to replace old values
331+-- | Render an `UpdateExpression`.
521− -> Condition '[] commons 'Ungrouped schemas params '[tab ::: row]
332+renderUpdateExpression
522− -- ^ condition under which to perform update on a row
333+ :: Aliased (UpdateExpression params columns) column
523− -> Manipulation commons schemas params '[]
334+ -> Maybe ByteString
524−update_ tab columns wh = update tab columns wh (Returning_ Nil)
335+renderUpdateExpression = \case
336+ Same `As` _ -> Nothing
337+ Set expression `As` column -> Just $
338+ renderAlias column <+> "=" <+> renderExpression expression
525
339
526{-----------------------------------------
340{-----------------------------------------
527DELETE statements
341DELETE statements
528-----------------------------------------}
342-----------------------------------------}
529
343
530−-- | Specify additional tables with `Using`
344+-- | Delete rows of a table.
531−-- an `also` list of table expressions, allowing columns
345+--
532−-- from other tables to appear in the WHERE condition.
346+-- >>> :{
533−-- This is similar to the list of tables that can be specified
347+-- let
534−-- in the FROM Clause of a SELECT statement;
348+-- manipulation :: Manipulation
535−-- for example, an alias for the table name can be specified.
349+-- '[ "tab" :::
536−-- Do not repeat the target table in the `Using` list,
350+-- '[ "col1" ::: 'Required ('NotNull 'PGint4)
537−-- unless you wish to set up a self-join.
351+-- , "col2" ::: 'Required ('NotNull 'PGint4) ]] '[]
538−-- `NoUsing` if no additional tables are to be used.
352+-- '[ "col1" ::: 'Required ('NotNull 'PGint4)
539−data UsingClause commons schemas params from where
353+-- , "col2" ::: 'Required ('NotNull 'PGint4) ]
540− NoUsing :: UsingClause commons schemas params '[]
354+-- manipulation = deleteFrom #tab (#col1 .== #col2) ReturningStar
541− Using
355+-- in renderManipulation manipulation
542− :: FromClause '[] commons schemas params from
356+-- :}
543− -- ^ what to use
357+-- "DELETE FROM tab WHERE (col1 = col2) RETURNING *;"
544− -> UsingClause commons schemas params from
545−
546−-- | Delete rows from a table.
547deleteFrom
358deleteFrom
548− :: ( SOP.SListI row1
359+ :: (SOP.SListI results, HasTable table schema columns)
549− , Has sch schemas schema
360+ => Alias table -- ^ table to delete from
550− , Has tab schema ('Table table)
361+ -> Condition '[table ::: columns] 'Ungrouped params
551− , row0 ~ TableToRow table
552− , columns ~ TableToColumns table )
553− => QualifiedAlias sch tab -- ^ table to delete from
554− -> UsingClause commons schemas params from
555− -> Condition '[] commons 'Ungrouped schemas params (tab ::: row0 ': from)
556− -- ^ condition under which to delete a row
557− -> ReturningClause commons schemas params '[tab ::: row0] row1 -- ^ results to return
558− -> Manipulation commons schemas params row1
559−deleteFrom tab using wh returning = UnsafeManipulation $
560− "DELETE FROM"
561− <+> renderSQL tab
562− <> case using of
563− NoUsing -> ""
564− Using tables -> " USING" <+> renderSQL tables
565− <+> "WHERE" <+> renderSQL wh
566− <> renderSQL returning
567−
568−-- | Delete rows returning `Nil`.
569−deleteFrom_
570− :: ( Has sch schemas schema
571− , Has tab schema ('Table table)
572− , row ~ TableToRow table
573− , columns ~ TableToColumns table )
574− => QualifiedAlias sch tab -- ^ table to delete from
575− -> Condition '[] commons 'Ungrouped schemas params '[tab ::: row]
576 -- ^ condition under which to delete a row
362 -- ^ condition under which to delete a row
577− -> Manipulation commons schemas params '[]
363+ -> ReturningClause columns params results -- ^ results to return
578−deleteFrom_ tab wh = deleteFrom tab NoUsing wh (Returning_ Nil)
364+ -> Manipulation schema params results
365+deleteFrom table wh returning = UnsafeManipulation $
366+ "DELETE FROM" <+> renderAlias table
367+ <+> "WHERE" <+> renderExpression wh
368+ <> renderReturningClause returning
squeal-postgresql/src/Squeal/PostgreSQL/Migration.hsdeleted−448
@@ -1,448 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Migration
3−Description: Squeal migrations
4−Copyright: (c) Eitan Chatav, 2017
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−This module defines a `Migration` type to safely
9−change the schema of your database over time. Let's see an example!
10−
11−First turn on some extensions.
12−
13−>>> :set -XDataKinds -XOverloadedLabels
14−>>> :set -XOverloadedStrings -XFlexibleContexts -XTypeOperators
15−
16−Next, let's define our `TableType`s.
17−
18−>>> :{
19−type UsersTable =
20− '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
21− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
22− , "name" ::: 'NoDef :=> 'NotNull 'PGtext
23− ]
24−:}
25−
26−>>> :{
27−type EmailsTable =
28− '[ "pk_emails" ::: 'PrimaryKey '["id"]
29− , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
30− ] :=>
31− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
32− , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
33− , "email" ::: 'NoDef :=> 'Null 'PGtext
34− ]
35−:}
36−
37−Now we can define some `Migration`s to make our tables.
38−
39−>>> :{
40−let
41− makeUsers :: Migration Definition (Public '[]) '["public" ::: '["users" ::: 'Table UsersTable]]
42− makeUsers = Migration
43− { name = "make users table"
44− , up = createTable #users
45− ( serial `as` #id :*
46− notNullable text `as` #name )
47− ( primaryKey #id `as` #pk_users )
48− , down = dropTable #users
49− }
50−:}
51−
52−>>> :{
53−let
54− makeEmails :: Migration Definition '["public" ::: '["users" ::: 'Table UsersTable]]
55− '["public" ::: '["users" ::: 'Table UsersTable, "emails" ::: 'Table EmailsTable]]
56− makeEmails = Migration
57− { name = "make emails table"
58− , up = createTable #emails
59− ( serial `as` #id :*
60− notNullable int `as` #user_id :*
61− nullable text `as` #email )
62− ( primaryKey #id `as` #pk_emails :*
63− foreignKey #user_id #users #id
64− OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
65− , down = dropTable #emails
66− }
67−:}
68−
69−Now that we have a couple migrations we can chain them together into a `Path`.
70−
71−>>> let migrations = makeUsers :>> makeEmails :>> Done
72−
73−Now run the migrations.
74−
75−>>> import Control.Monad.IO.Class
76−>>> :{
77−withConnection "host=localhost port=5432 dbname=exampledb" $
78− manipulate (UnsafeManipulation "SET client_min_messages TO WARNING;")
79− -- suppress notices
80− & pqThen (liftIO (putStrLn "Migrate"))
81− & pqThen (migrateUp migrations)
82− & pqThen (liftIO (putStrLn "Rollback"))
83− & pqThen (migrateDown migrations)
84−:}
85−Migrate
86−Rollback
87−
88−We can also create a simple executable using `defaultMain`.
89−
90−>>> let main = defaultMain "host=localhost port=5432 dbname=exampledb" migrations
91−
92−>>> withArgs [] main
93−Invalid command: "". Use:
94−migrate to run all available migrations
95−rollback to rollback all available migrations
96−status to display migrations run and migrations left to run
97−
98−>>> withArgs ["status"] main
99−Migrations already run:
100− None
101−Migrations left to run:
102− - make users table
103− - make emails table
104−
105−>>> withArgs ["migrate"] main
106−Migrations already run:
107− - make users table
108− - make emails table
109−Migrations left to run:
110− None
111−
112−>>> withArgs ["rollback"] main
113−Migrations already run:
114− None
115−Migrations left to run:
116− - make users table
117− - make emails table
118−
119−In addition to enabling `Migration`s using pure SQL `Definition`s for
120−the `up` and `down` instructions, you can also perform impure `IO` actions
121−by using a `Migration`s over the `Terminally` `PQ` `IO` category.
122−-}
123−
124−{-# LANGUAGE
125− DataKinds
126− , DeriveGeneric
127− , FlexibleContexts
128− , FlexibleInstances
129− , GADTs
130− , LambdaCase
131− , OverloadedLabels
132− , OverloadedStrings
133− , PolyKinds
134− , QuantifiedConstraints
135− , RankNTypes
136− , TypeApplications
137− , TypeOperators
138−#-}
139−
140−module Squeal.PostgreSQL.Migration
141− ( -- * Migration
142− Migration (..)
143− , Migratory (..)
144− , Terminally (..)
145− , terminally
146− , pureMigration
147− , MigrationsTable
148− , defaultMain
149− ) where
150−
151−import Control.Category
152−import Control.Monad
153−import Data.ByteString (ByteString)
154−import Data.Foldable (traverse_)
155−import Data.Function ((&))
156−import Data.List ((\\))
157−import Data.Text (Text)
158−import Data.Time (UTCTime)
159−import Prelude hiding ((.), id)
160−import System.Environment
161−import UnliftIO (MonadIO (..))
162−
163−import qualified Data.Text.IO as Text (putStrLn)
164−import qualified Generics.SOP as SOP
165−import qualified GHC.Generics as GHC
166−
167−import Squeal.PostgreSQL.Alias
168−import Squeal.PostgreSQL.Binary
169−import Squeal.PostgreSQL.Definition
170−import Squeal.PostgreSQL.Definition.Table
171−import Squeal.PostgreSQL.Definition.Table.Constraint
172−import Squeal.PostgreSQL.Expression.Comparison
173−import Squeal.PostgreSQL.Expression.Parameter
174−import Squeal.PostgreSQL.Expression.Time
175−import Squeal.PostgreSQL.Expression.Type
176−import Squeal.PostgreSQL.List
177−import Squeal.PostgreSQL.Manipulation
178−import Squeal.PostgreSQL.PQ
179−import Squeal.PostgreSQL.Query
180−import Squeal.PostgreSQL.Schema
181−import Squeal.PostgreSQL.Transaction
182−
183−-- | A `Migration` is a named "isomorphism" over a given category.
184−-- It should contain an inverse pair of `up` and `down`
185−-- instructions and a unique `name`.
186−data Migration p schemas0 schemas1 = Migration
187− { name :: Text -- ^ The `name` of a `Migration`.
188− -- Each `name` in a `Migration` should be unique.
189− , up :: p schemas0 schemas1 -- ^ The `up` instruction of a `Migration`.
190− , down :: p schemas1 schemas0 -- ^ The `down` instruction of a `Migration`.
191− } deriving (GHC.Generic)
192−
193−{- |
194−A `Migratory` @p@ is a `Category` for which one can execute or rewind
195−a `Path` of `Migration`s over @p@. This includes the category of pure
196−SQL `Definition`s and the category of impure `Terminally` `PQ` `IO` actions.
197−-}
198−class Category p => Migratory p where
199−
200− {- |
201− Run a `Path` of `Migration`s.
202− Create the `MigrationsTable` as @public.schema_migrations@ if it does not already exist.
203− In one transaction, for each each `Migration` query to see if the `Migration` has been executed;
204− if not, `up` the `Migration` and insert its `name` in the `MigrationsTable`.
205− -}
206− migrateUp
207− :: Path (Migration p) schemas0 schemas1
208− -> PQ schemas0 schemas1 IO ()
209−
210− {- |
211− Rewind a `Path` of `Migration`s.
212− Create the `MigrationsTable` as @public.schema_migrations@ if it does not already exist.
213− In one transaction, for each each `Migration` query to see if the `Migration` has been executed;
214− if so, `down` the `Migration` and delete its `name` in the `MigrationsTable`.
215− -}
216− migrateDown
217− :: Path (Migration p) schemas0 schemas1
218− -> PQ schemas1 schemas0 IO ()
219−
220−instance Migratory Definition where
221− migrateUp = migrateUp . cmap pureMigration
222− migrateDown = migrateDown . cmap pureMigration
223−
224−{- | `Terminally` turns an indexed monad transformer and the monad it transforms
225−into a category by restricting the return type to @()@ and permuting the type variables.
226−This is similar to how applying a monad to @()@ yields a monoid.
227−Since a `Terminally` action has a trivial return value, the only reason
228−to run one is for the side effects, in particular database and other IO effects.
229−-}
230−newtype Terminally trans monad x0 x1 = Terminally
231− { runTerminally :: trans x0 x1 monad () }
232− deriving GHC.Generic
233−
234−instance
235− ( IndexedMonadTransPQ trans
236− , Monad monad
237− , forall x0 x1. x0 ~ x1 => Monad (trans x0 x1 monad) )
238− => Category (Terminally trans monad) where
239− id = Terminally (return ())
240− Terminally g . Terminally f = Terminally $ pqThen g f
241−
242−-- | `terminally` ignores the output of a computation, returning @()@ and
243−-- wrapping it up into a `Terminally`. You can lift an action in the base monad
244−-- by using @terminally . lift@.
245−terminally
246− :: Functor (trans x0 x1 monad)
247− => trans x0 x1 monad ignore
248− -> Terminally trans monad x0 x1
249−terminally = Terminally . void
250−
251−-- | A `pureMigration` turns a `Migration` involving only pure SQL
252−-- `Definition`s into a `Migration` that may be combined with arbitrary `IO`.
253−pureMigration
254− :: Migration Definition schemas0 schemas1
255− -> Migration (Terminally PQ IO) schemas0 schemas1
256−pureMigration migration = Migration
257− { name = name migration
258− , up = terminally . define $ up migration
259− , down = terminally . define $ down migration
260− }
261−
262−instance Migratory (Terminally PQ IO) where
263−
264− migrateUp migration = unsafePQ . transactionally_ $ do
265− define createMigrations
266− upMigrations migration
267−
268− where
269−
270− upMigrations
271− :: Path (Migration (Terminally PQ IO)) schemas0 schemas1
272− -> PQ MigrationsSchemas MigrationsSchemas IO ()
273− upMigrations = \case
274− Done -> return ()
275− step :>> steps -> upMigration step >> upMigrations steps
276−
277− upMigration
278− :: Migration (Terminally PQ IO) schemas0 schemas1
279− -> PQ MigrationsSchemas MigrationsSchemas IO ()
280− upMigration step = do
281− executed <- queryExecuted step
282− unless (executed == 1) $ do
283− unsafePQ . runTerminally $ up step
284− manipulateParams_ insertMigration (Only (name step))
285−
286− queryExecuted
287− :: Migration (Terminally PQ IO) schemas0 schemas1
288− -> PQ MigrationsSchemas MigrationsSchemas IO Row
289− queryExecuted step = do
290− result <- runQueryParams selectMigration (Only (name step))
291− ntuples result
292−
293− migrateDown migrations = unsafePQ . transactionally_ $ do
294− define createMigrations
295− downMigrations migrations
296−
297− where
298−
299− downMigrations
300− :: Path (Migration (Terminally PQ IO)) schemas0 schemas1
301− -> PQ MigrationsSchemas MigrationsSchemas IO ()
302− downMigrations = \case
303− Done -> return ()
304− step :>> steps -> downMigrations steps >> downMigration step
305−
306− downMigration
307− :: Migration (Terminally PQ IO) schemas0 schemas1
308− -> PQ MigrationsSchemas MigrationsSchemas IO ()
309− downMigration step = do
310− executed <- queryExecuted step
311− unless (executed == 0) $ do
312− unsafePQ . runTerminally $ down step
313− manipulateParams_ deleteMigration (Only (name step))
314−
315− queryExecuted
316− :: Migration (Terminally PQ IO) schemas0 schemas1
317− -> PQ MigrationsSchemas MigrationsSchemas IO Row
318− queryExecuted step = do
319− result <- runQueryParams selectMigration (Only (name step))
320− ntuples result
321−
322−unsafePQ :: (Functor m) => PQ db0 db1 m x -> PQ db0' db1' m x
323−unsafePQ (PQ pq) = PQ $ fmap (SOP.K . SOP.unK) . pq . SOP.K . SOP.unK
324−
325−-- | The `TableType` for a Squeal migration.
326−type MigrationsTable =
327− '[ "migrations_unique_name" ::: 'Unique '["name"]] :=>
328− '[ "name" ::: 'NoDef :=> 'NotNull 'PGtext
329− , "executed_at" ::: 'Def :=> 'NotNull 'PGtimestamptz
330− ]
331−
332−data MigrationRow =
333− MigrationRow { migrationName :: Text
334− , migrationTime :: UTCTime }
335− deriving (GHC.Generic, Show)
336−
337−instance SOP.Generic MigrationRow
338−instance SOP.HasDatatypeInfo MigrationRow
339−
340−type MigrationsSchema = '["schema_migrations" ::: 'Table MigrationsTable]
341−type MigrationsSchemas = Public MigrationsSchema
342−
343−-- | Creates a `MigrationsTable` if it does not already exist.
344−createMigrations :: Definition MigrationsSchemas MigrationsSchemas
345−createMigrations =
346− createTableIfNotExists #schema_migrations
347− ( (text & notNullable) `as` #name :*
348− (timestampWithTimeZone & notNullable & default_ currentTimestamp)
349− `as` #executed_at )
350− ( unique #name `as` #migrations_unique_name )
351−
352−-- | Inserts a `Migration` into the `MigrationsTable`, returning
353−-- the time at which it was inserted.
354−insertMigration :: Manipulation_ MigrationsSchemas (Only Text) ()
355−insertMigration = insertInto_ #schema_migrations
356− (Values_ (Set (param @1) `as` #name :* Default `as` #executed_at))
357−
358−-- | Deletes a `Migration` from the `MigrationsTable`, returning
359−-- the time at which it was inserted.
360−deleteMigration :: Manipulation_ MigrationsSchemas (Only Text) ()
361−deleteMigration = deleteFrom_ #schema_migrations (#name .== param @1)
362−
363−-- | Selects a `Migration` from the `MigrationsTable`, returning
364−-- the time at which it was inserted.
365−selectMigration
366− :: Query_ MigrationsSchemas (Only Text) (Only UTCTime)
367−selectMigration = select_ (#executed_at `as` #fromOnly)
368− $ from (table (#schema_migrations))
369− & where_ (#name .== param @1)
370−
371−selectMigrations :: Query_ MigrationsSchemas () MigrationRow
372−selectMigrations = select_
373− (#name `as` #migrationName :* #executed_at `as` #migrationTime)
374− (from (table #schema_migrations))
375−
376−data MigrateCommand
377− = MigrateStatus
378− | MigrateUp
379− | MigrateDown deriving (GHC.Generic, Show)
380−
381−{- | `defaultMain` creates a simple executable
382−from a connection string and a list of `Migration`s. -}
383−defaultMain
384− :: Migratory p
385− => ByteString
386− -- ^ connection string
387− -> Path (Migration p) db0 db1
388− -- ^ migrations
389− -> IO ()
390−defaultMain connectTo migrations = do
391− command <- readCommandFromArgs
392− maybe (pure ()) performCommand command
393−
394− where
395−
396− performCommand :: MigrateCommand -> IO ()
397− performCommand = \case
398− MigrateStatus -> withConnection connectTo $
399− suppressNotices >> migrateStatus
400− MigrateUp -> withConnection connectTo $
401− suppressNotices & pqThen (migrateUp migrations) & pqThen migrateStatus
402− MigrateDown -> withConnection connectTo $
403− suppressNotices & pqThen (migrateDown migrations) & pqThen migrateStatus
404−
405− migrateStatus :: PQ schema schema IO ()
406− migrateStatus = unsafePQ $ do
407− runNames <- getRunMigrationNames
408− let names = ctoList name migrations
409− unrunNames = names \\ runNames
410− liftIO $ displayRunned runNames >> displayUnrunned unrunNames
411−
412− suppressNotices :: PQ schema schema IO ()
413− suppressNotices = manipulate_ $
414− UnsafeManipulation "SET client_min_messages TO WARNING;"
415−
416− readCommandFromArgs :: IO (Maybe MigrateCommand)
417− readCommandFromArgs = getArgs >>= \case
418− ["migrate"] -> pure . Just $ MigrateUp
419− ["rollback"] -> pure . Just $ MigrateDown
420− ["status"] -> pure . Just $ MigrateStatus
421− args -> displayUsage args >> pure Nothing
422−
423− displayUsage :: [String] -> IO ()
424− displayUsage args = do
425− putStrLn $ "Invalid command: \"" <> unwords args <> "\". Use:"
426− putStrLn "migrate to run all available migrations"
427− putStrLn "rollback to rollback all available migrations"
428− putStrLn "status to display migrations run and migrations left to run"
429−
430− getRunMigrationNames :: (MonadIO m) => PQ db0 db0 m [Text]
431− getRunMigrationNames =
432− fmap migrationName <$> (unsafePQ (define createMigrations & pqThen (runQuery selectMigrations)) >>= getRows)
433−
434− displayListOfNames :: [Text] -> IO ()
435− displayListOfNames [] = Text.putStrLn " None"
436− displayListOfNames xs =
437− let singleName n = Text.putStrLn $ " - " <> n
438− in traverse_ singleName xs
439−
440− displayUnrunned :: [Text] -> IO ()
441− displayUnrunned unrunned =
442− Text.putStrLn "Migrations left to run:"
443− >> displayListOfNames unrunned
444−
445− displayRunned :: [Text] -> IO ()
446− displayRunned runned =
447− Text.putStrLn "Migrations already run:"
448− >> displayListOfNames runned
squeal-postgresql/src/Squeal/PostgreSQL/PG.hsdeleted−388
@@ -1,388 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.PG
3−Description: Embedding of Haskell types into Postgres's type system
4−Copyright: (c) Eitan Chatav, 2010
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−`Squeal.PostgreSQL.PG` provides type families for turning Haskell
9−`Type`s into corresponding Postgres types.
10−-}
11−{-# LANGUAGE
12− AllowAmbiguousTypes
13− , DeriveAnyClass
14− , DeriveFoldable
15− , DeriveFunctor
16− , DeriveGeneric
17− , DeriveTraversable
18− , DerivingStrategies
19− , DefaultSignatures
20− , FlexibleContexts
21− , FlexibleInstances
22− , FunctionalDependencies
23− , GADTs
24− , LambdaCase
25− , MultiParamTypeClasses
26− , OverloadedStrings
27− , ScopedTypeVariables
28− , TypeApplications
29− , TypeFamilies
30− , TypeInType
31− , TypeOperators
32− , UndecidableInstances
33− , UndecidableSuperClasses
34−#-}
35−
36−module Squeal.PostgreSQL.PG
37− ( -- * PG embeddings
38− PG
39− , NullPG
40− , TuplePG
41− , RowPG
42− -- * Storage newtypes
43− , Money (..)
44− , Json (..)
45− , Jsonb (..)
46− , Composite (..)
47− , Enumerated (..)
48− , VarArray (..)
49− , FixArray (..)
50− , LibPQ.Oid (..)
51− -- * Type families
52− , LabelsPG
53− , DimPG
54− , FixPG
55− , TupleOf
56− , TupleCodeOf
57− , RowOf
58− , ConstructorsOf
59− , ConstructorNameOf
60− , ConstructorNamesOf
61− ) where
62−
63−import Data.Aeson (Value)
64−import Data.Kind (Type)
65−import Data.Int (Int16, Int32, Int64)
66−import Data.Scientific (Scientific)
67−import Data.Time (Day, DiffTime, LocalTime, TimeOfDay, TimeZone, UTCTime)
68−import Data.Vector (Vector)
69−import Data.UUID.Types (UUID)
70−import GHC.TypeLits
71−import Network.IP.Addr (NetAddr, IP)
72−
73−import qualified Data.ByteString.Lazy as Lazy (ByteString)
74−import qualified Data.ByteString as Strict (ByteString)
75−import qualified Data.Text.Lazy as Lazy (Text)
76−import qualified Data.Text as Strict (Text)
77−import qualified Database.PostgreSQL.LibPQ as LibPQ
78−import qualified GHC.Generics as GHC
79−import qualified Generics.SOP as SOP
80−import qualified Generics.SOP.Record as SOP
81−import qualified Generics.SOP.Type.Metadata as Type
82−
83−import Squeal.PostgreSQL.Alias
84−import Squeal.PostgreSQL.Schema
85−
86−-- $setup
87−-- >>> import Squeal.PostgreSQL
88−-- >>> import Data.Text (Text)
89−
90−{- | The `PG` type family embeds a subset of Haskell types
91−as Postgres types. As an open type family, `PG` is extensible.
92−
93−>>> :kind! PG LocalTime
94−PG LocalTime :: PGType
95−= 'PGtimestamp
96−
97−>>> newtype MyDouble = My Double
98−>>> :set -XTypeFamilies
99−>>> type instance PG MyDouble = 'PGfloat8
100−-}
101−type family PG (hask :: Type) :: PGType
102−-- | `PGbool`
103−type instance PG Bool = 'PGbool
104−-- | `PGint2`
105−type instance PG Int16 = 'PGint2
106−-- | `PGint4`
107−type instance PG Int32 = 'PGint4
108−-- | `PGint8`
109−type instance PG Int64 = 'PGint8
110−-- | `PGint2`
111−type instance PG LibPQ.Oid = 'PGoid
112−-- | `PGnumeric`
113−type instance PG Scientific = 'PGnumeric
114−-- | `PGfloat4`
115−type instance PG Float = 'PGfloat4
116−-- | `PGfloat8`
117−type instance PG Double = 'PGfloat8
118−-- | `PGchar` @1@
119−type instance PG Char = 'PGchar 1
120−-- | `PGtext`
121−type instance PG Strict.Text = 'PGtext
122−-- | `PGtext`
123−type instance PG Lazy.Text = 'PGtext
124−-- | `PGtext`
125−type instance PG String = 'PGtext
126−-- | `PGbytea`
127−type instance PG Strict.ByteString = 'PGbytea
128−-- | `PGbytea`
129−type instance PG Lazy.ByteString = 'PGbytea
130−-- | `PGtimestamp`
131−type instance PG LocalTime = 'PGtimestamp
132−-- | `PGtimestamptz`
133−type instance PG UTCTime = 'PGtimestamptz
134−-- | `PGdate`
135−type instance PG Day = 'PGdate
136−-- | `PGtime`
137−type instance PG TimeOfDay = 'PGtime
138−-- | `PGtimetz`
139−type instance PG (TimeOfDay, TimeZone) = 'PGtimetz
140−-- | `PGinterval`
141−type instance PG DiffTime = 'PGinterval
142−-- | `PGuuid`
143−type instance PG UUID = 'PGuuid
144−-- | `PGinet`
145−type instance PG (NetAddr IP) = 'PGinet
146−-- | `PGjson`
147−type instance PG Value = 'PGjson
148−
149−{-| The `LabelsPG` type family calculates the constructors of a
150−Haskell enum type.
151−
152−>>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic
153−>>> instance SOP.Generic Schwarma
154−>>> instance SOP.HasDatatypeInfo Schwarma
155−>>> :kind! LabelsPG Schwarma
156−LabelsPG Schwarma :: [Type.ConstructorName]
157−= '["Beef", "Lamb", "Chicken"]
158−-}
159−type family LabelsPG (hask :: Type) :: [Type.ConstructorName] where
160− LabelsPG hask =
161− ConstructorNamesOf (ConstructorsOf (SOP.DatatypeInfoOf hask))
162−
163−{- |
164−`RowPG` turns a Haskell `Type` into a `RowType`.
165−
166−`RowPG` may be applied to normal Haskell record types provided they
167−have `SOP.Generic` and `SOP.HasDatatypeInfo` instances;
168−
169−>>> data Person = Person { name :: Strict.Text, age :: Int32 } deriving GHC.Generic
170−>>> instance SOP.Generic Person
171−>>> instance SOP.HasDatatypeInfo Person
172−>>> :kind! RowPG Person
173−RowPG Person :: [(Symbol, NullityType)]
174−= '["name" ::: 'NotNull 'PGtext, "age" ::: 'NotNull 'PGint4]
175−-}
176−type family RowPG (hask :: Type) :: RowType where
177− RowPG hask = RowOf (SOP.RecordCodeOf hask)
178−
179−-- | `RowOf` applies `NullPG` to the fields of a list.
180−type family RowOf (record :: [(Symbol, Type)]) :: RowType where
181− RowOf (col ::: ty ': col1 ::: ty1 ': col2 ::: ty2 ': col3 ::: ty3 ': col4 ::: ty4 ': record) =
182− col ::: NullPG ty ': col1 ::: NullPG ty1 ': col2 ::: NullPG ty2 ': col3 ::: NullPG ty3 ': col4 ::: NullPG ty4 ': RowOf record
183− RowOf (col ::: ty ': col1 ::: ty1 ': col2 ::: ty2 ': col3 ::: ty3 ': record) =
184− col ::: NullPG ty ': col1 ::: NullPG ty1 ': col2 ::: NullPG ty2 ': col3 ::: NullPG ty3 ': RowOf record
185− RowOf (col ::: ty ': col1 ::: ty1 ': col2 ::: ty2 ': record) =
186− col ::: NullPG ty ': col1 ::: NullPG ty1 ': col2 ::: NullPG ty2 ': RowOf record
187− RowOf (col ::: ty ': col1 ::: ty1 ': record) =
188− col ::: NullPG ty ': col1::: NullPG ty1 ': RowOf record
189− RowOf (col ::: ty ': record) = col ::: NullPG ty ': RowOf record
190− RowOf '[] = '[]
191−
192−{- | `NullPG` turns a Haskell type into a `NullityType`.
193−
194−>>> :kind! NullPG Double
195−NullPG Double :: NullityType
196−= 'NotNull 'PGfloat8
197−>>> :kind! NullPG (Maybe Double)
198−NullPG (Maybe Double) :: NullityType
199−= 'Null 'PGfloat8
200−-}
201−type family NullPG (hask :: Type) :: NullityType where
202− NullPG (Maybe hask) = 'Null (PG hask)
203− NullPG hask = 'NotNull (PG hask)
204−
205−{- | `TuplePG` turns a Haskell tuple type (including record types) into
206−the corresponding list of `NullityType`s.
207−
208−>>> :kind! TuplePG (Double, Maybe Char)
209−TuplePG (Double, Maybe Char) :: [NullityType]
210−= '[ 'NotNull 'PGfloat8, 'Null ('PGchar 1)]
211−-}
212−type family TuplePG (hask :: Type) :: [NullityType] where
213− TuplePG hask = TupleOf (TupleCodeOf hask (SOP.Code hask))
214−
215−-- | `TupleOf` turns a list of Haskell `Type`s into a list of `NullityType`s.
216−type family TupleOf (tuple :: [Type]) :: [NullityType] where
217− TupleOf (hask ': hask1 ': hask2 ': hask3 ': hask4 ': hask5 ': tuple) =
218− NullPG hask ': NullPG hask1 ': NullPG hask2 ': NullPG hask3 ': NullPG hask4 ': NullPG hask5 ': TupleOf tuple
219− TupleOf (hask ': hask1 ': hask2 ': hask3 ': hask4 ': tuple) =
220− NullPG hask ': NullPG hask1 ': NullPG hask2 ': NullPG hask3 ': NullPG hask4 ': TupleOf tuple
221− TupleOf (hask ': hask1 ': hask2 ': hask3 ': tuple) =
222− NullPG hask ': NullPG hask1 ': NullPG hask2 ': NullPG hask3 ': TupleOf tuple
223− TupleOf (hask ': hask1 ': hask2 ': tuple) =
224− NullPG hask ': NullPG hask1 ': NullPG hask2 ': TupleOf tuple
225− TupleOf (hask ': hask1 ': tuple) = NullPG hask ': NullPG hask1 ': TupleOf tuple
226− TupleOf (hask ': tuple) = NullPG hask ': TupleOf tuple
227− TupleOf '[] = '[]
228−
229−-- | `TupleCodeOf` takes the `SOP.Code` of a haskell `Type`
230−-- and if it's a simple product returns it, otherwise giving a `TypeError`.
231−type family TupleCodeOf (hask :: Type) (code :: [[Type]]) :: [Type] where
232− TupleCodeOf hask '[tuple] = tuple
233− TupleCodeOf hask '[] =
234− TypeError
235− ( 'Text "The type `" ':<>: 'ShowType hask ':<>: 'Text "' is not a tuple type."
236− ':$$: 'Text "It is a void type with no constructors."
237− )
238− TupleCodeOf hask (_ ': _ ': _) =
239− TypeError
240− ( 'Text "The type `" ':<>: 'ShowType hask ':<>: 'Text "' is not a tuple type."
241− ':$$: 'Text "It is a sum type with more than one constructor."
242− )
243−
244−-- | Calculates constructors of a datatype.
245−type family ConstructorsOf (datatype :: Type.DatatypeInfo)
246− :: [Type.ConstructorInfo] where
247− ConstructorsOf ('Type.ADT _module _datatype constructors) =
248− constructors
249− ConstructorsOf ('Type.Newtype _module _datatype constructor) =
250− '[constructor]
251−
252−-- | Calculates the name of a nullary constructor, otherwise
253−-- generates a type error.
254−type family ConstructorNameOf (constructor :: Type.ConstructorInfo)
255− :: Type.ConstructorName where
256− ConstructorNameOf ('Type.Constructor name) = name
257− ConstructorNameOf ('Type.Infix name _assoc _fix) = TypeError
258− ('Text "ConstructorNameOf error: non-nullary constructor "
259− ':<>: 'Text name)
260− ConstructorNameOf ('Type.Record name _fields) = TypeError
261− ('Text "ConstructorNameOf error: non-nullary constructor "
262− ':<>: 'Text name)
263−
264−-- | Calculate the names of nullary constructors.
265−type family ConstructorNamesOf (constructors :: [Type.ConstructorInfo])
266− :: [Type.ConstructorName] where
267− ConstructorNamesOf '[] = '[]
268− ConstructorNamesOf (constructor ': constructors) =
269− ConstructorNameOf constructor ': ConstructorNamesOf constructors
270−
271−-- | `DimPG` turns Haskell nested homogeneous tuples into a list of lengths.
272−type family DimPG (hask :: Type) :: [Nat] where
273− DimPG (x,x) = 2 ': DimPG x
274− DimPG (x,x,x) = 3 ': DimPG x
275− DimPG (x,x,x,x) = 4 ': DimPG x
276− DimPG (x,x,x,x,x) = 5 ': DimPG x
277− DimPG (x,x,x,x,x,x) = 6 ': DimPG x
278− DimPG (x,x,x,x,x,x,x) = 7 ': DimPG x
279− DimPG (x,x,x,x,x,x,x,x) = 8 ': DimPG x
280− DimPG (x,x,x,x,x,x,x,x,x) = 9 ': DimPG x
281− DimPG (x,x,x,x,x,x,x,x,x,x) = 10 ': DimPG x
282− DimPG x = '[]
283−
284−-- | `FixPG` extracts `NullPG` of the base type of nested homogeneous tuples.
285−type family FixPG (hask :: Type) :: NullityType where
286− FixPG (x,x) = FixPG x
287− FixPG (x,x,x) = FixPG x
288− FixPG (x,x,x,x) = FixPG x
289− FixPG (x,x,x,x,x) = FixPG x
290− FixPG (x,x,x,x,x,x) = FixPG x
291− FixPG (x,x,x,x,x,x,x) = FixPG x
292− FixPG (x,x,x,x,x,x,x,x) = FixPG x
293− FixPG (x,x,x,x,x,x,x,x,x) = FixPG x
294− FixPG (x,x,x,x,x,x,x,x,x,x) = FixPG x
295− FixPG (x,x,x,x,x,x,x,x,x,x,x) = FixPG x
296− FixPG x = NullPG x
297−
298−{- | The `Money` newtype stores a monetary value in terms
299−of the number of cents, i.e. @$2,000.20@ would be expressed as
300−@Money { cents = 200020 }@.
301−
302−>>> import Control.Monad (void)
303−>>> import Control.Monad.IO.Class (liftIO)
304−>>> import Squeal.PostgreSQL
305−>>> :{
306−let
307− roundTrip :: Query_ (Public '[]) (Only Money) (Only Money)
308− roundTrip = values_ $ parameter @1 money `as` #fromOnly
309−:}
310−
311−>>> let input = Only (Money 20020)
312−
313−>>> :{
314−withConnection "host=localhost port=5432 dbname=exampledb" $ do
315− result <- runQueryParams roundTrip input
316− Just output <- firstRow result
317− liftIO . print $ input == output
318−:}
319−True
320−-}
321−newtype Money = Money { cents :: Int64 }
322− deriving stock (Eq, Ord, Show, Read, GHC.Generic)
323− deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
324−-- | `PGmoney`
325−type instance PG Money = 'PGmoney
326−
327−{- | The `Json` newtype is an indication that the Haskell
328−type it's applied to should be stored as a `PGjson`.
329−-}
330−newtype Json hask = Json {getJson :: hask}
331− deriving stock (Eq, Ord, Show, Read, GHC.Generic)
332− deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
333−-- | `PGjson`
334−type instance PG (Json hask) = 'PGjson
335−
336−{- | The `Jsonb` newtype is an indication that the Haskell
337−type it's applied to should be stored as a `PGjsonb`.
338−-}
339−newtype Jsonb hask = Jsonb {getJsonb :: hask}
340− deriving stock (Eq, Ord, Show, Read, GHC.Generic)
341− deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
342−-- | `PGjsonb`
343−type instance PG (Jsonb hask) = 'PGjsonb
344−
345−{- | The `Composite` newtype is an indication that the Haskell
346−type it's applied to should be stored as a `PGcomposite`.
347−-}
348−newtype Composite record = Composite {getComposite :: record}
349− deriving stock (Eq, Ord, Show, Read, GHC.Generic)
350− deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
351−-- | `PGcomposite` @(@`RowPG` @hask)@
352−type instance PG (Composite hask) = 'PGcomposite (RowPG hask)
353−
354−{- | The `Enumerated` newtype is an indication that the Haskell
355−type it's applied to should be stored as a `PGenum`.
356−-}
357−newtype Enumerated enum = Enumerated {getEnumerated :: enum}
358− deriving stock (Eq, Ord, Show, Read, GHC.Generic)
359− deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
360−-- | `PGenum` @(@`LabelsPG` @hask)@
361−type instance PG (Enumerated hask) = 'PGenum (LabelsPG hask)
362−
363−{- | The `VarArray` newtype is an indication that the Haskell
364−type it's applied to should be stored as a `PGvararray`.
365−
366−>>> :kind! PG (VarArray (Vector Double))
367−PG (VarArray (Vector Double)) :: PGType
368−= 'PGvararray ('NotNull 'PGfloat8)
369−-}
370−newtype VarArray arr = VarArray {getVarArray :: arr}
371− deriving stock (Eq, Ord, Show, Read, GHC.Generic)
372− deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
373−-- | `PGvararray` @(@`NullPG` @hask)@
374−type instance PG (VarArray (Vector hask)) = 'PGvararray (NullPG hask)
375−type instance PG (VarArray [hask]) = 'PGvararray (NullPG hask)
376−
377−{- | The `FixArray` newtype is an indication that the Haskell
378−type it's applied to should be stored as a `PGfixarray`.
379−
380−>>> :kind! PG (FixArray ((Double, Double), (Double, Double)))
381−PG (FixArray ((Double, Double), (Double, Double))) :: PGType
382−= 'PGfixarray '[2, 2] ('NotNull 'PGfloat8)
383−-}
384−newtype FixArray arr = FixArray {getFixArray :: arr}
385− deriving stock (Eq, Ord, Show, Read, GHC.Generic)
386− deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
387−-- | `PGfixarray` @(@`DimPG` @hask) (@`FixPG` @hask)@
388−type instance PG (FixArray hask) = 'PGfixarray (DimPG hask) (FixPG hask)
squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs+301−474
@@ -5,26 +5,22 @@ Copyright: (c) Eitan Chatav, 2017
5Maintainer: eitan@morphism.tech
5Maintainer: eitan@morphism.tech
6Stability: experimental
6Stability: experimental
7
7
8−This module is where Squeal commands actually get executed by
8+`Squeal.PostgreSQL.PQ` is where Squeal statements come to actually get run by
9−`Database.PostgreSQL.LibPQ`. It containts two typeclasses, `IndexedMonadTransPQ` for executing
9+`LibPQ`. It contains a `PQ` indexed monad transformer to run `Definition`s and
10−a `Definition` and `MonadPQ` for executing a `Manipulation` or `Query`,
10+a `MonadPQ` constraint for running a `Manipulation` or `Query`.
11−and a `PQ` type with instances for them.
12−
13−Using Squeal in your application will come down to defining
14−the @schemas@ of your database and including @PQ schemas schemas@ in your
15−application's monad transformer stack, giving it an instance of `MonadPQ`.
16−
17−This module also provides functions for retrieving rows from the `LibPQ.Result`
18−of executing Squeal commands.
19-}
11-}
20
12
21{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
13{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
22{-# LANGUAGE
14{-# LANGUAGE
23− DefaultSignatures
15+ DataKinds
16+ , DefaultSignatures
24 , FunctionalDependencies
17 , FunctionalDependencies
18+ , PolyKinds
19+ , DeriveFunctor
25 , FlexibleContexts
20 , FlexibleContexts
26 , FlexibleInstances
21 , FlexibleInstances
27− , InstanceSigs
22+ , MagicHash
23+ , MultiParamTypeClasses
28 , OverloadedStrings
24 , OverloadedStrings
29 , RankNTypes
25 , RankNTypes
30 , ScopedTypeVariables
26 , ScopedTypeVariables
@@ -37,57 +33,50 @@ of executing Squeal commands.
37
33
38module Squeal.PostgreSQL.PQ
34module Squeal.PostgreSQL.PQ
39 ( -- * Connection
35 ( -- * Connection
40− LibPQ.Connection
36+ Connection (unConnection)
41 , connectdb
37 , connectdb
42 , finish
38 , finish
43 , withConnection
39 , withConnection
44− , lowerConnection
45 -- * PQ
40 -- * PQ
46− , PQ (PQ, unPQ)
41+ , PQ (runPQ)
47− , runPQ
48 , execPQ
42 , execPQ
49− , evalPQ
43+ , pqAp
50− , IndexedMonadTransPQ (..)
44+ , pqBind
45+ , pqThen
46+ , define
47+ , thenDefine
48+ -- * MonadPQ
51 , MonadPQ (..)
49 , MonadPQ (..)
52− -- * Results
50+ , PQRun
53− , LibPQ.Result
51+ , pqliftWith
54− , LibPQ.Row
52+ -- * Result
55− , ntuples
53+ , Result (Result, unResult)
54+ , RowNumber (RowNumber, unRowNumber)
55+ , ColumnNumber (UnsafeColumnNumber, getColumnNumber)
56+ , HasColumnNumber (columnNumber)
57+ , getValue
56 , getRow
58 , getRow
57 , getRows
59 , getRows
58 , nextRow
60 , nextRow
59 , firstRow
61 , firstRow
60 , liftResult
62 , liftResult
61− , LibPQ.ExecStatus (..)
62− , resultStatus
63− , resultErrorMessage
64− , resultErrorCode
65− -- * Exceptions
66− , SquealException (..)
67− , PQState (..)
68− , okResult
69− , catchSqueal
70− , handleSqueal
71− , trySqueal
72 ) where
63 ) where
73
64
74−import Control.Exception (Exception, throw)
65+import Control.Exception.Lifted
66+import Control.Monad.Base
75import Control.Monad.Except
67import Control.Monad.Except
76−import Control.Monad.Morph
68+import Control.Monad.Trans.Control
77−import UnliftIO (MonadUnliftIO (..), bracket, catch, handle, try)
78import Data.ByteString (ByteString)
69import Data.ByteString (ByteString)
79import Data.Foldable
70import Data.Foldable
80import Data.Function ((&))
71import Data.Function ((&))
81−import Data.Functor ((<&>))
82import Data.Kind
72import Data.Kind
83−import Data.Text (pack, Text)
73+import Data.Monoid
84import Data.Traversable
74import Data.Traversable
85import Generics.SOP
75import Generics.SOP
86−import PostgreSQL.Binary.Encoding (encodingBytes)
76+import GHC.Exts hiding (fromList)
77+import GHC.TypeLits
87
78
88−import qualified Control.Monad.Fail as Fail
89import qualified Database.PostgreSQL.LibPQ as LibPQ
79import qualified Database.PostgreSQL.LibPQ as LibPQ
90−import qualified PostgreSQL.Binary.Encoding as Encoding
91
80
92import Squeal.PostgreSQL.Binary
81import Squeal.PostgreSQL.Binary
93import Squeal.PostgreSQL.Definition
82import Squeal.PostgreSQL.Definition
@@ -95,21 +84,10 @@ import Squeal.PostgreSQL.Manipulation
95import Squeal.PostgreSQL.Query
84import Squeal.PostgreSQL.Query
96import Squeal.PostgreSQL.Schema
85import Squeal.PostgreSQL.Schema
97
86
98−-- For `MonadPQ` transformer instances
87+-- | A `Connection` consists of a `Database.PostgreSQL.LibPQ`
99−import Control.Monad.Trans.Identity
88+-- `Database.PastgreSQL.LibPQ.Connection` and a phantom `TablesType`
100−import Control.Monad.Trans.Reader
89+newtype Connection (schema :: TablesType) =
101−import Control.Monad.Trans.Maybe
90+ Connection { unConnection :: LibPQ.Connection }
102−import Control.Monad.Trans.Cont
103−
104−import qualified Control.Monad.Trans.State.Lazy as Lazy
105−import qualified Control.Monad.Trans.State.Strict as Strict
106−import qualified Control.Monad.Trans.Writer.Lazy as Lazy
107−import qualified Control.Monad.Trans.Writer.Strict as Strict
108−import qualified Control.Monad.Trans.RWS.Lazy as Lazy
109−import qualified Control.Monad.Trans.RWS.Strict as Strict
110−
111−-- $setup
112−-- >>> import Squeal.PostgreSQL
113
91
114{- | Makes a new connection to the database server.
92{- | Makes a new connection to the database server.
115
93
@@ -125,175 +103,113 @@ backslashes within the value must be escaped with a backslash, i.e., ' and \.
125
103
126To specify the schema you wish to connect with, use type application.
104To specify the schema you wish to connect with, use type application.
127
105
128−>>> :set -XDataKinds
106+>>> :set -XTypeApplication
129−>>> :set -XPolyKinds
107+>>> conn <- connectdb @MySchema "host=localhost port=5432 dbname=exampledb"
130−>>> :set -XTypeOperators
131−>>> type Schema = '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint2]]
132−>>> :set -XTypeApplications
133−>>> :set -XOverloadedStrings
134−>>> conn <- connectdb @Schema "host=localhost port=5432 dbname=exampledb"
135
108
136Note that, for now, squeal doesn't offer any protection from connecting
109Note that, for now, squeal doesn't offer any protection from connecting
137with the wrong schema!
110with the wrong schema!
138-}
111-}
139connectdb
112connectdb
140− :: forall schemas io
113+ :: forall schema io
141− . MonadIO io
114+ . MonadBase IO io
142 => ByteString -- ^ conninfo
115 => ByteString -- ^ conninfo
143− -> io (K LibPQ.Connection schemas)
116+ -> io (Connection schema)
144−connectdb = fmap K . liftIO . LibPQ.connectdb
117+connectdb = fmap Connection . liftBase . LibPQ.connectdb
145
118
146-- | Closes the connection to the server.
119-- | Closes the connection to the server.
147−finish :: MonadIO io => K LibPQ.Connection schemas -> io ()
120+finish :: MonadBase IO io => Connection schema -> io ()
148−finish = liftIO . LibPQ.finish . unK
121+finish = liftBase . LibPQ.finish . unConnection
149
122
150-- | Do `connectdb` and `finish` before and after a computation.
123-- | Do `connectdb` and `finish` before and after a computation.
151withConnection
124withConnection
152− :: forall schemas0 schemas1 io x
125+ :: forall schema io x
153− . MonadUnliftIO io
126+ . MonadBaseControl IO io
154 => ByteString
127 => ByteString
155− -> PQ schemas0 schemas1 io x
128+ -> (Connection schema -> io x)
156 -> io x
129 -> io x
157−withConnection connString action = do
130+withConnection connString = bracket (connectdb connString) finish
158− K x <- bracket (connectdb connString) finish (unPQ action)
159− return x
160
131
161−-- | Safely `lowerConnection` to a smaller schema.
162−lowerConnection
163− :: K LibPQ.Connection (schema ': schemas)
164− -> K LibPQ.Connection schemas
165−lowerConnection (K conn) = K conn
166
132
167-- | We keep track of the schema via an Atkey indexed state monad transformer,
133-- | We keep track of the schema via an Atkey indexed state monad transformer,
168-- `PQ`.
134-- `PQ`.
169newtype PQ
135newtype PQ
170− (schemas0 :: SchemasType)
136+ (schema0 :: TablesType)
171− (schemas1 :: SchemasType)
137+ (schema1 :: TablesType)
172 (m :: Type -> Type)
138 (m :: Type -> Type)
173 (x :: Type) =
139 (x :: Type) =
174− PQ { unPQ :: K LibPQ.Connection schemas0 -> m (K x schemas1) }
140+ PQ { runPQ :: Connection schema0 -> m (x, Connection schema1) }
141+ deriving Functor
175
142
176−instance Monad m => Functor (PQ schemas0 schemas1 m) where
143+-- | Run a `PQ` and discard the result but keep the `Connection`.
177− fmap f (PQ pq) = PQ $ \ conn -> do
178− K x <- pq conn
179− return $ K (f x)
180−
181−-- | Run a `PQ` and keep the result and the `LibPQ.Connection`.
182−runPQ
183− :: Functor m
184− => PQ schemas0 schemas1 m x
185− -> K LibPQ.Connection schemas0
186− -> m (x, K LibPQ.Connection schemas1)
187−runPQ (PQ pq) conn = (\ x -> (unK x, K (unK conn))) <$> pq conn
188− -- K x <- pq conn
189− -- return (x, K (unK conn))
190−
191−-- | Execute a `PQ` and discard the result but keep the `LibPQ.Connection`.
192execPQ
144execPQ
193 :: Functor m
145 :: Functor m
194− => PQ schemas0 schemas1 m x
146+ => PQ schema0 schema1 m x
195− -> K LibPQ.Connection schemas0
147+ -> Connection schema0
196− -> m (K LibPQ.Connection schemas1)
148+ -> m (Connection schema1)
197−execPQ (PQ pq) conn = mapKK (\ _ -> unK conn) <$> pq conn
149+execPQ (PQ pq) = fmap snd . pq
198−
150+
199−-- | Evaluate a `PQ` and discard the `LibPQ.Connection` but keep the result.
151+-- | indexed analog of `<*>`
200−evalPQ
152+pqAp
201− :: Functor m
153+ :: Monad m
202− => PQ schemas0 schemas1 m x
154+ => PQ schema0 schema1 m (x -> y)
203− -> K LibPQ.Connection schemas0
155+ -> PQ schema1 schema2 m x
204− -> m x
156+ -> PQ schema0 schema2 m y
205−evalPQ (PQ pq) conn = unK <$> pq conn
157+pqAp (PQ f) (PQ x) = PQ $ \ conn -> do
206−
158+ (f', conn') <- f conn
207−-- | An [Atkey indexed monad](https://bentnib.org/paramnotions-jfp.pdf) is a `Functor`
159+ (x', conn'') <- x conn'
208−-- [enriched category](https://ncatlab.org/nlab/show/enriched+category).
160+ return (f' x', conn'')
209−-- An indexed monad transformer transforms a `Monad` into an indexed monad.
161+
210−-- And, `IndexedMonadTransPQ` is a class for indexed monad transformers that
162+-- | indexed analog of `=<<`
211−-- support running `Definition`s using `define`.
163+pqBind
212−class IndexedMonadTransPQ pq where
164+ :: Monad m
213−
165+ => (x -> PQ schema1 schema2 m y)
214− -- | indexed analog of `<*>`
166+ -> PQ schema0 schema1 m x
215− pqAp
167+ -> PQ schema0 schema2 m y
216− :: Monad m
168+pqBind f (PQ x) = PQ $ \ conn -> do
217− => pq schemas0 schemas1 m (x -> y)
169+ (x', conn') <- x conn
218− -> pq schemas1 schemas2 m x
170+ runPQ (f x') conn'
219− -> pq schemas0 schemas2 m y
171+
220−
172+-- | indexed analog of flipped `>>`
221− -- | indexed analog of `join`
173+pqThen
222− pqJoin
174+ :: Monad m
223− :: Monad m
175+ => PQ schema1 schema2 m y
224− => pq schemas0 schemas1 m (pq schemas1 schemas2 m y)
176+ -> PQ schema0 schema1 m x
225− -> pq schemas0 schemas2 m y
177+ -> PQ schema0 schema2 m y
226− pqJoin pq = pq & pqBind id
178+pqThen pq2 pq1 = pq1 & pqBind (\ _ -> pq2)
227−
179+
228− -- | indexed analog of `=<<`
180+-- | Run a `Definition` with `LibPQ.exec`, we expect that libpq obeys the law
229− pqBind
181+--
230− :: Monad m
182+-- prop> pqThen (define statement2) statement1 = define (statement2 . statement1)
231− => (x -> pq schemas1 schemas2 m y)
183+define
232− -> pq schemas0 schemas1 m x
184+ :: MonadBase IO io
233− -> pq schemas0 schemas2 m y
185+ => Definition schema0 schema1
234−
186+ -> PQ schema0 schema1 io (Result '[])
235− -- | indexed analog of flipped `>>`
187+define (UnsafeDefinition q) = PQ $ \ (Connection conn) -> do
236− pqThen
188+ resultMaybe <- liftBase $ LibPQ.exec conn q
237− :: Monad m
189+ case resultMaybe of
238− => pq schemas1 schemas2 m y
190+ Nothing -> error
239− -> pq schemas0 schemas1 m x
191+ "define: LibPQ.exec returned no results"
240− -> pq schemas0 schemas2 m y
192+ Just result -> return (Result result, Connection conn)
241− pqThen pq2 pq1 = pq1 & pqBind (\ _ -> pq2)
193+
242−
194+-- | Chain together `define` actions.
243− -- | indexed analog of `<=<`
195+thenDefine
244− pqAndThen
196+ :: MonadBase IO io
245− :: Monad m
197+ => Definition schema1 schema2
246− => (y -> pq schemas1 schemas2 m z)
198+ -> PQ schema0 schema1 io x
247− -> (x -> pq schemas0 schemas1 m y)
199+ -> PQ schema0 schema2 io (Result '[])
248− -> x -> pq schemas0 schemas2 m z
200+thenDefine = pqThen . define
249− pqAndThen g f x = pqBind g (f x)
201+
250−
202+{- | `MonadPQ` is an `mtl` style constraint, similar to
251− -- | Run a `Definition` with `LibPQ.exec`.
203+`Control.Monad.State.Class.MonadState`, for using `LibPQ` to
252− --
253− -- It should be functorial in effect.
254− --
255− -- @define id = return ()@
256− -- @define (statement1 >>> statement2) = define statement1 & pqThen (define statement2)@
257− define
258− :: MonadIO io
259− => Definition schemas0 schemas1
260− -> pq schemas0 schemas1 io ()
261−
262−instance IndexedMonadTransPQ PQ where
263−
264− pqAp (PQ f) (PQ x) = PQ $ \ conn -> do
265− K f' <- f conn
266− K x' <- x (K (unK conn))
267− return $ K (f' x')
268−
269− pqBind f (PQ x) = PQ $ \ conn -> do
270− K x' <- x conn
271− unPQ (f x') (K (unK conn))
272−
273− define (UnsafeDefinition q) = PQ $ \ (K conn) -> do
274− resultMaybe <- liftIO $ LibPQ.exec conn q
275− case resultMaybe of
276− Nothing -> throw $ ResultException
277− "define: LibPQ.exec returned no results"
278− Just result -> K <$> okResult_ result
279−
280−{- | `MonadPQ` is an @mtl@ style constraint, similar to
281−`Control.Monad.State.Class.MonadState`, for using `Database.PostgreSQL.LibPQ` to
282
204
283* `manipulateParams` runs a `Manipulation` with params from a type
205* `manipulateParams` runs a `Manipulation` with params from a type
284 with a `ToParams` constraint. It calls `LibPQ.execParams` and
206 with a `ToParams` constraint. It calls `LibPQ.execParams` and
285 doesn't afraid of anything.
207 doesn't afraid of anything.
286
208
287−* `manipulateParams_` is like `manipulateParams` for a returning-free statement.
288−
289* `manipulate` is like `manipulateParams` for a parameter-free statement.
209* `manipulate` is like `manipulateParams` for a parameter-free statement.
290
210
291−* `manipulate_` is like `manipulate` for a returning-free statement.
292−
293* `runQueryParams` is like `manipulateParams` for query statements.
211* `runQueryParams` is like `manipulateParams` for query statements.
294
212
295−* `runQuery` is like `runQueryParams` for a parameter-free statement.
296−
297* `traversePrepared` has the same type signature as a composition of
213* `traversePrepared` has the same type signature as a composition of
298 `traverse` and `manipulateParams` but provides an optimization by
214 `traverse` and `manipulateParams` but provides an optimization by
299 preparing the statement with `LibPQ.prepare` and then traversing a
215 preparing the statement with `LibPQ.prepare` and then traversing a
@@ -303,11 +219,11 @@ instance IndexedMonadTransPQ PQ where
303* `forPrepared` is a flipped `traversePrepared`
219* `forPrepared` is a flipped `traversePrepared`
304
220
305* `traversePrepared_` is like `traversePrepared` but works on `Foldable`
221* `traversePrepared_` is like `traversePrepared` but works on `Foldable`
306− containers for a returning-free statement.
222+ containers and returns unit.
307
223
308* `forPrepared_` is a flipped `traversePrepared_`.
224* `forPrepared_` is a flipped `traversePrepared_`.
309
225
310−* `liftPQ` lets you lift actions from `Database.PostgreSQL.LibPQ` that require a connection
226+* `liftPQ` lets you lift actions from `LibPQ` that require a connection
311 into your monad.
227 into your monad.
312
228
313To define an instance, you can minimally define only `manipulateParams`,
229To define an instance, you can minimally define only `manipulateParams`,
@@ -315,398 +231,309 @@ To define an instance, you can minimally define only `manipulateParams`,
315a default instance.
231a default instance.
316
232
317-}
233-}
318−class Monad pq => MonadPQ schemas pq | pq -> schemas where
234+class Monad pq => MonadPQ schema pq | pq -> schema where
319 manipulateParams
235 manipulateParams
320− :: (ToParams x params, All OidOfParam params)
236+ :: ToParams x params
321− => Manipulation '[] schemas params ys
237+ => Manipulation schema params ys
322 -- ^ `insertInto`, `update` or `deleteFrom`
238 -- ^ `insertInto`, `update` or `deleteFrom`
323− -> x -> pq (K LibPQ.Result ys)
239+ -> x -> pq (Result ys)
324 default manipulateParams
240 default manipulateParams
325− :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)
241+ :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)
326− => (ToParams x params, All OidOfParam params)
242+ => ToParams x params
327− => Manipulation '[] schemas params ys
243+ => Manipulation schema params ys
328 -- ^ `insertInto`, `update` or `deleteFrom`
244 -- ^ `insertInto`, `update` or `deleteFrom`
329− -> x -> pq (K LibPQ.Result ys)
245+ -> x -> pq (Result ys)
330 manipulateParams manipulation params = lift $
246 manipulateParams manipulation params = lift $
331 manipulateParams manipulation params
247 manipulateParams manipulation params
332
248
333− manipulateParams_
249+ manipulate :: Manipulation schema '[] ys -> pq (Result ys)
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−
340− manipulate :: Manipulation '[] schemas '[] ys -> pq (K LibPQ.Result ys)
341 manipulate statement = manipulateParams statement ()
250 manipulate statement = manipulateParams statement ()
342
251
343− manipulate_ :: Manipulation '[] schemas '[] '[] -> pq ()
344− manipulate_ = void . manipulate
345−
346 runQueryParams
252 runQueryParams
347− :: (ToParams x params, All OidOfParam params)
253+ :: ToParams x params
348− => Query '[] '[] schemas params ys
254+ => Query schema params ys
349 -- ^ `select` and friends
255 -- ^ `select` and friends
350− -> x -> pq (K LibPQ.Result ys)
256+ -> x -> pq (Result ys)
351 runQueryParams = manipulateParams . queryStatement
257 runQueryParams = manipulateParams . queryStatement
352
258
353 runQuery
259 runQuery
354− :: Query '[] '[] schemas '[] ys
260+ :: Query schema '[] ys
355 -- ^ `select` and friends
261 -- ^ `select` and friends
356− -> pq (K LibPQ.Result ys)
262+ -> pq (Result ys)
357 runQuery q = runQueryParams q ()
263 runQuery q = runQueryParams q ()
358
264
359 traversePrepared
265 traversePrepared
360− :: (ToParams x params, Traversable list, All OidOfParam params)
266+ :: (ToParams x params, Traversable list)
361− => Manipulation '[] schemas params ys
267+ => Manipulation schema params ys
362− -- ^ `insertInto`, `update`, or `deleteFrom`, and friends
268+ -- ^ `insertInto`, `update` or `deleteFrom`
363− -> list x -> pq (list (K LibPQ.Result ys))
269+ -> list x -> pq (list (Result ys))
364 default traversePrepared
270 default traversePrepared
365− :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)
271+ :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)
366− => (ToParams x params, Traversable list, All OidOfParam params)
272+ => (ToParams x params, Traversable list)
367− => Manipulation '[] schemas params ys -> list x -> pq (list (K LibPQ.Result ys))
273+ => Manipulation schema params ys -> list x -> pq (list (Result ys))
368 traversePrepared manipulation params = lift $
274 traversePrepared manipulation params = lift $
369 traversePrepared manipulation params
275 traversePrepared manipulation params
370
276
371 forPrepared
277 forPrepared
372− :: (ToParams x params, Traversable list, All OidOfParam params)
278+ :: (ToParams x params, Traversable list)
373 => list x
279 => list x
374− -> Manipulation '[] schemas params ys
280+ -> Manipulation schema params ys
375 -- ^ `insertInto`, `update` or `deleteFrom`
281 -- ^ `insertInto`, `update` or `deleteFrom`
376− -> pq (list (K LibPQ.Result ys))
282+ -> pq (list (Result ys))
377 forPrepared = flip traversePrepared
283 forPrepared = flip traversePrepared
378
284
379 traversePrepared_
285 traversePrepared_
380− :: (ToParams x params, Foldable list, All OidOfParam params)
286+ :: (ToParams x params, Foldable list)
381− => Manipulation '[] schemas params '[]
287+ => Manipulation schema params ys
382 -- ^ `insertInto`, `update` or `deleteFrom`
288 -- ^ `insertInto`, `update` or `deleteFrom`
383 -> list x -> pq ()
289 -> list x -> pq ()
384 default traversePrepared_
290 default traversePrepared_
385− :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)
291+ :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)
386− => (ToParams x params, Foldable list, All OidOfParam params)
292+ => (ToParams x params, Foldable list)
387− => Manipulation '[] schemas params '[]
293+ => Manipulation schema params ys
388 -- ^ `insertInto`, `update` or `deleteFrom`
294 -- ^ `insertInto`, `update` or `deleteFrom`
389 -> list x -> pq ()
295 -> list x -> pq ()
390 traversePrepared_ manipulation params = lift $
296 traversePrepared_ manipulation params = lift $
391 traversePrepared_ manipulation params
297 traversePrepared_ manipulation params
392
298
393 forPrepared_
299 forPrepared_
394− :: (ToParams x params, Foldable list, All OidOfParam params)
300+ :: (ToParams x params, Traversable list)
395 => list x
301 => list x
396− -> Manipulation '[] schemas params '[]
302+ -> Manipulation schema params ys
397 -- ^ `insertInto`, `update` or `deleteFrom`
303 -- ^ `insertInto`, `update` or `deleteFrom`
398 -> pq ()
304 -> pq ()
399 forPrepared_ = flip traversePrepared_
305 forPrepared_ = flip traversePrepared_
400
306
401 liftPQ :: (LibPQ.Connection -> IO a) -> pq a
307 liftPQ :: (LibPQ.Connection -> IO a) -> pq a
402 default liftPQ
308 default liftPQ
403− :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)
309+ :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)
404 => (LibPQ.Connection -> IO a) -> pq a
310 => (LibPQ.Connection -> IO a) -> pq a
405 liftPQ = lift . liftPQ
311 liftPQ = lift . liftPQ
406
312
407−instance (MonadIO io, schemas0 ~ schemas, schemas1 ~ schemas)
313+instance MonadBase IO io => MonadPQ schema (PQ schema schema io) where
408− => MonadPQ schemas (PQ schemas0 schemas1 io) where
409
314
410 manipulateParams
315 manipulateParams
411− (UnsafeManipulation q :: Manipulation '[] schemas ps ys) (params :: x) =
316+ (UnsafeManipulation q :: Manipulation schema ps ys) (params :: x) =
412− PQ $ \ (K conn) -> do
317+ PQ $ \ (Connection conn) -> do
413 let
318 let
414− paramSet
319+ toParam' bytes = (LibPQ.invalidOid,bytes,LibPQ.Binary)
415− :: forall param. OidOfParam param
320+ params' = fmap (fmap toParam') (hcollapse (toParams @x @ps params))
416− => K (Maybe Encoding.Encoding) param
321+ resultMaybe <- liftBase $ LibPQ.execParams conn q params' LibPQ.Binary
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
425− q' = q <> ";"
426− resultMaybe <- liftIO $ LibPQ.execParams conn q' params' LibPQ.Binary
427 case resultMaybe of
322 case resultMaybe of
428− Nothing -> throw $ ResultException
323+ Nothing -> error
429 "manipulateParams: LibPQ.execParams returned no results"
324 "manipulateParams: LibPQ.execParams returned no results"
430− Just result -> do
325+ Just result -> return (Result result, Connection conn)
431− okResult_ result
432− return $ K (K result)
433
326
434 traversePrepared
327 traversePrepared
435− (UnsafeManipulation q :: Manipulation '[] schemas xs ys) (list :: list x) =
328+ (UnsafeManipulation q :: Manipulation schema xs ys) (list :: list x) =
436− PQ $ \ (K conn) -> liftIO $ do
329+ PQ $ \ (Connection conn) -> liftBase $ do
437− let
330+ let temp = "temporary_statement"
438− temp = "temporary_statement"
331+ prepResultMaybe <- LibPQ.prepare conn temp q Nothing
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')
446 case prepResultMaybe of
332 case prepResultMaybe of
447− Nothing -> throw $ ResultException
333+ Nothing -> error
448 "traversePrepared: LibPQ.prepare returned no results"
334 "traversePrepared: LibPQ.prepare returned no results"
449− Just prepResult -> okResult_ prepResult
335+ Just prepResult -> do
336+ status <- LibPQ.resultStatus prepResult
337+ unless (status == LibPQ.CommandOk) . error $
338+ "traversePrepared: LibPQ.prepare status " <> show status
450 results <- for list $ \ params -> do
339 results <- for list $ \ params -> do
451 let
340 let
452− toParam' encoding = (encodingBytes encoding, LibPQ.Binary)
341+ toParam' bytes = (bytes,LibPQ.Binary)
453 params' = fmap (fmap toParam') (hcollapse (toParams @x @xs params))
342 params' = fmap (fmap toParam') (hcollapse (toParams @x @xs params))
454 resultMaybe <- LibPQ.execPrepared conn temp params' LibPQ.Binary
343 resultMaybe <- LibPQ.execPrepared conn temp params' LibPQ.Binary
455 case resultMaybe of
344 case resultMaybe of
456− Nothing -> throw $ ResultException
345+ Nothing -> error
457 "traversePrepared: LibPQ.execParams returned no results"
346 "traversePrepared: LibPQ.execParams returned no results"
458− Just result -> do
347+ Just result -> return $ Result result
459− okResult_ result
460− return $ K result
461 deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")
348 deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")
462 case deallocResultMaybe of
349 case deallocResultMaybe of
463− Nothing -> throw $ ResultException
350+ Nothing -> error
464 "traversePrepared: LibPQ.exec DEALLOCATE returned no results"
351 "traversePrepared: LibPQ.exec DEALLOCATE returned no results"
465− Just deallocResult -> okResult_ deallocResult
352+ Just deallocResult -> do
466− return (K results)
353+ status <- LibPQ.resultStatus deallocResult
354+ unless (status == LibPQ.CommandOk) . error $
355+ "traversePrepared: DEALLOCATE status " <> show status
356+ return (results, Connection conn)
467
357
468 traversePrepared_
358 traversePrepared_
469− (UnsafeManipulation q :: Manipulation '[] schemas xs '[]) (list :: list x) =
359+ (UnsafeManipulation q :: Manipulation schema xs ys) (list :: list x) =
470− PQ $ \ (K conn) -> liftIO $ do
360+ PQ $ \ (Connection conn) -> liftBase $ do
471− let
361+ let temp = "temporary_statement"
472− temp = "temporary_statement"
362+ prepResultMaybe <- LibPQ.prepare conn temp q Nothing
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')
480 case prepResultMaybe of
363 case prepResultMaybe of
481− Nothing -> throw $ ResultException
364+ Nothing -> error
482 "traversePrepared_: LibPQ.prepare returned no results"
365 "traversePrepared_: LibPQ.prepare returned no results"
483− Just prepResult -> okResult_ prepResult
366+ Just prepResult -> do
367+ status <- LibPQ.resultStatus prepResult
368+ unless (status == LibPQ.CommandOk) . error $
369+ "traversePrepared: LibPQ.prepare status " <> show status
484 for_ list $ \ params -> do
370 for_ list $ \ params -> do
485 let
371 let
486− toParam' encoding = (encodingBytes encoding, LibPQ.Binary)
372+ toParam' bytes = (bytes,LibPQ.Binary)
487 params' = fmap (fmap toParam') (hcollapse (toParams @x @xs params))
373 params' = fmap (fmap toParam') (hcollapse (toParams @x @xs params))
488 resultMaybe <- LibPQ.execPrepared conn temp params' LibPQ.Binary
374 resultMaybe <- LibPQ.execPrepared conn temp params' LibPQ.Binary
489 case resultMaybe of
375 case resultMaybe of
490− Nothing -> throw $ ResultException
376+ Nothing -> error
491 "traversePrepared_: LibPQ.execParams returned no results"
377 "traversePrepared_: LibPQ.execParams returned no results"
492− Just result -> okResult_ result
378+ Just _result -> return ()
493 deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")
379 deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")
494 case deallocResultMaybe of
380 case deallocResultMaybe of
495− Nothing -> throw $ ResultException
381+ Nothing -> error
496 "traversePrepared: LibPQ.exec DEALLOCATE returned no results"
382 "traversePrepared: LibPQ.exec DEALLOCATE returned no results"
497− Just deallocResult -> okResult_ deallocResult
383+ Just deallocResult -> do
498− return (K ())
384+ status <- LibPQ.resultStatus deallocResult
499−
385+ unless (status == LibPQ.CommandOk) . error $
500− liftPQ pq = PQ $ \ (K conn) -> do
386+ "traversePrepared: DEALLOCATE status " <> show status
501− y <- liftIO $ pq conn
387+ return ((), Connection conn)
502− return (K y)
388+
503−
389+ liftPQ pq = PQ $ \ (Connection conn) -> do
504−instance MonadPQ schemas m => MonadPQ schemas (IdentityT m)
390+ y <- liftBase $ pq conn
505−instance MonadPQ schemas m => MonadPQ schemas (ReaderT r m)
391+ return (y, Connection conn)
506−instance MonadPQ schemas m => MonadPQ schemas (Strict.StateT s m)
392+
507−instance MonadPQ schemas m => MonadPQ schemas (Lazy.StateT s m)
393+instance Monad m => Applicative (PQ schema schema m) where
508−instance (Monoid w, MonadPQ schemas m) => MonadPQ schemas (Strict.WriterT w m)
394+ pure x = PQ $ \ conn -> pure (x, conn)
509−instance (Monoid w, MonadPQ schemas m) => MonadPQ schemas (Lazy.WriterT w m)
510−instance MonadPQ schemas m => MonadPQ schemas (MaybeT m)
511−instance MonadPQ schemas m => MonadPQ schemas (ExceptT e m)
512−instance (Monoid w, MonadPQ schemas m) => MonadPQ schemas (Strict.RWST r w s m)
513−instance (Monoid w, MonadPQ schemas m) => MonadPQ schemas (Lazy.RWST r w s m)
514−instance MonadPQ schemas m => MonadPQ schemas (ContT r m)
515−
516−instance (Monad m, schemas0 ~ schemas1)
517− => Applicative (PQ schemas0 schemas1 m) where
518− pure x = PQ $ \ _conn -> pure (K x)
519 (<*>) = pqAp
395 (<*>) = pqAp
520
396
521−instance (Monad m, schemas0 ~ schemas1)
397+instance Monad m => Monad (PQ schema schema m) where
522− => Monad (PQ schemas0 schemas1 m) where
523 return = pure
398 return = pure
524 (>>=) = flip pqBind
399 (>>=) = flip pqBind
525
400
526−instance (Monad m, schemas0 ~ schemas1)
401+instance MonadTrans (PQ schema schema) where
527− => Fail.MonadFail (PQ schemas0 schemas1 m) where
402+ lift m = PQ $ \ conn -> do
528− fail = Fail.fail
529−
530−instance schemas0 ~ schemas1 => MFunctor (PQ schemas0 schemas1) where
531− hoist f (PQ pq) = PQ (f . pq)
532−
533−instance schemas0 ~ schemas1 => MonadTrans (PQ schemas0 schemas1) where
534− lift m = PQ $ \ _conn -> do
535 x <- m
403 x <- m
536− return (K x)
404+ return (x, conn)
537−
405+
538−instance schemas0 ~ schemas1 => MMonad (PQ schemas0 schemas1) where
406+instance MonadBase b m => MonadBase b (PQ schema schema m) where
539− embed f (PQ pq) = PQ $ \ conn -> do
407+ liftBase = lift . liftBase
540− evalPQ (f (pq conn)) conn
408+
541−
409+-- | A snapshot of the state of a `PQ` computation.
542−instance (MonadIO m, schema0 ~ schema1)
410+type PQRun schema =
543− => MonadIO (PQ schema0 schema1 m) where
411+ forall m x. Monad m => PQ schema schema m x -> m (x, Connection schema)
544− liftIO = lift . liftIO
412+
545−
413+-- | Helper function in defining `MonadBaseControl` instance for `PQ`.
546−instance (MonadUnliftIO m, schemas0 ~ schemas1)
414+pqliftWith :: Functor m => (PQRun schema -> m a) -> PQ schema schema m a
547− => MonadUnliftIO (PQ schemas0 schemas1 m) where
415+pqliftWith f = PQ $ \ conn ->
548− withRunInIO
416+ fmap (\ x -> (x, conn)) (f $ \ pq -> runPQ pq conn)
549− :: ((forall a . PQ schemas0 schema1 m a -> IO a) -> IO b)
417+
550− -> PQ schemas0 schema1 m b
418+instance MonadBaseControl b m => MonadBaseControl b (PQ schema schema m) where
551− withRunInIO inner = PQ $ \conn ->
419+ type StM (PQ schema schema m) x = StM m (x, Connection schema)
552− withRunInIO $ \(run :: (forall x . m x -> IO x)) ->
420+ liftBaseWith f =
553− K <$> inner (\pq -> run $ unK <$> unPQ pq conn)
421+ pqliftWith $ \ run -> liftBaseWith $ \ runInBase -> f $ runInBase . run
554−
422+ restoreM = PQ . const . restoreM
555−-- | Get a row corresponding to a given row number from a `LibPQ.Result`,
423+
556−-- throwing an exception if the row number is out of bounds.
424+-- | Encapsulates the result of a squeal command run by @LibPQ@.
425+-- `Result`s are parameterized by a `ColumnsType` describing the column names
426+-- and their types.
427+newtype Result (columns :: ColumnsType)
428+ = Result { unResult :: LibPQ.Result }
429+
430+-- | Just newtypes around a `CInt`
431+newtype RowNumber = RowNumber { unRowNumber :: LibPQ.Row }
432+
433+-- | In addition to being newtypes around a `CInt`, a `ColumnNumber` is
434+-- parameterized by a `Nat`ural number and acts as an index into a row.
435+newtype ColumnNumber (n :: Nat) (cs :: [k]) (c :: k) =
436+ UnsafeColumnNumber { getColumnNumber :: LibPQ.Column }
437+
438+-- | >>> getColumnNumber (columnNumber @5)
439+-- 5
440+class KnownNat n => HasColumnNumber n columns column
441+ | n columns -> column where
442+ columnNumber :: ColumnNumber n columns column
443+ columnNumber =
444+ UnsafeColumnNumber . fromIntegral $ natVal' (proxy# :: Proxy# n)
445+instance {-# OVERLAPPING #-} HasColumnNumber 0 (column1:columns) column1
446+instance {-# OVERLAPPABLE #-}
447+ (KnownNat n, HasColumnNumber (n-1) columns column)
448+ => HasColumnNumber n (column' : columns) column
449+
450+-- | Get a single value corresponding to a given row and column number
451+-- from a `Result`.
452+getValue
453+ :: (FromColumnValue colty y, MonadBase IO io)
454+ => RowNumber -- ^ row
455+ -> ColumnNumber n columns colty -- ^ col
456+ -> Result columns -- ^ result
457+ -> io y
458+getValue
459+ (RowNumber r)
460+ (UnsafeColumnNumber c :: ColumnNumber n columns colty)
461+ (Result result)
462+ = fmap (fromColumnValue @colty . K) $ liftBase $ do
463+ numRows <- LibPQ.ntuples result
464+ when (numRows < r) $ error $
465+ "getValue: expected at least " <> show r <> "rows but only saw "
466+ <> show numRows
467+ LibPQ.getvalue result r c
468+
469+-- | Get a row corresponding to a given row number from a `Result`.
557getRow
470getRow
558− :: (FromRow columns y, MonadIO io)
471+ :: (FromRow columns y, MonadBase IO io)
559− => LibPQ.Row
472+ => RowNumber
560− -- ^ row number
473+ -- ^ row
561− -> K LibPQ.Result columns
474+ -> Result columns
562 -- ^ result
475 -- ^ result
563 -> io y
476 -> io y
564−getRow r (K result :: K LibPQ.Result columns) = liftIO $ do
477+getRow (RowNumber r) (Result result :: Result columns) = liftBase $do
565 numRows <- LibPQ.ntuples result
478 numRows <- LibPQ.ntuples result
566− when (numRows < r) $ throw $ ResultException $
479+ when (numRows < r) $ error $
567− "getRow: expected at least " <> pack (show r) <> "rows but only saw "
480+ "getRow: expected at least " <> show r <> "rows but only saw "
568− <> pack (show numRows)
481+ <> show numRows
569 let len = fromIntegral (lengthSList (Proxy @columns))
482 let len = fromIntegral (lengthSList (Proxy @columns))
570 row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]
483 row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]
571 case fromList row' of
484 case fromList row' of
572− Nothing -> throw $ ResultException "getRow: found unexpected length"
485+ Nothing -> error "getRow: found unexpected length"
573− Just row -> case fromRow @columns row of
486+ Just row -> return $ fromRow @columns row
574− Left parseError -> throw $ ParseException $ "getRow: " <> parseError
575− Right y -> return y
576
487
577-- | Intended to be used for unfolding in streaming libraries, `nextRow`
488-- | Intended to be used for unfolding in streaming libraries, `nextRow`
578−-- takes a total number of rows (which can be found with `ntuples`)
489+-- takes a total number of rows (which can be found with `LibPQ.ntuples`)
579−-- and a `LibPQ.Result` and given a row number if it's too large returns `Nothing`,
490+-- and a `Result` and given a row number if it's too large returns `Nothing`,
580-- otherwise returning the row along with the next row number.
491-- otherwise returning the row along with the next row number.
581nextRow
492nextRow
582− :: (FromRow columns y, MonadIO io)
493+ :: (FromRow columns y, MonadBase IO io)
583− => LibPQ.Row -- ^ total number of rows
494+ => RowNumber -- ^ total number of rows
584− -> K LibPQ.Result columns -- ^ result
495+ -> Result columns -- ^ result
585− -> LibPQ.Row -- ^ row number
496+ -> RowNumber -- ^ row number
586− -> io (Maybe (LibPQ.Row,y))
497+ -> io (Maybe (RowNumber,y))
587−nextRow total (K result :: K LibPQ.Result columns) r
498+nextRow (RowNumber total) (Result result :: Result columns) (RowNumber r)
588− = liftIO $ if r >= total then return Nothing else do
499+ = liftBase $ if r >= total then return Nothing else do
589 let len = fromIntegral (lengthSList (Proxy @columns))
500 let len = fromIntegral (lengthSList (Proxy @columns))
590 row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]
501 row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]
591 case fromList row' of
502 case fromList row' of
592− Nothing -> throw $ ResultException "nextRow: found unexpected length"
503+ Nothing -> error "nextRow: found unexpected length"
593− Just row -> case fromRow @columns row of
504+ Just row -> return $ Just (RowNumber (r+1), fromRow @columns row)
594− Left parseError -> throw $ ParseException $ "nextRow: " <> parseError
595− Right y -> return $ Just (r+1, y)
596
505
597−-- | Get all rows from a `LibPQ.Result`.
506+-- | Get all rows from a `Result`.
598getRows
507getRows
599− :: (FromRow columns y, MonadIO io)
508+ :: (FromRow columns y, MonadBase IO io)
600− => K LibPQ.Result columns -- ^ result
509+ => Result columns -- ^ result
601 -> io [y]
510 -> io [y]
602−getRows (K result :: K LibPQ.Result columns) = liftIO $ do
511+getRows (Result result :: Result columns) = liftBase $ do
603 let len = fromIntegral (lengthSList (Proxy @columns))
512 let len = fromIntegral (lengthSList (Proxy @columns))
604 numRows <- LibPQ.ntuples result
513 numRows <- LibPQ.ntuples result
605 for [0 .. numRows - 1] $ \ r -> do
514 for [0 .. numRows - 1] $ \ r -> do
606 row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]
515 row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]
607 case fromList row' of
516 case fromList row' of
608− Nothing -> throw $ ResultException "getRows: found unexpected length"
517+ Nothing -> error "getRows: found unexpected length"
609− Just row -> case fromRow @columns row of
518+ Just row -> return $ fromRow @columns row
610− Left parseError -> throw $ ParseException $ "getRows: " <> parseError
611− Right y -> return y
612
519
613−-- | Get the first row if possible from a `LibPQ.Result`.
520+-- | Get the first row if possible from a `Result`.
614firstRow
521firstRow
615− :: (FromRow columns y, MonadIO io)
522+ :: (FromRow columns y, MonadBase IO io)
616− => K LibPQ.Result columns -- ^ result
523+ => Result columns -- ^ result
617 -> io (Maybe y)
524 -> io (Maybe y)
618−firstRow (K result :: K LibPQ.Result columns) = liftIO $ do
525+firstRow (Result result :: Result columns) = liftBase $ do
619 numRows <- LibPQ.ntuples result
526 numRows <- LibPQ.ntuples result
620 if numRows <= 0 then return Nothing else do
527 if numRows <= 0 then return Nothing else do
621 let len = fromIntegral (lengthSList (Proxy @columns))
528 let len = fromIntegral (lengthSList (Proxy @columns))
622 row' <- traverse (LibPQ.getvalue result 0) [0 .. len - 1]
529 row' <- traverse (LibPQ.getvalue result 0) [0 .. len - 1]
623 case fromList row' of
530 case fromList row' of
624− Nothing -> throw $ ResultException "firstRow: found unexpected length"
531+ Nothing -> error "firstRow: found unexpected length"
625− Just row -> case fromRow @columns row of
532+ Just row -> return . Just $ fromRow @columns row
626− Left parseError -> throw $ ParseException $ "firstRow: " <> parseError
627− Right y -> return $ Just y
628
533
629−-- | Lifts actions on results from @LibPQ@.
534+-- | Lifts actions on results from `LibPQ`.
630liftResult
535liftResult
631− :: MonadIO io
536+ :: MonadBase IO io
632 => (LibPQ.Result -> IO x)
537 => (LibPQ.Result -> IO x)
633− -> K LibPQ.Result results -> io x
538+ -> Result results -> io x
634−liftResult f (K result) = liftIO $ f result
539+liftResult f (Result result) = liftBase $ f result
635−
636−-- | Returns the number of rows (tuples) in the query result.
637−ntuples :: MonadIO io => K LibPQ.Result columns -> io LibPQ.Row
638−ntuples = liftResult LibPQ.ntuples
639−
640−-- | Returns the result status of the command.
641−resultStatus :: MonadIO io => K LibPQ.Result results -> io LibPQ.ExecStatus
642−resultStatus = liftResult LibPQ.resultStatus
643−
644−-- | Returns the error message most recently generated by an operation
645−-- on the connection.
646−resultErrorMessage
647− :: MonadIO io => K LibPQ.Result results -> io (Maybe ByteString)
648−resultErrorMessage = liftResult LibPQ.resultErrorMessage
649−
650−-- | Returns the error code most recently generated by an operation
651−-- on the connection.
652−--
653−-- https://www.postgresql.org/docs/current/static/errcodes-appendix.html
654−resultErrorCode
655− :: MonadIO io
656− => K LibPQ.Result results
657− -> io (Maybe ByteString)
658−resultErrorCode = liftResult (flip LibPQ.resultErrorField LibPQ.DiagSqlstate)
659−
660−-- | the state of LibPQ
661−data PQState = PQState
662− { sqlExecStatus :: LibPQ.ExecStatus
663− , sqlStateCode :: Maybe ByteString
664− -- ^ https://www.postgresql.org/docs/current/static/errcodes-appendix.html
665− , sqlErrorMessage :: Maybe ByteString
666− } deriving (Eq, Show)
667−
668−-- | `Exception`s that can be thrown by Squeal.
669−data SquealException
670− = PQException PQState
671− | ResultException Text
672− | ParseException Text
673− deriving (Eq, Show)
674−instance Exception SquealException
675−
676−okResult_ :: MonadIO io => LibPQ.Result -> io ()
677−okResult_ result = liftIO $ do
678− status <- LibPQ.resultStatus result
679− case status of
680− LibPQ.CommandOk -> return ()
681− LibPQ.TuplesOk -> return ()
682− _ -> do
683− stateCode <- LibPQ.resultErrorField result LibPQ.DiagSqlstate
684− msg <- LibPQ.resultErrorMessage result
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
691−
692−-- | Catch `SquealException`s.
693−catchSqueal
694− :: MonadUnliftIO io
695− => io a
696− -> (SquealException -> io a) -- ^ handler
697− -> io a
698−catchSqueal = catch
699−
700−-- | Handle `SquealException`s.
701−handleSqueal
702− :: MonadUnliftIO io
703− => (SquealException -> io a) -- ^ handler
704− -> io a -> io a
705−handleSqueal = 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.hsdeleted−122
@@ -1,122 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Pool
3−Description: Connection pools
4−Copyright: (c) Eitan Chatav, 2017
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
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
31−-}
32−
33−{-# LANGUAGE
34− DeriveFunctor
35− , FlexibleContexts
36− , FlexibleInstances
37− , InstanceSigs
38− , MultiParamTypeClasses
39− , RankNTypes
40− , ScopedTypeVariables
41− , TypeFamilies
42− , TypeInType
43− , UndecidableInstances
44−#-}
45−
46−module Squeal.PostgreSQL.Pool
47− ( -- * Pools
48− Pool
49− , createConnectionPool
50− , usingConnectionPool
51− , destroyConnectionPool
52− ) where
53−
54−import Data.ByteString
55−import Data.Time
56−import Generics.SOP (K(..), unK)
57−import UnliftIO (MonadUnliftIO (..))
58−import UnliftIO.Pool (Pool, createPool, destroyAllResources, withResource)
59−
60−import Squeal.PostgreSQL.PQ
61−
62−-- | Create a striped pool of connections.
63−-- Although the garbage collector will destroy all idle connections when the pool is garbage collected it's recommended to manually `destroyAllResources` when you're done with the pool so that the connections are freed up as soon as possible.
64−createConnectionPool
65− :: MonadUnliftIO io
66− => ByteString
67− -- ^ The passed string can be empty to use all default parameters, or it can
68− -- contain one or more parameter settings separated by whitespace.
69− -- Each parameter setting is in the form keyword = value. Spaces around the equal
70− -- sign are optional. To write an empty value or a value containing spaces,
71− -- surround it with single quotes, e.g., keyword = 'a value'. Single quotes and
72− -- backslashes within the value must be escaped with a backslash, i.e., ' and \.
73− -> Int
74− -- ^ The number of stripes (distinct sub-pools) to maintain. The smallest acceptable value is 1.
75− -> NominalDiffTime
76− -- ^ Amount of time for which an unused connection is kept open. The smallest acceptable value is 0.5 seconds.
77− -- The elapsed time before destroying a connection may be a little longer than requested, as the reaper thread wakes at 1-second intervals.
78− -> Int
79− -- ^ Maximum number of connections to keep open per stripe. The smallest acceptable value is 1.
80− -- Requests for connections will block if this limit is reached on a single stripe, even if other stripes have idle connections available.
81− -> io (Pool (K Connection schemas))
82−createConnectionPool conninfo stripes idle maxResrc =
83− createPool (connectdb conninfo) finish stripes idle maxResrc
84−
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/Prettyprint.hsnew file+67
@@ -0,0 +1,67 @@
1+{-|
2+Module: Squeal.PostgreSQL.PrettyPrint
3+Description: Pretty print helper functions
4+Copyright: (c) Eitan Chatav, 2017
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Pretty print helper functions.
9+-}
10+
11+{-# LANGUAGE
12+ MagicHash
13+ , OverloadedStrings
14+ , PolyKinds
15+ , RankNTypes
16+ , ScopedTypeVariables
17+ , TypeApplications
18+#-}
19+
20+module Squeal.PostgreSQL.Prettyprint where
21+
22+import Data.ByteString (ByteString)
23+import Data.Maybe
24+import Data.Monoid ((<>))
25+import Generics.SOP
26+import GHC.Exts
27+import GHC.TypeLits
28+
29+import qualified Data.ByteString as ByteString
30+
31+-- | Parenthesize a `ByteString`.
32+parenthesized :: ByteString -> ByteString
33+parenthesized str = "(" <> str <> ")"
34+
35+-- | Concatenate two `ByteString`s with a space between.
36+(<+>) :: ByteString -> ByteString -> ByteString
37+str1 <+> str2 = str1 <> " " <> str2
38+
39+-- | Comma separate a list of `ByteString`s.
40+commaSeparated :: [ByteString] -> ByteString
41+commaSeparated = ByteString.intercalate ", "
42+
43+-- | Comma separate the renderings of a heterogeneous list.
44+renderCommaSeparated
45+ :: SListI xs
46+ => (forall x. expression x -> ByteString)
47+ -> NP expression xs -> ByteString
48+renderCommaSeparated render
49+ = commaSeparated
50+ . hcollapse
51+ . hmap (K . render)
52+
53+-- | Comma separate the `Maybe` renderings of a heterogeneous list, dropping
54+-- `Nothing`s.
55+renderCommaSeparatedMaybe
56+ :: SListI xs
57+ => (forall x. expression x -> Maybe ByteString)
58+ -> NP expression xs -> ByteString
59+renderCommaSeparatedMaybe render
60+ = commaSeparated
61+ . catMaybes
62+ . hcollapse
63+ . hmap (K . render)
64+
65+-- | Render a promoted `Nat`.
66+renderNat :: KnownNat n => proxy n -> ByteString
67+renderNat (_ :: proxy n) = fromString (show (natVal' (proxy# :: Proxy# n)))
squeal-postgresql/src/Squeal/PostgreSQL/Query.hs+485−804
@@ -1,7 +1,7 @@
1{-|
1{-|
2Module: Squeal.PostgreSQL.Query
2Module: Squeal.PostgreSQL.Query
3Description: Squeal queries
3Description: Squeal queries
4−Copyright: (c) Eitan Chatav, 2019
4+Copyright: (c) Eitan Chatav, 2017
5Maintainer: eitan@morphism.tech
5Maintainer: eitan@morphism.tech
6Stability: experimental
6Stability: experimental
7
7
@@ -9,81 +9,68 @@ Squeal queries.
9-}
9-}
10
10
11{-# LANGUAGE
11{-# LANGUAGE
12− ConstraintKinds
12+ DataKinds
13+ , DeriveDataTypeable
13 , DeriveGeneric
14 , DeriveGeneric
14− , FlexibleContexts
15 , FlexibleInstances
15 , FlexibleInstances
16 , GADTs
16 , GADTs
17 , GeneralizedNewtypeDeriving
17 , GeneralizedNewtypeDeriving
18+ , KindSignatures
18 , LambdaCase
19 , LambdaCase
19 , MultiParamTypeClasses
20 , MultiParamTypeClasses
20− , OverloadedLabels
21 , OverloadedStrings
21 , OverloadedStrings
22− , QuantifiedConstraints
23 , ScopedTypeVariables
22 , ScopedTypeVariables
24 , StandaloneDeriving
23 , StandaloneDeriving
25 , TypeApplications
24 , TypeApplications
26− , TypeFamilies
27 , TypeInType
25 , TypeInType
28 , TypeOperators
26 , TypeOperators
29− , RankNTypes
30 , UndecidableInstances
27 , UndecidableInstances
31− #-}
28+#-}
32
29
33module Squeal.PostgreSQL.Query
30module Squeal.PostgreSQL.Query
34 ( -- * Queries
31 ( -- * Queries
35− Query_
32+ Query (UnsafeQuery, renderQuery)
36− , Query (..)
37− -- ** Select
38− , select
39− , select_
40− , selectDistinct
41− , selectDistinct_
42− , selectDistinctOn
43− , selectDistinctOn_
44− , Selection (..)
45− -- ** Values
46− , values
47− , values_
48− -- ** Set Operations
49 , union
33 , union
50 , unionAll
34 , unionAll
51 , intersect
35 , intersect
52 , intersectAll
36 , intersectAll
53 , except
37 , except
54 , exceptAll
38 , exceptAll
55− -- ** With
39+ -- * Select
56− , With (..)
40+ , select
57− , CommonTableExpression (..)
41+ , selectDistinct
58− , withRecursive
42+ , selectStar
43+ , selectDistinctStar
44+ , selectDotStar
45+ , selectDistinctDotStar
59 -- * Table Expressions
46 -- * Table Expressions
60 , TableExpression (..)
47 , TableExpression (..)
48+ , renderTableExpression
61 , from
49 , from
62 , where_
50 , where_
63− , groupBy
51+ , group
64 , having
52 , having
53+ , orderBy
65 , limit
54 , limit
66 , offset
55 , offset
67− -- * From Clauses
56+ -- * From
68 , FromClause (..)
57 , FromClause (..)
69− , table
58+ , renderFromClause
70− , subquery
71− , view
72− , common
73− , crossJoin
74− , innerJoin
75− , leftOuterJoin
76− , rightOuterJoin
77− , fullOuterJoin
78 -- * Grouping
59 -- * Grouping
79− , By (..)
60+ , By (By, By2)
80− , GroupByClause (..)
61+ , renderBy
81− , HavingClause (..)
62+ , GroupByClause (NoGroups, Group)
63+ , renderGroupByClause
64+ , HavingClause (NoHaving, Having)
65+ , renderHavingClause
66+ -- * Sorting
67+ , SortExpression (..)
68+ , renderSortExpression
82 ) where
69 ) where
83
70
84import Control.DeepSeq
71import Control.DeepSeq
85import Data.ByteString (ByteString)
72import Data.ByteString (ByteString)
86−import Data.Kind (Type)
73+import Data.Monoid
87import Data.String
74import Data.String
88import Data.Word
75import Data.Word
89import Generics.SOP hiding (from)
76import Generics.SOP hiding (from)
@@ -91,577 +78,339 @@ import GHC.TypeLits
91
78
92import qualified GHC.Generics as GHC
79import qualified GHC.Generics as GHC
93
80
94−import Squeal.PostgreSQL.Alias
95import Squeal.PostgreSQL.Expression
81import Squeal.PostgreSQL.Expression
96−import Squeal.PostgreSQL.Expression.Logic
82+import Squeal.PostgreSQL.Prettyprint
97−import Squeal.PostgreSQL.Expression.Sort
98−import Squeal.PostgreSQL.Expression.Window
99−import Squeal.PostgreSQL.List
100−import Squeal.PostgreSQL.PG
101−import Squeal.PostgreSQL.Render
102import Squeal.PostgreSQL.Schema
83import Squeal.PostgreSQL.Schema
103
84
104−-- $setup
105−-- >>> import Squeal.PostgreSQL
106−-- >>> import Data.Int (Int32, Int64)
107−-- >>> import Data.Monoid (Sum (..))
108−-- >>> import Data.Text (Text)
109−-- >>> import qualified Generics.SOP as SOP
110−
111−{- |
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{- |
85{- |
134−The top level `Query_` type is parameterized by a @schemas@ `SchemasType`,
86+The process of retrieving or the command to retrieve data from a database
135−against which the query is type-checked, an input @parameters@ Haskell `Type`,
87+is called a `Query`. The `select`, `selectStar`, `selectDotStar`,
136−and an ouput row Haskell `Type`.
88+`selectDistinct`, `selectDistinctStar` and `selectDistinctDotStar` commands
137−
89+are used to specify queries.
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−:}
155
90
156simple query:
91simple query:
157
92
158−>>> type Columns = '["col1" ::: 'NoDef :=> 'NotNull 'PGint4, "col2" ::: 'NoDef :=> 'NotNull 'PGint4]
159−>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]
160>>> :{
93>>> :{
161let
94let
162− query :: Query_ (Public Schema) () (Row Int32 Int32)
95+ query :: Query '["tab" ::: '["col" ::: 'Required ('Null 'PGint4)]] '[]
163− query = select Star (from (table #tab))
96+ '["col" ::: 'Required ('Null 'PGint4)]
164−in printSQL query
97+ query = selectStar (from (Table (#tab `As` #t)))
98+in renderQuery query
165:}
99:}
166−SELECT * FROM "tab" AS "tab"
100+"SELECT * FROM tab AS t"
167
101
168restricted query:
102restricted query:
169
103
170>>> :{
104>>> :{
171let
105let
172− query :: Query_ (Public Schema) () (Row Int32 Int32)
106+ query :: Query
173− query =
107+ '[ "tab" :::
174− select_ ((#col1 + #col2) `as` #col1 :* #col1 `as` #col2)
108+ '[ "col1" ::: 'Required ('NotNull 'PGint4)
175− ( from (table #tab)
109+ , "col2" ::: 'Required ('NotNull 'PGint4) ]]
110+ '[]
111+ '[ "sum" ::: 'Required ('NotNull 'PGint4)
112+ , "col1" ::: 'Required ('NotNull 'PGint4) ]
113+ query =
114+ select
115+ ((#col1 + #col2) `As` #sum :* #col1 `As` #col1 :* Nil)
116+ ( from (Table (#tab `As` #t))
176 & where_ (#col1 .> #col2)
117 & where_ (#col1 .> #col2)
177 & where_ (#col2 .> 0) )
118 & where_ (#col2 .> 0) )
178−in printSQL query
119+in renderQuery query
179:}
120:}
180−SELECT ("col1" + "col2") AS "col1", "col1" AS "col2" FROM "tab" AS "tab" WHERE (("col1" > "col2") AND ("col2" > 0))
121+"SELECT (col1 + col2) AS sum, col1 AS col1 FROM tab AS t WHERE ((col1 > col2) AND (col2 > 0))"
181
122
182subquery:
123subquery:
183
124
184>>> :{
125>>> :{
185let
126let
186− query :: Query_ (Public Schema) () (Row Int32 Int32)
127+ query :: Query '["tab" ::: '["col" ::: 'Required ('Null 'PGint4)]] '[]
187− query = select Star (from (subquery (select Star (from (table #tab)) `as` #sub)))
128+ '["col" ::: 'Required ('Null 'PGint4)]
188−in printSQL query
129+ query =
130+ selectStar
131+ (from (Subquery (selectStar (from (Table (#tab `As` #t))) `As` #sub)))
132+in renderQuery query
189:}
133:}
190−SELECT * FROM (SELECT * FROM "tab" AS "tab") AS "sub"
134+"SELECT * FROM (SELECT * FROM tab AS t) AS sub"
191
135
192limits and offsets:
136limits and offsets:
193
137
194>>> :{
138>>> :{
195let
139let
196− query :: Query_ (Public Schema) () (Row Int32 Int32)
140+ query :: Query '["tab" ::: '["col" ::: 'Required ('Null 'PGint4)]] '[]
197− query = select Star (from (table #tab) & limit 100 & offset 2 & limit 50 & offset 2)
141+ '["col" ::: 'Required ('Null 'PGint4)]
198−in printSQL query
142+ query = selectStar
143+ ( from (Table (#tab `As` #t))
144+ & limit 100
145+ & offset 2
146+ & limit 50
147+ & offset 2 )
148+in renderQuery query
199:}
149:}
200−SELECT * FROM "tab" AS "tab" LIMIT 50 OFFSET 4
150+"SELECT * FROM tab AS t LIMIT 50 OFFSET 4"
201
151
202parameterized query:
152parameterized query:
203
153
204>>> :{
154>>> :{
205let
155let
206− query :: Query_ (Public Schema) (Only Int32) (Row Int32 Int32)
156+ query :: Query '["tab" ::: '["col" ::: 'Required ('Null 'PGint4)]]
207− query = select Star (from (table #tab) & where_ (#col1 .> param @1))
157+ '[ 'Required ('NotNull 'PGbool)]
208−in printSQL query
158+ '["col" ::: 'Required ('Null 'PGint4)]
159+ query = selectStar
160+ (from (Table (#tab `As` #t)) & where_ (param @1))
161+in renderQuery query
209:}
162:}
210−SELECT * FROM "tab" AS "tab" WHERE ("col1" > ($1 :: int4))
163+"SELECT * FROM tab AS t WHERE ($1 :: bool)"
211
164
212aggregation query:
165aggregation query:
213
166
214>>> :{
167>>> :{
215let
168let
216− query :: Query_ (Public Schema) () (Row Int64 Int32)
169+ query :: Query
170+ '[ "tab" :::
171+ '[ "col1" ::: 'Required ('NotNull 'PGint4)
172+ , "col2" ::: 'Required ('NotNull 'PGint4) ]]
173+ '[]
174+ '[ "sum" ::: 'Required ('NotNull 'PGint4)
175+ , "col1" ::: 'Required ('NotNull 'PGint4) ]
217 query =
176 query =
218− select_ ((fromNull 0 (sum_ (All #col2))) `as` #col1 :* #col1 `as` #col2)
177+ select (sum_ #col2 `As` #sum :* #col1 `As` #col1 :* Nil)
219− ( from (table (#tab `as` #table1))
178+ ( from (Table (#tab `As` #table1))
220− & groupBy #col1
179+ & group (By #col1 :* Nil)
221− & having (sum_ (Distinct #col2) .> 1) )
180+ & having (#col1 + sum_ #col2 .> 1) )
222−in printSQL query
181+in renderQuery query
223:}
182:}
224−SELECT COALESCE(sum(ALL "col2"), 0) AS "col1", "col1" AS "col2" FROM "tab" AS "table1" GROUP BY "col1" HAVING (sum(DISTINCT "col2") > 1)
183+"SELECT sum(col2) AS sum, col1 AS col1 FROM tab AS table1 GROUP BY col1 HAVING ((col1 + sum(col2)) > 1)"
225
184
226sorted query:
185sorted query:
227
186
228>>> :{
187>>> :{
229let
188let
230− query :: Query_ (Public Schema) () (Row Int32 Int32)
189+ query :: Query '["tab" ::: '["col" ::: 'Required ('Null 'PGint4)]] '[]
231− query = select Star (from (table #tab) & orderBy [#col1 & Asc])
190+ '["col" ::: 'Required ('Null 'PGint4)]
232−in printSQL query
191+ query = selectStar
192+ (from (Table (#tab `As` #t)) & orderBy [#col & AscNullsFirst])
193+in renderQuery query
233:}
194:}
234−SELECT * FROM "tab" AS "tab" ORDER BY "col1" ASC
195+"SELECT * FROM tab AS t ORDER BY col ASC NULLS FIRST"
235
196
236joins:
197joins:
237
198
238−>>> :{
199+>>> :set -XFlexibleContexts
239−type OrdersColumns =
240− '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4
241− , "price" ::: 'NoDef :=> 'NotNull 'PGfloat4
242− , "customer_id" ::: 'NoDef :=> 'NotNull 'PGint4
243− , "shipper_id" ::: 'NoDef :=> 'NotNull 'PGint4 ]
244−:}
245−
246−>>> :{
247−type OrdersConstraints =
248− '["pk_orders" ::: PrimaryKey '["id"]
249− ,"fk_customers" ::: ForeignKey '["customer_id"] "customers" '["id"]
250− ,"fk_shippers" ::: ForeignKey '["shipper_id"] "shippers" '["id"] ]
251−:}
252−
253−>>> type NamesColumns = '["id" ::: 'NoDef :=> 'NotNull 'PGint4, "name" ::: 'NoDef :=> 'NotNull 'PGtext]
254−>>> type CustomersConstraints = '["pk_customers" ::: PrimaryKey '["id"]]
255−>>> type ShippersConstraints = '["pk_shippers" ::: PrimaryKey '["id"]]
256−>>> :{
257−type OrdersSchema =
258− '[ "orders" ::: 'Table (OrdersConstraints :=> OrdersColumns)
259− , "customers" ::: 'Table (CustomersConstraints :=> NamesColumns)
260− , "shippers" ::: 'Table (ShippersConstraints :=> NamesColumns) ]
261−:}
262−
263−>>> :{
264−data Order = Order
265− { price :: Float
266− , customerName :: Text
267− , shipperName :: Text
268− } deriving GHC.Generic
269−instance SOP.Generic Order
270−instance SOP.HasDatatypeInfo Order
271−:}
272−
273>>> :{
200>>> :{
274let
201let
275− query :: Query_ (Public OrdersSchema) () Order
202+ query :: Query
276− query = select_
203+ '[ "orders" :::
277− ( #o ! #price `as` #price :*
204+ '[ "id" ::: 'Required ('NotNull 'PGint4)
278− #c ! #name `as` #customerName :*
205+ , "order_price" ::: 'Required ('NotNull 'PGfloat4)
279− #s ! #name `as` #shipperName )
206+ , "customer_id" ::: 'Required ('NotNull 'PGint4)
280− ( from (table (#orders `as` #o)
207+ , "shipper_id" ::: 'Required ('NotNull 'PGint4)
281− & innerJoin (table (#customers `as` #c))
208+ ]
209+ , "customers" :::
210+ '[ "id" ::: 'Required ('NotNull 'PGint4)
211+ , "name" ::: 'Required ('NotNull 'PGtext)
212+ ]
213+ , "shippers" :::
214+ '[ "id" ::: 'Required ('NotNull 'PGint4)
215+ , "name" ::: 'Required ('NotNull 'PGtext)
216+ ]
217+ ]
218+ '[]
219+ '[ "order_price" ::: 'Required ('NotNull 'PGfloat4)
220+ , "customer_name" ::: 'Required ('NotNull 'PGtext)
221+ , "shipper_name" ::: 'Required ('NotNull 'PGtext)
222+ ]
223+ query = select
224+ ( #o ! #order_price `As` #order_price :*
225+ #c ! #name `As` #customer_name :*
226+ #s ! #name `As` #shipper_name :* Nil )
227+ ( from (Table (#orders `As` #o)
228+ & InnerJoin (Table (#customers `As` #c))
282 (#o ! #customer_id .== #c ! #id)
229 (#o ! #customer_id .== #c ! #id)
283− & innerJoin (table (#shippers `as` #s))
230+ & InnerJoin (Table (#shippers `As` #s))
284 (#o ! #shipper_id .== #s ! #id)) )
231 (#o ! #shipper_id .== #s ! #id)) )
285−in printSQL query
232+in renderQuery query
286:}
233:}
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")
234+"SELECT o.order_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)"
288
235
289self-join:
236self-join:
290
237
291>>> :{
238>>> :{
292let
239let
293− query :: Query_ (Public Schema) () (Row Int32 Int32)
240+ query :: Query '["tab" ::: '["col" ::: 'Required ('Null 'PGint4)]] '[]
294− query = select
241+ '["col" ::: 'Required ('Null 'PGint4)]
295− (#t1 & DotStar)
242+ query = selectDotStar #t1
296− (from (table (#tab `as` #t1) & crossJoin (table (#tab `as` #t2))))
243+ (from (Table (#tab `As` #t1) & CrossJoin (Table (#tab `As` #t2))))
297−in printSQL query
244+in renderQuery query
298:}
245:}
299−SELECT "t1".* FROM "tab" AS "t1" CROSS JOIN "tab" AS "t2"
246+"SELECT t1.* FROM tab AS t1 CROSS JOIN tab AS t2"
300−
301−value queries:
302−
303−>>> :{
304−let
305− query :: Query_ schemas () (Row String Bool)
306− query = values
307− ("true" `as` #col1 :* true `as` #col2)
308− ["false" `as` #col1 :* false `as` #col2]
309−in printSQL query
310−:}
311−SELECT * FROM (VALUES (E'true', TRUE), (E'false', FALSE)) AS t ("col1", "col2")
312
247
313set operations:
248set operations:
314
249
315>>> :{
250>>> :{
316let
251let
317− query :: Query_ (Public Schema) () (Row Int32 Int32)
252+ query :: Query '["tab" ::: '["col" ::: 'Required ('Null 'PGint4)]] '[]
318− query = select Star (from (table #tab)) `unionAll` select Star (from (table #tab))
253+ '["col" ::: 'Required ('Null 'PGint4)]
319−in printSQL query
320−:}
321−(SELECT * FROM "tab" AS "tab") UNION ALL (SELECT * FROM "tab" AS "tab")
322−
323−with queries:
324−
325−>>> :{
326−let
327− query :: Query_ (Public Schema) () (Row Int32 Int32)
328− query = with (
329− select Star (from (table #tab)) `as` #cte1 :>>
330− select Star (from (common #cte1)) `as` #cte2
331− ) (select Star (from (common #cte2)))
332−in printSQL query
333−:}
334−WITH "cte1" AS (SELECT * FROM "tab" AS "tab"), "cte2" AS (SELECT * FROM "cte1" AS "cte1") SELECT * FROM "cte2" AS "cte2"
335−
336−window function queries
337−
338−>>> :{
339−let
340− query :: Query_ (Public Schema) () (Row Int32 Int64)
341− query = select
342− (#col1 & Also (rank `as` #col2 `Over` (partitionBy #col1 & orderBy [#col2 & Asc])))
343− (from (table #tab))
344−in printSQL query
345−:}
346−SELECT "col1" AS "col1", rank() OVER (PARTITION BY "col1" ORDER BY "col2" ASC) AS "col2" FROM "tab" AS "tab"
347−
348−correlated subqueries
349−
350−>>> :{
351−let
352− query :: Query_ (Public Schema) () (Only Int32)
353 query =
254 query =
354− select (#col1 `as` #fromOnly) (from (table (#tab `as` #t1))
255+ selectStar (from (Table (#tab `As` #t)))
355− & where_ (exists (
256+ `unionAll`
356− select Star (from (table (#tab `as` #t2))
257+ selectStar (from (Table (#tab `As` #t)))
357− & where_ (#t2 ! #col2 .== #t1 ! #col1)))))
258+in renderQuery query
358−in printSQL query
359:}
259:}
360−SELECT "col1" AS "fromOnly" FROM "tab" AS "t1" WHERE EXISTS (SELECT * FROM "tab" AS "t2" WHERE ("t2"."col2" = "t1"."col1"))
260+"(SELECT * FROM tab AS t) UNION ALL (SELECT * FROM tab AS t)"
361−
362-}
261-}
363−type family Query_
262+
364− (schemas :: SchemasType)
263+newtype Query
365− (parameters :: Type)
264+ (schema :: TablesType)
366− (row :: Type) where
265+ (params :: [ColumnType])
367− Query_ schemas params row =
266+ (columns :: ColumnsType)
368− Query '[] '[] schemas (TuplePG params) (RowPG row)
267+ = UnsafeQuery { renderQuery :: ByteString }
268+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
369
269
370-- | The results of two queries can be combined using the set operation
270-- | The results of two queries can be combined using the set operation
371−-- `union`. Duplicate rows are eliminated.
271+-- `union`. Duplicate rows are eliminated.
372union
272union
373− :: Query outer commons schemas params columns
273+ :: Query schema params columns
374− -> Query outer commons schemas params columns
274+ -> Query schema params columns
375− -> Query outer commons schemas params columns
275+ -> Query schema params columns
376q1 `union` q2 = UnsafeQuery $
276q1 `union` q2 = UnsafeQuery $
377− parenthesized (renderSQL q1)
277+ parenthesized (renderQuery q1)
378 <+> "UNION"
278 <+> "UNION"
379− <+> parenthesized (renderSQL q2)
279+ <+> parenthesized (renderQuery q2)
380
280
381-- | The results of two queries can be combined using the set operation
281-- | The results of two queries can be combined using the set operation
382-- `unionAll`, the disjoint union. Duplicate rows are retained.
282-- `unionAll`, the disjoint union. Duplicate rows are retained.
383unionAll
283unionAll
384− :: Query outer commons schemas params columns
284+ :: Query schema params columns
385− -> Query outer commons schemas params columns
285+ -> Query schema params columns
386− -> Query outer commons schemas params columns
286+ -> Query schema params columns
387q1 `unionAll` q2 = UnsafeQuery $
287q1 `unionAll` q2 = UnsafeQuery $
388− parenthesized (renderSQL q1)
288+ parenthesized (renderQuery q1)
389 <+> "UNION" <+> "ALL"
289 <+> "UNION" <+> "ALL"
390− <+> parenthesized (renderSQL q2)
290+ <+> parenthesized (renderQuery q2)
391
291
392-- | The results of two queries can be combined using the set operation
292-- | The results of two queries can be combined using the set operation
393-- `intersect`, the intersection. Duplicate rows are eliminated.
293-- `intersect`, the intersection. Duplicate rows are eliminated.
394intersect
294intersect
395− :: Query outer commons schemas params columns
295+ :: Query schema params columns
396− -> Query outer commons schemas params columns
296+ -> Query schema params columns
397− -> Query outer commons schemas params columns
297+ -> Query schema params columns
398q1 `intersect` q2 = UnsafeQuery $
298q1 `intersect` q2 = UnsafeQuery $
399− parenthesized (renderSQL q1)
299+ parenthesized (renderQuery q1)
400 <+> "INTERSECT"
300 <+> "INTERSECT"
401− <+> parenthesized (renderSQL q2)
301+ <+> parenthesized (renderQuery q2)
402
302
403-- | The results of two queries can be combined using the set operation
303-- | The results of two queries can be combined using the set operation
404-- `intersectAll`, the intersection. Duplicate rows are retained.
304-- `intersectAll`, the intersection. Duplicate rows are retained.
405intersectAll
305intersectAll
406− :: Query outer commons schemas params columns
306+ :: Query schema params columns
407− -> Query outer commons schemas params columns
307+ -> Query schema params columns
408− -> Query outer commons schemas params columns
308+ -> Query schema params columns
409q1 `intersectAll` q2 = UnsafeQuery $
309q1 `intersectAll` q2 = UnsafeQuery $
410− parenthesized (renderSQL q1)
310+ parenthesized (renderQuery q1)
411 <+> "INTERSECT" <+> "ALL"
311 <+> "INTERSECT" <+> "ALL"
412− <+> parenthesized (renderSQL q2)
312+ <+> parenthesized (renderQuery q2)
413
313
414-- | The results of two queries can be combined using the set operation
314-- | The results of two queries can be combined using the set operation
415-- `except`, the set difference. Duplicate rows are eliminated.
315-- `except`, the set difference. Duplicate rows are eliminated.
416except
316except
417− :: Query outer commons schemas params columns
317+ :: Query schema params columns
418− -> Query outer commons schemas params columns
318+ -> Query schema params columns
419− -> Query outer commons schemas params columns
319+ -> Query schema params columns
420q1 `except` q2 = UnsafeQuery $
320q1 `except` q2 = UnsafeQuery $
421− parenthesized (renderSQL q1)
321+ parenthesized (renderQuery q1)
422 <+> "EXCEPT"
322 <+> "EXCEPT"
423− <+> parenthesized (renderSQL q2)
323+ <+> parenthesized (renderQuery q2)
424
324
425-- | The results of two queries can be combined using the set operation
325-- | The results of two queries can be combined using the set operation
426-- `exceptAll`, the set difference. Duplicate rows are retained.
326-- `exceptAll`, the set difference. Duplicate rows are retained.
427exceptAll
327exceptAll
428− :: Query outer commons schemas params columns
328+ :: Query schema params columns
429− -> Query outer commons schemas params columns
329+ -> Query schema params columns
430− -> Query outer commons schemas params columns
330+ -> Query schema params columns
431q1 `exceptAll` q2 = UnsafeQuery $
331q1 `exceptAll` q2 = UnsafeQuery $
432− parenthesized (renderSQL q1)
332+ parenthesized (renderQuery q1)
433 <+> "EXCEPT" <+> "ALL"
333 <+> "EXCEPT" <+> "ALL"
434− <+> parenthesized (renderSQL q2)
334+ <+> parenthesized (renderQuery q2)
435
335
436{-----------------------------------------
336{-----------------------------------------
437SELECT queries
337SELECT queries
438-----------------------------------------}
338-----------------------------------------}
439
339
440−{- | The simplest kinds of `Selection` are `Star` and `DotStar` which
441−emits all columns that a `TableExpression` produces. A select `List`
442−is a list of `Expression`s. A `Selection` could be a list of
443−`WindowFunction`s `Over` `WindowDefinition`. `Additional` `Selection`s can
444−be selected with `Also`.
445−-}
446−data Selection outer commons grp schemas params from row where
447− Star
448− :: HasUnique tab from row
449− => Selection outer commons 'Ungrouped schemas params from row
450− -- ^ `HasUnique` table in the `FromClause`
451− DotStar
452− :: Has tab from row
453− => Alias tab
454− -- ^ `Has` table with `Alias`
455− -> Selection outer commons 'Ungrouped schemas params from row
456− List
457− :: SListI row
458− => NP (Aliased (Expression outer commons grp schemas params from)) row
459− -- ^ `NP` list of `Aliased` `Expression`s
460− -> Selection outer commons grp schemas params from row
461− Over
462− :: SListI row
463− => NP (Aliased (WindowFunction outer commons grp schemas params from)) row
464− -- ^ `NP` list of `Aliased` `WindowFunction`s
465− -> WindowDefinition outer commons grp schemas params from
466− -> Selection outer commons grp schemas params from row
467− Also
468− :: Selection outer commons grp schemas params from right
469− -- ^ `Additional` `Selection`
470− -> Selection outer commons grp schemas params from left
471− -> Selection outer commons grp schemas params from (Join left right)
472−instance Additional (Selection outer commons grp schemas params from) where
473− also = Also
474−instance (KnownSymbol col, row ~ '[col ::: ty])
475− => Aliasable col
476− (Expression outer commons grp schemas params from ty)
477− (Selection outer commons grp schemas params from row) where
478− expr `as` col = List (expr `as` col)
479−instance (Has tab (Join outer from) row0, Has col row0 ty, row1 ~ '[col ::: ty])
480− => IsQualified tab col
481− (Selection outer commons 'Ungrouped schemas params from row1) where
482− tab ! col = tab ! col `as` col
483−instance
484− ( Has tab (Join outer from) row0
485− , Has col row0 ty
486− , row1 ~ '[col ::: ty]
487− , GroupedBy tab col bys )
488− => IsQualified tab col
489− (Selection outer commons ('Grouped bys) schemas params from row1) where
490− tab ! col = tab ! col `as` col
491−instance (HasUnique tab (Join outer from) row0, Has col row0 ty, row1 ~ '[col ::: ty])
492− => IsLabel col
493− (Selection outer commons 'Ungrouped schemas params from row1) where
494− fromLabel = fromLabel @col `as` Alias
495−instance
496− ( HasUnique tab (Join outer from) row0
497− , Has col row0 ty
498− , row1 ~ '[col ::: ty]
499− , GroupedBy tab col bys )
500− => IsLabel col
501− (Selection outer commons ('Grouped bys) schemas params from row1) where
502− fromLabel = fromLabel @col `as` Alias
503−
504−instance RenderSQL (Selection outer commons grp schemas params from row) where
505− renderSQL = \case
506− List list -> renderCommaSeparated (renderAliased renderSQL) list
507− Star -> "*"
508− DotStar tab -> renderSQL tab <> ".*"
509− Also right left -> renderSQL left <> ", " <> renderSQL right
510− Over winFns winDef ->
511− let
512− renderOver
513− :: Aliased (WindowFunction outer commons grp schemas params from) field
514− -> ByteString
515− renderOver (winFn `As` col) = renderSQL winFn
516− <+> "OVER" <+> parenthesized (renderSQL winDef)
517− <+> "AS" <+> renderSQL col
518− in
519− renderCommaSeparated renderOver winFns
520−
521−instance IsString
522− (Selection outer commons grp schemas params from '["fromOnly" ::: 'NotNull 'PGtext]) where
523− fromString str = fromString str `as` Alias
524−
525-- | the `TableExpression` in the `select` command constructs an intermediate
340-- | the `TableExpression` in the `select` command constructs an intermediate
526-- virtual table by possibly combining tables, views, eliminating rows,
341-- virtual table by possibly combining tables, views, eliminating rows,
527-- grouping, etc. This table is finally passed on to processing by
342-- grouping, etc. This table is finally passed on to processing by
528−-- the select list. The `Selection` determines which columns of
343+-- the select list. The select list determines which columns of
529-- the intermediate table are actually output.
344-- the intermediate table are actually output.
530select
345select
531− :: (SListI row, row ~ (x ': xs))
346+ :: SListI columns
532− => Selection outer commons grp schemas params from row
347+ => NP (Aliased (Expression tables grouping params)) (column ': columns)
533− -- ^ selection
534− -> TableExpression outer commons grp schemas params from
535− -- ^ intermediate virtual table
536− -> Query outer commons schemas params row
537−select selection tabexpr = UnsafeQuery $
538− "SELECT"
539− <+> renderSQL selection
540− <+> renderSQL tabexpr
541−
542−-- | Like `select` but takes an `NP` list of `Expression`s instead
543−-- of a general `Selection`.
544−select_
545− :: (SListI row, row ~ (x ': xs))
546− => NP (Aliased (Expression outer commons grp schemas params from)) row
547 -- ^ select list
348 -- ^ select list
548− -> TableExpression outer commons grp schemas params from
349+ -> TableExpression schema params tables grouping
549 -- ^ intermediate virtual table
350 -- ^ intermediate virtual table
550− -> Query outer commons schemas params row
351+ -> Query schema params (column ': columns)
551−select_ = select . List
352+select list tabs = UnsafeQuery $
353+ "SELECT"
354+ <+> renderCommaSeparated (renderAliased renderExpression) list
355+ <+> renderTableExpression tabs
552
356
553-- | After the select list has been processed, the result table can
357-- | After the select list has been processed, the result table can
554-- be subject to the elimination of duplicate rows using `selectDistinct`.
358-- be subject to the elimination of duplicate rows using `selectDistinct`.
555selectDistinct
359selectDistinct
556− :: (SListI columns, columns ~ (col ': cols))
360+ :: SListI columns
557− => Selection outer commons grp schemas params from columns
361+ => NP (Aliased (Expression tables 'Ungrouped params)) (column ': columns)
558− -- ^ selection
362+ -- ^ select list
559− -> TableExpression outer commons grp schemas params from
363+ -> TableExpression schema params tables 'Ungrouped
560 -- ^ intermediate virtual table
364 -- ^ intermediate virtual table
561− -> Query outer commons schemas params columns
365+ -> Query schema params (column ': columns)
562−selectDistinct selection tabexpr = UnsafeQuery $
366+selectDistinct list tabs = UnsafeQuery $
563 "SELECT DISTINCT"
367 "SELECT DISTINCT"
564− <+> renderSQL selection
368+ <+> renderCommaSeparated (renderAliased renderExpression) list
565− <+> renderSQL tabexpr
369+ <+> renderTableExpression tabs
566−
370+
567−-- | Like `selectDistinct` but takes an `NP` list of `Expression`s instead
371+-- | The simplest kind of query is `selectStar` which emits all columns
568−-- of a general `Selection`.
372+-- that the table expression produces.
569−selectDistinct_
373+selectStar
570− :: (SListI columns, columns ~ (col ': cols))
374+ :: HasUnique table tables columns
571− => NP (Aliased (Expression outer commons grp schemas params from)) columns
375+ => TableExpression schema params tables 'Ungrouped
572− -- ^ select list
573− -> TableExpression outer commons grp schemas params from
574 -- ^ intermediate virtual table
376 -- ^ intermediate virtual table
575− -> Query outer commons schemas params columns
377+ -> Query schema params columns
576−selectDistinct_ = selectDistinct . List
378+selectStar tabs = UnsafeQuery $ "SELECT" <+> "*" <+> renderTableExpression tabs
577−
379+
578−{-|
380+-- | A `selectDistinctStar` emits all columns that the table expression
579−`selectDistinctOn` keeps only the first row of each set of rows where
381+-- produces and eliminates duplicate rows.
580−the given expressions evaluate to equal. The DISTINCT ON expressions are
382+selectDistinctStar
581−interpreted using the same rules as for ORDER BY. ORDER BY is used to
383+ :: HasUnique table tables columns
582−ensure that the desired row appears first.
384+ => TableExpression schema params tables 'Ungrouped
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
385 -- ^ intermediate virtual table
599− -> Query outer commons schemas params columns
386+ -> Query schema params columns
600−selectDistinctOn distincts selection tab = UnsafeQuery $
387+selectDistinctStar tabs = UnsafeQuery $
601− "SELECT DISTINCT ON"
388+ "SELECT DISTINCT" <+> "*" <+> renderTableExpression tabs
602− <+> parenthesized (commaSeparated (renderDistinctOn <$> distincts))
389+
603− <+> renderSQL selection
390+-- | When working with multiple tables, it can also be useful to ask
604− <+> renderSQL (tab {orderByClause = distincts <> orderByClause tab})
391+-- for all the columns of a particular table, using `selectDotStar`.
605− where
392+selectDotStar
606− renderDistinctOn = \case
393+ :: HasTable table tables columns
607− Asc expression -> renderSQL expression
394+ => Alias table
608− Desc expression -> renderSQL expression
395+ -- ^ particular virtual subtable
609− AscNullsFirst expression -> renderSQL expression
396+ -> TableExpression schema params tables 'Ungrouped
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
397 -- ^ intermediate virtual table
624− -> Query outer commons schemas params columns
398+ -> Query schema params columns
625−selectDistinctOn_ distincts = selectDistinctOn distincts . List
399+selectDotStar table tables = UnsafeQuery $
626−
400+ "SELECT" <+> renderAlias table <> ".*" <+> renderTableExpression tables
627−-- | `values` computes a row value or set of row values
401+
628−-- specified by value expressions. It is most commonly used
402+-- | A `selectDistinctDotStar` asks for all the columns of a particular table,
629−-- to generate a “constant table” within a larger command,
403+-- and eliminates duplicate rows.
630−-- but it can be used on its own.
404+selectDistinctDotStar
631−--
405+ :: HasTable table tables columns
632−-- >>> type Row = '["a" ::: 'NotNull 'PGint4, "b" ::: 'NotNull 'PGtext]
406+ => Alias table
633−-- >>> let query = values (1 `as` #a :* "one" `as` #b) [] :: Query outer commons schemas '[] Row
407+ -- ^ particular virtual subtable
634−-- >>> printSQL query
408+ -> TableExpression schema params tables 'Ungrouped
635−-- SELECT * FROM (VALUES (1, E'one')) AS t ("a", "b")
409+ -- ^ intermediate virtual table
636−values
410+ -> Query schema params columns
637− :: SListI cols
411+selectDistinctDotStar table tables = UnsafeQuery $
638− => NP (Aliased (Expression outer commons 'Ungrouped schemas params '[] )) cols
412+ "SELECT DISTINCT" <+> renderAlias table <> ".*"
639− -> [NP (Aliased (Expression outer commons 'Ungrouped schemas params '[] )) cols]
413+ <+> renderTableExpression tables
640− -- ^ When more than one row is specified, all the rows must
641− -- must have the same number of elements
642− -> Query outer commons schemas params cols
643−values rw rws = UnsafeQuery $ "SELECT * FROM"
644− <+> parenthesized (
645− "VALUES"
646− <+> commaSeparated
647− ( parenthesized
648− . renderCommaSeparated renderValuePart <$> rw:rws )
649− ) <+> "AS t"
650− <+> parenthesized (renderCommaSeparated renderAliasPart rw)
651− where
652− renderAliasPart, renderValuePart
653− :: Aliased (Expression outer commons 'Ungrouped schemas params '[] ) ty -> ByteString
654− renderAliasPart (_ `As` name) = renderSQL name
655− renderValuePart (value `As` _) = renderSQL value
656−
657−-- | `values_` computes a row value or set of row values
658−-- specified by value expressions.
659−values_
660− :: SListI cols
661− => NP (Aliased (Expression outer commons 'Ungrouped schemas params '[] )) cols
662− -- ^ one row of values
663− -> Query outer commons schemas params cols
664−values_ rw = values rw []
665
414
666{-----------------------------------------
415{-----------------------------------------
667Table Expressions
416Table Expressions
@@ -674,17 +423,15 @@ Table Expressions
674-- to a table on disk, a so-called base table, but more complex expressions
423-- to a table on disk, a so-called base table, but more complex expressions
675-- can be used to modify or combine base tables in various ways.
424-- can be used to modify or combine base tables in various ways.
676data TableExpression
425data TableExpression
677− (outer :: FromType)
426+ (schema :: TablesType)
678− (commons :: FromType)
427+ (params :: [ColumnType])
679− (grp :: Grouping)
428+ (tables :: TablesType)
680− (schemas :: SchemasType)
429+ (grouping :: Grouping)
681− (params :: [NullityType])
682− (from :: FromType)
683 = TableExpression
430 = TableExpression
684− { fromClause :: FromClause outer commons schemas params from
431+ { fromClause :: FromClause schema params tables
685 -- ^ A table reference that can be a table name, or a derived table such
432 -- ^ A table reference that can be a table name, or a derived table such
686 -- as a subquery, a @JOIN@ construct, or complex combinations of these.
433 -- as a subquery, a @JOIN@ construct, or complex combinations of these.
687− , whereClause :: [Condition outer commons 'Ungrouped schemas params from]
434+ , whereClause :: [Condition tables 'Ungrouped params]
688 -- ^ optional search coditions, combined with `.&&`. After the processing
435 -- ^ optional search coditions, combined with `.&&`. After the processing
689 -- of the `fromClause` is done, each row of the derived virtual table
436 -- of the `fromClause` is done, each row of the derived virtual table
690 -- is checked against the search condition. If the result of the
437 -- is checked against the search condition. If the result of the
@@ -693,20 +440,20 @@ data TableExpression
693 -- at least one column of the table generated in the `fromClause`;
440 -- at least one column of the table generated in the `fromClause`;
694 -- this is not required, but otherwise the WHERE clause will
441 -- this is not required, but otherwise the WHERE clause will
695 -- be fairly useless.
442 -- be fairly useless.
696− , groupByClause :: GroupByClause grp from
443+ , groupByClause :: GroupByClause tables grouping
697 -- ^ The `groupByClause` is used to group together those rows in a table
444 -- ^ The `groupByClause` is used to group together those rows in a table
698 -- that have the same values in all the columns listed. The order in which
445 -- that have the same values in all the columns listed. The order in which
699 -- the columns are listed does not matter. The effect is to combine each
446 -- the columns are listed does not matter. The effect is to combine each
700 -- set of rows having common values into one group row that represents all
447 -- set of rows having common values into one group row that represents all
701 -- rows in the group. This is done to eliminate redundancy in the output
448 -- rows in the group. This is done to eliminate redundancy in the output
702 -- and/or compute aggregates that apply to these groups.
449 -- and/or compute aggregates that apply to these groups.
703− , havingClause :: HavingClause outer commons grp schemas params from
450+ , havingClause :: HavingClause tables grouping params
704 -- ^ If a table has been grouped using `groupBy`, but only certain groups
451 -- ^ If a table has been grouped using `groupBy`, but only certain groups
705 -- are of interest, the `havingClause` can be used, much like a
452 -- are of interest, the `havingClause` can be used, much like a
706 -- `whereClause`, to eliminate groups from the result. Expressions in the
453 -- `whereClause`, to eliminate groups from the result. Expressions in the
707 -- `havingClause` can refer both to grouped expressions and to ungrouped
454 -- `havingClause` can refer both to grouped expressions and to ungrouped
708 -- expressions (which necessarily involve an aggregate function).
455 -- expressions (which necessarily involve an aggregate function).
709− , orderByClause :: [SortExpression outer commons grp schemas params from]
456+ , orderByClause :: [SortExpression tables grouping params]
710 -- ^ The `orderByClause` is for optional sorting. When more than one
457 -- ^ The `orderByClause` is for optional sorting. When more than one
711 -- `SortExpression` is specified, the later (right) values are used to sort
458 -- `SortExpression` is specified, the later (right) values are used to sort
712 -- rows that are equal according to the earlier (left) values.
459 -- rows that are equal according to the earlier (left) values.
@@ -716,102 +463,110 @@ data TableExpression
716 -- will be returned (but possibly fewer, if the query itself yields
463 -- will be returned (but possibly fewer, if the query itself yields
717 -- fewer rows).
464 -- fewer rows).
718 , offsetClause :: [Word64]
465 , offsetClause :: [Word64]
719− -- ^ The `offsetClause` is combined with `Prelude.+` to give an offset count
466+ -- ^ The `offsetClause` is combined with `+` to give an offset count
720 -- if nonempty. The offset count says to skip that many rows before
467 -- if nonempty. The offset count says to skip that many rows before
721 -- beginning to return rows. The rows are skipped before the limit count
468 -- beginning to return rows. The rows are skipped before the limit count
722 -- is applied.
469 -- is applied.
723− } deriving (GHC.Generic)
470+ }
724
471
725-- | Render a `TableExpression`
472-- | Render a `TableExpression`
726−instance RenderSQL (TableExpression outer commons grp schemas params from) where
473+renderTableExpression
727− renderSQL
474+ :: TableExpression schema params tables grouping
728− (TableExpression frm' whs' grps' hvs' srts' lims' offs') = mconcat
475+ -> ByteString
729− [ "FROM ", renderSQL frm'
476+renderTableExpression
730− , renderWheres whs'
477+ (TableExpression tables whs' grps' hvs' srts' lims' offs') = mconcat
731− , renderSQL grps'
478+ [ "FROM ", renderFromClause tables
732− , renderSQL hvs'
479+ , renderWheres whs'
733− , renderOrderByClause srts'
480+ , renderGroupByClause grps'
734− , renderLimits lims'
481+ , renderHavingClause hvs'
735− , renderOffsets offs' ]
482+ , renderOrderByClause srts'
736− where
483+ , renderLimits lims'
737− renderWheres = \case
484+ , renderOffsets offs'
738− [] -> ""
485+ ]
739− wh:[] -> " WHERE" <+> renderSQL wh
486+ where
740− wh:whs -> " WHERE" <+> renderSQL (foldr (.&&) wh whs)
487+ renderWheres = \case
741− renderOrderByClause = \case
488+ [] -> ""
742− [] -> ""
489+ wh:[] -> " WHERE" <+> renderExpression wh
743− srts -> " ORDER BY"
490+ wh:whs -> " WHERE" <+> renderExpression (foldr (.&&) wh whs)
744− <+> commaSeparated (renderSQL <$> srts)
491+ renderOrderByClause = \case
745− renderLimits = \case
492+ [] -> ""
746− [] -> ""
493+ srts -> " ORDER BY"
747− lims -> " LIMIT" <+> fromString (show (minimum lims))
494+ <+> commaSeparated (renderSortExpression <$> srts)
748− renderOffsets = \case
495+ renderLimits = \case
749− [] -> ""
496+ [] -> ""
750− offs -> " OFFSET" <+> fromString (show (sum offs))
497+ lims -> " LIMIT" <+> fromString (show (minimum lims))
498+ renderOffsets = \case
499+ [] -> ""
500+ offs -> " OFFSET" <+> fromString (show (sum offs))
751
501
752-- | A `from` generates a `TableExpression` from a table reference that can be
502-- | A `from` generates a `TableExpression` from a table reference that can be
753-- a table name, or a derived table such as a subquery, a JOIN construct,
503-- a table name, or a derived table such as a subquery, a JOIN construct,
754-- or complex combinations of these. A `from` may be transformed by `where_`,
504-- or complex combinations of these. A `from` may be transformed by `where_`,
755−-- `groupBy`, `having`, `orderBy`, `limit` and `offset`, using the `&` operator
505+-- `group`, `having`, `orderBy`, `limit` and `offset`, using the `&` operator
756-- to match the left-to-right sequencing of their placement in SQL.
506-- to match the left-to-right sequencing of their placement in SQL.
757from
507from
758− :: FromClause outer commons schemas params from -- ^ table reference
508+ :: FromClause schema params tables -- ^ table reference
759− -> TableExpression outer commons 'Ungrouped schemas params from
509+ -> TableExpression schema params tables 'Ungrouped
760−from tab = TableExpression tab [] noGroups NoHaving [] [] []
510+from tables = TableExpression tables [] NoGroups NoHaving [] [] []
761
511
762-- | A `where_` is an endomorphism of `TableExpression`s which adds a
512-- | A `where_` is an endomorphism of `TableExpression`s which adds a
763-- search condition to the `whereClause`.
513-- search condition to the `whereClause`.
764where_
514where_
765− :: Condition outer commons 'Ungrouped schemas params from -- ^ filtering condition
515+ :: Condition tables 'Ungrouped params
766− -> TableExpression outer commons grp schemas params from
516+ -> TableExpression schema params tables grouping
767− -> TableExpression outer commons grp schemas params from
517+ -> TableExpression schema params tables grouping
768−where_ wh rels = rels {whereClause = wh : whereClause rels}
518+where_ wh tables = tables {whereClause = wh : whereClause tables}
769
519
770−-- | A `groupBy` is a transformation of `TableExpression`s which switches
520+-- | A `group` is a transformation of `TableExpression`s which switches
771−-- its `Grouping` from `Ungrouped` to `Grouped`. Use @groupBy Nil@ to perform
521+-- its `Grouping` from `Ungrouped` to `Grouped`. Use @group Nil@ to perform
772-- a "grand total" aggregation query.
522-- a "grand total" aggregation query.
773−groupBy
523+group
774 :: SListI bys
524 :: SListI bys
775− => NP (By from) bys -- ^ grouped columns
525+ => NP (By tables) bys
776− -> TableExpression outer commons 'Ungrouped schemas params from
526+ -> TableExpression schema params tables 'Ungrouped
777− -> TableExpression outer commons ('Grouped bys) schemas params from
527+ -> TableExpression schema params tables ('Grouped bys)
778−groupBy bys rels = TableExpression
528+group bys tables = TableExpression
779− { fromClause = fromClause rels
529+ { fromClause = fromClause tables
780− , whereClause = whereClause rels
530+ , whereClause = whereClause tables
781− , groupByClause = group bys
531+ , groupByClause = Group bys
782 , havingClause = Having []
532 , havingClause = Having []
783 , orderByClause = []
533 , orderByClause = []
784− , limitClause = limitClause rels
534+ , limitClause = limitClause tables
785− , offsetClause = offsetClause rels
535+ , offsetClause = offsetClause tables
786 }
536 }
787
537
788-- | A `having` is an endomorphism of `TableExpression`s which adds a
538-- | A `having` is an endomorphism of `TableExpression`s which adds a
789-- search condition to the `havingClause`.
539-- search condition to the `havingClause`.
790having
540having
791− :: Condition outer commons ('Grouped bys) schemas params from -- ^ having condition
541+ :: Condition tables ('Grouped bys) params
792− -> TableExpression outer commons ('Grouped bys) schemas params from
542+ -> TableExpression schema params tables ('Grouped bys)
793− -> TableExpression outer commons ('Grouped bys) schemas params from
543+ -> TableExpression schema params tables ('Grouped bys)
794−having hv rels = rels
544+having hv tables = tables
795− { havingClause = case havingClause rels of Having hvs -> Having (hv:hvs) }
545+ { havingClause = case havingClause tables of Having hvs -> Having (hv:hvs) }
796−
546+
797−instance OrderBy TableExpression where
547+-- | An `orderBy` is an endomorphism of `TableExpression`s which appends an
798− orderBy srts rels = rels {orderByClause = orderByClause rels ++ srts}
548+-- ordering to the right of the `orderByClause`.
549+orderBy
550+ :: [SortExpression tables grouping params]
551+ -> TableExpression schema params tables grouping
552+ -> TableExpression schema params tables grouping
553+orderBy srts tables = tables {orderByClause = orderByClause tables ++ srts}
799
554
800-- | A `limit` is an endomorphism of `TableExpression`s which adds to the
555-- | A `limit` is an endomorphism of `TableExpression`s which adds to the
801-- `limitClause`.
556-- `limitClause`.
802limit
557limit
803− :: Word64 -- ^ limit parameter
558+ :: Word64
804− -> TableExpression outer commons grp schemas params from
559+ -> TableExpression schema params tables grouping
805− -> TableExpression outer commons grp schemas params from
560+ -> TableExpression schema params tables grouping
806−limit lim rels = rels {limitClause = lim : limitClause rels}
561+limit lim tables = tables {limitClause = lim : limitClause tables}
807
562
808-- | An `offset` is an endomorphism of `TableExpression`s which adds to the
563-- | An `offset` is an endomorphism of `TableExpression`s which adds to the
809-- `offsetClause`.
564-- `offsetClause`.
810offset
565offset
811− :: Word64 -- ^ offset parameter
566+ :: Word64
812− -> TableExpression outer commons grp schemas params from
567+ -> TableExpression schema params tables grouping
813− -> TableExpression outer commons grp schemas params from
568+ -> TableExpression schema params tables grouping
814−offset off rels = rels {offsetClause = off : offsetClause rels}
569+offset off tables = tables {offsetClause = off : offsetClause tables}
815
570
816{-----------------------------------------
571{-----------------------------------------
817FROM clauses
572FROM clauses
@@ -820,279 +575,205 @@ FROM clauses
820{- |
575{- |
821A `FromClause` can be a table name, or a derived table such
576A `FromClause` can be a table name, or a derived table such
822as a subquery, a @JOIN@ construct, or complex combinations of these.
577as a subquery, a @JOIN@ construct, or complex combinations of these.
823−-}
824−newtype FromClause outer commons schemas params from
825− = UnsafeFromClause { renderFromClause :: ByteString }
826− deriving (GHC.Generic,Show,Eq,Ord,NFData)
827−instance RenderSQL (FromClause outer commons schemas params from) where
828− renderSQL = renderFromClause
829−
830−-- | A real `table` is a table from the database.
831−table
832− :: (Has sch schemas schema, Has tab schema ('Table table))
833− => Aliased (QualifiedAlias sch) (alias ::: tab)
834− -> FromClause outer commons schemas params '[alias ::: TableToRow table]
835−table (tab `As` alias) = UnsafeFromClause $
836− renderSQL tab <+> "AS" <+> renderSQL alias
837−
838−-- | `subquery` derives a table from a `Query`.
839−subquery
840− :: Aliased (Query outer commons schemas params) query
841− -> FromClause outer commons schemas params '[query]
842−subquery = UnsafeFromClause . renderAliased (parenthesized . renderSQL)
843−
844−-- | `view` derives a table from a `View`.
845−view
846− :: (Has sch schemas schema, Has vw schema ('View view))
847− => Aliased (QualifiedAlias sch) (alias ::: vw)
848− -> FromClause outer commons schemas params '[alias ::: view]
849−view (vw `As` alias) = UnsafeFromClause $
850− renderSQL vw <+> "AS" <+> renderSQL alias
851−
852−-- | `common` derives a table from a common table expression.
853−common
854− :: Has cte commons common
855− => Aliased Alias (alias ::: cte)
856− -> FromClause outer commons schemas params '[alias ::: common]
857−common (cte `As` alias) = UnsafeFromClause $
858− renderSQL cte <+> "AS" <+> renderSQL alias
859−
860−instance Additional (FromClause outer commons schemas params) where
861− also right left = UnsafeFromClause $
862− renderSQL left <> ", " <> renderSQL right
863
578
864−{- |
579+* A real `Table` is a table from the schema.
865−@left & crossJoin right@. For every possible combination of rows from
580+
866−@left@ and @right@ (i.e., a Cartesian product), the joined table will contain
581+* `Subquery` derives a table from a `Query`.
867−a row consisting of all columns in @left@ followed by all columns in @right@.
582+
868−If the tables have @n@ and @m@ rows respectively, the joined table will
583+* A joined table is a table derived from two other (real or derived) tables
869−have @n * m@ rows.
584+according to the rules of the particular join type. `CrossJoin`, `InnerJoin`,
870−-}
585+`LeftOuterJoin`, `RightOuterJoin` and `FullOuterJoin` are available and can
871−crossJoin
586+be nested using the `&` operator to match the left-to-right sequencing of
872− :: FromClause outer commons schemas params right
587+their placement in SQL.
873− -- ^ right
588+
874− -> FromClause outer commons schemas params left
589+ * @t1 & CrossJoin t2@. For every possible combination of rows from
875− -- ^ left
590+ @t1@ and @t2@ (i.e., a Cartesian product), the joined table will contain
876− -> FromClause outer commons schemas params (Join left right)
591+ a row consisting of all columns in @t1@ followed by all columns in @t2@.
877−crossJoin right left = UnsafeFromClause $
592+ If the tables have @n@ and @m@ rows respectively, the joined table will
878− renderSQL left <+> "CROSS JOIN" <+> renderSQL right
593+ have @n * m@ rows.
879−
594+
880−{- | @left & innerJoin right on@. The joined table is filtered by
595+ * @t1 & InnerJoin t2 on@. For each row @r1@ of @t1@, the joined
881−the @on@ condition.
596+ table has a row for each row in @t2@ that satisfies the @on@ condition
882−-}
597+ with @r1@
883−innerJoin
598+
884− :: FromClause outer commons schemas params right
599+ * @t1 & LeftOuterJoin t2 on@. First, an inner join is performed.
885− -- ^ right
600+ Then, for each row in @t1@ that does not satisfy the @on@ condition with
886− -> Condition outer commons 'Ungrouped schemas params (Join left right)
601+ any row in @t2@, a joined row is added with null values in columns of @t2@.
887− -- ^ @on@ condition
602+ Thus, the joined table always has at least one row for each row in @t1@.
888− -> FromClause outer commons schemas params left
603+
889− -- ^ left
604+ * @t1 & RightOuterJoin t2 on@. First, an inner join is performed.
890− -> FromClause outer commons schemas params (Join left right)
605+ Then, for each row in @t2@ that does not satisfy the @on@ condition with
891−innerJoin right on left = UnsafeFromClause $
606+ any row in @t1@, a joined row is added with null values in columns of @t1@.
892− renderSQL left <+> "INNER JOIN" <+> renderSQL right
893− <+> "ON" <+> renderSQL on
894−
895−{- | @left & leftOuterJoin right on@. First, an inner join is performed.
896− Then, for each row in @left@ that does not satisfy the @on@ condition with
897− any row in @right@, a joined row is added with null values in columns of @right@.
898− Thus, the joined table always has at least one row for each row in @left@.
899−-}
900−leftOuterJoin
901− :: FromClause outer commons schemas params right
902− -- ^ right
903− -> Condition outer commons 'Ungrouped schemas params (Join left right)
904− -- ^ @on@ condition
905− -> FromClause outer commons schemas params left
906− -- ^ left
907− -> FromClause outer commons schemas params (Join left (NullifyFrom right))
908−leftOuterJoin right on left = UnsafeFromClause $
909− renderSQL left <+> "LEFT OUTER JOIN" <+> renderSQL right
910− <+> "ON" <+> renderSQL on
911−
912−{- | @left & rightOuterJoin right on@. First, an inner join is performed.
913− Then, for each row in @right@ that does not satisfy the @on@ condition with
914− any row in @left@, a joined row is added with null values in columns of @left@.
915 This is the converse of a left join: the result table will always
607 This is the converse of a left join: the result table will always
916− have a row for each row in @right@.
608+ have a row for each row in @t2@.
917−-}
609+
918−rightOuterJoin
610+ * @t1 & FullOuterJoin t2 on@. First, an inner join is performed.
919− :: FromClause outer commons schemas params right
611+ Then, for each row in @t1@ that does not satisfy the @on@ condition with
920− -- ^ right
612+ any row in @t2@, a joined row is added with null values in columns of @t2@.
921− -> Condition outer commons 'Ungrouped schemas params (Join left right)
613+ Also, for each row of @t2@ that does not satisfy the join condition
922− -- ^ @on@ condition
614+ with any row in @t1@, a joined row with null values in the columns of @t1@
923− -> FromClause outer commons schemas params left
924− -- ^ left
925− -> FromClause outer commons schemas params (Join (NullifyFrom left) right)
926−rightOuterJoin right on left = UnsafeFromClause $
927− renderSQL left <+> "RIGHT OUTER JOIN" <+> renderSQL right
928− <+> "ON" <+> renderSQL on
929−
930−{- | @left & fullOuterJoin right on@. First, an inner join is performed.
931− Then, for each row in @left@ that does not satisfy the @on@ condition with
932− any row in @right@, a joined row is added with null values in columns of @right@.
933− Also, for each row of @right@ that does not satisfy the join condition
934− with any row in @left@, a joined row with null values in the columns of @left@
935 is added.
615 is added.
936-}
616-}
937−fullOuterJoin
617+data FromClause schema params tables where
938− :: FromClause outer commons schemas params right
618+ Table
939− -- ^ right
619+ :: Aliased (Table schema) table
940− -> Condition outer commons 'Ungrouped schemas params (Join left right)
620+ -> FromClause schema params '[table]
941− -- ^ @on@ condition
621+ Subquery
942− -> FromClause outer commons schemas params left
622+ :: Aliased (Query schema params) table
943− -- ^ left
623+ -> FromClause schema params '[table]
944− -> FromClause outer commons schemas params
624+ CrossJoin
945− (Join (NullifyFrom left) (NullifyFrom right))
625+ :: FromClause schema params right
946−fullOuterJoin right on left = UnsafeFromClause $
626+ -> FromClause schema params left
947− renderSQL left <+> "FULL OUTER JOIN" <+> renderSQL right
627+ -> FromClause schema params (Join left right)
948− <+> "ON" <+> renderSQL on
628+ InnerJoin
629+ :: FromClause schema params right
630+ -> Condition (Join left right) 'Ungrouped params
631+ -> FromClause schema params left
632+ -> FromClause schema params (Join left right)
633+ LeftOuterJoin
634+ :: FromClause schema params right
635+ -> Condition (Join left right) 'Ungrouped params
636+ -> FromClause schema params left
637+ -> FromClause schema params (Join left (NullifyTables right))
638+ RightOuterJoin
639+ :: FromClause schema params right
640+ -> Condition (Join left right) 'Ungrouped params
641+ -> FromClause schema params left
642+ -> FromClause schema params (Join (NullifyTables left) right)
643+ FullOuterJoin
644+ :: FromClause schema params right
645+ -> Condition (Join left right) 'Ungrouped params
646+ -> FromClause schema params left
647+ -> FromClause schema params
648+ (Join (NullifyTables left) (NullifyTables right))
649+
650+-- | Renders a `FromClause`.
651+renderFromClause :: FromClause schema params tables -> ByteString
652+renderFromClause = \case
653+ Table table -> renderAliased renderTable table
654+ Subquery selection -> renderAliased (parenthesized . renderQuery) selection
655+ CrossJoin right left ->
656+ renderFromClause left <+> "CROSS JOIN" <+> renderFromClause right
657+ InnerJoin right on left -> renderJoin "INNER JOIN" right on left
658+ LeftOuterJoin right on left -> renderJoin "LEFT OUTER JOIN" right on left
659+ RightOuterJoin right on left -> renderJoin "RIGHT OUTER JOIN" right on left
660+ FullOuterJoin right on left -> renderJoin "FULL OUTER JOIN" right on left
661+ where
662+ renderJoin op right on left =
663+ renderFromClause left <+> op <+> renderFromClause right
664+ <+> "ON" <+> renderExpression on
949
665
950{-----------------------------------------
666{-----------------------------------------
951Grouping
667Grouping
952-----------------------------------------}
668-----------------------------------------}
953
669
954−-- | `By`s are used in `groupBy` to reference a list of columns which are then
670+-- | `By`s are used in `group` to reference a list of columns which are then
955-- used to group together those rows in a table that have the same values
671-- used to group together those rows in a table that have the same values
956-- in all the columns listed. @By \#col@ will reference an unambiguous
672-- in all the columns listed. @By \#col@ will reference an unambiguous
957-- column @col@; otherwise @By2 (\#tab \! \#col)@ will reference a table
673-- column @col@; otherwise @By2 (\#tab \! \#col)@ will reference a table
958-- qualified column @tab.col@.
674-- qualified column @tab.col@.
959data By
675data By
960− (from :: FromType)
676+ (tables :: TablesType)
961 (by :: (Symbol,Symbol)) where
677 (by :: (Symbol,Symbol)) where
962− By1
678+ By
963− :: (HasUnique table from columns, Has column columns ty)
679+ :: (HasUnique table tables columns, HasColumn column columns ty)
964 => Alias column
680 => Alias column
965− -> By from '(table, column)
681+ -> By tables '(table, column)
966 By2
682 By2
967− :: (Has table from columns, Has column columns ty)
683+ :: (HasTable table tables columns, HasColumn column columns ty)
968− => Alias table
684+ => (Alias table, Alias column)
969− -> Alias column
685+ -> By tables '(table, column)
970− -> By from '(table, column)
686+deriving instance Show (By tables by)
971−deriving instance Show (By from by)
687+deriving instance Eq (By tables by)
972−deriving instance Eq (By from by)
688+deriving instance Ord (By tables by)
973−deriving instance Ord (By from by)
689+
974−instance RenderSQL (By from by) where
690+-- | Renders a `By`.
975− renderSQL = \case
691+renderBy :: By tables tabcolty -> ByteString
976− By1 column -> renderSQL column
692+renderBy = \case
977− By2 rel column -> renderSQL rel <> "." <> renderSQL column
693+ By column -> renderAlias column
978−
694+ By2 (table, column) -> renderAlias table <> "." <> renderAlias column
979−instance (HasUnique rel rels cols, Has col cols ty, by ~ '(rel, col))
980− => IsLabel col (By rels by) where fromLabel = By1 fromLabel
981−instance (HasUnique rel rels cols, Has col cols ty, bys ~ '[ '(rel, col)])
982− => IsLabel col (NP (By rels) bys) where fromLabel = By1 fromLabel :* Nil
983−instance (Has rel rels cols, Has col cols ty, by ~ '(rel, col))
984− => IsQualified rel col (By rels by) where (!) = By2
985−instance (Has rel rels cols, Has col cols ty, bys ~ '[ '(rel, col)])
986− => IsQualified rel col (NP (By rels) bys) where
987− rel ! col = By2 rel col :* Nil
988
695
989-- | A `GroupByClause` indicates the `Grouping` of a `TableExpression`.
696-- | A `GroupByClause` indicates the `Grouping` of a `TableExpression`.
990-- A `NoGroups` indicates `Ungrouped` while a `Group` indicates `Grouped`.
697-- A `NoGroups` indicates `Ungrouped` while a `Group` indicates `Grouped`.
991-- @NoGroups@ is distinguised from @Group Nil@ since no aggregation can be
698-- @NoGroups@ is distinguised from @Group Nil@ since no aggregation can be
992-- done on @NoGroups@ while all output `Expression`s must be aggregated
699-- done on @NoGroups@ while all output `Expression`s must be aggregated
993−-- in @Group Nil@. In general, all output `Expression`s in the
700+-- in @Group Nil@.
994−-- complement of @bys@ must be aggregated in @Group bys@.
701+data GroupByClause tables grouping where
995−newtype GroupByClause grp from = UnsafeGroupByClause
702+ NoGroups :: GroupByClause tables 'Ungrouped
996− { renderGroupByClause :: ByteString }
703+ Group
997− deriving (GHC.Generic,Show,Eq,Ord,NFData)
704+ :: SListI bys
998−instance RenderSQL (GroupByClause grp from) where
705+ => NP (By tables) bys
999− renderSQL = renderGroupByClause
706+ -> GroupByClause tables ('Grouped bys)
1000−noGroups :: GroupByClause 'Ungrouped from
707+
1001−noGroups = UnsafeGroupByClause ""
708+-- | Renders a `GroupByClause`.
1002−group
709+renderGroupByClause :: GroupByClause tables grouping -> ByteString
1003− :: SListI bys
710+renderGroupByClause = \case
1004− => NP (By from) bys
711+ NoGroups -> ""
1005− -> GroupByClause ('Grouped bys) from
712+ Group Nil -> ""
1006−group bys = UnsafeGroupByClause $ case bys of
713+ Group bys -> " GROUP BY" <+> renderCommaSeparated renderBy bys
1007− Nil -> ""
1008− bys' -> " GROUP BY" <+> renderCommaSeparated renderSQL bys'
1009
714
1010-- | A `HavingClause` is used to eliminate groups that are not of interest.
715-- | A `HavingClause` is used to eliminate groups that are not of interest.
1011-- An `Ungrouped` `TableExpression` may only use `NoHaving` while a `Grouped`
716-- An `Ungrouped` `TableExpression` may only use `NoHaving` while a `Grouped`
1012-- `TableExpression` must use `Having` whose conditions are combined with
717-- `TableExpression` must use `Having` whose conditions are combined with
1013-- `.&&`.
718-- `.&&`.
1014−data HavingClause outer commons grp schemas params from where
719+data HavingClause tables grouping params where
1015− NoHaving :: HavingClause outer commons 'Ungrouped schemas params from
720+ NoHaving :: HavingClause tables 'Ungrouped params
1016 Having
721 Having
1017− :: [Condition outer commons ('Grouped bys) schemas params from]
722+ :: [Condition tables ('Grouped bys) params]
1018− -> HavingClause outer commons ('Grouped bys) schemas params from
723+ -> HavingClause tables ('Grouped bys) params
1019−deriving instance Show (HavingClause outer commons grp schemas params from)
724+deriving instance Show (HavingClause tables grouping params)
1020−deriving instance Eq (HavingClause outer commons grp schemas params from)
725+deriving instance Eq (HavingClause tables grouping params)
1021−deriving instance Ord (HavingClause outer commons grp schemas params from)
726+deriving instance Ord (HavingClause tables grouping params)
1022
727
1023-- | Render a `HavingClause`.
728-- | Render a `HavingClause`.
1024−instance RenderSQL (HavingClause outer commons grp schemas params from) where
729+renderHavingClause :: HavingClause tables grouping params -> ByteString
1025− renderSQL = \case
730+renderHavingClause = \case
1026− NoHaving -> ""
731+ NoHaving -> ""
1027− Having [] -> ""
732+ Having [] -> ""
1028− Having conditions ->
733+ Having conditions ->
1029− " HAVING" <+> commaSeparated (renderSQL <$> conditions)
734+ " HAVING" <+> commaSeparated (renderExpression <$> conditions)
1030−
1031−-- | A `CommonTableExpression` is an auxiliary statement in a `with` clause.
1032−data CommonTableExpression statement
1033− (schemas :: SchemasType)
1034− (params :: [NullityType])
1035− (commons0 :: FromType)
1036− (commons1 :: FromType) where
1037− CommonTableExpression
1038− :: Aliased (statement commons schemas params) (cte ::: common)
1039− -> CommonTableExpression statement schemas params commons (cte ::: common ': commons)
1040−instance
1041− ( KnownSymbol cte
1042− , commons1 ~ (cte ::: common ': commons)
1043− ) => Aliasable cte
1044− (statement commons schemas params common)
1045− (CommonTableExpression statement schemas params commons commons1) where
1046− statement `as` cte = CommonTableExpression (statement `as` cte)
1047−instance
1048− ( KnownSymbol cte
1049− , commons1 ~ (cte ::: common ': commons)
1050− ) => Aliasable cte
1051− (statement commons schemas params common)
1052− (Path (CommonTableExpression statement schemas params) commons commons1) where
1053− statement `as` cte = csingleton (statement `as` cte)
1054−
1055−instance (forall c s p r. RenderSQL (statement c s p r)) => RenderSQL
1056− (CommonTableExpression statement schemas params commons0 commons1) where
1057− renderSQL (CommonTableExpression (statement `As` cte)) =
1058− renderSQL cte <+> "AS" <+> parenthesized (renderSQL statement)
1059−
1060−-- | `with` provides a way to write auxiliary statements for use in a larger query.
1061−-- These statements, referred to as `CommonTableExpression`s, can be thought of as
1062−-- defining temporary tables that exist just for one query.
1063−class With statement where
1064− with
1065− :: Path (CommonTableExpression statement schemas params) commons0 commons1
1066− -- ^ common table expressions
1067− -> statement commons1 schemas params row
1068− -- ^ larger query
1069− -> statement commons0 schemas params row
1070−instance With (Query outer) where
1071− with Done query = query
1072− with ctes query = UnsafeQuery $
1073− "WITH" <+> commaSeparated (ctoList renderSQL ctes) <+> renderSQL query
1074
735
1075−{- |
736+{-----------------------------------------
1076−>>> import Data.Monoid (Sum (..))
737+Sorting
1077−>>> import Data.Int (Int64)
738+-----------------------------------------}
1078−>>> :{
739+
1079− let
740+-- | `SortExpression`s are used by `sortBy` to optionally sort the results
1080− query :: Query_ schema () (Sum Int64)
741+-- of a `Query`. `Asc` or `Desc` set the sort direction of a `NotNull` result
1081− query = withRecursive
742+-- column to ascending or descending. Ascending order puts smaller values
1082− ( values_ ((1 & astype int) `as` #n)
743+-- first, where "smaller" is defined in terms of the `.<` operator. Similarly,
1083− `unionAll`
744+-- descending order is determined with the `.>` operator. `AscNullsFirst`,
1084− select_ ((#n + 1) `as` #n)
745+-- `AscNullsLast`, `DescNullsFirst` and `DescNullsLast` options are used to
1085− (from (common #t) & where_ (#n .< 100)) `as` #t )
746+-- determine whether nulls appear before or after non-null values in the sort
1086− ( select_ (fromNull 0 (sum_ (All #n)) `as` #getSum) (from (common #t) & groupBy Nil))
747+-- ordering of a `Null` result column.
1087− in printSQL query
748+data SortExpression tables grouping params where
1088−:}
749+ Asc
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"
750+ :: Expression tables grouping params ('Required ('NotNull ty))
1090−-}
751+ -> SortExpression tables grouping params
1091−withRecursive
752+ Desc
1092− :: Aliased (Query outer (recursive ': commons) schemas params) recursive
753+ :: Expression tables grouping params ('Required ('NotNull ty))
1093− -> Query outer (recursive ': commons) schemas params row
754+ -> SortExpression tables grouping params
1094− -> Query outer commons schemas params row
755+ AscNullsFirst
1095−withRecursive (recursive `As` cte) query = UnsafeQuery $
756+ :: Expression tables grouping params ('Required ('Null ty))
1096− "WITH RECURSIVE" <+> renderSQL cte
757+ -> SortExpression tables grouping params
1097− <+> "AS" <+> parenthesized (renderSQL recursive)
758+ AscNullsLast
1098− <+> renderSQL query
759+ :: Expression tables grouping params ('Required ('Null ty))
760+ -> SortExpression tables grouping params
761+ DescNullsFirst
762+ :: Expression tables grouping params ('Required ('Null ty))
763+ -> SortExpression tables grouping params
764+ DescNullsLast
765+ :: Expression tables grouping params ('Required ('Null ty))
766+ -> SortExpression tables grouping params
767+deriving instance Show (SortExpression tables grouping params)
768+
769+-- | Render a `SortExpression`.
770+renderSortExpression :: SortExpression tables grouping params -> ByteString
771+renderSortExpression = \case
772+ Asc expression -> renderExpression expression <+> "ASC"
773+ Desc expression -> renderExpression expression <+> "DESC"
774+ AscNullsFirst expression -> renderExpression expression
775+ <+> "ASC NULLS FIRST"
776+ DescNullsFirst expression -> renderExpression expression
777+ <+> "DESC NULLS FIRST"
778+ AscNullsLast expression -> renderExpression expression <+> "ASC NULLS LAST"
779+ DescNullsLast expression -> renderExpression expression <+> "DESC NULLS LAST"
squeal-postgresql/src/Squeal/PostgreSQL/Render.hsdeleted−145
@@ -1,145 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Render
3−Description: Rendering helper functions
4−Copyright: (c) Eitan Chatav, 2017
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Rendering helper functions.
9−-}
10−
11−{-# LANGUAGE
12− AllowAmbiguousTypes
13− , ConstraintKinds
14− , FlexibleContexts
15− , LambdaCase
16− , MagicHash
17− , OverloadedStrings
18− , PolyKinds
19− , RankNTypes
20− , ScopedTypeVariables
21− , TypeApplications
22−#-}
23−
24−module Squeal.PostgreSQL.Render
25− ( -- * Render
26− RenderSQL (..)
27− , printSQL
28− , escape
29− , parenthesized
30− , bracketed
31− , (<+>)
32− , commaSeparated
33− , doubleQuoted
34− , singleQuotedText
35− , singleQuotedUtf8
36− , renderCommaSeparated
37− , renderCommaSeparatedConstraint
38− , renderCommaSeparatedMaybe
39− , renderNat
40− , renderSymbol
41− ) where
42−
43−import Control.Monad.IO.Class (MonadIO (..))
44−import Data.ByteString (ByteString)
45−import Data.Maybe (catMaybes)
46−import Data.Monoid ((<>))
47−import Data.Text (Text)
48−import Generics.SOP
49−import GHC.Exts
50−import GHC.TypeLits hiding (Text)
51−
52−import qualified Data.Text as Text
53−import qualified Data.Text.Encoding as Text
54−import qualified Data.ByteString as ByteString
55−import qualified Data.ByteString.Char8 as Char8
56−
57−-- | Parenthesize a `ByteString`.
58−parenthesized :: ByteString -> ByteString
59−parenthesized str = "(" <> str <> ")"
60−
61−-- | Square bracket a `ByteString`
62−bracketed :: ByteString -> ByteString
63−bracketed str = "[" <> str <> "]"
64−
65−-- | Concatenate two `ByteString`s with a space between.
66−(<+>) :: ByteString -> ByteString -> ByteString
67−infixr 7 <+>
68−str1 <+> str2 = str1 <> " " <> str2
69−
70−-- | Comma separate a list of `ByteString`s.
71−commaSeparated :: [ByteString] -> ByteString
72−commaSeparated = ByteString.intercalate ", "
73−
74−-- | Add double quotes around a `ByteString`.
75−doubleQuoted :: ByteString -> ByteString
76−doubleQuoted str = "\"" <> str <> "\""
77−
78−-- | Add single quotes around a `Text` and escape single quotes within it.
79−singleQuotedText :: Text -> ByteString
80−singleQuotedText str =
81− "'" <> Text.encodeUtf8 (Text.replace "'" "''" str) <> "'"
82−
83−-- | Add single quotes around a `ByteString` and escape single quotes within it.
84−singleQuotedUtf8 :: ByteString -> ByteString
85−singleQuotedUtf8 = singleQuotedText . Text.decodeUtf8
86−
87−-- | Comma separate the renderings of a heterogeneous list.
88−renderCommaSeparated
89− :: SListI xs
90− => (forall x. expression x -> ByteString)
91− -> NP expression xs -> ByteString
92−renderCommaSeparated render
93− = commaSeparated
94− . hcollapse
95− . hmap (K . render)
96−
97−-- | Comma separate the renderings of a heterogeneous list.
98−renderCommaSeparatedConstraint
99− :: forall c xs expression. (All c xs, SListI xs)
100− => (forall x. c x => expression x -> ByteString)
101− -> NP expression xs -> ByteString
102−renderCommaSeparatedConstraint render
103− = commaSeparated
104− . hcollapse
105− . hcmap (Proxy @c) (K . render)
106−
107−-- | Comma separate the `Maybe` renderings of a heterogeneous list, dropping
108−-- `Nothing`s.
109−renderCommaSeparatedMaybe
110− :: SListI xs
111− => (forall x. expression x -> Maybe ByteString)
112− -> NP expression xs -> ByteString
113−renderCommaSeparatedMaybe render
114− = commaSeparated
115− . catMaybes
116− . hcollapse
117− . hmap (K . render)
118−
119−-- | Render a promoted `Nat`.
120−renderNat :: forall n. KnownNat n => ByteString
121−renderNat = fromString (show (natVal' (proxy# :: Proxy# n)))
122−
123−-- | Render a promoted `Symbol`.
124−renderSymbol :: forall s. KnownSymbol s => ByteString
125−renderSymbol = fromString (symbolVal' (proxy# :: Proxy# s))
126−
127−-- | A class for rendering SQL
128−class RenderSQL sql where renderSQL :: sql -> ByteString
129−
130−-- | Print SQL.
131−printSQL :: (RenderSQL sql, MonadIO io) => sql -> io ()
132−printSQL = liftIO . Char8.putStrLn . renderSQL
133−
134−-- | `escape` a character to prevent injection
135−escape :: Char -> String
136−escape = \case
137− '\NUL' -> "\\0"
138− '\'' -> "''"
139− '"' -> "\\\""
140− '\b' -> "\\b"
141− '\n' -> "\\n"
142− '\r' -> "\\r"
143− '\t' -> "\\t"
144− '\\' -> "\\\\"
145− c -> [c]
squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs+221−493
@@ -1,120 +1,88 @@
1{-|
1{-|
2Module: Squeal.PostgreSQL.Schema
2Module: Squeal.PostgreSQL.Schema
3Description: Embedding of PostgreSQL type and alias system
3Description: Embedding of PostgreSQL type and alias system
4−Copyright: (c) Eitan Chatav, 2019
4+Copyright: (c) Eitan Chatav, 2017
5Maintainer: eitan@morphism.tech
5Maintainer: eitan@morphism.tech
6Stability: experimental
6Stability: experimental
7
7
8−`Squeal.PostgreSQL.Schema` provides a type-level DSL for kinds of Postgres types,
8+Embedding of PostgreSQL type and alias system
9−tables, schema, constraints, aliases, enumerated labels, and groupings.
10−It also defines useful type families to operate on these. Finally,
11−it defines an embedding of Haskell types into Postgres types.
12-}
9-}
10+
13{-# LANGUAGE
11{-# LANGUAGE
14− AllowAmbiguousTypes
12+ ConstraintKinds
15− , ConstraintKinds
13+ , DataKinds
16 , DeriveAnyClass
14 , DeriveAnyClass
15+ , DeriveDataTypeable
17 , DeriveGeneric
16 , DeriveGeneric
18 , FlexibleContexts
17 , FlexibleContexts
19 , FlexibleInstances
18 , FlexibleInstances
20− , FunctionalDependencies
21 , GADTs
19 , GADTs
22− , LambdaCase
20+ , MagicHash
21+ , MultiParamTypeClasses
23 , OverloadedStrings
22 , OverloadedStrings
24− , QuantifiedConstraints
23+ , PolyKinds
25 , RankNTypes
24 , RankNTypes
26 , ScopedTypeVariables
25 , ScopedTypeVariables
27 , StandaloneDeriving
26 , StandaloneDeriving
28 , TypeApplications
27 , TypeApplications
29− , TypeFamilyDependencies
28+ , TypeFamilies
30 , TypeInType
29 , TypeInType
31 , TypeOperators
30 , TypeOperators
32− , UndecidableInstances
33− , UndecidableSuperClasses
34#-}
31#-}
35
32
36module Squeal.PostgreSQL.Schema
33module Squeal.PostgreSQL.Schema
37− ( -- * Postgres Types
34+ ( -- * Kinds
38 PGType (..)
35 PGType (..)
39 , NullityType (..)
36 , NullityType (..)
40− , RowType
37+ , ColumnType (..)
41− , FromType
42− -- * Schema Types
43− , ColumnType
44 , ColumnsType
38 , ColumnsType
45− , TableType
39+ , TablesType
46− , SchemumType (..)
40+ , Grouping (..)
47− , IndexType (..)
48− , FunctionType
49− , OperatorType (..)
50− , ReturnsType (..)
51− , SchemaType
52− , SchemasType
53− , Public
54 -- * Constraints
41 -- * Constraints
55− , (:=>)
56− , ColumnConstraint (..)
57− , TableConstraint (..)
58− , TableConstraints
59− , Uniquely
60− -- * Enumerated Labels
61− , IsPGlabel (..)
62− , PGlabel (..)
63− -- * Data Definitions
64− , Create
65− , CreateIfNotExists
66− , CreateOrReplace
67− , Drop
68− , DropSchemum
69− , DropIfExists
70− , DropSchemumIfExists
71− , Alter
72− , AlterIfExists
73− , Rename
74− , RenameIfExists
75− , ConstraintInvolves
76− , DropIfConstraintsInvolve
77− , IsNotElem
78− , AllUnique
79− -- * Type Classifications
80 , PGNum
42 , PGNum
81 , PGIntegral
43 , PGIntegral
82 , PGFloating
44 , PGFloating
83− , PGTypeOf
45+ -- * Aliases
84− , PGJsonType
46+ , (:::)
85− , PGJsonKey
47+ , Alias (Alias)
86− , SamePGType
48+ , renderAlias
49+ , Aliased (As)
50+ , renderAliased
51+ , IsLabel (..)
52+ , IsTableColumn (..)
53+ -- * Type Families
54+ , In
55+ , HasUnique
56+ , BaseType
57+ , SameTypes
87 , AllNotNull
58 , AllNotNull
88 , NotAllNull
59 , NotAllNull
89− -- * Nullifications
90 , NullifyType
60 , NullifyType
91− , NullifyRow
61+ , NullifyColumns
92− , NullifyFrom
62+ , NullifyTables
93− -- * Table Conversions
63+ , Join
94− , TableToColumns
64+ , Create
95− , ColumnsToRow
65+ , Drop
96− , TableToRow
66+ , Alter
67+ , Rename
68+ -- * Generics
69+ , SameField
70+ , SameFields
97 ) where
71 ) where
98
72
99−import Control.Category
73+import Control.DeepSeq
100−import Data.Kind
74+import Data.ByteString
101−import Data.Monoid hiding (All)
75+import Data.Monoid
102−import Data.Type.Bool
76+import Data.String
103−import Generics.SOP
77+import Generics.SOP (AllZip)
78+import GHC.Generics (Generic)
79+import GHC.Exts
80+import GHC.OverloadedLabels
104import GHC.TypeLits
81import GHC.TypeLits
105−import Prelude hiding (id, (.))
106
82
107−import Squeal.PostgreSQL.Alias
83+import qualified Generics.SOP.Type.Metadata as Type
108−import Squeal.PostgreSQL.List
109−import Squeal.PostgreSQL.Render
110−
111−-- $setup
112−-- >>> import Squeal.PostgreSQL
113
84
114-- | `PGType` is the promoted datakind of PostgreSQL types.
85-- | `PGType` is the promoted datakind of PostgreSQL types.
115−--
116−-- >>> :kind 'PGbool
117−-- 'PGbool :: PGType
118data PGType
86data PGType
119 = PGbool -- ^ logical Boolean (true/false)
87 = PGbool -- ^ logical Boolean (true/false)
120 | PGint2 -- ^ signed two-byte integer
88 | PGint2 -- ^ signed two-byte integer
@@ -123,7 +91,6 @@ data PGType
123 | PGnumeric -- ^ arbitrary precision numeric type
91 | PGnumeric -- ^ arbitrary precision numeric type
124 | PGfloat4 -- ^ single precision floating-point number (4 bytes)
92 | PGfloat4 -- ^ single precision floating-point number (4 bytes)
125 | PGfloat8 -- ^ double precision floating-point number (8 bytes)
93 | PGfloat8 -- ^ double precision floating-point number (8 bytes)
126− | PGmoney -- ^ currency amount
127 | PGchar Nat -- ^ fixed-length character string
94 | PGchar Nat -- ^ fixed-length character string
128 | PGvarchar Nat -- ^ variable-length character string
95 | PGvarchar Nat -- ^ variable-length character string
129 | PGtext -- ^ variable-length character string
96 | PGtext -- ^ variable-length character string
@@ -138,459 +105,220 @@ data PGType
138 | PGinet -- ^ IPv4 or IPv6 host address
105 | PGinet -- ^ IPv4 or IPv6 host address
139 | PGjson -- ^ textual JSON data
106 | PGjson -- ^ textual JSON data
140 | PGjsonb -- ^ binary JSON data, decomposed
107 | PGjsonb -- ^ binary JSON data, decomposed
141− | PGvararray NullityType -- ^ variable length array
142− | PGfixarray [Nat] NullityType -- ^ fixed length array
143− | PGenum [Symbol] -- ^ enumerated (enum) types are data types that comprise a static, ordered set of values.
144− | PGcomposite RowType -- ^ a composite type represents the structure of a row or record; it is essentially just a list of field names and their data types.
145− | PGtsvector -- ^ A tsvector value is a sorted list of distinct lexemes, which are words that have been normalized to merge different variants of the same word.
146− | PGtsquery -- ^ A tsquery value stores lexemes that are to be searched for.
147− | PGoid -- Object identifiers (OIDs) are used internally by PostgreSQL as primary keys for various system tables.
148− | PGrange PGType -- ^ Range types are data types representing a range of values of some element type (called the range's subtype).
149 | UnsafePGType Symbol -- ^ an escape hatch for unsupported PostgreSQL types
108 | UnsafePGType Symbol -- ^ an escape hatch for unsupported PostgreSQL types
150
109
151-- | `NullityType` encodes the potential presence or definite absence of a
110-- | `NullityType` encodes the potential presence or definite absence of a
152-- @NULL@ allowing operations which are sensitive to such to be well typed.
111-- @NULL@ allowing operations which are sensitive to such to be well typed.
153−--
154−-- >>> :kind 'Null 'PGint4
155−-- 'Null 'PGint4 :: NullityType
156−-- >>> :kind 'NotNull ('PGvarchar 50)
157−-- 'NotNull ('PGvarchar 50) :: NullityType
158data NullityType
112data NullityType
159 = Null PGType -- ^ @NULL@ may be present
113 = Null PGType -- ^ @NULL@ may be present
160 | NotNull PGType -- ^ @NULL@ is absent
114 | NotNull PGType -- ^ @NULL@ is absent
161
115
162−-- | The constraint operator, `:=>` is a type level pair
116+-- | `ColumnType` encodes the allowance of @DEFAULT@ and the only way
163−-- between a "constraint" and some type, for use in pairing
117+-- to generate an `Optional` `Squeal.PostgreSQL.Expression.Expression`
164−-- a `ColumnConstraint` with a `NullityType` to produce a `ColumnType`
118+-- is to use `Squeal.PostgreSQL.Expression.def`,
165−-- or a `TableConstraints` and a `ColumnsType` to produce a `TableType`.
119+-- `Squeal.PostgreSQL.Expression.unDef` or
166−type (:=>) constraint ty = '(constraint,ty)
120+-- `Squeal.PostgreSQL.Expression.param`.
167−infixr 7 :=>
121+data ColumnType
168−
122+ = Optional NullityType
169−-- | `ColumnConstraint` encodes the availability of @DEFAULT@ for inserts and updates.
123+ -- ^ @DEFAULT@ is allowed
170−-- A column can be assigned a default value.
124+ | Required NullityType
171−-- A data `Squeal.PostgreSQL.Manipulations.Manipulation` command can also
125+ -- ^ @DEFAULT@ is not allowed
172−-- request explicitly that a column be set to its default value,
126+
173−-- without having to know what that value is.
127+-- | `ColumnsType` is a kind synonym for a row of `ColumnType`s.
174−data ColumnConstraint
175− = Def -- ^ @DEFAULT@ is available for inserts and updates
176− | NoDef -- ^ @DEFAULT@ is unavailable for inserts and updates
177−
178−-- | `ColumnType` encodes the allowance of @DEFAULT@ and @NULL@ and the
179−-- base `PGType` for a column.
180−--
181−-- >>> :set -XTypeFamilies -XTypeInType
182−-- >>> import GHC.TypeLits
183−-- >>> type family IdColumn :: ColumnType where IdColumn = 'Def :=> 'NotNull 'PGint4
184−-- >>> type family EmailColumn :: ColumnType where EmailColumn = 'NoDef :=> 'Null 'PGtext
185−type ColumnType = (ColumnConstraint,NullityType)
186−
187−-- | `ColumnsType` is a row of `ColumnType`s.
188−--
189−-- >>> :{
190−-- type family UsersColumns :: ColumnsType where
191−-- UsersColumns =
192−-- '[ "name" ::: 'NoDef :=> 'NotNull 'PGtext
193−-- , "id" ::: 'Def :=> 'NotNull 'PGint4
194−-- ]
195−-- :}
196type ColumnsType = [(Symbol,ColumnType)]
128type ColumnsType = [(Symbol,ColumnType)]
197
129
198−-- | `TableConstraint` encodes various forms of data constraints
130+-- | `TablesType` is a kind synonym for a row of `ColumnsType`s.
199−-- of columns in a table.
131+-- It is used as a kind for both a schema, a disjoint union of tables,
200−-- `TableConstraint`s give you as much control over the data in your tables
132+-- and a joined table `Squeal.PostgreSQL.Query.FromClause`,
201−-- as you wish. If a user attempts to store data in a column that would
133+-- a product of tables.
202−-- violate a constraint, an error is raised. This applies
134+type TablesType = [(Symbol,ColumnsType)]
203−-- even if the value came from the default value definition.
135+
204−data TableConstraint
136+-- | `Grouping` is an auxiliary namespace, created by
205− = Check [Symbol]
137+-- @GROUP BY@ clauses (`Squeal.PostgreSQL.Query.group`), and used
206− | Unique [Symbol]
138+-- for typesafe aggregation
207− | PrimaryKey [Symbol]
139+data Grouping
208− | ForeignKey [Symbol] Symbol [Symbol]
140+ = Ungrouped
209−
141+ | Grouped [(Symbol,Symbol)]
210−{- | A `TableConstraints` is a row of `TableConstraint`s.
142+
211−
143+-- | `PGNum` is a constraint on `PGType` whose
212−>>> :{
144+-- `Squeal.PostgreSQL.Expression.Expression`s have a `Num` constraint.
213−type family UsersConstraints :: TableConstraints where
145+type PGNum ty =
214− UsersConstraints = '[ "pk_users" ::: 'PrimaryKey '["id"] ]
146+ In ty '[ 'PGint2, 'PGint4, 'PGint8, 'PGnumeric, 'PGfloat4, 'PGfloat8]
215−:}
147+
216−-}
148+-- | `PGFloating` is a constraint on `PGType` whose
217−type TableConstraints = [(Symbol,TableConstraint)]
149+-- `Squeal.PostgreSQL.Expression.Expression`s
218−
150+-- have `Fractional` and `Floating` constraints.
219−-- | A `ForeignKey` must reference columns that either are
151+type PGFloating ty = In ty '[ 'PGfloat4, 'PGfloat8, 'PGnumeric]
220−-- a `PrimaryKey` or form a `Unique` constraint.
152+
221−type family Uniquely
153+-- | `PGIntegral` is a constraint on `PGType` whose
222− (key :: [Symbol])
154+-- `Squeal.PostgreSQL.Expression.Expression`s
223− (constraints :: TableConstraints) :: Constraint where
155+-- have `Squeal.PostgreSQL.Expression.div_` and
224− Uniquely key (uq ::: 'Unique key ': constraints) = ()
156+-- `Squeal.PostgreSQL.Expression.mod_` functions.
225− Uniquely key (pk ::: 'PrimaryKey key ': constraints) = ()
157+type PGIntegral ty = In ty '[ 'PGint2, 'PGint4, 'PGint8]
226− Uniquely key (_ ': constraints) = Uniquely key constraints
158+
227−
159+-- | `:::` is like a promoted version of `As`, a type level pair between
228−-- | `TableType` encodes a row of constraints on a table as well as the types
160+-- an alias and some type, usually a column alias and a `ColumnType` or
229−-- of its columns.
161+-- a table alias and a `ColumnsType`.
162+type (:::) (alias :: Symbol) (ty :: polykind) = '(alias,ty)
163+
164+-- | `Alias`es are proxies for a type level string or `Symbol`
165+-- and have an `IsLabel` instance so that with @-XOverloadedLabels@
230--
166--
231−-- >>> :{
167+-- >>> :set -XOverloadedLabels
232−-- type family UsersTable :: TableType where
168+-- >>> #foobar :: Alias "foobar"
233−-- UsersTable =
169+-- Alias
234−-- '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
170+data Alias (alias :: Symbol) = Alias
235−-- '[ "id" ::: 'Def :=> 'NotNull 'PGint4
171+ deriving (Eq,Generic,Ord,Show,NFData)
236−-- , "name" ::: 'NoDef :=> 'NotNull 'PGtext
172+instance alias1 ~ alias2 => IsLabel alias1 (Alias alias2) where
237−-- ]
173+ fromLabel = Alias
238−-- :}
174+
239−type TableType = (TableConstraints,ColumnsType)
175+-- | >>> renderAlias #alias
240−
176+-- "alias"
241−{- | A `RowType` is a row of `NullityType`. They correspond to Haskell
177+renderAlias :: KnownSymbol alias => Alias alias -> ByteString
242−record types by means of `Squeal.PostgreSQL.Binary.RowPG` and are used in many places.
178+renderAlias = fromString . symbolVal
243−
179+
244−>>> :{
180+-- | The `As` operator is used to name an expression. `As` is like a demoted
245−type family PersonRow :: RowType where
181+-- version of `:::`.
246− PersonRow =
182+--
247− '[ "name" ::: 'NotNull 'PGtext
183+-- >>> Just "hello" `As` #hi :: Aliased Maybe ("hi" ::: String)
248− , "age" ::: 'NotNull 'PGint4
184+-- As (Just "hello") Alias
249− , "dateOfBirth" ::: 'Null 'PGdate
185+data Aliased expression aliased where
250− ]
186+ As
251−:}
187+ :: KnownSymbol alias
252−-}
188+ => expression ty
253−type RowType = [(Symbol,NullityType)]
189+ -> Alias alias
254−
190+ -> Aliased expression (alias ::: ty)
255−{- | `FromType` is a row of `RowType`s. It can be thought of as
191+deriving instance Show (expression ty)
256−a product, or horizontal gluing and is used in `Squeal.PostgreSQL.Query.FromClause`s
192+ => Show (Aliased expression (alias ::: ty))
257−and `Squeal.PostgreSQL.Query.TableExpression`s.
193+deriving instance Eq (expression ty)
258−-}
194+ => Eq (Aliased expression (alias ::: ty))
259−type FromType = [(Symbol,RowType)]
195+deriving instance Ord (expression ty)
260−
196+ => Ord (Aliased expression (alias ::: ty))
261−-- | `ColumnsToRow` removes column constraints.
197+
262−type family ColumnsToRow (columns :: ColumnsType) :: RowType where
198+-- | >>> let renderMaybe = fromString . maybe "Nothing" (const "Just")
263− ColumnsToRow (column ::: _ :=> ty ': column1 ::: _ :=> ty1 ': column2 ::: _ :=> ty2 ': column3 ::: _ :=> ty3 ': column4 ::: _ :=> ty4 ': column5 ::: _ :=> ty5 ': columns) =
199+-- >>> renderAliased renderMaybe (Just (3::Int) `As` #an_int)
264− column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': column3 ::: ty3 ': column4 ::: ty4 ': column5 ::: ty5 ': ColumnsToRow columns
200+-- "Just AS an_int"
265− ColumnsToRow (column ::: _ :=> ty ': column1 ::: _ :=> ty1 ': column2 ::: _ :=> ty2 ': column3 ::: _ :=> ty3 ': column4 ::: _ :=> ty4 ': columns) =
201+renderAliased
266− column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': column3 ::: ty3 ': column4 ::: ty4 ': ColumnsToRow columns
202+ :: (forall ty. expression ty -> ByteString)
267− ColumnsToRow (column ::: _ :=> ty ': column1 ::: _ :=> ty1 ': column2 ::: _ :=> ty2 ': column3 ::: _ :=> ty3 ': columns) =
203+ -> Aliased expression aliased
268− column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': column3 ::: ty3 ': ColumnsToRow columns
204+ -> ByteString
269− ColumnsToRow (column ::: _ :=> ty ': column1 ::: _ :=> ty1 ': column2 ::: _ :=> ty2 ': columns) =
205+renderAliased render (expression `As` alias) =
270− column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': ColumnsToRow columns
206+ render expression <> " AS " <> renderAlias alias
271− ColumnsToRow (column ::: _ :=> ty ': column1 ::: _ :=> ty1 ': columns) =
207+
272− column ::: ty ': column1 ::: ty1 ': ColumnsToRow columns
208+-- | Analagous to `IsLabel`, the constraint
273− ColumnsToRow (column ::: _ :=> ty ': columns) =
209+-- `IsTableColumn` defines `!` for a column alias qualified
274− column ::: ty ': ColumnsToRow columns
210+-- by a table alias.
275− ColumnsToRow '[] = '[]
211+class IsTableColumn table column expression where
276−
212+ (!) :: Alias table -> Alias column -> expression
277−-- | `TableToColumns` removes table constraints.
213+ infixl 9 !
278−type family TableToColumns (table :: TableType) :: ColumnsType where
214+instance IsTableColumn table column (Alias table, Alias column) where (!) = (,)
279− TableToColumns (constraints :=> columns) = columns
215+
280−
216+-- | @In x xs@ is a constraint that proves that @x@ is in @xs@.
281−-- | Convert a table to a row type.
217+type family In x xs :: Constraint where
282−type family TableToRow (table :: TableType) :: RowType where
218+ In x (x ': xs) = ()
283− TableToRow tab = ColumnsToRow (TableToColumns tab)
219+ In x (y ': xs) = In x xs
284−
220+
285−-- | Numeric Postgres types.
221+-- | @HasUnique alias xs x@ is a constraint that proves that @xs@ is a singleton
286−type PGNum =
222+-- of @alias ::: x@.
287− '[ 'PGint2, 'PGint4, 'PGint8, 'PGnumeric, 'PGfloat4, 'PGfloat8]
223+type HasUnique alias xs x = xs ~ '[alias ::: x]
288−
224+
289−-- | Floating Postgres types.
225+-- | `BaseType` forgets about @NULL@ and @DEFAULT@
290−type PGFloating = '[ 'PGfloat4, 'PGfloat8, 'PGnumeric]
226+type family BaseType (ty :: ColumnType) :: PGType where
291−
227+ BaseType (optionality (nullity pg)) = pg
292−-- | Integral Postgres types.
228+
293−type PGIntegral = '[ 'PGint2, 'PGint4, 'PGint8]
229+-- | `SameTypes` is a constraint that proves two `ColumnsType`s have the same
294−
230+-- length and the same `ColumnType`s.
295−-- | `PGTypeOf` forgets about @NULL@ and any column constraints.
231+type family SameTypes
296−type family PGTypeOf (ty :: NullityType) :: PGType where
232+ (columns0 :: ColumnsType) (columns1 :: ColumnsType)
297− PGTypeOf (nullity pg) = pg
233+ :: Constraint where
298−
234+ SameTypes '[] '[] = ()
299−-- | Equality constraint on the underlying `PGType` of two columns.
235+ SameTypes ((column0 ::: ty0) ': columns0) ((column1 ::: ty1) ': columns1)
300−class SamePGType
236+ = (ty0 ~ ty1, SameTypes columns0 columns1)
301− (ty0 :: (Symbol,ColumnType)) (ty1 :: (Symbol,ColumnType)) where
302−instance ty0 ~ ty1 => SamePGType
303− (alias0 ::: def0 :=> nullity0 ty0)
304− (alias1 ::: def1 :=> nullity1 ty1)
305
237
306-- | `AllNotNull` is a constraint that proves a `ColumnsType` has no @NULL@s.
238-- | `AllNotNull` is a constraint that proves a `ColumnsType` has no @NULL@s.
307type family AllNotNull (columns :: ColumnsType) :: Constraint where
239type 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
314 AllNotNull '[] = ()
240 AllNotNull '[] = ()
241+ AllNotNull ((column ::: (optionality ('NotNull ty))) ': columns)
242+ = AllNotNull columns
315
243
316-- | `NotAllNull` is a constraint that proves a `ColumnsType` has some
244-- | `NotAllNull` is a constraint that proves a `ColumnsType` has some
317-- @NOT NULL@.
245-- @NOT NULL@.
318−type family NotAllNull (columns :: ColumnsType) :: Constraint where
246+type family NotAllNull columns :: Constraint where
319− NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()
247+ NotAllNull ((column ::: (optionality ('NotNull ty))) ': columns) = ()
320− NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()
248+ NotAllNull ((column ::: (optionality ('Null ty))) ': columns)
321− NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()
249+ = NotAllNull columns
322− NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()
250+
323− NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()
251+-- | `NullifyType` is an idempotent that nullifies a `ColumnType`.
324− NotAllNull (_ ::: _ :=> 'NotNull _ ': _) = ()
252+type family NullifyType (ty :: ColumnType) :: ColumnType where
325− NotAllNull (_ ::: _ :=> 'Null _ ': columns) = NotAllNull columns
253+ NullifyType (optionality ('Null ty)) = optionality ('Null ty)
326−
254+ NullifyType (optionality ('NotNull ty)) = optionality ('Null ty)
327−-- | `NullifyType` is an idempotent that nullifies a `NullityType`.
255+
328−type family NullifyType (ty :: NullityType) :: NullityType where
256+-- | `NullifyColumns` is an idempotent that nullifies a `ColumnsType`.
329− NullifyType ('Null ty) = 'Null ty
257+type family NullifyColumns (columns :: ColumnsType) :: ColumnsType where
330− NullifyType ('NotNull ty) = 'Null ty
258+ NullifyColumns '[] = '[]
331−
259+ NullifyColumns ((column ::: ty) ': columns) =
332−-- | `NullifyRow` is an idempotent that nullifies a `RowType`.
260+ (column ::: NullifyType ty) ': NullifyColumns columns
333−type family NullifyRow (columns :: RowType) :: RowType where
261+
334− NullifyRow (column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': column3 ::: ty3 ': column4 ::: ty4 ': column5 ::: ty5 ': columns) =
262+-- | `NullifyTables` is an idempotent that nullifies a `TablesType`
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
344− NullifyRow (column ::: ty ': columns) =
345− column ::: NullifyType ty ': NullifyRow columns
346− NullifyRow '[] = '[]
347−
348−-- | `NullifyFrom` is an idempotent that nullifies a `FromType`
349-- used to nullify the left or right hand side of an outer join
263-- used to nullify the left or right hand side of an outer join
350-- in a `Squeal.PostgreSQL.Query.FromClause`.
264-- in a `Squeal.PostgreSQL.Query.FromClause`.
351−type family NullifyFrom (tables :: FromType) :: FromType where
265+type family NullifyTables (tables :: TablesType) :: TablesType where
352− NullifyFrom (table ::: columns ': table1 ::: columns1 ': table2 ::: columns2 ': table3 ::: columns3 ': table4 ::: columns4 ': table5 ::: columns5 ': tables) =
266+ NullifyTables '[] = '[]
353− table ::: NullifyRow columns ': table1 ::: NullifyRow columns1 ': table2 ::: NullifyRow columns2 ': table3 ::: NullifyRow columns3 ': table4 ::: NullifyRow columns5 ': table5 ::: NullifyRow columns4 ': NullifyFrom tables
267+ NullifyTables ((table ::: columns) ': tables) =
354− NullifyFrom (table ::: columns ': table1 ::: columns1 ': table2 ::: columns2 ': table3 ::: columns3 ': table4 ::: columns4 ': tables) =
268+ (table ::: NullifyColumns columns) ': NullifyTables tables
355− table ::: NullifyRow columns ': table1 ::: NullifyRow columns1 ': table2 ::: NullifyRow columns2 ': table3 ::: NullifyRow columns3 ': table4 ::: NullifyRow columns4 ': NullifyFrom tables
269+
356− NullifyFrom (table ::: columns ': table1 ::: columns1 ': table2 ::: columns2 ': table3 ::: columns3 ': tables) =
270+-- | `Join` is simply promoted `++` and is used in @JOIN@s in
357− table ::: NullifyRow columns ': table1 ::: NullifyRow columns1 ': table2 ::: NullifyRow columns2 ': table3 ::: NullifyRow columns3 ': NullifyFrom tables
271+-- `Squeal.PostgreSQL.Query.FromClause`s.
358− NullifyFrom (table ::: columns ': table1 ::: columns1 ': table2 ::: columns2 ': tables) =
272+type family Join xs ys where
359− table ::: NullifyRow columns ': table1 ::: NullifyRow columns1 ': table2 ::: NullifyRow columns2 ': NullifyFrom tables
273+ Join '[] ys = ys
360− NullifyFrom (table ::: columns ': table1 ::: columns1 ': tables) =
274+ Join (x ': xs) ys = x ': Join xs ys
361− table ::: NullifyRow columns ': table1 ::: NullifyRow columns1 ': NullifyFrom tables
362− NullifyFrom (table ::: columns ': tables) =
363− table ::: NullifyRow columns ': NullifyFrom tables
364− NullifyFrom '[] = '[]
365
275
366-- | @Create alias x xs@ adds @alias ::: x@ to the end of @xs@ and is used in
276-- | @Create alias x xs@ adds @alias ::: x@ to the end of @xs@ and is used in
367-- `Squeal.PostgreSQL.Definition.createTable` statements and in @ALTER TABLE@
277-- `Squeal.PostgreSQL.Definition.createTable` statements and in @ALTER TABLE@
368−-- `Squeal.PostgreSQL.Definition.addColumn`.
278+-- `Squeal.PostgreSQL.Definition.addColumnDefault` and
279+-- `Squeal.PostgreSQL.Definition.addColumnNull` statements.
369type family Create alias x xs where
280type family Create alias x xs where
370 Create alias x '[] = '[alias ::: x]
281 Create alias x '[] = '[alias ::: x]
371− Create alias x (alias ::: y ': xs) = TypeError
372− ('Text "Create: alias "
373− ':<>: 'ShowType alias
374− ':<>: 'Text "already exists")
375 Create alias y (x ': xs) = x ': Create alias y xs
282 Create alias y (x ': xs) = x ': Create alias y xs
376
283
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−
394-- | @Drop alias xs@ removes the type associated with @alias@ in @xs@
284-- | @Drop alias xs@ removes the type associated with @alias@ in @xs@
395-- and is used in `Squeal.PostgreSQL.Definition.dropTable` statements
285-- and is used in `Squeal.PostgreSQL.Definition.dropTable` statements
396-- and in @ALTER TABLE@ `Squeal.PostgreSQL.Definition.dropColumn` statements.
286-- and in @ALTER TABLE@ `Squeal.PostgreSQL.Definition.dropColumn` statements.
397type family Drop alias xs where
287type family Drop alias xs where
398− Drop alias '[] = TypeError
288+ Drop alias ((alias ::: x) ': xs) = xs
399− ('Text "Drop: alias "
400− ':<>: 'ShowType alias
401− ':<>: 'Text " does not exist" )
402− Drop alias (alias ::: x ': xs) = xs
403 Drop alias (x ': xs) = x ': Drop alias xs
289 Drop alias (x ': xs) = x ': Drop alias xs
404
290
405−type family DropSchemum alias sch xs where
291+-- | @Alter alias xs x@ replaces the type associated with an @alias@ in @xs@
406− DropSchemum alias sch '[] = TypeError
292+-- with the type `x` and is used in `Squeal.PostgreSQL.Definition.alterTable`
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−
437−-- | @Alter alias x xs@ replaces the type associated with an @alias@ in @xs@
438−-- with the type @x@ and is used in `Squeal.PostgreSQL.Definition.alterTable`
439-- and `Squeal.PostgreSQL.Definition.alterColumn`.
293-- and `Squeal.PostgreSQL.Definition.alterColumn`.
440−type family Alter alias x xs where
294+type family Alter alias xs x where
441− Alter alias x '[] = TypeError
295+ Alter alias ((alias ::: x0) ': xs) x1 = (alias ::: x1) ': xs
442− ('Text "Alter: alias "
296+ Alter alias (x0 ': xs) x1 = x0 ': Alter alias xs x1
443− ':<>: 'ShowType alias
444− ':<>: 'Text " does not exist" )
445− Alter alias x1 (alias ::: x0 ': xs) = alias ::: x1 ': xs
446− Alter alias x1 (x0 ': xs) = x0 ': Alter alias x1 xs
447−
448−type family AlterIfExists alias x xs where
449− AlterIfExists alias x '[] = '[]
450− AlterIfExists alias x1 (alias ::: x0 ': xs) = alias ::: x1 ': xs
451− AlterIfExists alias x1 (x0 ': xs) = x0 ': AlterIfExists alias x1 xs
452
297
453-- | @Rename alias0 alias1 xs@ replaces the alias @alias0@ by @alias1@ in @xs@
298-- | @Rename alias0 alias1 xs@ replaces the alias @alias0@ by @alias1@ in @xs@
454-- and is used in `Squeal.PostgreSQL.Definition.alterTableRename` and
299-- and is used in `Squeal.PostgreSQL.Definition.alterTableRename` and
455-- `Squeal.PostgreSQL.Definition.renameColumn`.
300-- `Squeal.PostgreSQL.Definition.renameColumn`.
456type family Rename alias0 alias1 xs where
301type family Rename alias0 alias1 xs where
457− Rename alias0 alias1 '[] = TypeError
458− ('Text "Rename: alias "
459− ':<>: 'ShowType alias0
460− ':<>: 'Text " does not exist" )
461 Rename alias0 alias1 ((alias0 ::: x0) ': xs) = (alias1 ::: x0) ': xs
302 Rename alias0 alias1 ((alias0 ::: x0) ': xs) = (alias1 ::: x0) ': xs
462 Rename alias0 alias1 (x ': xs) = x ': Rename alias0 alias1 xs
303 Rename alias0 alias1 (x ': xs) = x ': Rename alias0 alias1 xs
463
304
464−type family RenameIfExists alias0 alias1 xs where
305+-- | A `SameField` constraint is an equality constraint on a
465− RenameIfExists alias x '[] = '[]
306+-- `Generics.SOP.Type.Metadata.FieldInfo` and the column alias in a `:::` pair.
466− RenameIfExists alias0 alias1 ((alias0 ::: x0) ': xs) = (alias1 ::: x0) ': xs
307+class SameField
467− RenameIfExists alias0 alias1 (x ': xs) = x ': RenameIfExists alias0 alias1 xs
308+ (fieldInfo :: Type.FieldInfo) (fieldty :: (Symbol,ColumnType)) where
468−
309+instance field ~ column => SameField ('Type.FieldInfo field) (column ::: ty)
469−-- | Check if a `TableConstraint` involves a column
310+
470−type family ConstraintInvolves column constraint where
311+-- | A `SameFields` constraint proves that a
471− ConstraintInvolves column ('Check columns) = column `Elem` columns
312+-- `Generics.SOP.Type.Metadata.DatatypeInfo` of a record type has the same
472− ConstraintInvolves column ('Unique columns) = column `Elem` columns
313+-- field names as the column aliases of a `ColumnsType`.
473− ConstraintInvolves column ('PrimaryKey columns) = column `Elem` columns
314+type family SameFields
474− ConstraintInvolves column ('ForeignKey columns tab refcolumns)
315+ (datatypeInfo :: Type.DatatypeInfo) (columns :: ColumnsType)
475− = column `Elem` columns
316+ :: Constraint where
476−
317+ SameFields
477−-- | Drop all `TableConstraint`s that involve a column
318+ ('Type.ADT _module _datatype '[ 'Type.Record _constructor fields])
478−type family DropIfConstraintsInvolve column constraints where
319+ columns
479− DropIfConstraintsInvolve column '[] = '[]
320+ = AllZip SameField fields columns
480− DropIfConstraintsInvolve column (alias ::: constraint ': constraints)
321+ SameFields
481− = If (ConstraintInvolves column constraint)
322+ ('Type.Newtype _module _datatype ('Type.Record _constructor fields))
482− (DropIfConstraintsInvolve column constraints)
323+ columns
483− (alias ::: constraint ': DropIfConstraintsInvolve column constraints)
324+ = AllZip SameField fields columns
484−
485−-- | A `SchemumType` is a user-defined type, either a `Table`,
486−-- `View` or `Typedef`.
487−data SchemumType
488− = Table TableType
489− | View RowType
490− | Typedef PGType
491− | Index IndexType
492− | Function FunctionType
493− | Operator OperatorType
494− | UnsafeSchemum Symbol
495−
496−type FunctionType = ([NullityType], ReturnsType)
497−
498−data IndexType
499− = Btree
500− | Hash
501− | Gist
502− | Spgist
503− | Gin
504− | Brin
505−
506−data ReturnsType
507− = Returns NullityType
508− | ReturnsTable RowType
509−
510−data OperatorType
511− = BinaryOp NullityType NullityType NullityType
512− | LeftOp NullityType NullityType
513− | RightOp NullityType NullityType
514−
515−{- | The schema of a database consists of a list of aliased,
516−user-defined `SchemumType`s.
517−
518−>>> :{
519−type family Schema :: SchemaType where
520− Schema =
521− '[ "users" ::: 'Table (
522− '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
523− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
524− , "name" ::: 'NoDef :=> 'NotNull 'PGtext
525− ])
526− , "emails" ::: 'Table (
527− '[ "pk_emails" ::: 'PrimaryKey '["id"]
528− , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
529− ] :=>
530− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
531− , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
532− , "email" ::: 'NoDef :=> 'Null 'PGtext
533− ])
534− ]
535−:}
536−-}
537−type SchemaType = [(Symbol,SchemumType)]
538−
539−{- |
540−A database contains one or more named schemas, which in turn contain tables.
541−The same object name can be used in different schemas without conflict;
542−for example, both schema1 and myschema can contain tables named mytable.
543−Unlike databases, schemas are not rigidly separated:
544−a user can access objects in any of the schemas in the database they are connected to,
545−if they have privileges to do so.
546−
547−There are several reasons why one might want to use schemas:
548−
549− * To allow many users to use one database without interfering with each other.
550− * To organize database objects into logical groups to make them more manageable.
551− * Third-party applications can be put into separate schemas
552− so they do not collide with the names of other objects.
553−-}
554−type SchemasType = [(Symbol,SchemaType)]
555−
556−-- | A type family to use for a single schema database.
557−type family Public (schema :: SchemaType) :: SchemasType
558− where Public schema = '["public" ::: schema]
559−
560−-- | `IsPGlabel` looks very much like the `IsLabel` class. Whereas
561−-- the overloaded label, `fromLabel` is used for column references,
562−-- `label`s are used for enum terms. A `label` is called with
563−-- type application like `label @"beef"`.
564−class IsPGlabel (label :: Symbol) expr where label :: expr
565−instance label ~ label1
566− => IsPGlabel label (PGlabel label1) where label = PGlabel
567−instance labels ~ '[label]
568− => IsPGlabel label (NP PGlabel labels) where label = PGlabel :* Nil
569−-- | A `PGlabel` unit type with an `IsPGlabel` instance
570−data PGlabel (label :: Symbol) = PGlabel
571−instance KnownSymbol label => RenderSQL (PGlabel label) where
572− renderSQL _ = "\'" <> renderSymbol @label <> "\'"
573−instance All KnownSymbol labels => RenderSQL (NP PGlabel labels) where
574− renderSQL
575− = commaSeparated
576− . hcollapse
577− . hcmap (Proxy @KnownSymbol) (K . renderSQL)
578−
579−-- | Is a type a valid JSON key?
580−type PGJsonKey = '[ 'PGint2, 'PGint4, 'PGtext ]
581−
582−-- | Is a type a valid JSON type?
583−type PGJsonType = '[ 'PGjson, 'PGjsonb ]
584−
585−-- | Utility class for `AllUnique` to provide nicer error messages.
586−class IsNotElem x isElem where
587−instance IsNotElem x 'False where
588−instance (TypeError ( 'Text "Cannot assign to "
589− ':<>: 'ShowType alias
590− ':<>: 'Text " more than once"))
591− => IsNotElem '(alias, a) 'True where
592−
593−-- | No elem of @xs@ appears more than once, in the context of assignment.
594−class AllUnique (xs :: [(Symbol, a)]) where
595−instance AllUnique '[] where
596−instance (IsNotElem x (Elem x xs), AllUnique xs) => AllUnique (x ': xs) where
squeal-postgresql/src/Squeal/PostgreSQL/Transaction.hsdeleted−252
@@ -1,252 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Transaction
3−Description: Squeal transaction control language
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Squeal transaction control language.
9−-}
10−
11−{-# LANGUAGE
12− DataKinds
13− , FlexibleContexts
14− , LambdaCase
15− , OverloadedStrings
16− , TypeInType
17−#-}
18−
19−module Squeal.PostgreSQL.Transaction
20− ( -- * Transaction
21− transactionally
22− , transactionally_
23− , transactionallyRetry
24− , ephemerally
25− , ephemerally_
26− , begin
27− , commit
28− , rollback
29− -- * Transaction Mode
30− , TransactionMode (..)
31− , defaultMode
32− , longRunningMode
33− , IsolationLevel (..)
34− , AccessMode (..)
35− , DeferrableMode (..)
36− ) where
37−
38−import UnliftIO
39−
40−import Squeal.PostgreSQL.Manipulation
41−import Squeal.PostgreSQL.Render
42−import Squeal.PostgreSQL.PQ
43−
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−-}
50−transactionally
51− :: (MonadUnliftIO tx, MonadPQ schemas tx)
52− => TransactionMode
53− -> tx x -- ^ run inside a transaction
54− -> tx x
55−transactionally mode tx = mask $ \restore -> do
56− manipulate_ $ begin mode
57− result <- restore tx `onException` (manipulate_ rollback)
58− manipulate_ commit
59− return result
60−
61−-- | Run a computation `transactionally_`, in `defaultMode`.
62−transactionally_
63− :: (MonadUnliftIO tx, MonadPQ schemas tx)
64− => tx x -- ^ run inside a transaction
65− -> tx x
66−transactionally_ = transactionally defaultMode
67−
68−{- |
69−`transactionallyRetry` a computation;
70−
71−* first `begin`,
72−* then `try` the computation,
73− - if it raises a serialization failure then `rollback` and restart the transaction,
74− - if it raises any other exception then `rollback` and rethrow the exception,
75− - otherwise `commit` and `return` the result.
76−-}
77−transactionallyRetry
78− :: (MonadUnliftIO tx, MonadPQ schemas tx)
79− => TransactionMode
80− -> tx x -- ^ run inside a transaction
81− -> tx x
82−transactionallyRetry mode tx = mask $ \restore ->
83− loop . try $ do
84− x <- restore tx
85− manipulate_ commit
86− return x
87− where
88− loop attempt = do
89− manipulate_ $ begin mode
90− attempt >>= \case
91− Left (PQException (PQState _ (Just "40001") _)) -> do
92− manipulate_ rollback
93− loop attempt
94− Left err -> do
95− manipulate_ rollback
96− throwIO err
97− Right x -> return x
98−
99−{- | Run a computation `ephemerally`;
100−Like `transactionally` but always `rollback`, useful in testing.
101−-}
102−ephemerally
103− :: (MonadUnliftIO tx, MonadPQ schemas tx)
104− => TransactionMode
105− -> tx x -- ^ run inside an ephemeral transaction
106− -> tx x
107−ephemerally mode tx = mask $ \restore -> do
108− manipulate_ $ begin mode
109− result <- restore tx `onException` (manipulate_ rollback)
110− manipulate_ rollback
111− return result
112−
113−{- | Run a computation `ephemerally` in `defaultMode`. -}
114−ephemerally_
115− :: (MonadUnliftIO tx, MonadPQ schemas tx)
116− => tx x -- ^ run inside an ephemeral transaction
117− -> tx x
118−ephemerally_ = ephemerally defaultMode
119−
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"
131−
132−-- | The available transaction characteristics are the transaction `IsolationLevel`,
133−-- the transaction `AccessMode` (`ReadWrite` or `ReadOnly`), and the `DeferrableMode`.
134−data TransactionMode = TransactionMode
135− { isolationLevel :: IsolationLevel
136− , accessMode :: AccessMode
137− , deferrableMode :: DeferrableMode
138− } deriving (Show, Eq)
139−
140−-- | `TransactionMode` with a `Serializable` `IsolationLevel`,
141−-- `ReadWrite` `AccessMode` and `NotDeferrable` `DeferrableMode`.
142−defaultMode :: TransactionMode
143−defaultMode = TransactionMode ReadCommitted ReadWrite NotDeferrable
144−
145−-- | `TransactionMode` with a `Serializable` `IsolationLevel`,
146−-- `ReadOnly` `AccessMode` and `Deferrable` `DeferrableMode`.
147−-- This mode is well suited for long-running reports or backups.
148−longRunningMode :: TransactionMode
149−longRunningMode = TransactionMode Serializable ReadOnly Deferrable
150−
151−-- | Render a `TransactionMode`.
152−instance RenderSQL TransactionMode where
153− renderSQL mode =
154− "ISOLATION LEVEL"
155− <+> renderSQL (isolationLevel mode)
156− <+> renderSQL (accessMode mode)
157− <+> renderSQL (deferrableMode mode)
158−
159−-- | The SQL standard defines four levels of transaction isolation.
160−-- The most strict is `Serializable`, which is defined by the standard in a paragraph
161−-- which says that any concurrent execution of a set of `Serializable` transactions is
162−-- guaranteed to produce the same effect as running them one at a time in some order.
163−-- The other three levels are defined in terms of phenomena, resulting from interaction
164−-- between concurrent transactions, which must not occur at each level.
165−-- The phenomena which are prohibited at various levels are:
166−--
167−-- __Dirty read__: A transaction reads data written by a concurrent uncommitted transaction.
168−--
169−-- __Nonrepeatable read__: A transaction re-reads data it has previously read and finds that data
170−-- has been modified by another transaction (that committed since the initial read).
171−--
172−-- __Phantom read__: A transaction re-executes a query returning a set of rows that satisfy
173−-- a search condition and finds that the set of rows satisfying the condition
174−-- has changed due to another recently-committed transaction.
175−--
176−-- __Serialization anomaly__: The result of successfully committing a group of transactions is inconsistent
177−-- with all possible orderings of running those transactions one at a time.
178−--
179−-- In PostgreSQL, you can request any of the four standard transaction
180−-- isolation levels, but internally only three distinct isolation levels are implemented,
181−-- i.e. PostgreSQL's `ReadUncommitted` mode behaves like `ReadCommitted`.
182−-- This is because it is the only sensible way to map the standard isolation levels to
183−-- PostgreSQL's multiversion concurrency control architecture.
184−data IsolationLevel
185− = Serializable
186− -- ^ Dirty read is not possible.
187− -- Nonrepeatable read is not possible.
188− -- Phantom read is not possible.
189− -- Serialization anomaly is not possible.
190− | RepeatableRead
191− -- ^ Dirty read is not possible.
192− -- Nonrepeatable read is not possible.
193− -- Phantom read is not possible.
194− -- Serialization anomaly is possible.
195− | ReadCommitted
196− -- ^ Dirty read is not possible.
197− -- Nonrepeatable read is possible.
198− -- Phantom read is possible.
199− -- Serialization anomaly is possible.
200− | ReadUncommitted
201− -- ^ Dirty read is not possible.
202− -- Nonrepeatable read is possible.
203− -- Phantom read is possible.
204− -- Serialization anomaly is possible.
205− deriving (Show, Eq)
206−
207−-- | Render an `IsolationLevel`.
208−instance RenderSQL IsolationLevel where
209− renderSQL = \case
210− Serializable -> "SERIALIZABLE"
211− ReadCommitted -> "READ COMMITTED"
212− ReadUncommitted -> "READ UNCOMMITTED"
213− RepeatableRead -> "REPEATABLE READ"
214−
215−-- | The transaction access mode determines whether the transaction is `ReadWrite` or `ReadOnly`.
216−-- `ReadWrite` is the default. When a transaction is `ReadOnly`,
217−-- the following SQL commands are disallowed:
218−-- @INSERT@, @UPDATE@, @DELETE@, and @COPY FROM@
219−-- if the table they would write to is not a temporary table;
220−-- all @CREATE@, @ALTER@, and @DROP@ commands;
221−-- @COMMENT@, @GRANT@, @REVOKE@, @TRUNCATE@;
222−-- and @EXPLAIN ANALYZE@ and @EXECUTE@ if the command they would execute is among those listed.
223−-- This is a high-level notion of `ReadOnly` that does not prevent all writes to disk.
224−data AccessMode
225− = ReadWrite
226− | ReadOnly
227− deriving (Show, Eq)
228−
229−-- | Render an `AccessMode`.
230−instance RenderSQL AccessMode where
231− renderSQL = \case
232− ReadWrite -> "READ WRITE"
233− ReadOnly -> "READ ONLY"
234−
235−-- | The `Deferrable` transaction property has no effect
236−-- unless the transaction is also `Serializable` and `ReadOnly`.
237−-- When all three of these properties are selected for a transaction,
238−-- the transaction may block when first acquiring its snapshot,
239−-- after which it is able to run without the normal overhead of a
240−-- `Serializable` transaction and without any risk of contributing
241−-- to or being canceled by a serialization failure.
242−-- This `longRunningMode` is well suited for long-running reports or backups.
243−data DeferrableMode
244− = Deferrable
245− | NotDeferrable
246− deriving (Show, Eq)
247−
248−-- | Render a `DeferrableMode`.
249−instance RenderSQL DeferrableMode where
250− renderSQL = \case
251− Deferrable -> "DEFERRABLE"
252− NotDeferrable -> "NOT DEFERRABLE"
squeal-postgresql/test/Doc.hsdeleted−6
@@ -1,6 +0,0 @@
1−module Main (main) where
2−
3−import Test.DocTest
4−
5−main :: IO ()
6−main = doctest [ "-isrc", "src" ]
squeal-postgresql/test/DocTest.hsnew file+12
@@ -0,0 +1,12 @@
1+module Main (main) where
2+
3+import Test.DocTest
4+
5+main :: IO ()
6+main = doctest
7+ [ "-isrc"
8+ , "src/Squeal/PostgreSQL/Binary.hs"
9+ , "src/Squeal/PostgreSQL/Definition.hs"
10+ , "src/Squeal/PostgreSQL/Manipulation.hs"
11+ , "src/Squeal/PostgreSQL/Query.hs"
12+ ]
squeal-postgresql/test/Property.hsdeleted−166
@@ -1,166 +0,0 @@
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.hs+1−136
@@ -1,136 +1 @@
1−{-# LANGUAGE
1+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
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/Squeal/PostgreSQL/DefinitionSpec.hsnew file+124
@@ -0,0 +1,124 @@
1+{-# LANGUAGE
2+ DataKinds
3+ , MagicHash
4+ , OverloadedLabels
5+ , OverloadedStrings
6+ , TypeApplications
7+ , TypeOperators
8+#-}
9+
10+module Squeal.PostgreSQL.DefinitionSpec where
11+
12+import Control.Category ((>>>))
13+import Data.Function
14+import Generics.SOP hiding (from)
15+import Test.Hspec
16+
17+import Squeal.PostgreSQL
18+
19+spec :: Spec
20+spec = do
21+ let
22+ definition `definitionRenders` str =
23+ renderDefinition definition `shouldBe` str
24+ it "should render CREATE TABLE statements" $ do
25+ createTable #table1
26+ ((int4 & notNull) `As` #col1 :* (int4 & notNull) `As` #col2 :* Nil)
27+ [primaryKey (Column #col1 :* Column #col2 :* Nil)]
28+ `definitionRenders`
29+ "CREATE TABLE table1\
30+ \ (col1 int4 NOT NULL, col2 int4 NOT NULL,\
31+ \ PRIMARY KEY (col1, col2));"
32+ createTable #table2
33+ ( serial `As` #col1 :*
34+ text `As` #col2 :*
35+ (int8 & notNull & default_ 8) `As` #col3 :* Nil )
36+ [check (#col3 .> 0)]
37+ `definitionRenders`
38+ "CREATE TABLE table2\
39+ \ (col1 serial,\
40+ \ col2 text,\
41+ \ col3 int8 NOT NULL DEFAULT 8,\
42+ \ CHECK ((col3 > 0)));"
43+ let
44+ statement :: Definition '[]
45+ '[ "users" :::
46+ '[ "id" ::: 'Optional ('NotNull 'PGint4)
47+ , "username" ::: 'Required ('NotNull 'PGtext)
48+ ]
49+ , "emails" :::
50+ '[ "id" ::: 'Optional ('NotNull 'PGint4)
51+ , "userid" ::: 'Required ('NotNull 'PGint4)
52+ , "email" ::: 'Required ('NotNull 'PGtext)
53+ ]
54+ ]
55+ statement =
56+ createTable #users
57+ (serial `As` #id :* (text & notNull) `As` #username :* Nil)
58+ [primaryKey (Column #id :* Nil)]
59+ >>>
60+ createTable #emails
61+ ( serial `As` #id :*
62+ (integer & notNull) `As` #userid :*
63+ (text & notNull) `As` #email :* Nil )
64+ [ primaryKey (Column #id :* Nil)
65+ , foreignKey (Column #userid :* Nil) #users (Column #id :* Nil)
66+ OnDeleteCascade OnUpdateRestrict
67+ , unique (Column #email :* Nil)
68+ , check (#email ./= "")
69+ ]
70+ statement `definitionRenders`
71+ "CREATE TABLE users\
72+ \ (id serial, username text NOT NULL,\
73+ \ PRIMARY KEY (id));\
74+ \ \
75+ \CREATE TABLE emails\
76+ \ (id serial,\
77+ \ userid integer NOT NULL,\
78+ \ email text NOT NULL,\
79+ \ PRIMARY KEY (id),\
80+ \ FOREIGN KEY (userid) REFERENCES users (id)\
81+ \ ON DELETE CASCADE ON UPDATE RESTRICT,\
82+ \ UNIQUE (email),\
83+ \ CHECK ((email <> E'')));"
84+ it "should render DROP TABLE statements" $ do
85+ let
86+ statement :: Definition Tables '[]
87+ statement = dropTable #table1
88+ statement `definitionRenders` "DROP TABLE table1;"
89+
90+type Columns =
91+ '[ "col1" ::: 'Required ('NotNull 'PGint4)
92+ , "col2" ::: 'Required ('NotNull 'PGint4)
93+ ]
94+type Tables = '[ "table1" ::: Columns ]
95+type SumAndCol1 =
96+ '[ "sum" ::: 'Required ('NotNull 'PGint4)
97+ , "col1" ::: 'Required ('NotNull 'PGint4)
98+ ]
99+type StudentsColumns = '["name" ::: 'Required ('NotNull 'PGtext)]
100+type StudentsTable = '["students" ::: StudentsColumns]
101+type OrderColumns =
102+ '[ "orderID" ::: 'Required ('NotNull 'PGint4)
103+ , "orderVal" ::: 'Required ('NotNull 'PGtext)
104+ , "customerID" ::: 'Required ('NotNull 'PGint4)
105+ , "shipperID" ::: 'Required ('NotNull 'PGint4)
106+ ]
107+type CustomerColumns =
108+ '[ "customerID" ::: 'Required ('NotNull 'PGint4)
109+ , "customerVal" ::: 'Required ('NotNull 'PGfloat4)
110+ ]
111+type ShipperColumns =
112+ '[ "shipperID" ::: 'Required ('NotNull 'PGint4)
113+ , "shipperVal" ::: 'Required ('NotNull 'PGbool)
114+ ]
115+type JoinTables =
116+ '[ "orders" ::: OrderColumns
117+ , "customers" ::: CustomerColumns
118+ , "shippers" ::: ShipperColumns
119+ ]
120+type ValueColumns =
121+ '[ "orderVal" ::: 'Required ('NotNull 'PGtext)
122+ , "customerVal" ::: 'Required ('NotNull 'PGfloat4)
123+ , "shipperVal" ::: 'Required ('NotNull 'PGbool)
124+ ]
squeal-postgresql/test/Squeal/PostgreSQL/ManipulationSpec.hsnew file+128
@@ -0,0 +1,128 @@
1+{-# LANGUAGE
2+ DataKinds
3+ , MagicHash
4+ , OverloadedLabels
5+ , OverloadedStrings
6+ , TypeApplications
7+ , TypeOperators
8+#-}
9+
10+module Squeal.PostgreSQL.ManipulationSpec where
11+
12+import Generics.SOP hiding (from)
13+import Test.Hspec
14+
15+import Squeal.PostgreSQL
16+
17+spec :: Spec
18+spec = do
19+ let
20+ manipulation `manipulationRenders` str =
21+ renderManipulation manipulation `shouldBe` str
22+ it "correctly renders returning INSERTs" $ do
23+ let
24+ statement :: Manipulation Tables '[] SumAndCol1
25+ statement =
26+ insertInto #table1 (Values (2 `As` #col1 :* 4 `As` #col2 :* Nil) [])
27+ OnConflictDoRaise
28+ (Returning $ (#col1 + #col2) `As` #sum :* #col1 `As` #col1 :* Nil)
29+ statement `manipulationRenders`
30+ "INSERT INTO table1 (col1, col2) VALUES (2, 4)\
31+ \ RETURNING (col1 + col2) AS sum, col1 AS col1;"
32+ it "correctly renders simple UPDATEs" $ do
33+ let
34+ statement :: Manipulation Tables '[] '[]
35+ statement =
36+ update #table1 (Set 2 `As` #col1 :* Same `As` #col2 :* Nil)
37+ (#col1 ./= #col2) (Returning Nil)
38+ statement `manipulationRenders`
39+ "UPDATE table1 SET col1 = 2\
40+ \ WHERE (col1 <> col2);"
41+ it "correctly renders returning UPDATEs" $ do
42+ let
43+ statement :: Manipulation Tables '[] SumAndCol1
44+ statement =
45+ update #table1 (Set 2 `As` #col1 :* Same `As` #col2 :* Nil)
46+ (#col1 ./= #col2)
47+ (Returning $ (#col1 + #col2) `As` #sum :* #col1 `As` #col1 :* Nil)
48+ statement `manipulationRenders`
49+ "UPDATE table1 SET col1 = 2\
50+ \ WHERE (col1 <> col2)\
51+ \ RETURNING (col1 + col2) AS sum, col1 AS col1;"
52+ it "correctly renders upsert INSERTs" $ do
53+ let
54+ statement :: Manipulation Tables '[] '[]
55+ statement =
56+ insertInto #table1 (Values (2 `As` #col1 :* 4 `As` #col2 :* Nil) [])
57+ (OnConflictDoUpdate
58+ (Set 2 `As` #col1 :* Same `As` #col2 :* Nil) Nothing)
59+ (Returning Nil)
60+ statement `manipulationRenders`
61+ "INSERT INTO table1 (col1, col2) VALUES (2, 4)\
62+ \ ON CONFLICT DO UPDATE\
63+ \ SET col1 = 2;"
64+ it "correctly renders returning upsert INSERTs" $ do
65+ let
66+ statement :: Manipulation Tables '[] SumAndCol1
67+ statement =
68+ insertInto #table1 (Values (2 `As` #col1 :* 4 `As` #col2 :* Nil) [])
69+ (OnConflictDoUpdate
70+ (Set 2 `As` #col1 :* Same `As` #col2 :* Nil)
71+ (Just (#col1 ./= #col2)))
72+ (Returning $ (#col1 + #col2) `As` #sum :* #col1 `As` #col1 :* Nil)
73+ statement `manipulationRenders`
74+ "INSERT INTO table1 (col1, col2) VALUES (2, 4)\
75+ \ ON CONFLICT DO UPDATE\
76+ \ SET col1 = 2\
77+ \ WHERE (col1 <> col2)\
78+ \ RETURNING (col1 + col2) AS sum, col1 AS col1;"
79+ it "correctly renders DELETEs" $ do
80+ let
81+ statement :: Manipulation Tables '[] '[]
82+ statement = deleteFrom #table1 (#col1 .== #col2) (Returning Nil)
83+ statement `manipulationRenders`
84+ "DELETE FROM table1 WHERE (col1 = col2);"
85+ it "should be safe against SQL injection in literal text" $ do
86+ let
87+ statement :: Manipulation StudentsTable '[] '[]
88+ statement = insertInto #students
89+ (Values ("Robert'); DROP TABLE students;" `As` #name :* Nil) [])
90+ OnConflictDoRaise (Returning Nil)
91+ statement `manipulationRenders`
92+ "INSERT INTO students (name) VALUES (E'Robert''); DROP TABLE students;');"
93+
94+type Columns =
95+ '[ "col1" ::: 'Required ('NotNull 'PGint4)
96+ , "col2" ::: 'Required ('NotNull 'PGint4)
97+ ]
98+type Tables = '[ "table1" ::: Columns ]
99+type SumAndCol1 =
100+ '[ "sum" ::: 'Required ('NotNull 'PGint4)
101+ , "col1" ::: 'Required ('NotNull 'PGint4)
102+ ]
103+type StudentsColumns = '["name" ::: 'Required ('NotNull 'PGtext)]
104+type StudentsTable = '["students" ::: StudentsColumns]
105+type OrderColumns =
106+ '[ "orderID" ::: 'Required ('NotNull 'PGint4)
107+ , "orderVal" ::: 'Required ('NotNull 'PGtext)
108+ , "customerID" ::: 'Required ('NotNull 'PGint4)
109+ , "shipperID" ::: 'Required ('NotNull 'PGint4)
110+ ]
111+type CustomerColumns =
112+ '[ "customerID" ::: 'Required ('NotNull 'PGint4)
113+ , "customerVal" ::: 'Required ('NotNull 'PGfloat4)
114+ ]
115+type ShipperColumns =
116+ '[ "shipperID" ::: 'Required ('NotNull 'PGint4)
117+ , "shipperVal" ::: 'Required ('NotNull 'PGbool)
118+ ]
119+type JoinTables =
120+ '[ "orders" ::: OrderColumns
121+ , "customers" ::: CustomerColumns
122+ , "shippers" ::: ShipperColumns
123+ ]
124+type ValueColumns =
125+ '[ "orderVal" ::: 'Required ('NotNull 'PGtext)
126+ , "customerVal" ::: 'Required ('NotNull 'PGfloat4)
127+ , "shipperVal" ::: 'Required ('NotNull 'PGbool)
128+ ]
squeal-postgresql/test/Squeal/PostgreSQL/QuerySpec.hsnew file+181
@@ -0,0 +1,181 @@
1+{-# LANGUAGE
2+ DataKinds
3+ , MagicHash
4+ , OverloadedLabels
5+ , OverloadedStrings
6+ , TypeApplications
7+ , TypeOperators
8+#-}
9+
10+module Squeal.PostgreSQL.QuerySpec where
11+
12+import Data.Function
13+import Generics.SOP hiding (from)
14+import Test.Hspec
15+
16+import Squeal.PostgreSQL
17+
18+spec :: Spec
19+spec = do
20+ let
21+ qry `queryRenders` str =
22+ renderManipulation (queryStatement qry) `shouldBe` str
23+ it "correctly renders a simple SELECT query" $ do
24+ let
25+ statement :: Query Tables '[] SumAndCol1
26+ statement =
27+ select ((#col1 + #col2) `As` #sum :* #col1 `As` #col1 :* Nil)
28+ (from (Table (#table1 `As` #table1)) & where_ (#col1 .> #col2))
29+ statement `queryRenders`
30+ "SELECT (col1 + col2) AS sum, col1 AS col1\
31+ \ FROM table1 AS table1 WHERE (col1 > col2);"
32+ it "combines WHEREs using AND" $ do
33+ let
34+ statement :: Query Tables '[] SumAndCol1
35+ statement =
36+ select ((#col1 + #col2) `As` #sum :* #col1 `As` #col1 :* Nil)
37+ (from (Table (#table1 `As` #table1)) & where_ true & where_ false)
38+ statement `queryRenders`
39+ "SELECT (col1 + col2) AS sum, col1 AS col1\
40+ \ FROM table1 AS table1 WHERE (TRUE AND FALSE);"
41+ it "performs sub SELECTs" $ do
42+ let
43+ statement :: Query Tables '[] SumAndCol1
44+ statement =
45+ selectStar (from (Subquery
46+ (select ((#col1 + #col2) `As` #sum :* #col1 `As` #col1 :* Nil)
47+ (from (Table (#table1 `As` #table1))) `As` #sub)))
48+ statement `queryRenders`
49+ "SELECT * FROM\
50+ \ (SELECT (col1 + col2) AS sum, col1 AS col1\
51+ \ FROM table1 AS table1) AS sub;"
52+ it "does LIMIT clauses" $ do
53+ let
54+ statement :: Query Tables '[] Columns
55+ statement = selectStar (from (Table (#table1 `As` #table1)) & limit 1)
56+ statement `queryRenders` "SELECT * FROM table1 AS table1 LIMIT 1;"
57+ it "should use the minimum of given LIMITs" $ do
58+ let
59+ statement :: Query Tables '[] Columns
60+ statement =
61+ selectStar (from (Table (#table1 `As` #table1)) & limit 1 & limit 2)
62+ statement `queryRenders` "SELECT * FROM table1 AS table1 LIMIT 1;"
63+ it "should render parameters using $ signs" $ do
64+ let
65+ statement :: Query Tables '[ 'Required ('NotNull 'PGbool)] Columns
66+ statement = selectStar
67+ (from (Table (#table1 `As` #table1)) & where_ (param @1))
68+ statement `queryRenders`
69+ "SELECT * FROM table1 AS table1 WHERE ($1 :: bool);"
70+ it "does OFFSET clauses" $ do
71+ let
72+ statement :: Query Tables '[] Columns
73+ statement =
74+ selectStar (from (Table (#table1 `As` #table1)) & offset 1)
75+ statement `queryRenders` "SELECT * FROM table1 AS table1 OFFSET 1;"
76+ it "should use the sum of given OFFSETs" $ do
77+ let
78+ statement :: Query Tables '[] Columns
79+ statement = selectStar
80+ (from (Table (#table1 `As` #table1)) & offset 1 & offset 2)
81+ statement `queryRenders` "SELECT * FROM table1 AS table1 OFFSET 3;"
82+ it "should render GROUP BY and HAVING clauses" $ do
83+ let
84+ statement :: Query Tables '[] SumAndCol1
85+ statement =
86+ select (sum_ #col2 `As` #sum :* #col1 `As` #col1 :* Nil)
87+ ( from (Table (#table1 `As` #table1))
88+ & group (By #col1 :* Nil)
89+ & having (#col1 + sum_ #col2 .> 1) )
90+ statement `queryRenders`
91+ "SELECT sum(col2) AS sum, col1 AS col1\
92+ \ FROM table1 AS table1\
93+ \ GROUP BY col1\
94+ \ HAVING ((col1 + sum(col2)) > 1);"
95+ describe "JOINs" $ do
96+ it "should render CROSS JOINs" $ do
97+ let
98+ statement :: Query JoinTables '[] ValueColumns
99+ statement = select
100+ ( #orders ! #orderVal `As` #orderVal :*
101+ #customers ! #customerVal `As` #customerVal :*
102+ #shippers ! #shipperVal `As` #shipperVal :* Nil )
103+ ( from (Table (#orders `As` #orders)
104+ & CrossJoin (Table (#customers `As` #customers))
105+ & CrossJoin (Table (#shippers `As` #shippers))) )
106+ statement `queryRenders`
107+ "SELECT\
108+ \ orders.orderVal AS orderVal,\
109+ \ customers.customerVal AS customerVal,\
110+ \ shippers.shipperVal AS shipperVal\
111+ \ FROM orders AS orders\
112+ \ CROSS JOIN customers AS customers\
113+ \ CROSS JOIN shippers AS shippers;"
114+ it "should render INNER JOINs" $ do
115+ let
116+ statement :: Query JoinTables '[] ValueColumns
117+ statement = select
118+ ( (#orders ! #orderVal) `As` #orderVal
119+ :* (#customers ! #customerVal) `As` #customerVal
120+ :* (#shippers ! #shipperVal) `As` #shipperVal :* Nil)
121+ ( from (Table (#orders `As` #orders)
122+ & InnerJoin (Table (#customers `As` #customers))
123+ ((#orders ! #customerID) .== (#customers ! #customerID))
124+ & InnerJoin (Table (#shippers `As` #shippers))
125+ ((#orders ! #shipperID) .== (#shippers ! #shipperID))))
126+ statement `queryRenders`
127+ "SELECT\
128+ \ orders.orderVal AS orderVal,\
129+ \ customers.customerVal AS customerVal,\
130+ \ shippers.shipperVal AS shipperVal\
131+ \ FROM orders AS orders\
132+ \ INNER JOIN customers AS customers\
133+ \ ON (orders.customerID = customers.customerID)\
134+ \ INNER JOIN shippers AS shippers\
135+ \ ON (orders.shipperID = shippers.shipperID);"
136+ it "should render self JOINs" $ do
137+ let
138+ statement :: Query JoinTables '[] OrderColumns
139+ statement = selectDotStar #orders1
140+ (from (Table (#orders `As` #orders1)
141+ & CrossJoin (Table (#orders `As` #orders2))))
142+ statement `queryRenders`
143+ "SELECT orders1.*\
144+ \ FROM orders AS orders1\
145+ \ CROSS JOIN orders AS orders2;"
146+
147+type Columns =
148+ '[ "col1" ::: 'Required ('NotNull 'PGint4)
149+ , "col2" ::: 'Required ('NotNull 'PGint4)
150+ ]
151+type Tables = '[ "table1" ::: Columns ]
152+type SumAndCol1 =
153+ '[ "sum" ::: 'Required ('NotNull 'PGint4)
154+ , "col1" ::: 'Required ('NotNull 'PGint4)
155+ ]
156+type StudentsColumns = '["name" ::: 'Required ('NotNull 'PGtext)]
157+type StudentsTable = '["students" ::: StudentsColumns]
158+type OrderColumns =
159+ '[ "orderID" ::: 'Required ('NotNull 'PGint4)
160+ , "orderVal" ::: 'Required ('NotNull 'PGtext)
161+ , "customerID" ::: 'Required ('NotNull 'PGint4)
162+ , "shipperID" ::: 'Required ('NotNull 'PGint4)
163+ ]
164+type CustomerColumns =
165+ '[ "customerID" ::: 'Required ('NotNull 'PGint4)
166+ , "customerVal" ::: 'Required ('NotNull 'PGfloat4)
167+ ]
168+type ShipperColumns =
169+ '[ "shipperID" ::: 'Required ('NotNull 'PGint4)
170+ , "shipperVal" ::: 'Required ('NotNull 'PGbool)
171+ ]
172+type JoinTables =
173+ '[ "orders" ::: OrderColumns
174+ , "customers" ::: CustomerColumns
175+ , "shippers" ::: ShipperColumns
176+ ]
177+type ValueColumns =
178+ '[ "orderVal" ::: 'Required ('NotNull 'PGtext)
179+ , "customerVal" ::: 'Required ('NotNull 'PGfloat4)
180+ , "shipperVal" ::: 'Required ('NotNull 'PGbool)
181+ ]
squeal-presentation-raveline.mddeleted−794
@@ -1,794 +0,0 @@
1−# Squeal
2−
3−_A bridge between SQL and Haskell_
4−
5−by [@Raveline](https://github.com/raveline)
6−
7−---
8−
9−# Rationale
10−
11−Using `postgresql-simple` you have a typical "Trial, error, despair" workflow:
12−
13−- Write query manually or semi-automatically
14−
15−- Write haskell code using the query
16−
17−- Pray that the query syntax is correct
18−
19−- Pray that it returns what you want
20−
21−- Realize the inefficiency of prayer when it comes to SQL
22−
23−- Iterate till it works
24−
25−---
26−
27−![Can't take this anymore](http://gif.eraveline.eu/static/img/0x16e.gif)
28−
29−---
30−
31−# Use your best friend: GHC
32−
33−Squeal provides several eDSL to make your SQL typesafe:
34−
35−- Type level eDSL to express schema;
36−
37−- Value level eDSL to manipulate schema (plus migration, yeehaw !);
38−
39−- Type level eDSL to express queries;
40−
41−- Value level eDSL to perform queries
42−
43−However, it's not an ORM. There's no caching, lazy loading - you retain control over your memory. Also, joins - and mostly aggregation after joins - have to be handled manually.
44−
45−---
46−
47−# Part I. Schema & migration
48−
49−---
50−
51−# The Schema
52−
53−- The schema will be used to validate _everything_: migration, queries, etc.
54−
55−- A schema is mostly a collection of tables.
56−
57−- In this presentation, we will create a very basic database modeling a parliament. We will store _members of parliament_ and _parliamentary groups_.
58−
59−- A simple Schema to represent a Parliament could be:
60−
61−```haskell
62−type Schema = '[ "mp" ::: 'Table MemberOfParliament
63− , "groupp" ::: 'Table ParliamentGroup ]
64−```
65−
66−---
67−
68−> _note_ We need the `DataKinds` extension to be able to express heterogenous lists containing
69−> specific types like this one.
70−
71−> You can perfectly call your table "group" and not "groupp" even though it is a
72−> keyword in SQL - Squeal queries will be properly escaped.
73−
74−---
75−
76−# A small example
77−
78−```haskell
79−type ParliamentaryGroup =
80− '[ "pk_groupp" ::: 'PrimaryKey '["groupp_id"]]
81− :=>
82− '[ "groupp_id" ::: 'NoDef :=> 'NotNull 'PGuuid
83− , "name" ::: 'NoDef :=> 'NotNull 'PGtext
84− ]
85−```
86−
87−- That's a whole simple table defined in one go.
88−
89−- `:::` lets us define a column or a constraint.
90−
91−- `:=>` associates the constraints to the column.
92−
93−- Let's split constraints and column to study the syntax a bit more.
94−
95−---
96−
97−> _note_ We are using `:::` and `:=>` to quickly express associations when writing
98−> our schema. We need the `TypeOperators` extension.]
99−
100−---
101−
102−![What does this means ?!](http://gif.eraveline.eu/static/img/0x27e.gif)
103−
104−---
105−
106−# Defining a table
107−
108−```haskell
109−type MemberOfParliament =
110− '[ "pk_mp" ::: 'PrimaryKey '["mp_id"]
111− , "fk_mp_groupp" ::: 'ForeignKey '["mp_group"] "groupp" '["groupp_id"]
112− ] :=> MpCols
113−```
114−
115−- A table is a collection of constraints associated to a collection of columns.
116−
117−- We defined a table named "mp".
118−
119−- It has a constraint named "pk_mp", defining its primary key on column "mp_id".
120−
121−- It has a constraint named "fk_mp_groupp" defining a foreign key on column "mg_group", connected to the column "groupp_id" of table "groupp".
122−
123−- These constraints will be associated to the columns defined in `MpCols`.
124−
125−---
126−
127−# Defining columns
128−
129−```haskell
130−type MpCols =
131− '[ "mp_id" ::: 'NoDef :=> 'NotNull 'PGuuid
132− , "first_name" ::: 'NoDef :=> 'NotNull 'PGtext
133− , "last_name" ::: 'NoDef :=> 'NotNull 'PGtext
134− ]
135−```
136−
137−- A listing of column associate, for each element:
138−
139− * a name;
140−
141− * the mention of an eventual default value;
142−
143− * the nullability;
144−
145− * the type (obviously).
146−
147−---
148−
149−> _note_ GHC is already helping. If I named the "mp_id" column differently,
150−> GHC would yell because I promised a primary key constraint on a column named `mp_id`, so there must be one.]
151−
152−---
153−
154−# Implementating the schema
155−
156−- We will carry this schema type pretty much everywhere.
157−
158−- But before we play with this schema, we need to implement it.
159−
160−---
161−
162−```haskell
163−setup :: Definition '[] Schema
164−setup =
165− createTable #groupp
166− ( notNullable uuid `as` #groupp_id
167− :* notNullable text `as` #name)
168− ( primaryKey #groupp_id `as` #pk_groupp )
169− >>> createTable #mp
170− ( notNullable uuid `as` #mp_id
171− :* notNullable text `as` #first_name
172− :* notNullable text `as` #last_name
173− :* notNullable text `as` #mp_group)
174− ( primaryKey #mp_id `as` #pk_mp
175− :* foreignKey #mp_group #groupp #groupp_id
176− OnDeleteCascade OnUpdateCascade
177− `as` #fk_mp_groupp)
178−```
179−
180−---
181−
182−# Damn, that's verbose
183−
184−- Yes. But you need verbosity to get type safety.
185−
186−- On the plus side, it's fairly straightforward.
187−
188−- You use `:*` to compose the element of the heterogenous list of columns.
189−
190−- You use `>>>` to compose table creation.
191−
192−> _note_ The compiler will catch any mistype between Schema and
193−> definition; wrong nullability, wrong type, wrong name, etc.
194−
195−---
196−
197−> _note_ You'll also need `OverloadedLabels`, for naming stuff.
198−> This is mostly to avoid having to write manual proxies all
199−> the time and for convenience.
200−
201−---
202−
203−# Setting up the schema
204−
205−- Squeal comes with a very good migration manager, handling _upgrades_ AND
206−_downgrades_.
207−
208−- A migration is a simple type:
209−
210−```haskell
211−Migration io schema0 schema1
212−```
213−
214−- The first parameter is a BaseMonad (typically, IO).
215−
216−- The second parameter is "the current schema of your DB".
217−
218−- The last one is "what you will migrate to".
219−
220−- The `Definition` type used to define upgrade and downgrade functions use the
221− same logic (from one schema to the other).
222−
223−---
224−
225−# Defining our first migration
226−
227−- We have the setup bit, we need the teardown:
228−
229−```haskell
230−tearDown :: Definition Schema '[]
231−tearDown = dropTable #mp >>> dropTable #groupp
232−```
233−
234−> _note_ GHC will also detect the _proper_ order of what you typed in
235−> downgrade and upgrade should there be any conflict (with foreign keys).
236−
237−```haskell
238−initDB :: Migration IO '[] Schema
239−initDB =
240− Migration { name = "Schema creation"
241− , up = void $ define setup
242− , down = void $ define tearDown }
243−```
244−
245−---
246−
247−# Simple migrator example
248−
249−```haskell
250−main :: IO ()
251−main = do
252− printSQL setup
253− void $ withConnection connectionString $
254− migrateUp $ single initDB
255−```
256−
257−- We print the migration query; you can do this for all queries generated through Squeal.
258−
259−- We use `migrateUp` to perform the migration.
260−
261−- You can run several migration at the same time, to run only one use `single`.
262−
263−---
264−
265−![That was easy](http://gif.eraveline.eu/static/img/0x47f.gif)
266−
267−---
268−
269−# Part II. Insertions
270−
271−---
272−
273−# Manipulations & Queries
274−
275−Besides the specific case of migration, you will mostly perform:
276−
277−- `Manipulation` : inserting, updating and deleting data.
278−
279−- `Query` : fetching data.
280−
281−- Both types are parametric over the same things:
282−
283− * A schema
284−
285− * Input parameters
286−
287− * Output
288−
289−- Simplified, they look like this:
290−
291−```haskell
292−Manipulation schema params columns
293−
294−Query schema params columns
295−```
296−
297−
298−---
299−
300−# Our Haskell model
301−
302−```haskell
303−type Parliament = [Group]
304−
305−data Group =
306− Group { name :: Text
307− , members :: [MemberOfParliament] }
308−
309−data MemberOfParliament =
310− MemberOfParliament { firstName :: Text
311− , lastName :: Text }
312−```
313−
314−> _note_ We didn't use anything from Squeal.
315−> The model can be entirely separated from the persistence layer.
316−
317−---
318−
319−# Inserting a Parliamentary Group
320−
321−- A group is very simple: it's a uuid and a name. Let's define our params:
322−
323−```haskell
324−type GroupInsertionParams = '[ 'NotNull 'PGuuid
325− , 'NotNull 'PGtext ]
326−```
327−
328−- Params are not named, but they are indexed. You just need nullability and type.
329−
330−---
331−
332−```haskell
333−groupInsertion :: Manipulation Schema GroupInsertionParams '[]
334−groupInsertion =
335− insertRow_ #groupp ( Set (param @1) `as` #groupp_id
336− :* Set (param @2) `as` #name )
337−```
338−
339−---
340−
341−- `TypeApplication` lets us use the index of parameters (counting from 1).
342−
343−- Once again: all this is checked by the compiler. Wrong name, wrong type... you'll get a compile error.
344−
345−- `insertRow_` is a simplified version of `insertRow`. `insertRow` lets you express a `RETURNING` clause and the expected behaviour in case of conflict.
346−
347−---
348−
349−_Inserting a Member of Parliament_
350−# Doing an INSERT INTO ... SELECT
351−
352−- We could create a naive query that takes MP uuid, first name, last name and group uuid...
353−
354−---
355−
356−- But that's boring. So let's use the `INSERT INTO ... SELECT`.
357−
358−---
359−
360−- We will build a query that will return as constants our MP's uuid, first name and last name...
361−
362−---
363−
364−- ... and fetch the uuid of a group given the name of the group.
365−
366−---
367−
368−- There's a `insertQuery` utility function for that. All we have to do is write the `select` !
369−
370−```haskell
371−mpInsertion :: Manipulation Schema MpParams '[]
372−mpInsertion =
373− insertQuery_ #mp selectGroup -- we just have to write selectGroup !
374−```
375−
376−---
377−
378−_Inserting a Member of Parliament_
379−# The query type
380−
381−- A query looks just like a `Manipulation`:
382−
383−```haskell
384−Query schema params returns
385−```
386−
387−- Returns use a special syntax, that demands names, nullability and types:
388−
389−```haskell
390−type ExampleReturnType = '[ "some_column" ::: 'NotNull 'PGuuid
391− , "other_column" ::: 'Null 'PGtext ]
392−```
393−
394−- It is not the same as the column definition we used in the schema. That one also expects that you specify, for each column, an eventual default:
395−
396−```haskell
397−type ExampleSchemaCols =
398− '[ "some_column" ::: 'NoDef :=> 'NotNull 'PGuuid
399− , "other_column" ::: 'NoDef :=> 'Null 'PGtext ]
400−```
401−
402−---
403−
404−_Inserting a Member of Parliament_
405−# Don't rewrite column definitions
406−
407−- We want our return type to be "all columns from table MP expressed as return type".
408−
409−- But we cannot reuse our neat `MpCols` alias, since the type do not match as we've just seen.
410−
411−- Hopefully, there's a neat Type Family that will let you convert any table you defined to the type of the equivalent row: `TableToRow`.
412−
413−- We finally have the signature for our SELECT query.
414−
415−```haskell
416−selectGroup :: Query Schema MpParams (TableToRow MemberOfParliament)
417−```
418−
419−---
420−
421−_Inserting a Member of Parliament_
422−# Our final Select query
423−
424−- Our intermediate query looks like this:
425−
426−```haskell
427−selectGroup =
428− select
429− ( param @1 `as` #mp_id
430− :* param @2 `as` #first_name
431− :* param @3 `as` #last_name
432− :* #groupp ! #groupp_id `as` #mp_group
433− )
434− ( from (table #groupp)
435− & where_ ( #groupp ! #name .== param @4 )
436− )
437−```
438−
439−- The first three columns are constant defined through our params;
440−
441−- ... we alias the column name using `as`...
442−
443−- ... and when we need the result from the table we use the `#table ! #column` syntax.
444−
445−- We'll go back to the "from" block later.
446−
447−---
448−
449−# Dealing with the connection context
450−
451−- Queries are runned in a connection context:
452−
453− * When dealing with a single-connection context, use the type `PQ`.
454−
455− * When dealing with a pool of connection, use the type `PoolPQ`.
456−
457−- Or get rid of the context and use `mtl` style, with the typeclass `MonadPQ`.
458−
459−- We'll use that to demonstrate how to actually run our queries.
460−
461−---
462−
463−# Inserting a whole group
464−
465−```haskell
466−insertGroup :: (MonadPQ Schema m, MonadBaseControl IO m) => Group -> m ()
467−insertGroup g@(Group name _) = do
468− uuid' <- liftBase nextRandom
469− void $ manipulateParams groupInsertion (uuid', name)
470− insertMps g
471−```
472−
473−- Remember that we defined a group as a name and a list of MPs.
474−
475−- We are in `MonadBaseControl`, so we cannot use `liftIO`, we need `liftBase`.
476−
477−- To perform a simple insertion, use `manipulateParams`. It takes into parameter
478−instances of `ToParam`, but you will typically use tuples or Generic-SOP.
479−
480−---
481−
482−# Inserting a bunch of MPs
483−
484−```haskell
485−insertMps :: (MonadPQ Schema m, MonadBaseControl IO m) => Group -> m ()
486−insertMps (Group groupName mps) =
487− let tuplify Mp{..} = (, firstName, lastName, groupName) <$> nextRandom
488− params = traverse tuplify mps
489− in void $ liftBase params >>= traversePrepared mpInsertion
490−```
491−
492−- This time, we want to do a `preparedStatement`. We'll use `traversePrepare`
493−which behaves like `manipulateParams`, but expect a list of `ToParam`
494−instances.
495−
496−- We build our tuple manually again, mostly because we want to generate UUID on
497−the fly and we don't want to have them in our model.
498−
499−---
500−
501−# Inserting a whole parliament
502−
503−```haskell
504−insertParliament ::
505− (MonadPQ Schema m, MonadBaseControl IO m) => Parliament -> m ()
506−insertParliament = traverse_ insertGroup
507−```
508−
509−- That's simple enough !
510−
511−- If we want to be a bit safer, though, we can wrap this call in a
512−`transactionally_` function, which will put all that in a transaction.
513−
514−---
515−
516−![Very simple](https://media1.tenor.com/images/0188c63209aced59f1583e1ca94e509e/tenor.gif?itemid=3550689)
517−
518−
519−---
520−
521−# Part III. Selects
522−
523−---
524−
525−# Composable queries
526−
527−- Building basic queries is easy, and is well documented.
528−
529−- However, the real interest of a tool like Squeal is in DRYness, and the documentation is still lacking in "how-to" related to composability.
530−
531−- I'll build an example showing how column selections and from clause can be factorized.
532−
533−- We want to write two queries:
534−
535− * One to get all members of a specific group.
536−
537− * One to get all the parliament.
538−
539−---
540−
541−# Decomposing a `Query`
542−
543−- A query typically stars with `select` (variants are available).
544−
545−- It then takes:
546−
547− * A heterogenous list of fields with a scary signature;
548−
549− * A virtual table (the from clause and filter clauses), called a `TableExpression`.
550−
551−- And return fields. Ours will look like this:
552−
553−```haskell
554−type GroupRowResult =
555− '[ "groupName" ::: 'NotNull 'PGtext
556− , "firstName" ::: 'NotNull 'PGtext
557− , "lastName" ::: 'NotNull 'PGtext ]
558−```
559−
560−---
561−
562−# The Table Expression
563−
564−- It necessarily contains a `fromClause` (table, view or subquery, plus optional joins).
565−
566−- You can add where, groups, "HAVING" clause, order, etc.
567−
568−- `from` creates a basic `TableExpression` that you extend through various function to add clauses.
569−
570−- For our queries, we will share a common `FromClause`.
571−
572−---
573−
574−# The From Clause
575−
576−```
577−FromClause schema params from
578−```
579−
580−- We need Schema, input parameters and a `FromType` giving the available fields of the expression.
581−
582−- In our case, we'll join the table `mp` and the table `groupp`, meaning the `from` will be all fields of these tables.
583−
584−- We can use `TableToRow` to be more DRY:
585−
586−```haskell
587−type BaseParliamentSelection =
588− '[ "g" ::: TableToRow GroupCols
589− , "m" ::: TableToRow MpCols ]
590−```
591−
592−> _note_ We've also put everything with table aliases: "g" and "m".
593−
594−---
595−
596−# Writing our from clause
597−
598−```haskell
599−baseParliamentTables ::
600− FromClause Schema (param :: [NullityType]) BaseParliamentSelection
601−baseParliamentTables =
602− table
603− (#groupp `as` #g)
604− & innerJoin
605− (table (#mp `as` #m))
606− (#m ! #mp_group .== #g ! #groupp_id)
607−```
608−
609−- When picking "from" something, you need to specify the type with a function: `table` for a table, `view` for a view, etc.
610−
611−- All joins are available. `innerJoin` is the most basic one. It takes the joined table and the joining condition.
612−
613−- We have to specifiy the type of `param` (current limitation of the lib), even though _any_ params will be compatible with this, so we can plug `where` clauses depending on params should we need to !
614−
615−---
616−
617−# Typing the common selection
618−
619−- Both our querie will need the same fields. This has to be factorized too.
620−
621−- The scary signature of selection fields:
622−
623−```haskell
624−NP (Aliased (Expression schema from grouping params)) cols
625−```
626−
627−- `NP` is for heterogenous lists ("n-ary product").
628−
629−- `from` is the virtual table type, so our `BaseParliamentSelection`.
630−
631−- `grouping` is there to make a distinction between aggregated / unaggregated queries.
632−
633−- And finally, cols is the return type.
634−
635−---
636−
637−# Our common selection
638−
639−```haskell
640−groupSelection ::
641− NP (Aliased (Expression Schema BaseParliamentSelection 'Ungrouped param))
642− GroupRowResult
643−groupSelection =
644− #g ! #name `as` #groupName
645− :* #m ! #first_name `as` #firstName
646− :* #m ! #last_name `as` #lastName
647−```
648−
649−- I hope you like big signatures.
650−
651−- But it's what let GHC checks that all alias and columns are available.
652−
653−- And that you're returning what you really intend to return.
654−
655−---
656−
657−# Putting it all together
658−
659−```haskell
660−selectParliament :: Query Schema '[] GroupRowResult
661−selectParliament =
662− select groupSelection (from baseParliamentTables)
663−```
664−
665−```haskell
666−selectGroupMembers :: Query Schema '[ 'NotNull 'PGtext] GroupRowResult
667−selectGroupMembers =
668− select groupSelection
669− (from baseParliamentTables
670− & where_ (#g ! #name .== param @1))
671−```
672−
673−- That is fairly DRY. And _entirely typesafe_.
674−
675−---
676−
677−# Actually fetching the data
678−
679−- We'll build an intermediary datatype representing our rows.
680−
681−- We'll make it match our row.
682−
683−- And we'll add generic-SOP so that we can build them from query results.
684−
685−```haskell
686−type GroupRowResult =
687− '[ "groupName" ::: 'NotNull 'PGtext
688− , "firstName" ::: 'NotNull 'PGtext
689− , "lastName" ::: 'NotNull 'PGtext ]
690−```
691−
692−```haskell
693−data GroupRow =
694− GroupRow { groupName :: Text
695− , firstName :: Text
696− , lastName :: Text }
697− deriving (Generic)
698−
699−instance SOP.Generic GroupRow
700−instance SOP.HasDatatypeInfo GroupRow
701−```
702−
703−---
704−
705−# Aggregate result logic
706−
707−- We will get tabular, SQL data.
708−
709−- Our results will be `[GroupRow]`.
710−
711−- We'll build `Groups` from this:
712−
713−```haskell
714−buildGroup :: NE.NonEmpty GroupRow -> Group
715−buildGroup grs =
716− let buildMP (GroupRow _ f l) = Mp f l
717− name = groupName . NE.head $ grs
718− members = NE.toList (buildMP <$> grs)
719− in Group{..}
720−
721−rowToGroups :: [GroupRow] -> [Group]
722−rowToGroups =
723− let grouped = fmap NE.fromList . L.groupBy ((==) `on` groupName)
724− in fmap buildGroup . grouped
725−```
726−
727−---
728−
729−# Finally calling our queries
730−
731−- Query with params will use `runQueryParams`.
732−
733−- Query without params will use `runQuery`.
734−
735−- Result is inside a `MonadPQ` and of type `K` from generic-sop.
736−
737−- You get your actual result using `getRows`. Exemple:
738−
739−```haskell
740−getParliament :: (MonadPQ Schema m, MonadBaseControl IO m) => m [Group]
741−getParliament = do
742− res <- runQuery selectParliament
743− rows <- getRows res
744− pure $ rowToGroups rows
745−```
746−
747−- In real life of course you'll write:
748−
749−```haskell
750−getParliament =
751− rowToGroups <$> (runQuery selectParliament >>= getRows)
752−```
753−
754−---
755−
756−# Our query with params
757−
758−```haskell
759−getGroupMembers ::
760− (MonadPQ Schema m, MonadBaseControl IO m) => Text -> m (Maybe Group)
761−getGroupMembers =
762− listToMaybe . rowToGroups <$>
763− (runQueryParams selectGroupMembers (Only t) >>= getRows)
764−```
765−
766−- And that's it.
767−
768−---
769−
770−![Eazy](https://media.tenor.com/images/8fc7c4077efe11b4a3a3b9ae4e643e87/tenor.gif)
771−
772−---
773−
774−# Conclusion
775−
776−---
777−
778−# Pros & Cons
779−
780−- Not everything is included: some cool stuff like array_agg and window functions are not available yet.
781−
782−- But development is _very_ active. `IN` clauses were missing but were added in the 4.0 released recently.
783−
784−- It's bleeding edge. You need latest LTS to be comfortable and psql >= 9.5.
785−
786−- It's Postgres-only but I would say that's a feature. Multi-DB tools are even more complex.
787−
788−- The author & maintainer is <3.
789−
790−- Typesafe. 'nuff said.
791−
792−---
793−
794−# Thank you !
squeal-presentation.pdfdeleted

Binary file not shown.

stack.yaml+1−6
@@ -1,8 +1,3 @@
1−resolver: nightly-2019-07-14
1+resolver: nightly-2017-08-25
2packages:
2packages:
3- squeal-postgresql
3- squeal-postgresql
4−
5−extra-deps:
6−- unliftio-pool-0.2.1.0
7−- github: morphismtech/free-categories
8− commit: c0e555fbefb5c21619e532264c4dfeac556d0630