git.iko.soy/squeal
on dev help sign in
swap
ddc9847919 ahead, 0 behind
.circleci/config.ymlnew file+24
since splitsnapshots
unifiedsplit
@@ -0,0 +1,24 @@
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,3 +17,4 @@ cabal.sandbox.config
17*.eventlog
17*.eventlog
18.stack-work/
18.stack-work/
19cabal.project.local
19cabal.project.local
20+.DS_Store
README.md+277−4
@@ -1,7 +1,280 @@
1−# squeel
1+# squeal
2
2
3−![squeel-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/squeel.svg?style=svg&circle-token=a699a654ef50db2c3744fb039cf2087c484d1226)](https://circleci.com/gh/echatav/squeel)
5+[![CircleCI](https://circleci.com/gh/echatav/squeal.svg?style=svg&circle-token=a699a654ef50db2c3744fb039cf2087c484d1226)](https://circleci.com/gh/morphismtech/squeal)
6
6
7−Main repository for the squeel database library.
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)
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.mdnew file+1217
@@ -0,0 +1,1217 @@
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.ymldeleted−10
@@ -1,10 +0,0 @@
1−dependencies:
2− cache_directories:
3− - "~/.stack"
4− - ".stack-work"
5− override:
6− - stack setup
7− - stack test --no-run-tests
8−test:
9− override:
10− - stack test
scrap-your-nils.mdnew file+60
@@ -0,0 +1,60 @@
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/LICENSEnew file+31
@@ -0,0 +1,31 @@
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.mdnew file+11
@@ -0,0 +1,11 @@
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)
squeel-postgresql/Setup.hs → squeal-postgresql/Setup.hsrenamed

The content is the same.

squeal-postgresql/docs-upload.shnew file+18
@@ -0,0 +1,18 @@
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.hsnew file+125
@@ -0,0 +1,125 @@
1+{-# LANGUAGE
2+ DataKinds
3+ , DeriveGeneric
4+ , FlexibleContexts
5+ , OverloadedLabels
6+ , OverloadedStrings
7+ , OverloadedLists
8+ , TypeApplications
9+ , TypeOperators
10+#-}
11+
12+module Main (main, main2) 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+
20+import Squeal.PostgreSQL
21+
22+import qualified Data.ByteString.Char8 as Char8
23+import qualified Generics.SOP as SOP
24+import qualified GHC.Generics as GHC
25+
26+type Schema =
27+ '[ "users" ::: 'Table (
28+ '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
29+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
30+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext
31+ , "vec" ::: 'NoDef :=> 'NotNull ('PGvararray ('Null 'PGint2))
32+ ])
33+ , "emails" ::: 'Table (
34+ '[ "pk_emails" ::: 'PrimaryKey '["id"]
35+ , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
36+ ] :=>
37+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
38+ , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
39+ , "email" ::: 'NoDef :=> 'Null 'PGtext
40+ ])
41+ , "positive" ::: 'Typedef 'PGfloat4
42+ ]
43+
44+type Schemas = Public Schema
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)
85+instance SOP.Generic User
86+instance SOP.HasDatatypeInfo User
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+
106+main :: IO ()
107+main = do
108+ Char8.putStrLn "squeal"
109+ connectionString <- pure
110+ "host=localhost port=5432 dbname=exampledb"
111+ Char8.putStrLn $ "connecting to " <> connectionString
112+ connection0 <- connectdb connectionString
113+ Char8.putStrLn "setting up schema"
114+ connection1 <- execPQ (define setup) connection0
115+ connection2 <- execPQ session connection1
116+ Char8.putStrLn "tearing down schema"
117+ connection3 <- execPQ (define teardown) connection2
118+ finish connection3
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.cabalnew file+147
@@ -0,0 +1,147 @@
1+name: squeal-postgresql
2+version: 0.5.1.0
3+synopsis: Squeal PostgreSQL Library
4+description: Squeal is a type-safe embedding of PostgreSQL in Haskell
5+homepage: https://github.com/morphismtech/squeal
6+bug-reports: https://github.com/morphismtech/squeal/issues
7+license: BSD3
8+license-file: LICENSE
9+author: Eitan Chatav
10+maintainer: eitan.chatav@gmail.com
11+copyright: Copyright (c) 2017 Morphism, LLC
12+category: Database
13+build-type: Simple
14+cabal-version: >=1.18
15+extra-doc-files: README.md
16+
17+source-repository head
18+ type: git
19+ location: https://github.com/morphismtech/squeal.git
20+
21+library
22+ hs-source-dirs: src
23+ exposed-modules:
24+ Squeal.PostgreSQL
25+ Squeal.PostgreSQL.Alias
26+ Squeal.PostgreSQL.Binary
27+ Squeal.PostgreSQL.Definition
28+ Squeal.PostgreSQL.Definition.Function
29+ Squeal.PostgreSQL.Definition.Index
30+ Squeal.PostgreSQL.Definition.Table
31+ Squeal.PostgreSQL.Definition.Table.Constraint
32+ Squeal.PostgreSQL.Definition.Type
33+ Squeal.PostgreSQL.Definition.Schema
34+ Squeal.PostgreSQL.Definition.View
35+ Squeal.PostgreSQL.Expression
36+ Squeal.PostgreSQL.Expression.Aggregate
37+ Squeal.PostgreSQL.Expression.Collection
38+ Squeal.PostgreSQL.Expression.Comparison
39+ Squeal.PostgreSQL.Expression.Json
40+ Squeal.PostgreSQL.Expression.Literal
41+ Squeal.PostgreSQL.Expression.Logic
42+ Squeal.PostgreSQL.Expression.Math
43+ Squeal.PostgreSQL.Expression.Null
44+ Squeal.PostgreSQL.Expression.Parameter
45+ Squeal.PostgreSQL.Expression.Range
46+ Squeal.PostgreSQL.Expression.Set
47+ Squeal.PostgreSQL.Expression.Sort
48+ Squeal.PostgreSQL.Expression.Subquery
49+ Squeal.PostgreSQL.Expression.Text
50+ Squeal.PostgreSQL.Expression.TextSearch
51+ Squeal.PostgreSQL.Expression.Time
52+ Squeal.PostgreSQL.Expression.Type
53+ Squeal.PostgreSQL.Expression.Window
54+ Squeal.PostgreSQL.List
55+ Squeal.PostgreSQL.Manipulation
56+ Squeal.PostgreSQL.Migration
57+ Squeal.PostgreSQL.Pool
58+ Squeal.PostgreSQL.PG
59+ Squeal.PostgreSQL.PQ
60+ Squeal.PostgreSQL.Render
61+ Squeal.PostgreSQL.Query
62+ Squeal.PostgreSQL.Schema
63+ Squeal.PostgreSQL.Transaction
64+ default-language: Haskell2010
65+ ghc-options: -Wall
66+ build-depends:
67+ aeson >= 1.2.4.0
68+ , base >= 4.11.1.0 && < 5.0
69+ , binary-parser >= 0.5.5
70+ , bytestring >= 0.10.8.2
71+ , bytestring-strict-builder >= 0.4.5
72+ , deepseq >= 1.4.3.0
73+ , free-categories >= 0.1.0.0
74+ , generics-sop >= 0.3.2.0 && < 0.5.0.0
75+ , mmorph >= 1.1.1
76+ , mtl >= 2.2.2
77+ , network-ip >= 0.3.0.2
78+ , postgresql-binary >= 0.12.1
79+ , postgresql-libpq >= 0.9.4.1
80+ , records-sop >= 0.1.0.0
81+ , resource-pool >= 0.2.3.2
82+ , scientific >= 0.3.5.3
83+ , text >= 1.2.3.0
84+ , time >= 1.8.0.2
85+ , transformers >= 0.5.2.0
86+ , unliftio >= 0.2.10
87+ , unliftio-pool >= 0.2.1.0
88+ , uuid-types >= 1.0.3
89+ , vector >= 0.12.0.1
90+
91+test-suite doctest
92+ default-language: Haskell2010
93+ type: exitcode-stdio-1.0
94+ hs-source-dirs: test
95+ ghc-options: -Wall
96+ main-is: Doc.hs
97+ build-depends:
98+ base >= 4.10.0.0
99+ , doctest >= 0.11.4
100+ , squeal-postgresql
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:
109+ base >= 4.10.0.0
110+ , bytestring >= 0.10.8.2
111+ , hedgehog >= 1.0
112+ , mtl >= 2.2.2
113+ , scientific >= 0.3.5.3
114+ , squeal-postgresql
115+ , time >= 1.8.0.2
116+
117+test-suite spec
118+ default-language: Haskell2010
119+ type: exitcode-stdio-1.0
120+ hs-source-dirs: test
121+ ghc-options: -Wall
122+ main-is: Spec.hs
123+ build-depends:
124+ base >= 4.10.0.0
125+ , async >= 2.2.2
126+ , bytestring >= 0.10.8.2
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+
134+executable example
135+ default-language: Haskell2010
136+ hs-source-dirs: exe
137+ ghc-options: -Wall
138+ main-is: Example.hs
139+ build-depends:
140+ base >= 4.10.0.0 && < 5.0
141+ , bytestring >= 0.10.8.2
142+ , generics-sop >= 0.3.1.0
143+ , mtl >= 2.2.1
144+ , squeal-postgresql
145+ , text >= 1.2.2.2
146+ , transformers >= 0.5.2.0
147+ , vector >= 0.12.0.1
squeal-postgresql/src/Squeal/PostgreSQL.hsnew file+233
@@ -0,0 +1,233 @@
1+{-|
2+Module: Squeal.PostgreSQL
3+Description: Squeal export module
4+Copyright: (c) Eitan Chatav, 2019
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Squeal is a deep embedding of [PostgreSQL](https://www.postgresql.org) in Haskell.
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+-}
193+module Squeal.PostgreSQL (module X, RenderSQL(..), printSQL) where
194+
195+import Squeal.PostgreSQL.Alias as X
196+import Squeal.PostgreSQL.Binary as X
197+import Squeal.PostgreSQL.Definition as X
198+import Squeal.PostgreSQL.Definition.Function as X
199+import Squeal.PostgreSQL.Definition.Index as X
200+import Squeal.PostgreSQL.Definition.Schema as X
201+import Squeal.PostgreSQL.Definition.Table as X
202+import Squeal.PostgreSQL.Definition.Table.Constraint as X
203+import Squeal.PostgreSQL.Definition.Type as X
204+import Squeal.PostgreSQL.Definition.View as X
205+import Squeal.PostgreSQL.Expression as X
206+import Squeal.PostgreSQL.Expression.Aggregate as X
207+import Squeal.PostgreSQL.Expression.Collection as X
208+import Squeal.PostgreSQL.Expression.Comparison as X
209+import Squeal.PostgreSQL.Expression.Json as X
210+import Squeal.PostgreSQL.Expression.Literal as X
211+import Squeal.PostgreSQL.Expression.Logic as X
212+import Squeal.PostgreSQL.Expression.Math as X
213+import Squeal.PostgreSQL.Expression.Null as X
214+import Squeal.PostgreSQL.Expression.Parameter as X
215+import Squeal.PostgreSQL.Expression.Range as X
216+import Squeal.PostgreSQL.Expression.Set as X
217+import Squeal.PostgreSQL.Expression.Sort as X
218+import Squeal.PostgreSQL.Expression.Subquery as X
219+import Squeal.PostgreSQL.Expression.Text as X
220+import Squeal.PostgreSQL.Expression.TextSearch as X
221+import Squeal.PostgreSQL.Expression.Time as X
222+import Squeal.PostgreSQL.Expression.Type as X
223+import Squeal.PostgreSQL.Expression.Window as X
224+import Squeal.PostgreSQL.List as X
225+import Squeal.PostgreSQL.Manipulation as X
226+import Squeal.PostgreSQL.Migration as X
227+import Squeal.PostgreSQL.PG as X
228+import Squeal.PostgreSQL.Pool as X
229+import Squeal.PostgreSQL.PQ as X
230+import Squeal.PostgreSQL.Query as X
231+import Squeal.PostgreSQL.Render (RenderSQL(..), printSQL)
232+import Squeal.PostgreSQL.Schema as X
233+import Squeal.PostgreSQL.Transaction as X
squeal-postgresql/src/Squeal/PostgreSQL/Alias.hsnew file+249
@@ -0,0 +1,249 @@
1+{-|
2+Module: Squeal.PostgreSQL.Alias
3+Description: Aliases
4+Copyright: (c) Eitan Chatav, 2019
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+This module embeds Postgres's alias system in Haskell in
9+a typesafe fashion. Thanks to GHC's @OverloadedLabels@ extension,
10+Squeal can reference aliases by prepending with a @#@.
11+-}
12+
13+{-# LANGUAGE
14+ AllowAmbiguousTypes
15+ , ConstraintKinds
16+ , DeriveAnyClass
17+ , DeriveGeneric
18+ , FlexibleContexts
19+ , FlexibleInstances
20+ , FunctionalDependencies
21+ , GADTs
22+ , LambdaCase
23+ , OverloadedStrings
24+ , QuantifiedConstraints
25+ , RankNTypes
26+ , ScopedTypeVariables
27+ , StandaloneDeriving
28+ , TypeApplications
29+ , TypeFamilyDependencies
30+ , TypeInType
31+ , TypeOperators
32+ , UndecidableInstances
33+ , UndecidableSuperClasses
34+#-}
35+
36+module Squeal.PostgreSQL.Alias
37+ ( (:::)
38+ , Alias (..)
39+ , IsLabel (..)
40+ , Aliased (As)
41+ , Aliasable (as)
42+ , renderAliased
43+ , Has
44+ , HasUnique
45+ , HasAll
46+ , HasIn
47+ , QualifiedAlias (..)
48+ , IsQualified (..)
49+ -- * Grouping
50+ , Grouping (..)
51+ , GroupedBy
52+ ) where
53+
54+import Control.DeepSeq
55+import Data.ByteString (ByteString)
56+import Data.String (fromString)
57+import GHC.OverloadedLabels
58+import GHC.TypeLits
59+
60+import qualified Generics.SOP as SOP
61+import qualified GHC.Generics as GHC
62+
63+import Squeal.PostgreSQL.List
64+import Squeal.PostgreSQL.Render
65+
66+-- $setup
67+-- >>> import Squeal.PostgreSQL
68+
69+-- | The alias operator `:::` is like a promoted version of `As`,
70+-- a type level pair between an alias and some type.
71+type (:::) (alias :: Symbol) ty = '(alias,ty)
72+infixr 6 :::
73+
74+
75+-- | `Grouping` is an auxiliary namespace, created by
76+-- @GROUP BY@ clauses (`Squeal.PostgreSQL.Query.group`), and used
77+-- for typesafe aggregation
78+data Grouping
79+ = Ungrouped -- ^ no aggregation permitted
80+ | Grouped [(Symbol,Symbol)] -- ^ aggregation required for any column which is not grouped
81+
82+{- | A `GroupedBy` constraint indicates that a table qualified column is
83+a member of the auxiliary namespace created by @GROUP BY@ clauses and thus,
84+may be called in an output `Squeal.PostgreSQL.Expression.Expression` without aggregating.
85+-}
86+class (KnownSymbol table, KnownSymbol column)
87+ => GroupedBy table column bys where
88+instance {-# OVERLAPPING #-} (KnownSymbol table, KnownSymbol column)
89+ => GroupedBy table column ('(table,column) ': bys)
90+instance {-# OVERLAPPABLE #-}
91+ ( KnownSymbol table
92+ , KnownSymbol column
93+ , GroupedBy table column bys
94+ ) => GroupedBy table column (tabcol ': bys)
95+
96+-- | `Alias`es are proxies for a type level string or `Symbol`
97+-- and have an `IsLabel` instance so that with @-XOverloadedLabels@
98+--
99+-- >>> :set -XOverloadedLabels
100+-- >>> #foobar :: Alias "foobar"
101+-- Alias
102+data Alias (alias :: Symbol) = Alias
103+ deriving (Eq,GHC.Generic,Ord,Show,NFData)
104+instance alias1 ~ alias2 => IsLabel alias1 (Alias alias2) where
105+ fromLabel = Alias
106+instance aliases ~ '[alias] => IsLabel alias (NP Alias aliases) where
107+ fromLabel = fromLabel SOP.:* Nil
108+-- | >>> printSQL (#jimbob :: Alias "jimbob")
109+-- "jimbob"
110+instance KnownSymbol alias => RenderSQL (Alias alias) where
111+ renderSQL = doubleQuoted . fromString . symbolVal
112+
113+-- >>> printSQL (#jimbob :* #kandi :: NP Alias '["jimbob", "kandi"])
114+-- "jimbob", "kandi"
115+instance SOP.All KnownSymbol aliases => RenderSQL (NP Alias aliases) where
116+ renderSQL
117+ = commaSeparated
118+ . SOP.hcollapse
119+ . SOP.hcmap (SOP.Proxy @KnownSymbol) (SOP.K . renderSQL)
120+
121+-- | The `As` operator is used to name an expression. `As` is like a demoted
122+-- version of `:::`.
123+--
124+-- >>> Just "hello" `As` #hi :: Aliased Maybe ("hi" ::: String)
125+-- As (Just "hello") Alias
126+data Aliased expression aliased where
127+ As
128+ :: KnownSymbol alias
129+ => expression ty
130+ -> Alias alias
131+ -> Aliased expression (alias ::: ty)
132+deriving instance Show (expression ty)
133+ => Show (Aliased expression (alias ::: ty))
134+deriving instance Eq (expression ty)
135+ => Eq (Aliased expression (alias ::: ty))
136+deriving instance Ord (expression ty)
137+ => Ord (Aliased expression (alias ::: ty))
138+instance (alias0 ~ alias1, alias0 ~ alias2, KnownSymbol alias2)
139+ => IsLabel alias0 (Aliased Alias (alias1 ::: alias2)) where
140+ fromLabel = fromLabel @alias2 `As` fromLabel @alias1
141+
142+-- | The `Aliasable` class provides a way to scrap your `Nil`s
143+-- in an `NP` list of `Aliased` expressions.
144+class KnownSymbol alias => Aliasable alias expression aliased
145+ | aliased -> expression
146+ , aliased -> alias
147+ where as :: expression -> Alias alias -> aliased
148+instance (KnownSymbol alias, aliased ~ (alias ::: ty)) => Aliasable alias
149+ (expression ty)
150+ (Aliased expression aliased)
151+ where
152+ as = As
153+instance (KnownSymbol alias, tys ~ '[alias ::: ty]) => Aliasable alias
154+ (expression ty)
155+ (NP (Aliased expression) tys)
156+ where
157+ expression `as` alias = expression `As` alias SOP.:* Nil
158+
159+-- | >>> let renderMaybe = fromString . maybe "Nothing" (const "Just")
160+-- >>> renderAliased renderMaybe (Just (3::Int) `As` #an_int)
161+-- "Just AS \"an_int\""
162+renderAliased
163+ :: (forall ty. expression ty -> ByteString)
164+ -> Aliased expression aliased
165+ -> ByteString
166+renderAliased render (expression `As` alias) =
167+ render expression <> " AS " <> renderSQL alias
168+
169+-- | @HasUnique alias fields field@ is a constraint that proves that
170+-- @fields@ is a singleton of @alias ::: field@.
171+type HasUnique alias fields field = fields ~ '[alias ::: field]
172+
173+-- | @Has alias fields field@ is a constraint that proves that
174+-- @fields@ has a field of @alias ::: field@, inferring @field@
175+-- from @alias@ and @fields@.
176+class KnownSymbol alias =>
177+ Has (alias :: Symbol) (fields :: [(Symbol,kind)]) (field :: kind)
178+ | alias fields -> field where
179+instance {-# OVERLAPPING #-} KnownSymbol alias
180+ => Has alias (alias ::: field ': fields) field
181+instance {-# OVERLAPPABLE #-} (KnownSymbol alias, Has alias fields field)
182+ => Has alias (field' ': fields) field
183+
184+{-| @HasIn fields (alias ::: field)@ is a constraint that proves that
185+@fields@ has a field of @alias ::: field@. It is used in @UPDATE@s to
186+choose which subfields to update.
187+-}
188+class HasIn fields field where
189+instance (Has alias fields field) => HasIn fields (alias ::: field) where
190+
191+-- | `HasAll` extends `Has` to take lists of @aliases@ and @fields@ and infer
192+-- a list of @subfields@.
193+class
194+ ( SOP.All KnownSymbol aliases
195+ ) => HasAll
196+ (aliases :: [Symbol])
197+ (fields :: [(Symbol,kind)])
198+ (subfields :: [(Symbol,kind)])
199+ | aliases fields -> subfields where
200+instance {-# OVERLAPPING #-} HasAll '[] fields '[]
201+instance {-# OVERLAPPABLE #-}
202+ (Has alias fields field, HasAll aliases fields subfields)
203+ => HasAll (alias ': aliases) fields (alias ::: field ': subfields)
204+
205+-- | Analagous to `IsLabel`, the constraint
206+-- `IsQualified` defines `!` for a column alias qualified
207+-- by a table alias.
208+class IsQualified table column expression where
209+ (!) :: Alias table -> Alias column -> expression
210+ infixl 9 !
211+instance IsQualified table column (Alias table, Alias column) where (!) = (,)
212+
213+{-| `QualifiedAlias`es enables multi-schema support by allowing a reference
214+to a `Squeal.PostgreSQL.Schema.Table`, `Squeal.PostgreSQL.Schema.Typedef`
215+or `Squeal.PostgreSQL.Schema.View` to be qualified by their schemas. By default,
216+a qualifier of @public@ is provided.
217+
218+>>> :{
219+let
220+ alias1 :: QualifiedAlias "sch" "tab"
221+ alias1 = #sch ! #tab
222+ alias2 :: QualifiedAlias "public" "vw"
223+ alias2 = #vw
224+in printSQL alias1 >> printSQL alias2
225+:}
226+"sch"."tab"
227+"vw"
228+-}
229+data QualifiedAlias (qualifier :: Symbol) (alias :: Symbol) = QualifiedAlias
230+ deriving (Eq,GHC.Generic,Ord,Show,NFData)
231+instance (q ~ q', a ~ a') => IsQualified q a (QualifiedAlias q' a') where
232+ _!_ = QualifiedAlias
233+instance (q' ~ "public", a ~ a') => IsLabel a (QualifiedAlias q' a') where
234+ fromLabel = QualifiedAlias
235+instance (q0 ~ q1, a0 ~ a1, a1 ~ a2, KnownSymbol a2) =>
236+ IsQualified q0 a0 (Aliased (QualifiedAlias q1) (a1 ::: a2)) where
237+ _!_ = QualifiedAlias `As` Alias
238+instance (q ~ "public", a0 ~ a1, a1 ~ a2, KnownSymbol a2) =>
239+ IsLabel a0 (Aliased (QualifiedAlias q) (a1 ::: a2)) where
240+ fromLabel = QualifiedAlias `As` Alias
241+
242+instance (KnownSymbol q, KnownSymbol a)
243+ => RenderSQL (QualifiedAlias q a) where
244+ renderSQL _ =
245+ let
246+ qualifier = renderSQL (Alias @q)
247+ alias = renderSQL (Alias @a)
248+ in
249+ if qualifier == "\"public\"" then alias else qualifier <> "." <> alias
squeal-postgresql/src/Squeal/PostgreSQL/Binary.hsnew file+848
@@ -0,0 +1,848 @@
1+{-|
2+Module: Squeal.PostgreSQL.Binary
3+Description: Binary encoding and decoding
4+Copyright: (c) Eitan Chatav, 2017
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+This module provides 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+-}
180+
181+{-# LANGUAGE
182+ AllowAmbiguousTypes
183+ , DeriveFoldable
184+ , DeriveFunctor
185+ , DeriveGeneric
186+ , DeriveTraversable
187+ , DefaultSignatures
188+ , FlexibleContexts
189+ , FlexibleInstances
190+ , FunctionalDependencies
191+ , GADTs
192+ , LambdaCase
193+ , OverloadedStrings
194+ , MultiParamTypeClasses
195+ , ScopedTypeVariables
196+ , TypeApplications
197+ , TypeFamilies
198+ , TypeInType
199+ , TypeOperators
200+ , UndecidableInstances
201+ , UndecidableSuperClasses
202+#-}
203+
204+module Squeal.PostgreSQL.Binary
205+ ( -- * Encoding
206+ ToParam (..)
207+ , ToParams (..)
208+ , ToNullityParam (..)
209+ , ToField (..)
210+ , ToFixArray (..)
211+ -- * Decoding
212+ , FromValue (..)
213+ , FromRow (..)
214+ , FromField (..)
215+ , FromFixArray (..)
216+ -- * Only
217+ , Only (..)
218+ -- * Oid
219+ , OidOf (..)
220+ , OidOfParam (..)
221+ , OidOfField (..)
222+ ) where
223+
224+import BinaryParser
225+import ByteString.StrictBuilder (builderLength, int32BE, int64BE, word32BE)
226+import Control.Arrow (left)
227+import Control.Monad
228+import Data.Int
229+import Data.Kind
230+import Data.Scientific
231+import Data.Time
232+import Data.UUID.Types
233+import Data.Vector (Vector)
234+import Data.Word
235+import Foreign.C.Types (CUInt(CUInt))
236+import Generics.SOP
237+import Generics.SOP.Record
238+import GHC.TypeLits
239+import Network.IP.Addr
240+
241+import qualified Data.Aeson as Aeson
242+import qualified Data.ByteString.Lazy as Lazy (ByteString)
243+import qualified Data.ByteString.Lazy as Lazy.ByteString
244+import qualified Data.ByteString as Strict (ByteString)
245+import qualified Data.Text.Lazy as Lazy (Text)
246+import qualified Data.Text as Strict (Text)
247+import qualified Data.Text as Strict.Text
248+import qualified Data.Vector as Vector
249+import qualified Database.PostgreSQL.LibPQ as LibPQ
250+import qualified GHC.Generics as GHC
251+import qualified PostgreSQL.Binary.Decoding as Decoding
252+import qualified PostgreSQL.Binary.Encoding as Encoding
253+
254+import Squeal.PostgreSQL.Alias
255+import Squeal.PostgreSQL.List
256+import Squeal.PostgreSQL.PG
257+import Squeal.PostgreSQL.Schema
258+
259+-- | A `ToParam` constraint gives an encoding of a Haskell `Type` into
260+-- into the binary format of a PostgreSQL `PGType`.
261+class ToParam (x :: Type) (pg :: PGType) where
262+ -- | >>> :set -XTypeApplications -XDataKinds
263+ -- >>> toParam @Bool @'PGbool False
264+ -- K "\NUL"
265+ --
266+ -- >>> toParam @Int16 @'PGint2 0
267+ -- K "\NUL\NUL"
268+ --
269+ -- >>> toParam @Int32 @'PGint4 0
270+ -- K "\NUL\NUL\NUL\NUL"
271+ --
272+ -- >>> :set -XMultiParamTypeClasses
273+ -- >>> newtype Id = Id { getId :: Int16 } deriving Show
274+ -- >>> instance ToParam Id 'PGint2 where toParam = toParam . getId
275+ -- >>> toParam @Id @'PGint2 (Id 1)
276+ -- K "\NUL\SOH"
277+ toParam :: x -> K Encoding.Encoding pg
278+instance ToParam Bool 'PGbool where toParam = K . Encoding.bool
279+instance ToParam Int16 'PGint2 where toParam = K . Encoding.int2_int16
280+instance ToParam Int32 'PGint4 where toParam = K . Encoding.int4_int32
281+instance ToParam Int64 'PGint8 where toParam = K . Encoding.int8_int64
282+instance ToParam Oid 'PGoid where toParam = K . Encoding.int4_word32 . getOid
283+instance ToParam Float 'PGfloat4 where toParam = K . Encoding.float4
284+instance ToParam Double 'PGfloat8 where toParam = K . Encoding.float8
285+instance ToParam Scientific 'PGnumeric where toParam = K . Encoding.numeric
286+instance ToParam Money 'PGmoney where toParam = K . Encoding.int8_int64 . cents
287+instance ToParam UUID 'PGuuid where toParam = K . Encoding.uuid
288+instance ToParam (NetAddr IP) 'PGinet where toParam = K . Encoding.inet
289+instance ToParam Char ('PGchar 1) where toParam = K . Encoding.char_utf8
290+instance ToParam Strict.Text 'PGtext where toParam = K . Encoding.text_strict
291+instance 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
294+instance ToParam Strict.ByteString 'PGbytea where
295+ toParam = K . Encoding.bytea_strict
296+instance ToParam Lazy.ByteString 'PGbytea where
297+ toParam = K . Encoding.bytea_lazy
298+instance ToParam Day 'PGdate where toParam = K . Encoding.date
299+instance ToParam TimeOfDay 'PGtime where toParam = K . Encoding.time_int
300+instance ToParam (TimeOfDay, TimeZone) 'PGtimetz where
301+ toParam = K . Encoding.timetz_int
302+instance ToParam LocalTime 'PGtimestamp where
303+ toParam = K . Encoding.timestamp_int
304+instance ToParam UTCTime 'PGtimestamptz where
305+ toParam = K . Encoding.timestamptz_int
306+instance ToParam DiffTime 'PGinterval where toParam = K . Encoding.interval_int
307+instance ToParam Aeson.Value 'PGjson where toParam = K . Encoding.json_ast
308+instance ToParam Aeson.Value 'PGjsonb where toParam = K . Encoding.jsonb_ast
309+instance Aeson.ToJSON x => ToParam (Json x) 'PGjson where
310+ toParam = K . Encoding.json_bytes
311+ . Lazy.ByteString.toStrict . Aeson.encode . getJson
312+instance Aeson.ToJSON x => ToParam (Jsonb x) 'PGjsonb where
313+ toParam = K . Encoding.jsonb_bytes
314+ . Lazy.ByteString.toStrict . Aeson.encode . getJsonb
315+instance (ToNullityParam x ty, ty ~ nullity pg, OidOf pg)
316+ => ToParam (VarArray [x]) ('PGvararray ty) where
317+ toParam = K
318+ . Encoding.array_foldable
319+ (getOid (oidOf @pg)) (unK . toNullityParam @x @ty)
320+ . getVarArray
321+instance (ToParam x pg, OidOf pg)
322+ => ToParam (VarArray (Vector x)) ('PGvararray ('NotNull pg)) where
323+ toParam = K
324+ . Encoding.array_vector (getOid (oidOf @pg)) (unK . toParam @x @pg)
325+ . getVarArray
326+instance (ToParam x pg, OidOf pg)
327+ => ToParam (VarArray (Vector (Maybe x))) ('PGvararray ('Null pg)) where
328+ toParam = K
329+ . Encoding.nullableArray_vector
330+ (getOid (oidOf @pg)) (unK . toParam @x @pg)
331+ . getVarArray
332+instance (ToFixArray x dims ty, ty ~ nullity pg, OidOf pg)
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
523+ toNullityParam = K . Just . unK . toParam @x @pg
524+instance ToParam x pg => ToNullityParam (Maybe x) ('Null pg) where
525+ toNullityParam = K . fmap (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+
554+-- | 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
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
559+ -- | >>> type Params = '[ 'NotNull 'PGbool, 'Null 'PGint2]
560+ -- >>> toParams @(Bool, Maybe Int16) @'[ 'NotNull 'PGbool, 'Null 'PGint2] (False, Just 0)
561+ -- K (Just "\NUL") :* K (Just "\NUL\NUL") :* Nil
562+ --
563+ -- >>> :set -XDeriveGeneric
564+ -- >>> data Tuple = Tuple { p1 :: Bool, p2 :: Maybe Int16} deriving GHC.Generic
565+ -- >>> instance Generic Tuple
566+ -- >>> toParams @Tuple @Params (Tuple False (Just 0))
567+ -- K (Just "\NUL") :* K (Just "\NUL\NUL") :* Nil
568+ toParams :: x -> NP (K (Maybe Encoding.Encoding)) tys
569+instance (SListI tys, IsProductType x xs, AllZip ToNullityParam xs tys)
570+ => ToParams x tys where
571+ toParams
572+ = htrans (Proxy @ToNullityParam) (toNullityParam . unI)
573+ . unZ . unSOP . from
574+
575+-- | A `FromValue` constraint gives a parser from the binary format of
576+-- a PostgreSQL `PGType` into a Haskell `Type`.
577+class FromValue (pg :: PGType) (y :: Type) where
578+ -- | >>> newtype Id = Id { getId :: Int16 } deriving Show
579+ -- >>> instance FromValue 'PGint2 Id where fromValue = Id <$> fromValue @'PGint2
580+ fromValue :: Decoding.Value y
581+instance FromValue 'PGbool Bool where fromValue = Decoding.bool
582+instance FromValue 'PGint2 Int16 where fromValue = Decoding.int
583+instance FromValue 'PGint4 Int32 where fromValue = Decoding.int
584+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
587+instance FromValue 'PGfloat8 Double where fromValue = Decoding.float8
588+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
591+instance FromValue 'PGinet (NetAddr IP) where fromValue = Decoding.inet
592+instance FromValue ('PGchar 1) Char where fromValue = Decoding.char
593+instance FromValue 'PGtext Strict.Text where fromValue = Decoding.text_strict
594+instance FromValue 'PGtext Lazy.Text where fromValue = Decoding.text_lazy
595+instance FromValue 'PGtext String where
596+ fromValue = Strict.Text.unpack <$> Decoding.text_strict
597+instance FromValue 'PGbytea Strict.ByteString where
598+ fromValue = Decoding.bytea_strict
599+instance FromValue 'PGbytea Lazy.ByteString where
600+ fromValue = Decoding.bytea_lazy
601+instance FromValue 'PGdate Day where fromValue = Decoding.date
602+instance FromValue 'PGtime TimeOfDay where fromValue = Decoding.time_int
603+instance FromValue 'PGtimetz (TimeOfDay, TimeZone) where
604+ fromValue = Decoding.timetz_int
605+instance FromValue 'PGtimestamp LocalTime where
606+ fromValue = Decoding.timestamp_int
607+instance FromValue 'PGtimestamptz UTCTime where
608+ fromValue = Decoding.timestamptz_int
609+instance FromValue 'PGinterval DiffTime where
610+ fromValue = Decoding.interval_int
611+instance FromValue 'PGjson Aeson.Value where fromValue = Decoding.json_ast
612+instance FromValue 'PGjsonb Aeson.Value where fromValue = Decoding.jsonb_ast
613+instance Aeson.FromJSON x => FromValue 'PGjson (Json x) where
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
704+-- to a decoding of a @(Symbol, NullityType)@ to a `Type`,
705+-- decoding `Null`s to `Maybe`s. You should not define instances for
706+-- `FromField`, just use the provided instances.
707+class FromField (pg :: (Symbol, NullityType)) (y :: (Symbol, Type)) where
708+ fromField
709+ :: K (Maybe Strict.ByteString) pg
710+ -> (Either Strict.Text :.: P) y
711+instance FromValue pg y
712+ => FromField (column ::: ('NotNull pg)) (column ::: y) where
713+ fromField = Comp . \case
714+ K Nothing -> Left "fromField: saw NULL when expecting NOT NULL"
715+ K (Just bytestring) -> P <$>
716+ Decoding.valueParser (fromValue @pg) bytestring
717+instance FromValue pg y
718+ => FromField (column ::: 'Null pg) (column ::: Maybe y) where
719+ fromField = Comp . \case
720+ K Nothing -> Right $ P Nothing
721+ K (Just bytestring) -> P . Just <$>
722+ Decoding.valueParser (fromValue @pg) bytestring
723+
724+-- | A `FromFixArray` constraint gives a decoding to a Haskell `Type`
725+-- from the binary format of a PostgreSQL fixed-length array.
726+-- You should not define instances for
727+-- `FromFixArray`, just use the provided instances.
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+
746+-- | A `FromRow` constraint generically sequences the parsings of the columns
747+-- of a `RowType` into the fields of a record `Type` provided they have
748+-- the same field names. You should not define instances of `FromRow`.
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
752+ -- | >>> :set -XOverloadedStrings
753+ -- >>> import Data.Text
754+ -- >>> newtype UserId = UserId { getUserId :: Int16 } deriving Show
755+ -- >>> instance FromValue 'PGint2 UserId where fromValue = UserId <$> fromValue @'PGint2
756+ -- >>> data UserRow = UserRow { userId :: UserId, userName :: Maybe Text } deriving (Show, GHC.Generic)
757+ -- >>> instance Generic UserRow
758+ -- >>> instance HasDatatypeInfo UserRow
759+ -- >>> type User = '["userId" ::: 'NotNull 'PGint2, "userName" ::: 'Null 'PGtext]
760+ -- >>> fromRow @User @UserRow (K (Just "\NUL\SOH") :* K (Just "bloodninja") :* Nil)
761+ -- Right (UserRow {userId = UserId {getUserId = 1}, userName = Just "bloodninja"})
762+ fromRow :: NP (K (Maybe Strict.ByteString)) result -> Either Strict.Text y
763+instance
764+ ( SListI result
765+ , IsRecord y ys
766+ , AllZip FromField result ys
767+ ) => FromRow result y where
768+ fromRow
769+ = fmap fromRecord
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+
820+-- | `Only` is a 1-tuple type, useful for encoding a single parameter with
821+-- `toParams` or decoding a single value with `fromRow`.
822+--
823+-- >>> import Data.Text
824+-- >>> toParams @(Only (Maybe Text)) @'[ 'Null 'PGtext] (Only (Just "foo"))
825+-- K (Just "foo") :* Nil
826+--
827+-- >>> fromRow @'["fromOnly" ::: 'Null 'PGtext] @(Only (Maybe Text)) (K (Just "bar") :* Nil)
828+-- Right (Only {fromOnly = Just "bar"})
829+newtype Only x = Only { fromOnly :: x }
830+ deriving (Functor,Foldable,Traversable,Eq,Ord,Read,Show,GHC.Generic)
831+instance Generic (Only x)
832+instance 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.hsnew file+82
@@ -0,0 +1,82 @@
1+{-|
2+Module: Squeal.PostgreSQL.Definition
3+Description: Squeal data definition language
4+Copyright: (c) Eitan Chatav, 2017
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Squeal data definition language.
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+ , UndecidableInstances
31+#-}
32+
33+module Squeal.PostgreSQL.Definition
34+ ( -- * Definition
35+ Definition (..)
36+ , (>>>)
37+ , manipDefinition
38+ ) where
39+
40+import Control.Category
41+import Control.DeepSeq
42+import Data.ByteString
43+import Data.Monoid
44+import Prelude hiding ((.), id)
45+
46+import qualified GHC.Generics as GHC
47+
48+import Squeal.PostgreSQL.Manipulation
49+import Squeal.PostgreSQL.Render
50+import Squeal.PostgreSQL.Schema
51+
52+-- $setup
53+-- >>> import Squeal.PostgreSQL
54+
55+{-----------------------------------------
56+statements
57+-----------------------------------------}
58+
59+-- | A `Definition` is a statement that changes the schemas of the
60+-- database, like a `createTable`, `dropTable`, or `alterTable` command.
61+-- `Definition`s may be composed using the `>>>` operator.
62+newtype Definition
63+ (schemas0 :: SchemasType)
64+ (schemas1 :: SchemasType)
65+ = UnsafeDefinition { renderDefinition :: ByteString }
66+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
67+
68+instance RenderSQL (Definition schemas0 schemas1) where
69+ renderSQL = renderDefinition
70+
71+instance Category Definition where
72+ id = UnsafeDefinition ";"
73+ ddl1 . ddl0 = UnsafeDefinition $
74+ renderSQL ddl0 <> "\n" <> renderSQL ddl1
75+
76+-- | A `Manipulation` without input or output can be run as a statement
77+-- along with other `Definition`s, by embedding it using `manipDefinition`.
78+manipDefinition
79+ :: Manipulation '[] schemas '[] '[]
80+ -- ^ no input or output
81+ -> Definition schemas schemas
82+manipDefinition = UnsafeDefinition . (<> ";") . renderSQL
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Function.hsnew file+238
@@ -0,0 +1,238 @@
1+{-|
2+Module: Squeal.PostgreSQL.Definition.Function
3+Description: Create and drop function and operator definitions
4+Copyright: (c) Eitan Chatav, 2017
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Create and drop function and operator definitions.
9+-}
10+
11+{-# LANGUAGE
12+ AllowAmbiguousTypes
13+ , ConstraintKinds
14+ , DeriveAnyClass
15+ , DeriveGeneric
16+ , DerivingStrategies
17+ , FlexibleContexts
18+ , FlexibleInstances
19+ , GADTs
20+ , LambdaCase
21+ , MultiParamTypeClasses
22+ , OverloadedLabels
23+ , OverloadedStrings
24+ , RankNTypes
25+ , ScopedTypeVariables
26+ , TypeApplications
27+ , TypeInType
28+ , TypeOperators
29+ , UndecidableSuperClasses
30+#-}
31+
32+module Squeal.PostgreSQL.Definition.Function
33+ ( createFunction
34+ , createOrReplaceFunction
35+ , createSetFunction
36+ , createOrReplaceSetFunction
37+ , createBinaryOp
38+ , createLeftOp
39+ , createRightOp
40+ , dropFunction
41+ , dropFunctionIfExists
42+ , dropOperator
43+ , dropOperatorIfExists
44+ , FunctionDefinition(..)
45+ , languageSqlExpr
46+ , languageSqlQuery
47+ ) where
48+
49+import Control.DeepSeq
50+import Data.ByteString
51+import GHC.TypeLits
52+
53+import qualified Generics.SOP as SOP
54+import qualified GHC.Generics as GHC
55+
56+import Squeal.PostgreSQL.Alias
57+import Squeal.PostgreSQL.Definition
58+import Squeal.PostgreSQL.Expression
59+import Squeal.PostgreSQL.Expression.Type
60+import Squeal.PostgreSQL.List
61+import Squeal.PostgreSQL.Query
62+import Squeal.PostgreSQL.Render
63+import Squeal.PostgreSQL.Schema
64+
65+-- $setup
66+-- >>> import Squeal.PostgreSQL
67+
68+createFunction
69+ :: ( Has sch schemas schema
70+ , KnownSymbol fun
71+ , SOP.SListI args )
72+ => QualifiedAlias sch fun
73+ -> NP (TypeExpression schemas) args
74+ -> TypeExpression schemas ret
75+ -> FunctionDefinition schemas args ('Returns ret)
76+ -> Definition schemas (Alter sch (Create fun ('Function (args :=> 'Returns ret)) schema) schemas)
77+createFunction fun args ret fundef = UnsafeDefinition $
78+ "CREATE" <+> "FUNCTION" <+> renderSQL fun
79+ <+> parenthesized (renderCommaSeparated renderSQL args)
80+ <+> "RETURNS" <+> renderSQL ret <+> renderSQL fundef <> ";"
81+
82+createOrReplaceFunction
83+ :: ( Has sch schemas schema
84+ , KnownSymbol fun
85+ , SOP.SListI args )
86+ => QualifiedAlias sch fun
87+ -> NP (TypeExpression schemas) args
88+ -> TypeExpression schemas ret
89+ -> FunctionDefinition schemas args ('Returns ret)
90+ -> Definition schemas (Alter sch (CreateOrReplace fun ('Function (args :=> 'Returns ret)) schema) schemas)
91+createOrReplaceFunction fun args ret fundef = UnsafeDefinition $
92+ "CREATE" <+> "OR" <+> "REPLACE" <+> "FUNCTION" <+> renderSQL fun
93+ <+> parenthesized (renderCommaSeparated renderSQL args)
94+ <+> "RETURNS" <+> renderSQL ret <+> renderSQL fundef <> ";"
95+
96+languageSqlExpr
97+ :: Expression '[] '[] 'Ungrouped schemas args '[] ret
98+ -> FunctionDefinition schemas args ('Returns ret)
99+languageSqlExpr expr = UnsafeFunctionDefinition $
100+ "language sql as"
101+ <+> "$$" <+> renderSQL (values_ (expr `as` #ret)) <+> "$$"
102+
103+languageSqlQuery
104+ :: Query '[] '[] schemas args rets
105+ -> FunctionDefinition schemas args ('ReturnsTable rets)
106+languageSqlQuery qry = UnsafeFunctionDefinition $
107+ "language sql as" <+> "$$" <+> renderSQL qry <+> "$$"
108+
109+createSetFunction
110+ :: ( Has sch schemas schema
111+ , KnownSymbol fun
112+ , SOP.SListI args
113+ , SOP.SListI rets )
114+ => QualifiedAlias sch fun
115+ -> NP (TypeExpression schemas) args
116+ -> NP (Aliased (TypeExpression schemas)) rets
117+ -> FunctionDefinition schemas args ('ReturnsTable rets)
118+ -> Definition schemas (Alter sch (Create fun ('Function (args :=> 'ReturnsTable rets)) schema) schemas)
119+createSetFunction fun args rets fundef = UnsafeDefinition $
120+ "CREATE" <+> "FUNCTION" <+> renderSQL fun
121+ <+> parenthesized (renderCommaSeparated renderSQL args)
122+ <+> "RETURNS" <+> "TABLE"
123+ <+> parenthesized (renderCommaSeparated renderRet rets)
124+ <+> renderSQL fundef <> ";"
125+ where
126+ renderRet :: Aliased (TypeExpression s) r -> ByteString
127+ renderRet (ty `As` col) = renderSQL col <+> renderSQL ty
128+
129+createOrReplaceSetFunction
130+ :: ( Has sch schemas schema
131+ , KnownSymbol fun
132+ , SOP.SListI args
133+ , SOP.SListI rets )
134+ => QualifiedAlias sch fun
135+ -> NP (TypeExpression schemas) args
136+ -> NP (Aliased (TypeExpression schemas)) rets
137+ -> FunctionDefinition schemas args ('ReturnsTable rets)
138+ -> Definition schemas (Alter sch (CreateOrReplace fun ('Function (args :=> 'ReturnsTable rets)) schema) schemas)
139+createOrReplaceSetFunction fun args rets fundef = UnsafeDefinition $
140+ "CREATE" <+> "OR" <+> "REPLACE" <+> "FUNCTION" <+> renderSQL fun
141+ <+> parenthesized (renderCommaSeparated renderSQL args)
142+ <+> "RETURNS" <+> "TABLE"
143+ <+> parenthesized (renderCommaSeparated renderRet rets)
144+ <+> renderSQL fundef <> ";"
145+ where
146+ renderRet :: Aliased (TypeExpression s) r -> ByteString
147+ renderRet (ty `As` col) = renderSQL col <+> renderSQL ty
148+
149+createBinaryOp
150+ :: forall op fun sch schemas schema x y z.
151+ ( Has sch schemas schema
152+ , Has fun schema ('Function ('[x,y] :=> 'Returns z))
153+ , KnownSymbol op )
154+ => QualifiedAlias sch fun
155+ -> TypeExpression schemas x
156+ -> TypeExpression schemas y
157+ -> Definition schemas
158+ (Alter sch (Create op ('Operator ('BinaryOp x y z)) schema) schemas)
159+createBinaryOp fun x y = UnsafeDefinition $
160+ "CREATE" <+> "OPERATOR" <+> renderSymbol @op
161+ <+> parenthesized (commaSeparated opdef)
162+ where
163+ opdef =
164+ [ "FUNCTION" <+> "=" <+> renderSQL fun
165+ , "LEFTARG" <+> "=" <+> renderSQL x
166+ , "RIGHTARG" <+> "=" <+> renderSQL y ]
167+
168+createLeftOp
169+ :: forall op fun sch schemas schema x y.
170+ ( Has sch schemas schema
171+ , Has fun schema ('Function ('[x] :=> 'Returns y))
172+ , KnownSymbol op )
173+ => QualifiedAlias sch fun
174+ -> TypeExpression schemas x
175+ -> Definition schemas
176+ (Alter sch (Create op ('Operator ('LeftOp x y)) schema) schemas)
177+createLeftOp fun x = UnsafeDefinition $
178+ "CREATE" <+> "OPERATOR" <+> renderSymbol @op
179+ <+> parenthesized (commaSeparated opdef)
180+ where
181+ opdef =
182+ [ "FUNCTION" <+> "=" <+> renderSQL fun
183+ , "RIGHTARG" <+> "=" <+> renderSQL x ]
184+
185+createRightOp
186+ :: forall op fun sch schemas schema x y.
187+ ( Has sch schemas schema
188+ , Has fun schema ('Function ('[x] :=> 'Returns y))
189+ , KnownSymbol op )
190+ => QualifiedAlias sch fun
191+ -> TypeExpression schemas x
192+ -> Definition schemas
193+ (Alter sch (Create op ('Operator ('RightOp x y)) schema) schemas)
194+createRightOp fun x = UnsafeDefinition $
195+ "CREATE" <+> "OPERATOR" <+> renderSymbol @op
196+ <+> parenthesized (commaSeparated opdef)
197+ where
198+ opdef =
199+ [ "FUNCTION" <+> "=" <+> renderSQL fun
200+ , "LEFTARG" <+> "=" <+> renderSQL x ]
201+
202+dropFunction
203+ :: (Has sch schemas schema, KnownSymbol fun)
204+ => QualifiedAlias sch fun
205+ -- ^ name of the user defined function
206+ -> Definition schemas (Alter sch (DropSchemum fun 'Function schema) schemas)
207+dropFunction fun = UnsafeDefinition $
208+ "DROP" <+> "FUNCTION" <+> renderSQL fun <> ";"
209+
210+dropFunctionIfExists
211+ :: (Has sch schemas schema, KnownSymbol fun)
212+ => QualifiedAlias sch fun
213+ -- ^ name of the user defined function
214+ -> Definition schemas (Alter sch (DropSchemumIfExists fun 'Function schema) schemas)
215+dropFunctionIfExists fun = UnsafeDefinition $
216+ "DROP FUNCTION IF EXISTS" <+> renderSQL fun <> ";"
217+
218+dropOperator
219+ :: (Has sch schemas schema, KnownSymbol op)
220+ => QualifiedAlias sch op
221+ -- ^ name of the user defined operator
222+ -> Definition schemas (Alter sch (DropSchemum op 'Operator schema) schemas)
223+dropOperator op = UnsafeDefinition $
224+ "DROP" <+> "OPERATOR" <+> renderSQL op <> ";"
225+
226+dropOperatorIfExists
227+ :: (Has sch schemas schema, KnownSymbol op)
228+ => QualifiedAlias sch op
229+ -- ^ name of the user defined operator
230+ -> Definition schemas (Alter sch (DropSchemumIfExists op 'Operator schema) schemas)
231+dropOperatorIfExists op = UnsafeDefinition $
232+ "DROP OPERATOR IF EXISTS" <+> renderSQL op <> ";"
233+
234+newtype FunctionDefinition schemas args ret = UnsafeFunctionDefinition
235+ { renderFunctionDefinition :: ByteString }
236+ deriving (Eq,Show,GHC.Generic,NFData)
237+instance RenderSQL (FunctionDefinition schemas args ret) where
238+ renderSQL = renderFunctionDefinition
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Index.hsnew file+159
@@ -0,0 +1,159 @@
1+{-|
2+Module: Squeal.PostgreSQL.Definition.Index
3+Description: Create and drop index definitions
4+Copyright: (c) Eitan Chatav, 2017
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Create and drop index definitions.
9+-}
10+
11+{-# LANGUAGE
12+ AllowAmbiguousTypes
13+ , ConstraintKinds
14+ , DeriveAnyClass
15+ , DeriveGeneric
16+ , DerivingStrategies
17+ , FlexibleContexts
18+ , FlexibleInstances
19+ , GADTs
20+ , LambdaCase
21+ , MultiParamTypeClasses
22+ , OverloadedLabels
23+ , OverloadedStrings
24+ , RankNTypes
25+ , ScopedTypeVariables
26+ , TypeApplications
27+ , TypeInType
28+ , TypeOperators
29+ , UndecidableSuperClasses
30+#-}
31+
32+module Squeal.PostgreSQL.Definition.Index
33+ ( createIndex
34+ , createIndexIfNotExists
35+ , dropIndex
36+ , dropIndexIfExists
37+ , IndexMethod (..)
38+ , btree
39+ , hash
40+ , gist
41+ , spgist
42+ , gin
43+ , brin
44+ ) where
45+
46+import Data.ByteString
47+import GHC.TypeLits
48+
49+import qualified GHC.Generics as GHC
50+
51+import Squeal.PostgreSQL.Alias
52+import Squeal.PostgreSQL.Definition
53+import Squeal.PostgreSQL.Expression.Sort
54+import Squeal.PostgreSQL.Render
55+import Squeal.PostgreSQL.Schema
56+
57+-- $setup
58+-- >>> import Squeal.PostgreSQL
59+
60+{- |
61+>>> :{
62+type Table = '[] :=>
63+ '[ "a" ::: 'NoDef :=> 'Null 'PGint4
64+ , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]
65+:}
66+
67+>>> :{
68+let
69+ setup :: Definition (Public '[]) (Public '["tab" ::: 'Table Table, "ix" ::: 'Index 'Btree])
70+ setup =
71+ createTable #tab (nullable int `as` #a :* nullable real `as` #b) Nil >>>
72+ createIndex #ix #tab btree [#a & AscNullsFirst, #b & AscNullsLast]
73+in printSQL setup
74+:}
75+CREATE TABLE "tab" ("a" int NULL, "b" real NULL);
76+CREATE INDEX "ix" ON "tab" USING btree (("a") ASC NULLS FIRST, ("b") ASC NULLS LAST);
77+-}
78+createIndex
79+ :: (Has sch schemas schema, Has tab schema ('Table table), KnownSymbol ix)
80+ => Alias ix
81+ -> QualifiedAlias sch tab
82+ -> IndexMethod method
83+ -> [SortExpression '[] '[] 'Ungrouped schemas '[] '[tab ::: TableToRow table]]
84+ -> Definition schemas (Alter sch (Create ix ('Index method) schema) schemas)
85+createIndex ix tab method cols = UnsafeDefinition $
86+ "CREATE" <+> "INDEX" <+> renderSQL ix <+> "ON" <+> renderSQL tab
87+ <+> "USING" <+> renderSQL method
88+ <+> parenthesized (commaSeparated (renderIndex <$> cols))
89+ <> ";"
90+ where
91+ renderIndex = \case
92+ Asc expression -> parenthesized (renderSQL expression) <+> "ASC"
93+ Desc expression -> parenthesized (renderSQL expression) <+> "DESC"
94+ AscNullsFirst expression -> parenthesized (renderSQL expression)
95+ <+> "ASC NULLS FIRST"
96+ DescNullsFirst expression -> parenthesized (renderSQL expression)
97+ <+> "DESC NULLS FIRST"
98+ AscNullsLast expression -> parenthesized (renderSQL expression)
99+ <+> "ASC NULLS LAST"
100+ DescNullsLast expression -> parenthesized (renderSQL expression)
101+ <+> "DESC NULLS LAST"
102+
103+createIndexIfNotExists
104+ :: (Has sch schemas schema, Has tab schema ('Table table), KnownSymbol ix)
105+ => Alias ix
106+ -> QualifiedAlias sch tab
107+ -> IndexMethod method
108+ -> [SortExpression '[] '[] 'Ungrouped schemas '[] '[tab ::: TableToRow table]]
109+ -> Definition schemas (Alter sch (CreateIfNotExists ix ('Index method) schema) schemas)
110+createIndexIfNotExists ix tab method cols = UnsafeDefinition $
111+ "CREATE INDEX IF NOT EXISTS" <+> renderSQL ix <+> "ON" <+> renderSQL tab
112+ <+> "USING" <+> renderSQL method
113+ <+> parenthesized (commaSeparated (renderIndex <$> cols))
114+ <> ";"
115+ where
116+ renderIndex = \case
117+ Asc expression -> parenthesized (renderSQL expression) <+> "ASC"
118+ Desc expression -> parenthesized (renderSQL expression) <+> "DESC"
119+ AscNullsFirst expression -> parenthesized (renderSQL expression)
120+ <+> "ASC NULLS FIRST"
121+ DescNullsFirst expression -> parenthesized (renderSQL expression)
122+ <+> "DESC NULLS FIRST"
123+ AscNullsLast expression -> parenthesized (renderSQL expression)
124+ <+> "ASC NULLS LAST"
125+ DescNullsLast expression -> parenthesized (renderSQL expression)
126+ <+> "DESC NULLS LAST"
127+
128+newtype IndexMethod ty = UnsafeIndexMethod {renderIndexMethod :: ByteString}
129+ deriving stock (Eq, Ord, Show, GHC.Generic)
130+instance RenderSQL (IndexMethod ty) where renderSQL = renderIndexMethod
131+btree :: IndexMethod 'Btree
132+btree = UnsafeIndexMethod "btree"
133+hash :: IndexMethod 'Hash
134+hash = UnsafeIndexMethod "hash"
135+gist :: IndexMethod 'Gist
136+gist = UnsafeIndexMethod "gist"
137+spgist :: IndexMethod 'Spgist
138+spgist = UnsafeIndexMethod "spgist"
139+gin :: IndexMethod 'Gin
140+gin = UnsafeIndexMethod "gin"
141+brin :: IndexMethod 'Brin
142+brin = UnsafeIndexMethod "brin"
143+
144+-- |
145+-- >>> printSQL (dropIndex #ix :: Definition (Public '["ix" ::: 'Index 'Btree]) (Public '[]))
146+-- DROP INDEX "ix";
147+dropIndex
148+ :: (Has sch schemas schema, KnownSymbol ix)
149+ => QualifiedAlias sch ix
150+ -- ^ name of the user defined index
151+ -> Definition schemas (Alter sch (DropSchemum ix 'Index schema) schemas)
152+dropIndex ix = UnsafeDefinition $ "DROP" <+> "INDEX" <+> renderSQL ix <> ";"
153+
154+dropIndexIfExists
155+ :: (Has sch schemas schema, KnownSymbol ix)
156+ => QualifiedAlias sch ix
157+ -- ^ name of the user defined index
158+ -> Definition schemas (Alter sch (DropSchemumIfExists ix 'Index schema) schemas)
159+dropIndexIfExists ix = UnsafeDefinition $ "DROP INDEX IF EXISTS" <+> renderSQL ix <> ";"
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Schema.hsnew file+96
@@ -0,0 +1,96 @@
1+{-|
2+Module: Squeal.PostgreSQL.Definition.Schema
3+Description: Create and drop schema definitions
4+Copyright: (c) Eitan Chatav, 2017
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Create and drop schema definitions.
9+-}
10+
11+{-# LANGUAGE
12+ AllowAmbiguousTypes
13+ , ConstraintKinds
14+ , DeriveAnyClass
15+ , DeriveGeneric
16+ , DerivingStrategies
17+ , FlexibleContexts
18+ , FlexibleInstances
19+ , GADTs
20+ , LambdaCase
21+ , MultiParamTypeClasses
22+ , OverloadedLabels
23+ , OverloadedStrings
24+ , RankNTypes
25+ , ScopedTypeVariables
26+ , TypeApplications
27+ , TypeInType
28+ , TypeOperators
29+ , UndecidableSuperClasses
30+#-}
31+
32+module Squeal.PostgreSQL.Definition.Schema
33+ ( createSchema
34+ , createSchemaIfNotExists
35+ , dropSchema
36+ , dropSchemaIfExists
37+ ) where
38+
39+import GHC.TypeLits
40+
41+import Squeal.PostgreSQL.Alias
42+import Squeal.PostgreSQL.Definition
43+import Squeal.PostgreSQL.Render
44+import Squeal.PostgreSQL.Schema
45+
46+-- $setup
47+-- >>> import Squeal.PostgreSQL
48+
49+{- |
50+`createSchema` enters a new schema into the current database.
51+The schema name must be distinct from the name of any existing schema
52+in the current database.
53+
54+A schema is essentially a namespace: it contains named objects
55+(tables, data types, functions, and operators) whose names
56+can duplicate those of other objects existing in other schemas.
57+Named objects are accessed by `QualifiedAlias`es with the schema
58+name as a prefix.
59+-}
60+createSchema
61+ :: KnownSymbol sch
62+ => Alias sch
63+ -> Definition schemas (Create sch '[] schemas)
64+createSchema sch = UnsafeDefinition $
65+ "CREATE" <+> "SCHEMA" <+> renderSQL sch <> ";"
66+
67+{- | Idempotent version of `createSchema`. -}
68+createSchemaIfNotExists
69+ :: (KnownSymbol sch, Has sch schemas schema)
70+ => Alias sch
71+ -> Definition schemas (CreateIfNotExists sch '[] schemas)
72+createSchemaIfNotExists sch = UnsafeDefinition $
73+ "CREATE" <+> "SCHEMA" <+> "IF" <+> "NOT" <+> "EXISTS"
74+ <+> renderSQL sch <> ";"
75+
76+-- | >>> :{
77+-- let
78+-- definition :: Definition '["muh_schema" ::: schema, "public" ::: public] '["public" ::: public]
79+-- definition = dropSchema #muh_schema
80+-- :}
81+--
82+-- >>> printSQL definition
83+-- DROP SCHEMA "muh_schema";
84+dropSchema
85+ :: KnownSymbol sch
86+ => Alias sch
87+ -- ^ user defined schema
88+ -> Definition schemas (Drop sch schemas)
89+dropSchema sch = UnsafeDefinition $ "DROP SCHEMA" <+> renderSQL sch <> ";"
90+
91+dropSchemaIfExists
92+ :: KnownSymbol sch
93+ => Alias sch
94+ -- ^ user defined schema
95+ -> Definition schemas (DropIfExists sch schemas)
96+dropSchemaIfExists sch = UnsafeDefinition $ "DROP SCHEMA" <+> renderSQL sch <> ";"
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Table.hsnew file+500
@@ -0,0 +1,500 @@
1+{-|
2+Module: Squeal.PostgreSQL.Definition.Table
3+Description: Create, drop and alter table definitions
4+Copyright: (c) Eitan Chatav, 2017
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Create, drop and alter table definitions.
9+-}
10+
11+{-# LANGUAGE
12+ AllowAmbiguousTypes
13+ , ConstraintKinds
14+ , DeriveAnyClass
15+ , DeriveGeneric
16+ , DerivingStrategies
17+ , FlexibleContexts
18+ , FlexibleInstances
19+ , GADTs
20+ , LambdaCase
21+ , MultiParamTypeClasses
22+ , OverloadedLabels
23+ , OverloadedStrings
24+ , RankNTypes
25+ , ScopedTypeVariables
26+ , TypeApplications
27+ , TypeInType
28+ , TypeOperators
29+ , UndecidableSuperClasses
30+#-}
31+
32+module Squeal.PostgreSQL.Definition.Table
33+ ( createTable
34+ , createTableIfNotExists
35+ , dropTable
36+ , dropTableIfExists
37+ , alterTable
38+ , alterTableIfExists
39+ , alterTableRename
40+ , alterTableIfExistsRename
41+ , AlterTable (..)
42+ , addConstraint
43+ , dropConstraint
44+ , AddColumn (..)
45+ , dropColumn
46+ , renameColumn
47+ , alterColumn
48+ , AlterColumn (..)
49+ , setDefault
50+ , dropDefault
51+ , setNotNull
52+ , dropNotNull
53+ , alterType
54+ ) where
55+
56+import Control.DeepSeq
57+import Data.ByteString
58+import GHC.TypeLits
59+
60+import qualified Generics.SOP as SOP
61+import qualified GHC.Generics as GHC
62+
63+import Squeal.PostgreSQL.Alias
64+import Squeal.PostgreSQL.Definition
65+import Squeal.PostgreSQL.Definition.Table.Constraint
66+import Squeal.PostgreSQL.Expression
67+import Squeal.PostgreSQL.Expression.Type
68+import Squeal.PostgreSQL.List
69+import Squeal.PostgreSQL.Render
70+import Squeal.PostgreSQL.Schema
71+
72+-- $setup
73+-- >>> import Squeal.PostgreSQL
74+
75+{- | `createTable` adds a table to the schema.
76+
77+>>> :set -XOverloadedLabels
78+>>> :{
79+type Table = '[] :=>
80+ '[ "a" ::: 'NoDef :=> 'Null 'PGint4
81+ , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]
82+:}
83+
84+>>> :{
85+let
86+ setup :: Definition (Public '[]) (Public '["tab" ::: 'Table Table])
87+ setup = createTable #tab
88+ (nullable int `as` #a :* nullable real `as` #b) Nil
89+in printSQL setup
90+:}
91+CREATE TABLE "tab" ("a" int NULL, "b" real NULL);
92+-}
93+createTable
94+ :: ( KnownSymbol sch
95+ , KnownSymbol tab
96+ , columns ~ (col ': cols)
97+ , SOP.SListI columns
98+ , SOP.SListI constraints
99+ , Has sch schemas0 schema0
100+ , schemas1 ~ Alter sch (Create tab ('Table (constraints :=> columns)) schema0) schemas0 )
101+ => QualifiedAlias sch tab -- ^ the name of the table to add
102+ -> NP (Aliased (ColumnTypeExpression schemas0)) columns
103+ -- ^ the names and datatype of each column
104+ -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints
105+ -- ^ constraints that must hold for the table
106+ -> Definition schemas0 schemas1
107+createTable tab columns constraints = UnsafeDefinition $
108+ "CREATE TABLE" <+> renderCreation tab columns constraints
109+
110+{-| `createTableIfNotExists` creates a table if it doesn't exist, but does not add it to the schema.
111+Instead, the schema already has the table so if the table did not yet exist, the schema was wrong.
112+`createTableIfNotExists` fixes this. Interestingly, this property makes it an idempotent in
113+the `Category` of `Definition`s.
114+
115+>>> :set -XOverloadedLabels -XTypeApplications
116+>>> :{
117+type Table = '[] :=>
118+ '[ "a" ::: 'NoDef :=> 'Null 'PGint4
119+ , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]
120+:}
121+
122+>>> type Schemas = Public '["tab" ::: 'Table Table]
123+
124+>>> :{
125+let
126+ setup :: Definition Schemas Schemas
127+ setup = createTableIfNotExists #tab
128+ (nullable int `as` #a :* nullable real `as` #b) Nil
129+in printSQL setup
130+:}
131+CREATE TABLE IF NOT EXISTS "tab" ("a" int NULL, "b" real NULL);
132+-}
133+createTableIfNotExists
134+ :: ( KnownSymbol sch
135+ , KnownSymbol tab
136+ , columns ~ (col ': cols)
137+ , SOP.SListI columns
138+ , SOP.SListI constraints
139+ , Has sch schemas0 schema0
140+ , schemas1 ~ Alter sch (CreateIfNotExists tab ('Table (constraints :=> columns)) schema0) schemas0 )
141+ => QualifiedAlias sch tab -- ^ the name of the table to add
142+ -> NP (Aliased (ColumnTypeExpression schemas0)) columns
143+ -- ^ the names and datatype of each column
144+ -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints
145+ -- ^ constraints that must hold for the table
146+ -> Definition schemas0 schemas1
147+createTableIfNotExists tab columns constraints = UnsafeDefinition $
148+ "CREATE TABLE IF NOT EXISTS"
149+ <+> renderCreation tab columns constraints
150+
151+-- helper function for `createTable` and `createTableIfNotExists`
152+renderCreation
153+ :: ( KnownSymbol sch
154+ , KnownSymbol tab
155+ , SOP.SListI columns
156+ , SOP.SListI constraints )
157+ => QualifiedAlias sch tab -- ^ the name of the table to add
158+ -> NP (Aliased (ColumnTypeExpression schemas0)) columns
159+ -- ^ the names and datatype of each column
160+ -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints
161+ -- ^ constraints that must hold for the table
162+ -> ByteString
163+renderCreation tab columns constraints = renderSQL tab
164+ <+> parenthesized
165+ ( renderCommaSeparated renderColumnDef columns
166+ <> ( case constraints of
167+ Nil -> ""
168+ _ -> ", " <>
169+ renderCommaSeparated renderConstraint constraints ) )
170+ <> ";"
171+ where
172+ renderColumnDef :: Aliased (ColumnTypeExpression schemas) x -> ByteString
173+ renderColumnDef (ty `As` column) =
174+ renderSQL column <+> renderColumnTypeExpression ty
175+ renderConstraint
176+ :: Aliased (TableConstraintExpression sch tab schemas) constraint
177+ -> ByteString
178+ renderConstraint (constraint `As` alias) =
179+ "CONSTRAINT" <+> renderSQL alias <+> renderSQL constraint
180+
181+-- | `dropTable` removes a table from the schema.
182+--
183+-- >>> :{
184+-- let
185+-- definition :: Definition '["public" ::: '["muh_table" ::: 'Table t]] (Public '[])
186+-- definition = dropTable #muh_table
187+-- :}
188+--
189+-- >>> printSQL definition
190+-- DROP TABLE "muh_table";
191+dropTable
192+ :: ( Has sch schemas schema
193+ , KnownSymbol tab )
194+ => QualifiedAlias sch tab -- ^ table to remove
195+ -> Definition schemas (Alter sch (DropSchemum tab 'Table schema) schemas)
196+dropTable tab = UnsafeDefinition $ "DROP TABLE" <+> renderSQL tab <> ";"
197+
198+dropTableIfExists
199+ :: ( Has sch schemas schema
200+ , KnownSymbol tab)
201+ => QualifiedAlias sch tab -- ^ table to remove
202+ -> Definition schemas (Alter sch (DropSchemumIfExists tab 'Table schema) schemas)
203+dropTableIfExists tab = UnsafeDefinition $ "DROP TABLE IF EXISTS" <+> renderSQL tab <> ";"
204+
205+-- | `alterTable` changes the definition of a table from the schema.
206+alterTable
207+ :: (Has sch schemas schema, KnownSymbol tab)
208+ => QualifiedAlias sch tab -- ^ table to alter
209+ -> AlterTable sch tab schemas table -- ^ alteration to perform
210+ -> Definition schemas (Alter sch (Alter tab ('Table table) schema) schemas)
211+alterTable tab alteration = UnsafeDefinition $
212+ "ALTER TABLE"
213+ <+> renderSQL tab
214+ <+> renderAlterTable alteration
215+ <> ";"
216+
217+-- | `alterTable` changes the definition of a table from the schema.
218+alterTableIfExists
219+ :: (Has sch schemas schema, KnownSymbol tab)
220+ => QualifiedAlias sch tab -- ^ table to alter
221+ -> AlterTable sch tab schemas table -- ^ alteration to perform
222+ -> Definition schemas (Alter sch (AlterIfExists tab ('Table table) schema) schemas)
223+alterTableIfExists tab alteration = UnsafeDefinition $
224+ "ALTER TABLE IF EXISTS"
225+ <+> renderSQL tab
226+ <+> renderAlterTable alteration
227+ <> ";"
228+
229+-- | `alterTableRename` changes the name of a table from the schema.
230+--
231+-- >>> printSQL $ alterTableRename #foo #bar
232+-- ALTER TABLE "foo" RENAME TO "bar";
233+alterTableRename
234+ :: (KnownSymbol tab0, KnownSymbol tab1)
235+ => Alias tab0 -- ^ table to rename
236+ -> Alias tab1 -- ^ what to rename it
237+ -> Definition schema (Rename tab0 tab1 schema)
238+alterTableRename tab0 tab1 = UnsafeDefinition $
239+ "ALTER TABLE" <+> renderSQL tab0
240+ <+> "RENAME TO" <+> renderSQL tab1 <> ";"
241+
242+alterTableIfExistsRename
243+ :: (KnownSymbol tab0, KnownSymbol tab1)
244+ => Alias tab0 -- ^ table to rename
245+ -> Alias tab1 -- ^ what to rename it
246+ -> Definition schema (RenameIfExists tab0 tab1 schema)
247+alterTableIfExistsRename tab0 tab1 = UnsafeDefinition $
248+ "ALTER TABLE IF EXISTS" <+> renderSQL tab0
249+ <+> "RENAME TO" <+> renderSQL tab1 <> ";"
250+
251+-- | An `AlterTable` describes the alteration to perform on the columns
252+-- of a table.
253+newtype AlterTable
254+ (sch :: Symbol)
255+ (tab :: Symbol)
256+ (schemas :: SchemasType)
257+ (table :: TableType) =
258+ UnsafeAlterTable {renderAlterTable :: ByteString}
259+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
260+
261+-- | An `addConstraint` adds a table constraint.
262+--
263+-- >>> :{
264+-- let
265+-- definition :: Definition
266+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
267+-- '["public" ::: '["tab" ::: 'Table ('["positive" ::: 'Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
268+-- definition = alterTable #tab (addConstraint #positive (check #col (#col .> 0)))
269+-- in printSQL definition
270+-- :}
271+-- ALTER TABLE "tab" ADD CONSTRAINT "positive" CHECK (("col" > 0));
272+addConstraint
273+ :: ( KnownSymbol alias
274+ , Has sch schemas schema
275+ , Has tab schema ('Table table0)
276+ , table0 ~ (constraints :=> columns)
277+ , table1 ~ (Create alias constraint constraints :=> columns) )
278+ => Alias alias
279+ -> TableConstraintExpression sch tab schemas constraint
280+ -- ^ constraint to add
281+ -> AlterTable sch tab schemas table1
282+addConstraint alias constraint = UnsafeAlterTable $
283+ "ADD" <+> "CONSTRAINT" <+> renderSQL alias
284+ <+> renderSQL constraint
285+
286+-- | A `dropConstraint` drops a table constraint.
287+--
288+-- >>> :{
289+-- let
290+-- definition :: Definition
291+-- '["public" ::: '["tab" ::: 'Table ('["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
292+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
293+-- definition = alterTable #tab (dropConstraint #positive)
294+-- in printSQL definition
295+-- :}
296+-- ALTER TABLE "tab" DROP CONSTRAINT "positive";
297+dropConstraint
298+ :: ( KnownSymbol constraint
299+ , Has sch schemas schema
300+ , Has tab schema ('Table table0)
301+ , table0 ~ (constraints :=> columns)
302+ , table1 ~ (Drop constraint constraints :=> columns) )
303+ => Alias constraint
304+ -- ^ constraint to drop
305+ -> AlterTable sch tab schemas table1
306+dropConstraint constraint = UnsafeAlterTable $
307+ "DROP" <+> "CONSTRAINT" <+> renderSQL constraint
308+
309+-- | An `AddColumn` is either @NULL@ or has @DEFAULT@.
310+class AddColumn ty where
311+ -- | `addColumn` adds a new column, initially filled with whatever
312+ -- default value is given or with @NULL@.
313+ --
314+ -- >>> :{
315+ -- let
316+ -- definition :: Definition
317+ -- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]
318+ -- '["public" ::: '["tab" ::: 'Table ('[] :=>
319+ -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
320+ -- , "col2" ::: 'Def :=> 'Null 'PGtext ])]]
321+ -- definition = alterTable #tab (addColumn #col2 (text & nullable & default_ "foo"))
322+ -- in printSQL definition
323+ -- :}
324+ -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL DEFAULT E'foo';
325+ --
326+ -- >>> :{
327+ -- let
328+ -- definition :: Definition
329+ -- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]
330+ -- '["public" ::: '["tab" ::: 'Table ('[] :=>
331+ -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
332+ -- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]]
333+ -- definition = alterTable #tab (addColumn #col2 (text & nullable))
334+ -- in printSQL definition
335+ -- :}
336+ -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL;
337+ addColumn
338+ :: ( KnownSymbol column
339+ , Has sch schemas schema
340+ , Has tab schema ('Table table0)
341+ , table0 ~ (constraints :=> columns) )
342+ => Alias column -- ^ column to add
343+ -> ColumnTypeExpression schemas ty -- ^ type of the new column
344+ -> AlterTable sch tab schemas (constraints :=> Create column ty columns)
345+ addColumn column ty = UnsafeAlterTable $
346+ "ADD COLUMN" <+> renderSQL column <+> renderColumnTypeExpression ty
347+instance {-# OVERLAPPING #-} AddColumn ('Def :=> ty)
348+instance {-# OVERLAPPABLE #-} AddColumn ('NoDef :=> 'Null ty)
349+
350+-- | A `dropColumn` removes a column. Whatever data was in the column
351+-- disappears. Table constraints involving the column are dropped, too.
352+-- However, if the column is referenced by a foreign key constraint of
353+-- another table, PostgreSQL will not silently drop that constraint.
354+--
355+-- >>> :{
356+-- let
357+-- definition :: Definition
358+-- '["public" ::: '["tab" ::: 'Table ('[] :=>
359+-- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
360+-- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]]
361+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]
362+-- definition = alterTable #tab (dropColumn #col2)
363+-- in printSQL definition
364+-- :}
365+-- ALTER TABLE "tab" DROP COLUMN "col2";
366+dropColumn
367+ :: ( KnownSymbol column
368+ , Has sch schemas schema
369+ , Has tab schema ('Table table0)
370+ , table0 ~ (constraints :=> columns)
371+ , table1 ~ (constraints :=> Drop column columns) )
372+ => Alias column -- ^ column to remove
373+ -> AlterTable sch tab schemas table1
374+dropColumn column = UnsafeAlterTable $
375+ "DROP COLUMN" <+> renderSQL column
376+
377+-- | A `renameColumn` renames a column.
378+--
379+-- >>> :{
380+-- let
381+-- definition :: Definition
382+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["foo" ::: 'NoDef :=> 'Null 'PGint4])]]
383+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["bar" ::: 'NoDef :=> 'Null 'PGint4])]]
384+-- definition = alterTable #tab (renameColumn #foo #bar)
385+-- in printSQL definition
386+-- :}
387+-- ALTER TABLE "tab" RENAME COLUMN "foo" TO "bar";
388+renameColumn
389+ :: ( KnownSymbol column0
390+ , KnownSymbol column1
391+ , Has sch schemas schema
392+ , Has tab schema ('Table table0)
393+ , table0 ~ (constraints :=> columns)
394+ , table1 ~ (constraints :=> Rename column0 column1 columns) )
395+ => Alias column0 -- ^ column to rename
396+ -> Alias column1 -- ^ what to rename the column
397+ -> AlterTable sch tab schemas table1
398+renameColumn column0 column1 = UnsafeAlterTable $
399+ "RENAME COLUMN" <+> renderSQL column0 <+> "TO" <+> renderSQL column1
400+
401+-- | An `alterColumn` alters a single column.
402+alterColumn
403+ :: ( KnownSymbol column
404+ , Has sch schemas schema
405+ , Has tab schema ('Table table0)
406+ , table0 ~ (constraints :=> columns)
407+ , Has column columns ty0
408+ , table1 ~ (constraints :=> Alter column ty1 columns))
409+ => Alias column -- ^ column to alter
410+ -> AlterColumn schemas ty0 ty1 -- ^ alteration to perform
411+ -> AlterTable sch tab schemas table1
412+alterColumn column alteration = UnsafeAlterTable $
413+ "ALTER COLUMN" <+> renderSQL column <+> renderAlterColumn alteration
414+
415+-- | An `AlterColumn` describes the alteration to perform on a single column.
416+newtype AlterColumn (schemas :: SchemasType) (ty0 :: ColumnType) (ty1 :: ColumnType) =
417+ UnsafeAlterColumn {renderAlterColumn :: ByteString}
418+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
419+
420+-- | A `setDefault` sets a new default for a column. Note that this doesn't
421+-- affect any existing rows in the table, it just changes the default for
422+-- future insert and update commands.
423+--
424+-- >>> :{
425+-- let
426+-- definition :: Definition
427+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
428+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]]
429+-- definition = alterTable #tab (alterColumn #col (setDefault 5))
430+-- in printSQL definition
431+-- :}
432+-- ALTER TABLE "tab" ALTER COLUMN "col" SET DEFAULT 5;
433+setDefault
434+ :: Expression '[] '[] 'Ungrouped schemas '[] '[] ty -- ^ default value to set
435+ -> AlterColumn schemas (constraint :=> ty) ('Def :=> ty)
436+setDefault expression = UnsafeAlterColumn $
437+ "SET DEFAULT" <+> renderExpression expression
438+
439+-- | A `dropDefault` removes any default value for a column.
440+--
441+-- >>> :{
442+-- let
443+-- definition :: Definition
444+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]]
445+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
446+-- definition = alterTable #tab (alterColumn #col dropDefault)
447+-- in printSQL definition
448+-- :}
449+-- ALTER TABLE "tab" ALTER COLUMN "col" DROP DEFAULT;
450+dropDefault :: AlterColumn schemas ('Def :=> ty) ('NoDef :=> ty)
451+dropDefault = UnsafeAlterColumn $ "DROP DEFAULT"
452+
453+-- | A `setNotNull` adds a @NOT NULL@ constraint to a column.
454+-- The constraint will be checked immediately, so the table data must satisfy
455+-- the constraint before it can be added.
456+--
457+-- >>> :{
458+-- let
459+-- definition :: Definition
460+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
461+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
462+-- definition = alterTable #tab (alterColumn #col setNotNull)
463+-- in printSQL definition
464+-- :}
465+-- ALTER TABLE "tab" ALTER COLUMN "col" SET NOT NULL;
466+setNotNull
467+ :: AlterColumn schemas (constraint :=> 'Null ty) (constraint :=> 'NotNull ty)
468+setNotNull = UnsafeAlterColumn $ "SET NOT NULL"
469+
470+-- | A `dropNotNull` drops a @NOT NULL@ constraint from a column.
471+--
472+-- >>> :{
473+-- let
474+-- definition :: Definition
475+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
476+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
477+-- definition = alterTable #tab (alterColumn #col dropNotNull)
478+-- in printSQL definition
479+-- :}
480+-- ALTER TABLE "tab" ALTER COLUMN "col" DROP NOT NULL;
481+dropNotNull
482+ :: AlterColumn schemas (constraint :=> 'NotNull ty) (constraint :=> 'Null ty)
483+dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL"
484+
485+-- | An `alterType` converts a column to a different data type.
486+-- This will succeed only if each existing entry in the column can be
487+-- converted to the new type by an implicit cast.
488+--
489+-- >>> :{
490+-- let
491+-- definition :: Definition
492+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
493+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGnumeric])]]
494+-- definition =
495+-- alterTable #tab (alterColumn #col (alterType (numeric & notNullable)))
496+-- in printSQL definition
497+-- :}
498+-- ALTER TABLE "tab" ALTER COLUMN "col" TYPE numeric NOT NULL;
499+alterType :: ColumnTypeExpression schemas ty -> AlterColumn schemas ty0 ty
500+alterType ty = UnsafeAlterColumn $ "TYPE" <+> renderColumnTypeExpression ty
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Table/Constraint.hsnew file+339
@@ -0,0 +1,339 @@
1+{-|
2+Module: Squeal.PostgreSQL.Definition.Table.Constraint
3+Description: Table constraint expressions
4+Copyright: (c) Eitan Chatav, 2017
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Table constraint expressions.
9+-}
10+
11+{-# LANGUAGE
12+ AllowAmbiguousTypes
13+ , ConstraintKinds
14+ , DeriveAnyClass
15+ , DeriveGeneric
16+ , DerivingStrategies
17+ , FlexibleContexts
18+ , FlexibleInstances
19+ , GADTs
20+ , LambdaCase
21+ , MultiParamTypeClasses
22+ , OverloadedLabels
23+ , OverloadedStrings
24+ , RankNTypes
25+ , ScopedTypeVariables
26+ , TypeApplications
27+ , TypeInType
28+ , TypeOperators
29+ , UndecidableSuperClasses
30+#-}
31+
32+module Squeal.PostgreSQL.Definition.Table.Constraint
33+ ( TableConstraintExpression (..)
34+ , check
35+ , unique
36+ , primaryKey
37+ , foreignKey
38+ , ForeignKeyed
39+ , OnDeleteClause (..)
40+ , OnUpdateClause (..)
41+ ) where
42+
43+import Control.DeepSeq
44+import Data.ByteString
45+import GHC.TypeLits
46+
47+import qualified Generics.SOP as SOP
48+import qualified GHC.Generics as GHC
49+
50+import Squeal.PostgreSQL.Alias
51+import Squeal.PostgreSQL.Expression.Logic
52+import Squeal.PostgreSQL.List
53+import Squeal.PostgreSQL.Render
54+import Squeal.PostgreSQL.Schema
55+
56+-- $setup
57+-- >>> import Squeal.PostgreSQL
58+
59+-- | Data types are a way to limit the kind of data that can be stored in a
60+-- table. For many applications, however, the constraint they provide is
61+-- too coarse. For example, a column containing a product price should
62+-- probably only accept positive values. But there is no standard data type
63+-- that accepts only positive numbers. Another issue is that you might want
64+-- to constrain column data with respect to other columns or rows.
65+-- For example, in a table containing product information,
66+-- there should be only one row for each product number.
67+-- `TableConstraint`s give you as much control over the data in your tables
68+-- as you wish. If a user attempts to store data in a column that would
69+-- violate a constraint, an error is raised. This applies
70+-- even if the value came from the default value definition.
71+newtype TableConstraintExpression
72+ (sch :: Symbol)
73+ (tab :: Symbol)
74+ (schemas :: SchemasType)
75+ (constraint :: TableConstraint)
76+ = UnsafeTableConstraintExpression
77+ { renderTableConstraintExpression :: ByteString }
78+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
79+instance RenderSQL
80+ (TableConstraintExpression sch tab schemas constraint) where
81+ renderSQL = renderTableConstraintExpression
82+
83+{-| A `check` constraint is the most generic `TableConstraint` type.
84+It allows you to specify that the value in a certain column must satisfy
85+a Boolean (truth-value) expression.
86+
87+>>> :{
88+type Schema = '[
89+ "tab" ::: 'Table ('[ "inequality" ::: 'Check '["a","b"]] :=> '[
90+ "a" ::: 'NoDef :=> 'NotNull 'PGint4,
91+ "b" ::: 'NoDef :=> 'NotNull 'PGint4
92+ ])]
93+:}
94+
95+>>> :{
96+let
97+ definition :: Definition (Public '[]) (Public Schema)
98+ definition = createTable #tab
99+ ( (int & notNullable) `as` #a :*
100+ (int & notNullable) `as` #b )
101+ ( check (#a :* #b) (#a .> #b) `as` #inequality )
102+:}
103+
104+>>> printSQL definition
105+CREATE TABLE "tab" ("a" int NOT NULL, "b" int NOT NULL, CONSTRAINT "inequality" CHECK (("a" > "b")));
106+-}
107+check
108+ :: ( Has sch schemas schema
109+ , Has tab schema ('Table table)
110+ , HasAll aliases (TableToRow table) subcolumns )
111+ => NP Alias aliases
112+ -- ^ specify the subcolumns which are getting checked
113+ -> (forall t. Condition '[] '[] 'Ungrouped schemas '[] '[t ::: subcolumns])
114+ -- ^ a closed `Condition` on those subcolumns
115+ -> TableConstraintExpression sch tab schemas ('Check aliases)
116+check _cols condition = UnsafeTableConstraintExpression $
117+ "CHECK" <+> parenthesized (renderSQL condition)
118+
119+{-| A `unique` constraint ensure that the data contained in a column,
120+or a group of columns, is unique among all the rows in the table.
121+
122+>>> :{
123+type Schema = '[
124+ "tab" ::: 'Table( '[ "uq_a_b" ::: 'Unique '["a","b"]] :=> '[
125+ "a" ::: 'NoDef :=> 'Null 'PGint4,
126+ "b" ::: 'NoDef :=> 'Null 'PGint4
127+ ])]
128+:}
129+
130+>>> :{
131+let
132+ definition :: Definition (Public '[]) (Public Schema)
133+ definition = createTable #tab
134+ ( (int & nullable) `as` #a :*
135+ (int & nullable) `as` #b )
136+ ( unique (#a :* #b) `as` #uq_a_b )
137+:}
138+
139+>>> printSQL definition
140+CREATE TABLE "tab" ("a" int NULL, "b" int NULL, CONSTRAINT "uq_a_b" UNIQUE ("a", "b"));
141+-}
142+unique
143+ :: ( Has sch schemas schema
144+ , Has tab schema('Table table)
145+ , HasAll aliases (TableToRow table) subcolumns )
146+ => NP Alias aliases
147+ -- ^ specify subcolumns which together are unique for each row
148+ -> TableConstraintExpression sch tab schemas ('Unique aliases)
149+unique columns = UnsafeTableConstraintExpression $
150+ "UNIQUE" <+> parenthesized (renderSQL columns)
151+
152+{-| A `primaryKey` constraint indicates that a column, or group of columns,
153+can be used as a unique identifier for rows in the table.
154+This requires that the values be both unique and not null.
155+
156+>>> :{
157+type Schema = '[
158+ "tab" ::: 'Table ('[ "pk_id" ::: 'PrimaryKey '["id"]] :=> '[
159+ "id" ::: 'Def :=> 'NotNull 'PGint4,
160+ "name" ::: 'NoDef :=> 'NotNull 'PGtext
161+ ])]
162+:}
163+
164+>>> :{
165+let
166+ definition :: Definition (Public '[]) (Public Schema)
167+ definition = createTable #tab
168+ ( serial `as` #id :*
169+ (text & notNullable) `as` #name )
170+ ( primaryKey #id `as` #pk_id )
171+:}
172+
173+>>> printSQL definition
174+CREATE TABLE "tab" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_id" PRIMARY KEY ("id"));
175+-}
176+primaryKey
177+ :: ( Has sch schemas schema
178+ , Has tab schema ('Table table)
179+ , HasAll aliases (TableToColumns table) subcolumns
180+ , AllNotNull subcolumns )
181+ => NP Alias aliases
182+ -- ^ specify the subcolumns which together form a primary key.
183+ -> TableConstraintExpression sch tab schemas ('PrimaryKey aliases)
184+primaryKey columns = UnsafeTableConstraintExpression $
185+ "PRIMARY KEY" <+> parenthesized (renderSQL columns)
186+
187+{-| A `foreignKey` specifies that the values in a column
188+(or a group of columns) must match the values appearing in some row of
189+another table. We say this maintains the referential integrity
190+between two related tables.
191+
192+>>> :{
193+type Schema =
194+ '[ "users" ::: 'Table (
195+ '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
196+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
197+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext
198+ ])
199+ , "emails" ::: 'Table (
200+ '[ "pk_emails" ::: 'PrimaryKey '["id"]
201+ , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
202+ ] :=>
203+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
204+ , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
205+ , "email" ::: 'NoDef :=> 'Null 'PGtext
206+ ])
207+ ]
208+:}
209+
210+>>> :{
211+let
212+ setup :: Definition (Public '[]) (Public Schema)
213+ setup =
214+ createTable #users
215+ ( serial `as` #id :*
216+ (text & notNullable) `as` #name )
217+ ( primaryKey #id `as` #pk_users ) >>>
218+ createTable #emails
219+ ( serial `as` #id :*
220+ (int & notNullable) `as` #user_id :*
221+ (text & nullable) `as` #email )
222+ ( primaryKey #id `as` #pk_emails :*
223+ foreignKey #user_id #users #id
224+ OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
225+in printSQL setup
226+:}
227+CREATE TABLE "users" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_users" PRIMARY KEY ("id"));
228+CREATE TABLE "emails" ("id" serial, "user_id" int NOT NULL, "email" text NULL, CONSTRAINT "pk_emails" PRIMARY KEY ("id"), CONSTRAINT "fk_user_id" FOREIGN KEY ("user_id") REFERENCES "users" ("id") ON DELETE CASCADE ON UPDATE CASCADE);
229+
230+A `foreignKey` can even be a table self-reference.
231+
232+>>> :{
233+type Schema =
234+ '[ "employees" ::: 'Table (
235+ '[ "employees_pk" ::: 'PrimaryKey '["id"]
236+ , "employees_employer_fk" ::: 'ForeignKey '["employer_id"] "employees" '["id"]
237+ ] :=>
238+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
239+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext
240+ , "employer_id" ::: 'NoDef :=> 'Null 'PGint4
241+ ])
242+ ]
243+:}
244+
245+>>> :{
246+let
247+ setup :: Definition (Public '[]) (Public Schema)
248+ setup =
249+ createTable #employees
250+ ( serial `as` #id :*
251+ (text & notNullable) `as` #name :*
252+ (integer & nullable) `as` #employer_id )
253+ ( primaryKey #id `as` #employees_pk :*
254+ foreignKey #employer_id #employees #id
255+ OnDeleteCascade OnUpdateCascade `as` #employees_employer_fk )
256+in printSQL setup
257+:}
258+CREATE TABLE "employees" ("id" serial, "name" text NOT NULL, "employer_id" integer NULL, CONSTRAINT "employees_pk" PRIMARY KEY ("id"), CONSTRAINT "employees_employer_fk" FOREIGN KEY ("employer_id") REFERENCES "employees" ("id") ON DELETE CASCADE ON UPDATE CASCADE);
259+-}
260+foreignKey
261+ :: (ForeignKeyed schemas sch schema child parent
262+ table reftable
263+ columns refcolumns
264+ constraints cols
265+ reftys tys )
266+ => NP Alias columns
267+ -- ^ column or columns in the table
268+ -> Alias parent
269+ -- ^ reference table
270+ -> NP Alias refcolumns
271+ -- ^ reference column or columns in the reference table
272+ -> OnDeleteClause
273+ -- ^ what to do when reference is deleted
274+ -> OnUpdateClause
275+ -- ^ what to do when reference is updated
276+ -> TableConstraintExpression sch child schemas
277+ ('ForeignKey columns parent refcolumns)
278+foreignKey keys parent refs ondel onupd = UnsafeTableConstraintExpression $
279+ "FOREIGN KEY" <+> parenthesized (renderSQL keys)
280+ <+> "REFERENCES" <+> renderSQL parent
281+ <+> parenthesized (renderSQL refs)
282+ <+> renderSQL ondel
283+ <+> renderSQL onupd
284+
285+-- | A constraint synonym between types involved in a foreign key constraint.
286+type ForeignKeyed schemas
287+ sch
288+ schema
289+ child parent
290+ table reftable
291+ columns refcolumns
292+ constraints cols
293+ reftys tys =
294+ ( Has sch schemas schema
295+ , Has child schema ('Table table)
296+ , Has parent schema ('Table reftable)
297+ , HasAll columns (TableToColumns table) tys
298+ , reftable ~ (constraints :=> cols)
299+ , HasAll refcolumns cols reftys
300+ , SOP.AllZip SamePGType tys reftys
301+ , Uniquely refcolumns constraints )
302+
303+-- | `OnDeleteClause` indicates what to do with rows that reference a deleted row.
304+data OnDeleteClause
305+ = OnDeleteNoAction
306+ -- ^ if any referencing rows still exist when the constraint is checked,
307+ -- an error is raised
308+ | OnDeleteRestrict -- ^ prevents deletion of a referenced row
309+ | OnDeleteCascade
310+ -- ^ specifies that when a referenced row is deleted,
311+ -- row(s) referencing it should be automatically deleted as well
312+ deriving (GHC.Generic,Show,Eq,Ord)
313+instance NFData OnDeleteClause
314+-- | Render `OnDeleteClause`.
315+instance RenderSQL OnDeleteClause where
316+ renderSQL = \case
317+ OnDeleteNoAction -> "ON DELETE NO ACTION"
318+ OnDeleteRestrict -> "ON DELETE RESTRICT"
319+ OnDeleteCascade -> "ON DELETE CASCADE"
320+
321+-- | Analagous to `OnDeleteClause` there is also `OnUpdateClause` which is invoked
322+-- when a referenced column is changed (updated).
323+data OnUpdateClause
324+ = OnUpdateNoAction
325+ -- ^ if any referencing rows has not changed when the constraint is checked,
326+ -- an error is raised
327+ | OnUpdateRestrict -- ^ prevents update of a referenced row
328+ | OnUpdateCascade
329+ -- ^ the updated values of the referenced column(s) should be copied
330+ -- into the referencing row(s)
331+ deriving (GHC.Generic,Show,Eq,Ord)
332+instance NFData OnUpdateClause
333+
334+-- | Render `OnUpdateClause`.
335+instance RenderSQL OnUpdateClause where
336+ renderSQL = \case
337+ OnUpdateNoAction -> "ON UPDATE NO ACTION"
338+ OnUpdateRestrict -> "ON UPDATE RESTRICT"
339+ OnUpdateCascade -> "ON UPDATE CASCADE"
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Type.hsnew file+229
@@ -0,0 +1,229 @@
1+{-|
2+Module: Squeal.PostgreSQL.Definition.Type
3+Description: Create and drop type definitions
4+Copyright: (c) Eitan Chatav, 2017
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Create and drop type definitions.
9+-}
10+
11+{-# LANGUAGE
12+ AllowAmbiguousTypes
13+ , ConstraintKinds
14+ , DeriveAnyClass
15+ , DeriveGeneric
16+ , DerivingStrategies
17+ , FlexibleContexts
18+ , FlexibleInstances
19+ , GADTs
20+ , LambdaCase
21+ , MultiParamTypeClasses
22+ , OverloadedLabels
23+ , OverloadedStrings
24+ , RankNTypes
25+ , ScopedTypeVariables
26+ , TypeApplications
27+ , TypeInType
28+ , TypeOperators
29+ , UndecidableSuperClasses
30+#-}
31+
32+module Squeal.PostgreSQL.Definition.Type
33+ ( createTypeEnum
34+ , createTypeEnumFrom
35+ , createTypeComposite
36+ , createTypeCompositeFrom
37+ , createTypeRange
38+ , createDomain
39+ , dropType
40+ , dropTypeIfExists
41+ ) where
42+
43+import Data.ByteString
44+import Data.Monoid
45+import GHC.TypeLits
46+import Prelude hiding ((.), id)
47+
48+import qualified Generics.SOP as SOP
49+
50+import Squeal.PostgreSQL.Alias
51+import Squeal.PostgreSQL.Expression.Logic
52+import Squeal.PostgreSQL.Expression.Type
53+import Squeal.PostgreSQL.Definition
54+import Squeal.PostgreSQL.List
55+import Squeal.PostgreSQL.PG
56+import Squeal.PostgreSQL.Render
57+import Squeal.PostgreSQL.Schema
58+
59+-- $setup
60+-- >>> import Squeal.PostgreSQL
61+-- >>> import qualified GHC.Generics as GHC
62+-- >>> import qualified Generics.SOP as SOP
63+
64+-- | Enumerated types are created using the `createTypeEnum` command, for example
65+--
66+-- >>> printSQL $ (createTypeEnum #mood (label @"sad" :* label @"ok" :* label @"happy") :: Definition (Public '[]) '["public" ::: '["mood" ::: 'Typedef ('PGenum '["sad","ok","happy"])]])
67+-- CREATE TYPE "mood" AS ENUM ('sad', 'ok', 'happy');
68+createTypeEnum
69+ :: (KnownSymbol enum, Has sch schemas schema, SOP.All KnownSymbol labels)
70+ => QualifiedAlias sch enum
71+ -- ^ name of the user defined enumerated type
72+ -> NP PGlabel labels
73+ -- ^ labels of the enumerated type
74+ -> Definition schemas (Alter sch (Create enum ('Typedef ('PGenum labels)) schema) schemas)
75+createTypeEnum enum labels = UnsafeDefinition $
76+ "CREATE" <+> "TYPE" <+> renderSQL enum <+> "AS" <+> "ENUM" <+>
77+ parenthesized (renderSQL labels) <> ";"
78+
79+-- | Enumerated types can also be generated from a Haskell type, for example
80+--
81+-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic
82+-- >>> instance SOP.Generic Schwarma
83+-- >>> instance SOP.HasDatatypeInfo Schwarma
84+-- >>> :{
85+-- let
86+-- createSchwarma :: Definition (Public '[]) '["public" ::: '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))]]
87+-- createSchwarma = createTypeEnumFrom @Schwarma #schwarma
88+-- in
89+-- printSQL createSchwarma
90+-- :}
91+-- CREATE TYPE "schwarma" AS ENUM ('Beef', 'Lamb', 'Chicken');
92+createTypeEnumFrom
93+ :: forall hask sch enum schemas schema.
94+ ( SOP.Generic hask
95+ , SOP.All KnownSymbol (LabelsPG hask)
96+ , KnownSymbol enum
97+ , Has sch schemas schema )
98+ => QualifiedAlias sch enum
99+ -- ^ name of the user defined enumerated type
100+ -> Definition schemas (Alter sch (Create enum ('Typedef (PG (Enumerated hask))) schema) schemas)
101+createTypeEnumFrom enum = createTypeEnum enum
102+ (SOP.hpure label :: NP PGlabel (LabelsPG hask))
103+
104+{- | `createTypeComposite` creates a composite type. The composite type is
105+specified by a list of attribute names and data types.
106+
107+>>> :{
108+type PGcomplex = 'PGcomposite
109+ '[ "real" ::: 'NotNull 'PGfloat8
110+ , "imaginary" ::: 'NotNull 'PGfloat8 ]
111+:}
112+
113+>>> :{
114+let
115+ setup :: Definition (Public '[]) '["public" ::: '["complex" ::: 'Typedef PGcomplex]]
116+ setup = createTypeComposite #complex
117+ (float8 `as` #real :* float8 `as` #imaginary)
118+in printSQL setup
119+:}
120+CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);
121+-}
122+createTypeComposite
123+ :: (KnownSymbol ty, Has sch schemas schema, SOP.SListI fields)
124+ => QualifiedAlias sch ty
125+ -- ^ name of the user defined composite type
126+ -> NP (Aliased (TypeExpression schemas)) fields
127+ -- ^ list of attribute names and data types
128+ -> Definition schemas (Alter sch (Create ty ('Typedef ('PGcomposite fields)) schema) schemas)
129+createTypeComposite ty fields = UnsafeDefinition $
130+ "CREATE" <+> "TYPE" <+> renderSQL ty <+> "AS" <+> parenthesized
131+ (renderCommaSeparated renderField fields) <> ";"
132+ where
133+ renderField :: Aliased (TypeExpression schemas) x -> ByteString
134+ renderField (typ `As` alias) =
135+ renderSQL alias <+> renderSQL typ
136+
137+-- | Composite types can also be generated from a Haskell type, for example
138+--
139+-- >>> data Complex = Complex {real :: Double, imaginary :: Double} deriving GHC.Generic
140+-- >>> instance SOP.Generic Complex
141+-- >>> instance SOP.HasDatatypeInfo Complex
142+-- >>> type Schema = '["complex" ::: 'Typedef (PG (Composite Complex))]
143+-- >>> :{
144+-- let
145+-- createComplex :: Definition (Public '[]) (Public Schema)
146+-- createComplex = createTypeCompositeFrom @Complex #complex
147+-- in
148+-- printSQL createComplex
149+-- :}
150+-- CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);
151+createTypeCompositeFrom
152+ :: forall hask sch ty schemas schema.
153+ ( SOP.All (FieldTyped schemas) (RowPG hask)
154+ , KnownSymbol ty
155+ , Has sch schemas schema )
156+ => QualifiedAlias sch ty
157+ -- ^ name of the user defined composite type
158+ -> Definition schemas (Alter sch (Create ty ( 'Typedef (PG (Composite hask))) schema) schemas)
159+createTypeCompositeFrom ty = createTypeComposite ty
160+ (SOP.hcpure (SOP.Proxy :: SOP.Proxy (FieldTyped schemas)) fieldtype
161+ :: NP (Aliased (TypeExpression schemas)) (RowPG hask))
162+
163+{-|
164+`createDomain` creates a new domain. A domain is essentially a data type
165+with constraints (restrictions on the allowed set of values).
166+
167+Domains are useful for abstracting common constraints on fields
168+into a single location for maintenance. For example, several tables might
169+contain email address columns, all requiring the same `check` constraint
170+to verify the address syntax. Define a domain rather than setting up
171+each table's constraint individually.
172+
173+>>> :{
174+let
175+ createPositive :: Definition (Public '[]) (Public '["positive" ::: 'Typedef 'PGfloat4])
176+ createPositive = createDomain #positive real (#value .> 0 .&& (#value & isNotNull))
177+in printSQL createPositive
178+:}
179+CREATE DOMAIN "positive" AS real CHECK ((("value" > 0) AND "value" IS NOT NULL));
180+-}
181+createDomain
182+ :: (Has sch schemas schema, KnownSymbol dom)
183+ => QualifiedAlias sch dom
184+ -> (forall null. TypeExpression schemas (null ty))
185+ -> (forall tab. Condition '[] '[] 'Ungrouped schemas '[] '[tab ::: '["value" ::: 'Null ty]])
186+ -> Definition schemas (Alter sch (Create dom ('Typedef ty) schema) schemas)
187+createDomain dom ty condition =
188+ UnsafeDefinition $ "CREATE DOMAIN" <+> renderSQL dom
189+ <+> "AS" <+> renderTypeExpression ty
190+ <+> "CHECK" <+> parenthesized (renderSQL condition) <> ";"
191+
192+{- |
193+>>> :{
194+let
195+ createSmallIntRange :: Definition (Public '[]) (Public '["int2range" ::: 'Typedef ('PGrange 'PGint2)])
196+ createSmallIntRange = createTypeRange #int2range int2
197+in printSQL createSmallIntRange
198+:}
199+CREATE TYPE "int2range" AS RANGE (subtype = int2);
200+-}
201+createTypeRange
202+ :: (Has sch schemas schema, KnownSymbol range)
203+ => QualifiedAlias sch range
204+ -> (forall null. TypeExpression schemas (null ty))
205+ -> Definition schemas (Alter sch (Create range ('Typedef ('PGrange ty)) schema) schemas)
206+createTypeRange range ty = UnsafeDefinition $
207+ "CREATE" <+> "TYPE" <+> renderSQL range <+> "AS" <+> "RANGE" <+>
208+ parenthesized ("subtype" <+> "=" <+> renderTypeExpression ty) <> ";"
209+
210+-- | Drop a type.
211+--
212+-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic
213+-- >>> instance SOP.Generic Schwarma
214+-- >>> instance SOP.HasDatatypeInfo Schwarma
215+-- >>> printSQL (dropType #schwarma :: Definition '["public" ::: '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))]] (Public '[]))
216+-- DROP TYPE "schwarma";
217+dropType
218+ :: (Has sch schemas schema, KnownSymbol td)
219+ => QualifiedAlias sch td
220+ -- ^ name of the user defined type
221+ -> Definition schemas (Alter sch (DropSchemum td 'Typedef schema) schemas)
222+dropType tydef = UnsafeDefinition $ "DROP" <+> "TYPE" <+> renderSQL tydef <> ";"
223+
224+dropTypeIfExists
225+ :: (Has sch schemas schema, KnownSymbol td)
226+ => QualifiedAlias sch td
227+ -- ^ name of the user defined type
228+ -> Definition schemas (Alter sch (DropSchemumIfExists td 'Typedef schema) schemas)
229+dropTypeIfExists tydef = UnsafeDefinition $ "DROP" <+> "TYPE" <+> renderSQL tydef <> ";"
squeal-postgresql/src/Squeal/PostgreSQL/Definition/View.hsnew file+104
@@ -0,0 +1,104 @@
1+{-|
2+Module: Squeal.PostgreSQL.Definition.View
3+Description: Create and drop view definitions
4+Copyright: (c) Eitan Chatav, 2017
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Create and drop view definitions.
9+-}
10+
11+{-# LANGUAGE
12+ AllowAmbiguousTypes
13+ , ConstraintKinds
14+ , DeriveAnyClass
15+ , DeriveGeneric
16+ , DerivingStrategies
17+ , FlexibleContexts
18+ , FlexibleInstances
19+ , GADTs
20+ , LambdaCase
21+ , MultiParamTypeClasses
22+ , OverloadedLabels
23+ , OverloadedStrings
24+ , RankNTypes
25+ , ScopedTypeVariables
26+ , TypeApplications
27+ , TypeInType
28+ , TypeOperators
29+ , UndecidableSuperClasses
30+#-}
31+
32+module Squeal.PostgreSQL.Definition.View
33+ ( createView
34+ , createOrReplaceView
35+ , dropView
36+ , dropViewIfExists
37+ ) where
38+
39+import GHC.TypeLits
40+
41+import Squeal.PostgreSQL.Alias
42+import Squeal.PostgreSQL.Definition
43+import Squeal.PostgreSQL.Query
44+import Squeal.PostgreSQL.Render
45+import Squeal.PostgreSQL.Schema
46+
47+-- $setup
48+-- >>> import Squeal.PostgreSQL
49+
50+{- | Create a view.
51+>>> type ABC = '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4]
52+>>> type BC = '["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4]
53+>>> :{
54+let
55+ definition :: Definition
56+ '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC)]]
57+ '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC), "bc" ::: 'View BC]]
58+ definition =
59+ createView #bc (select_ (#b :* #c) (from (table #abc)))
60+in printSQL definition
61+:}
62+CREATE VIEW "bc" AS SELECT "b" AS "b", "c" AS "c" FROM "abc" AS "abc";
63+-}
64+createView
65+ :: (Has sch schemas schema, KnownSymbol vw)
66+ => QualifiedAlias sch vw -- ^ the name of the view to add
67+ -> Query '[] '[] schemas '[] view -- ^ query
68+ -> Definition schemas (Alter sch (Create vw ('View view) schema) schemas)
69+createView alias query = UnsafeDefinition $
70+ "CREATE" <+> "VIEW" <+> renderSQL alias <+> "AS"
71+ <+> renderQuery query <> ";"
72+
73+createOrReplaceView
74+ :: (Has sch schemas schema, KnownSymbol vw)
75+ => QualifiedAlias sch vw -- ^ the name of the view to add
76+ -> Query '[] '[] schemas '[] view -- ^ query
77+ -> Definition schemas (Alter sch (CreateOrReplace vw ('View view) schema) schemas)
78+createOrReplaceView alias query = UnsafeDefinition $
79+ "CREATE OR REPLACE VIEW" <+> renderSQL alias <+> "AS"
80+ <+> renderQuery query <> ";"
81+
82+-- | Drop a view.
83+--
84+-- >>> :{
85+-- let
86+-- definition :: Definition
87+-- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])
88+-- , "bc" ::: 'View ('["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4])]]
89+-- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])]]
90+-- definition = dropView #bc
91+-- in printSQL definition
92+-- :}
93+-- DROP VIEW "bc";
94+dropView
95+ :: (Has sch schemas schema, KnownSymbol vw)
96+ => QualifiedAlias sch vw -- ^ view to remove
97+ -> Definition schemas (Alter sch (DropSchemum vw 'View schema) schemas)
98+dropView vw = UnsafeDefinition $ "DROP VIEW" <+> renderSQL vw <> ";"
99+
100+dropViewIfExists
101+ :: (Has sch schemas schema, KnownSymbol vw)
102+ => QualifiedAlias sch vw -- ^ view to remove
103+ -> Definition schemas (Alter sch (DropIfExists vw schema) schemas)
104+dropViewIfExists vw = UnsafeDefinition $ "DROP VIEW IF EXISTS" <+> renderSQL vw <> ";"
squeal-postgresql/src/Squeal/PostgreSQL/Expression.hsnew file+472
@@ -0,0 +1,472 @@
1+{-|
2+Module: Squeal.PostgreSQL.Expression
3+Description: Squeal expressions
4+Copyright: (c) Eitan Chatav, 2019
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Squeal expressions are the atoms used to build statements.
9+-}
10+
11+{-# LANGUAGE
12+ AllowAmbiguousTypes
13+ , ConstraintKinds
14+ , DeriveGeneric
15+ , FlexibleContexts
16+ , FlexibleInstances
17+ , FunctionalDependencies
18+ , GADTs
19+ , GeneralizedNewtypeDeriving
20+ , LambdaCase
21+ , MagicHash
22+ , OverloadedStrings
23+ , ScopedTypeVariables
24+ , StandaloneDeriving
25+ , TypeApplications
26+ , TypeFamilies
27+ , TypeInType
28+ , TypeOperators
29+ , UndecidableInstances
30+ , RankNTypes
31+#-}
32+
33+module Squeal.PostgreSQL.Expression
34+ ( -- * Expression
35+ Expression (..)
36+ , Expr
37+ , type (-->)
38+ , FunctionDB
39+ , unsafeFunction
40+ , function
41+ , unsafeLeftOp
42+ , leftOp
43+ , unsafeRightOp
44+ , rightOp
45+ , Operator
46+ , OperatorDB
47+ , unsafeBinaryOp
48+ , binaryOp
49+ , FunctionVar
50+ , unsafeFunctionVar
51+ , type (--->)
52+ , FunctionNDB
53+ , unsafeFunctionN
54+ , functionN
55+ , PGSubset (..)
56+ , PGIntersect (..)
57+ -- * Re-export
58+ , (&)
59+ , K (..)
60+ , unK
61+ ) where
62+
63+import Control.Category
64+import Control.DeepSeq
65+import Data.ByteString (ByteString)
66+import Data.Function ((&))
67+import Data.Semigroup hiding (All)
68+import Data.String
69+import Generics.SOP hiding (All, from)
70+import GHC.OverloadedLabels
71+import GHC.TypeLits
72+import Numeric
73+import Prelude hiding (id, (.))
74+
75+import qualified GHC.Generics as GHC
76+
77+import Squeal.PostgreSQL.Alias
78+import Squeal.PostgreSQL.List
79+import Squeal.PostgreSQL.Render
80+import Squeal.PostgreSQL.Schema
81+
82+-- $setup
83+-- >>> import Squeal.PostgreSQL
84+
85+{-----------------------------------------
86+column expressions
87+-----------------------------------------}
88+
89+{- | `Expression`s are used in a variety of contexts,
90+such as in the target `Squeal.PostgreSQL.Query.List` of the
91+`Squeal.PostgreSQL.Query.select` command,
92+as new column values in `Squeal.PostgreSQL.Manipulation.insertRow` or
93+`Squeal.PostgreSQL.Manipulation.update`,
94+or in search `Squeal.PostgreSQL.Logic.Condition`s in a number of commands.
95+
96+The expression syntax allows the calculation of
97+values from primitive expression using arithmetic, logical,
98+and 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+-}
114+newtype Expression
115+ (outer :: FromType)
116+ (commons :: FromType)
117+ (grp :: Grouping)
118+ (schemas :: SchemasType)
119+ (params :: [NullityType])
120+ (from :: FromType)
121+ (ty :: NullityType)
122+ = UnsafeExpression { renderExpression :: ByteString }
123+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
124+instance RenderSQL (Expression outer commons grp schemas params from ty) where
125+ renderSQL = renderExpression
126+
127+-- | An `Expr` is a closed `Expression`.
128+-- It is a F@RankNType@ but don't be scared.
129+-- Think of it as an expression which sees no
130+-- namespaces, so you can't use parameters
131+-- or alias references. It can be used as
132+-- a simple piece of more complex `Expression`s.
133+type Expr x
134+ = forall outer commons grp schemas params from
135+ . Expression outer commons grp schemas params from x
136+ -- ^ cannot reference aliases
137+
138+-- | A @RankNType@ for binary operators.
139+type Operator x1 x2 y
140+ = forall outer commons grp schemas params from
141+ . Expression outer commons grp schemas params from x1
142+ -- ^ left input
143+ -> Expression outer commons grp schemas params from x2
144+ -- ^ right input
145+ -> Expression outer commons grp schemas params from y
146+ -- ^ output
147+
148+type OperatorDB schemas x1 x2 y
149+ = forall outer commons grp params from
150+ . Expression outer commons grp schemas params from x1
151+ -- ^ left input
152+ -> Expression outer commons grp schemas params from x2
153+ -- ^ right input
154+ -> Expression outer commons grp schemas params from y
155+ -- ^ output
156+
157+-- | A @RankNType@ for functions with a single argument.
158+-- These could be either function calls or unary operators.
159+-- This is a subtype of the usual Haskell function type `Prelude.->`,
160+-- indeed a subcategory as it is closed under the usual
161+-- `Prelude..` and `Prelude.id`.
162+type (-->) x y
163+ = forall outer commons grp schemas params from
164+ . Expression outer commons grp schemas params from x
165+ -- ^ input
166+ -> Expression outer commons grp schemas params from y
167+ -- ^ output
168+
169+type FunctionDB schemas x y
170+ = forall outer commons grp params from
171+ . Expression outer commons grp schemas params from x
172+ -- ^ input
173+ -> Expression outer commons grp schemas params from y
174+ -- ^ output
175+
176+{- | A @RankNType@ for functions with a fixed-length list of heterogeneous arguments.
177+Use the `*:` operator to end your argument lists, like so.
178+
179+>>> printSQL (unsafeFunctionN "fun" (true :* false :* localTime *: true))
180+fun(TRUE, FALSE, LOCALTIME, TRUE)
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+-}
199+type FunctionVar x0 x1 y
200+ = forall outer commons grp schemas params from
201+ . [Expression outer commons grp schemas params from x0]
202+ -- ^ inputs
203+ -> Expression outer commons grp schemas params from x1
204+ -- ^ must have at least 1 input
205+ -> Expression outer commons grp schemas params from y
206+ -- ^ output
207+
208+{- | >>> printSQL (unsafeFunctionVar "greatest" [true, null_] false)
209+greatest(TRUE, NULL, FALSE)
210+-}
211+unsafeFunctionVar :: ByteString -> FunctionVar x0 x1 y
212+unsafeFunctionVar fun xs x = UnsafeExpression $ fun <> parenthesized
213+ (commaSeparated (renderSQL <$> xs) <> ", " <> renderSQL x)
214+
215+instance (HasUnique tab (Join outer from) row, Has col row ty)
216+ => IsLabel col (Expression outer commons 'Ungrouped schemas params from ty) where
217+ fromLabel = UnsafeExpression $ renderSQL (Alias @col)
218+instance (HasUnique tab (Join outer from) row, Has col row ty, tys ~ '[ty])
219+ => IsLabel col (NP (Expression outer commons 'Ungrouped schemas params from) tys) where
220+ fromLabel = fromLabel @col :* Nil
221+instance (HasUnique tab (Join outer from) row, Has col row ty, column ~ (col ::: ty))
222+ => IsLabel col
223+ (Aliased (Expression outer commons 'Ungrouped schemas params from) column) where
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+
246+instance
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
252+ fromLabel = UnsafeExpression $ renderSQL (Alias @col)
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+
278+instance
279+ ( Has tab (Join outer from) row
280+ , Has col row ty
281+ , GroupedBy tab col bys
282+ ) => IsQualified tab col
283+ (Expression outer commons ('Grouped bys) schemas params from ty) where
284+ tab ! col = UnsafeExpression $
285+ renderSQL tab <> "." <> renderSQL col
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
302+instance
303+ ( Has tab (Join outer from) row
304+ , Has col row ty
305+ , GroupedBy tab col bys
306+ , columns ~ '[col ::: ty]
307+ ) => IsQualified tab col
308+ (NP (Aliased (Expression outer commons ('Grouped bys) schemas params from)) columns) where
309+ tab ! col = tab ! col :* Nil
310+
311+instance (KnownSymbol label, label `In` labels) => IsPGlabel label
312+ (Expression outer commons grp schemas params from (null ('PGenum labels))) where
313+ label = UnsafeExpression $ renderSQL (PGlabel @label)
314+
315+-- | >>> printSQL $ unsafeBinaryOp "OR" true false
316+-- (TRUE OR FALSE)
317+unsafeBinaryOp :: ByteString -> Operator ty0 ty1 ty2
318+unsafeBinaryOp op x y = UnsafeExpression $ parenthesized $
319+ renderSQL x <+> op <+> renderSQL y
320+
321+binaryOp
322+ :: forall op sch schemas schema x y z.
323+ ( Has sch schemas schema
324+ , Has op schema ('Operator ('BinaryOp x y z)) )
325+ => OperatorDB schemas x y z
326+binaryOp = unsafeBinaryOp $ renderSymbol @op
327+
328+-- | >>> printSQL $ unsafeLeftOp "NOT" true
329+-- (NOT TRUE)
330+unsafeLeftOp :: ByteString -> x --> y
331+unsafeLeftOp op x = UnsafeExpression $ parenthesized $ op <+> renderSQL x
332+
333+leftOp
334+ :: forall op sch schemas schema x y.
335+ ( Has sch schemas schema
336+ , Has op schema ('Operator ('LeftOp x y)) )
337+ => FunctionDB schemas x y
338+leftOp = unsafeLeftOp $ renderSymbol @op
339+
340+-- | >>> printSQL $ true & unsafeRightOp "IS NOT TRUE"
341+-- (TRUE IS NOT TRUE)
342+unsafeRightOp :: ByteString -> x --> y
343+unsafeRightOp op x = UnsafeExpression $ parenthesized $ renderSQL x <+> op
344+
345+rightOp
346+ :: forall op sch schemas schema x y.
347+ ( Has sch schemas schema
348+ , Has op schema ('Operator ('RightOp x y)) )
349+ => FunctionDB schemas x y
350+rightOp = unsafeRightOp $ renderSymbol @op
351+
352+-- | >>> printSQL $ unsafeFunction "f" true
353+-- f(TRUE)
354+unsafeFunction :: ByteString -> x --> y
355+unsafeFunction fun x = UnsafeExpression $
356+ fun <> parenthesized (renderSQL x)
357+
358+function
359+ :: (Has sch schemas schema, Has fun schema ('Function ('[x] :=> 'Returns y)))
360+ => QualifiedAlias sch fun
361+ -> FunctionDB schemas x y
362+function = unsafeFunction . renderSQL
363+
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 "+"
381+ (-) = unsafeBinaryOp "-"
382+ (*) = unsafeBinaryOp "*"
383+ abs = unsafeFunction "abs"
384+ signum = unsafeFunction "sign"
385+ fromInteger
386+ = UnsafeExpression
387+ . fromString
388+ . show
389+
390+instance (ty `In` PGNum, ty `In` PGFloating) => Fractional
391+ (Expression outer commons grp schemas params from (null ty)) where
392+ (/) = unsafeBinaryOp "/"
393+ fromRational
394+ = UnsafeExpression
395+ . fromString
396+ . ($ "")
397+ . showFFloat Nothing
398+ . fromRat @Double
399+
400+instance (ty `In` PGNum, ty `In` PGFloating) => Floating
401+ (Expression outer commons grp schemas params from (null ty)) where
402+ pi = UnsafeExpression "pi()"
403+ exp = unsafeFunction "exp"
404+ log = unsafeFunction "ln"
405+ sqrt = unsafeFunction "sqrt"
406+ b ** x = UnsafeExpression $
407+ "power(" <> renderSQL b <> ", " <> renderSQL x <> ")"
408+ logBase b y = log y / log b
409+ sin = unsafeFunction "sin"
410+ cos = unsafeFunction "cos"
411+ tan = unsafeFunction "tan"
412+ asin = unsafeFunction "asin"
413+ acos = unsafeFunction "acos"
414+ atan = unsafeFunction "atan"
415+ sinh x = (exp x - exp (-x)) / 2
416+ cosh x = (exp x + exp (-x)) / 2
417+ tanh x = sinh x / cosh x
418+ asinh x = log (x + sqrt (x*x + 1))
419+ acosh x = log (x + sqrt (x*x - 1))
420+ atanh x = log ((1 + x) / (1 - x)) / 2
421+
422+-- | Contained by operators
423+class PGSubset ty where
424+ (@>) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
425+ (@>) = unsafeBinaryOp "@>"
426+ (<@) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
427+ (<@) = unsafeBinaryOp "<@"
428+instance PGSubset 'PGjsonb
429+instance PGSubset 'PGtsquery
430+instance PGSubset ('PGvararray ty)
431+instance PGSubset ('PGrange ty)
432+
433+class PGIntersect ty where
434+ (@&&) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
435+ (@&&) = unsafeBinaryOp "&&"
436+instance PGIntersect ('PGvararray ty)
437+instance PGIntersect ('PGrange ty)
438+
439+instance IsString
440+ (Expression outer commons grp schemas params from (null 'PGtext)) where
441+ fromString str = UnsafeExpression $
442+ "E\'" <> fromString (escape =<< str) <> "\'"
443+instance IsString
444+ (Expression outer commons grp schemas params from (null 'PGtsvector)) where
445+ fromString str = UnsafeExpression . parenthesized . (<> " :: tsvector") $
446+ "E\'" <> fromString (escape =<< str) <> "\'"
447+instance IsString
448+ (Expression outer commons grp schemas params from (null 'PGtsquery)) where
449+ fromString str = UnsafeExpression . parenthesized . (<> " :: tsquery") $
450+ "E\'" <> fromString (escape =<< str) <> "\'"
451+
452+instance Semigroup
453+ (Expression outer commons grp schemas params from (null ('PGvararray ty))) where
454+ (<>) = unsafeBinaryOp "||"
455+instance Semigroup
456+ (Expression outer commons grp schemas params from (null 'PGjsonb)) where
457+ (<>) = unsafeBinaryOp "||"
458+instance Semigroup
459+ (Expression outer commons grp schemas params from (null 'PGtext)) where
460+ (<>) = unsafeBinaryOp "||"
461+instance Semigroup
462+ (Expression outer commons grp schemas params from (null 'PGtsvector)) where
463+ (<>) = unsafeBinaryOp "||"
464+
465+instance Monoid
466+ (Expression outer commons grp schemas params from (null 'PGtext)) where
467+ mempty = fromString ""
468+ mappend = (<>)
469+instance Monoid
470+ (Expression outer commons grp schemas params from (null 'PGtsvector)) where
471+ mempty = fromString ""
472+ mappend = (<>)
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Aggregate.hsnew file+462
@@ -0,0 +1,462 @@
1+{-|
2+Module: Squeal.PostgreSQL.Expression.Aggregate
3+Description: Aggregate functions
4+Copyright: (c) Eitan Chatav, 2019
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Aggregate functions
9+-}
10+
11+{-# LANGUAGE
12+ DataKinds
13+ , DeriveGeneric
14+ , FlexibleContexts
15+ , FlexibleInstances
16+ , FunctionalDependencies
17+ , LambdaCase
18+ , MultiParamTypeClasses
19+ , OverloadedStrings
20+ , PolyKinds
21+ , TypeFamilies
22+ , TypeOperators
23+ , UndecidableInstances
24+#-}
25+
26+module Squeal.PostgreSQL.Expression.Aggregate
27+ ( Aggregate (..)
28+ , Distinction (..)
29+ , PGSum
30+ , PGAvg
31+ ) where
32+
33+import Control.DeepSeq
34+import Data.ByteString (ByteString)
35+import Data.Kind
36+import GHC.TypeLits
37+
38+import qualified GHC.Generics as GHC
39+import qualified Generics.SOP as SOP
40+
41+import Squeal.PostgreSQL.Alias
42+import Squeal.PostgreSQL.Expression
43+import Squeal.PostgreSQL.List
44+import Squeal.PostgreSQL.Render
45+import Squeal.PostgreSQL.Schema
46+
47+-- $setup
48+-- >>> import Squeal.PostgreSQL
49+
50+{- |
51+`Aggregate` functions compute a single result from a set of input values.
52+`Aggregate` functions can be used as `GroupedBy` `Expression`s as well
53+as `Squeal.PostgreSQL.Expression.Window.WindowFunction`s.
54+-}
55+class Aggregate expr1 exprN aggr
56+ | aggr -> expr1, aggr -> exprN where
57+
58+ -- | A special aggregation that does not require an input
59+ --
60+ -- >>> :{
61+ -- let
62+ -- expression :: Expression '[] commons ('Grouped bys) schemas params from ('NotNull 'PGint8)
63+ -- expression = countStar
64+ -- in printSQL expression
65+ -- :}
66+ -- count(*)
67+ countStar :: aggr ('NotNull 'PGint8)
68+
69+ -- | >>> :{
70+ -- let
71+ -- expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: null ty]] ('NotNull 'PGint8)
72+ -- expression = count (All #col)
73+ -- in printSQL expression
74+ -- :}
75+ -- count(ALL "col")
76+ count
77+ :: expr1 ty
78+ -- ^ what to count
79+ -> aggr ('NotNull 'PGint8)
80+
81+ -- | >>> :{
82+ -- let
83+ -- expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: 'Null 'PGnumeric]] ('Null 'PGnumeric)
84+ -- expression = sum_ (Distinct #col)
85+ -- in printSQL expression
86+ -- :}
87+ -- sum(DISTINCT "col")
88+ sum_
89+ :: expr1 (null ty)
90+ -> aggr ('Null (PGSum ty))
91+
92+ -- | input values, including nulls, concatenated into an array
93+ arrayAgg
94+ :: expr1 ty
95+ -> aggr ('Null ('PGvararray ty))
96+
97+ -- | aggregates values as a JSON array
98+ jsonAgg
99+ :: expr1 ty
100+ -> aggr ('Null 'PGjson)
101+
102+ -- | aggregates values as a JSON array
103+ jsonbAgg
104+ :: expr1 ty
105+ -> aggr ('Null 'PGjsonb)
106+
107+ {- |
108+ the bitwise AND of all non-null input values, or null if none
109+
110+ >>> :{
111+ let
112+ expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: null 'PGint4]] ('Null 'PGint4)
113+ expression = bitAnd (Distinct #col)
114+ in printSQL expression
115+ :}
116+ bit_and(DISTINCT "col")
117+ -}
118+ bitAnd
119+ :: int `In` PGIntegral
120+ => expr1 (null int)
121+ -- ^ what to aggregate
122+ -> aggr ('Null int)
123+
124+ {- |
125+ the bitwise OR of all non-null input values, or null if none
126+
127+ >>> :{
128+ let
129+ expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: null 'PGint4]] ('Null 'PGint4)
130+ expression = bitOr (All #col)
131+ in printSQL expression
132+ :}
133+ bit_or(ALL "col")
134+ -}
135+ bitOr
136+ :: int `In` PGIntegral
137+ => expr1 (null int)
138+ -- ^ what to aggregate
139+ -> aggr ('Null int)
140+
141+ {- |
142+ true if all input values are true, otherwise false
143+
144+ >>> :{
145+ let
146+ winFun :: WindowFunction '[] commons 'Ungrouped schemas params '[tab ::: '["col" ::: null 'PGbool]] ('Null 'PGbool)
147+ winFun = boolAnd #col
148+ in printSQL winFun
149+ :}
150+ bool_and("col")
151+ -}
152+ boolAnd
153+ :: expr1 (null 'PGbool)
154+ -- ^ what to aggregate
155+ -> aggr ('Null 'PGbool)
156+
157+ {- |
158+ true if at least one input value is true, otherwise false
159+
160+ >>> :{
161+ let
162+ expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: null 'PGbool]] ('Null 'PGbool)
163+ expression = boolOr (All #col)
164+ in printSQL expression
165+ :}
166+ bool_or(ALL "col")
167+ -}
168+ boolOr
169+ :: expr1 (null 'PGbool)
170+ -- ^ what to aggregate
171+ -> aggr ('Null 'PGbool)
172+
173+ {- |
174+ equivalent to `boolAnd`
175+
176+ >>> :{
177+ let
178+ expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: null 'PGbool]] ('Null 'PGbool)
179+ expression = every (Distinct #col)
180+ in printSQL expression
181+ :}
182+ every(DISTINCT "col")
183+ -}
184+ every
185+ :: expr1 (null 'PGbool)
186+ -- ^ what to aggregate
187+ -> aggr ('Null 'PGbool)
188+
189+ {- |maximum value of expression across all input values-}
190+ max_
191+ :: expr1 (null ty)
192+ -- ^ what to maximize
193+ -> aggr ('Null ty)
194+
195+ -- | minimum value of expression across all input values
196+ min_
197+ :: expr1 (null ty)
198+ -- ^ what to minimize
199+ -> aggr ('Null ty)
200+
201+ -- | the average (arithmetic mean) of all input values
202+ avg
203+ :: expr1 (null ty)
204+ -- ^ what to average
205+ -> aggr ('Null (PGAvg ty))
206+
207+ {- | correlation coefficient
208+
209+ >>> :{
210+ let
211+ expression :: Expression '[] c ('Grouped g) s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)
212+ expression = corr (All (#y *: #x))
213+ in printSQL expression
214+ :}
215+ corr(ALL "y", "x")
216+ -}
217+ corr
218+ :: exprN '[null 'PGfloat8, null 'PGfloat8]
219+ -> aggr ('Null 'PGfloat8)
220+
221+ {- | population covariance
222+
223+ >>> :{
224+ let
225+ expression :: Expression '[] c ('Grouped g) s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)
226+ expression = covarPop (All (#y *: #x))
227+ in printSQL expression
228+ :}
229+ covar_pop(ALL "y", "x")
230+ -}
231+ covarPop
232+ :: exprN '[null 'PGfloat8, null 'PGfloat8]
233+ -> aggr ('Null 'PGfloat8)
234+
235+ {- | sample covariance
236+
237+ >>> :{
238+ let
239+ winFun :: WindowFunction '[] c 'Ungrouped s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)
240+ winFun = covarSamp (#y *: #x)
241+ in printSQL winFun
242+ :}
243+ covar_samp("y", "x")
244+ -}
245+ covarSamp
246+ :: exprN '[null 'PGfloat8, null 'PGfloat8]
247+ -> aggr ('Null 'PGfloat8)
248+
249+ {- | average of the independent variable (sum(X)/N)
250+
251+ >>> :{
252+ let
253+ expression :: Expression '[] c ('Grouped g) s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)
254+ expression = regrAvgX (All (#y *: #x))
255+ in printSQL expression
256+ :}
257+ regr_avgx(ALL "y", "x")
258+ -}
259+ regrAvgX
260+ :: exprN '[null 'PGfloat8, null 'PGfloat8]
261+ -> aggr ('Null 'PGfloat8)
262+
263+ {- | average of the dependent variable (sum(Y)/N)
264+
265+ >>> :{
266+ let
267+ winFun :: WindowFunction '[] c 'Ungrouped s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)
268+ winFun = regrAvgY (#y *: #x)
269+ in printSQL winFun
270+ :}
271+ regr_avgy("y", "x")
272+ -}
273+ regrAvgY
274+ :: exprN '[null 'PGfloat8, null 'PGfloat8]
275+ -> aggr ('Null 'PGfloat8)
276+
277+ {- | number of input rows in which both expressions are nonnull
278+
279+ >>> :{
280+ let
281+ winFun :: WindowFunction '[] c 'Ungrouped s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGint8)
282+ winFun = regrCount (#y *: #x)
283+ in printSQL winFun
284+ :}
285+ regr_count("y", "x")
286+ -}
287+ regrCount
288+ :: exprN '[null 'PGfloat8, null 'PGfloat8]
289+ -> aggr ('Null 'PGint8)
290+
291+ {- | y-intercept of the least-squares-fit linear equation determined by the (X, Y) pairs
292+ >>> :{
293+ let
294+ expression :: Expression '[] c ('Grouped g) s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)
295+ expression = regrIntercept (All (#y *: #x))
296+ in printSQL expression
297+ :}
298+ regr_intercept(ALL "y", "x")
299+ -}
300+ regrIntercept
301+ :: exprN '[null 'PGfloat8, null 'PGfloat8]
302+ -> aggr ('Null 'PGfloat8)
303+
304+ -- | @regr_r2(Y, X)@, square of the correlation coefficient
305+ regrR2
306+ :: exprN '[null 'PGfloat8, null 'PGfloat8]
307+ -> aggr ('Null 'PGfloat8)
308+
309+ -- | @regr_slope(Y, X)@, slope of the least-squares-fit linear equation
310+ -- determined by the (X, Y) pairs
311+ regrSlope
312+ :: exprN '[null 'PGfloat8, null 'PGfloat8]
313+ -> aggr ('Null 'PGfloat8)
314+
315+ -- | @regr_sxx(Y, X)@, sum(X^2) - sum(X)^2/N
316+ -- (“sum of squares” of the independent variable)
317+ regrSxx
318+ :: exprN '[null 'PGfloat8, null 'PGfloat8]
319+ -> aggr ('Null 'PGfloat8)
320+
321+ -- | @regr_sxy(Y, X)@, sum(X*Y) - sum(X) * sum(Y)/N
322+ -- (“sum of products” of independent times dependent variable)
323+ regrSxy
324+ :: exprN '[null 'PGfloat8, null 'PGfloat8]
325+ -> aggr ('Null 'PGfloat8)
326+
327+ -- | @regr_syy(Y, X)@, sum(Y^2) - sum(Y)^2/N
328+ -- (“sum of squares” of the dependent variable)
329+ regrSyy
330+ :: exprN '[null 'PGfloat8, null 'PGfloat8]
331+ -> aggr ('Null 'PGfloat8)
332+
333+ -- | historical alias for `stddevSamp`
334+ stddev
335+ :: expr1 (null ty)
336+ -> aggr ('Null (PGAvg ty))
337+
338+ -- | population standard deviation of the input values
339+ stddevPop
340+ :: expr1 (null ty)
341+ -> aggr ('Null (PGAvg ty))
342+
343+ -- | sample standard deviation of the input values
344+ stddevSamp
345+ :: expr1 (null ty)
346+ -> aggr ('Null (PGAvg ty))
347+
348+ -- | historical alias for `varSamp`
349+ variance
350+ :: expr1 (null ty)
351+ -> aggr ('Null (PGAvg ty))
352+
353+ -- | population variance of the input values
354+ -- (square of the population standard deviation)
355+ varPop
356+ :: expr1 (null ty)
357+ -> aggr ('Null (PGAvg ty))
358+
359+ -- | sample variance of the input values
360+ -- (square of the sample standard deviation)
361+ varSamp
362+ :: expr1 (null ty)
363+ -> aggr ('Null (PGAvg ty))
364+
365+{- |
366+`Distinction`s are used for the input of `Aggregate` `Expression`s.
367+`All` invokes the aggregate once for each input row.
368+`Distinct` invokes the aggregate once for each distinct value of the expression
369+(or distinct set of values, for multiple expressions) found in the input
370+-}
371+data Distinction (expr :: kind -> Type) (ty :: kind)
372+ = All (expr ty)
373+ | Distinct (expr ty)
374+ deriving (GHC.Generic,Show,Eq,Ord)
375+instance NFData (Distinction (Expression outer commons grp schemas params from) ty)
376+instance RenderSQL (Distinction (Expression outer commons grp schemas params from) ty) where
377+ renderSQL = \case
378+ All x -> "ALL" <+> renderSQL x
379+ Distinct x -> "DISTINCT" <+> renderSQL x
380+instance SOP.SListI tys => RenderSQL
381+ (Distinction (NP (Expression outer commons grp schemas params from)) tys) where
382+ renderSQL = \case
383+ All xs -> "ALL" <+> renderCommaSeparated renderSQL xs
384+ Distinct xs -> "DISTINCT" <+> renderCommaSeparated renderSQL xs
385+
386+instance Aggregate
387+ (Distinction (Expression outer commons 'Ungrouped schemas params from))
388+ (Distinction (NP (Expression outer commons 'Ungrouped schemas params from)))
389+ (Expression outer commons ('Grouped bys) schemas params from) where
390+ countStar = UnsafeExpression "count(*)"
391+ count = unsafeAggregate1 "count"
392+ sum_ = unsafeAggregate1 "sum"
393+ arrayAgg = unsafeAggregate1 "array_agg"
394+ jsonAgg = unsafeAggregate1 "json_agg"
395+ jsonbAgg = unsafeAggregate1 "jsonb_agg"
396+ bitAnd = unsafeAggregate1 "bit_and"
397+ bitOr = unsafeAggregate1 "bit_or"
398+ boolAnd = unsafeAggregate1 "bool_and"
399+ boolOr = unsafeAggregate1 "bool_or"
400+ every = unsafeAggregate1 "every"
401+ max_ = unsafeAggregate1 "max"
402+ min_ = unsafeAggregate1 "min"
403+ avg = unsafeAggregate1 "avg"
404+ corr = unsafeAggregateN "corr"
405+ covarPop = unsafeAggregateN "covar_pop"
406+ covarSamp = unsafeAggregateN "covar_samp"
407+ regrAvgX = unsafeAggregateN "regr_avgx"
408+ regrAvgY = unsafeAggregateN "regr_avgy"
409+ regrCount = unsafeAggregateN "regr_count"
410+ regrIntercept = unsafeAggregateN "regr_intercept"
411+ regrR2 = unsafeAggregateN "regr_r2"
412+ regrSlope = unsafeAggregateN "regr_slope"
413+ regrSxx = unsafeAggregateN "regr_sxx"
414+ regrSxy = unsafeAggregateN "regr_sxy"
415+ regrSyy = unsafeAggregateN "regr_syy"
416+ stddev = unsafeAggregate1 "stddev"
417+ stddevPop = unsafeAggregate1 "stddev_pop"
418+ stddevSamp = unsafeAggregate1 "stddev_samp"
419+ variance = unsafeAggregate1 "variance"
420+ varPop = unsafeAggregate1 "var_pop"
421+ varSamp = unsafeAggregate1 "var_samp"
422+
423+-- | escape hatch to define aggregate functions
424+unsafeAggregate1
425+ :: ByteString -- ^ aggregate function
426+ -> Distinction (Expression outer commons 'Ungrouped schemas params from) x
427+ -> Expression outer commons ('Grouped bys) schemas params from y
428+unsafeAggregate1 fun x = UnsafeExpression $ fun <> parenthesized (renderSQL x)
429+
430+unsafeAggregateN
431+ :: SOP.SListI xs
432+ => ByteString -- ^ function
433+ -> Distinction (NP (Expression outer commons 'Ungrouped schemas params from)) xs
434+ -> Expression outer commons ('Grouped bys) schemas params from y
435+unsafeAggregateN fun xs = UnsafeExpression $ fun <> parenthesized (renderSQL xs)
436+
437+-- | A type family that calculates `PGSum``PGType` of
438+-- a given argument `PGType`.
439+type family PGSum ty where
440+ PGSum 'PGint2 = 'PGint8
441+ PGSum 'PGint4 = 'PGint8
442+ PGSum 'PGint8 = 'PGnumeric
443+ PGSum 'PGfloat4 = 'PGfloat4
444+ PGSum 'PGfloat8 = 'PGfloat8
445+ PGSum 'PGnumeric = 'PGnumeric
446+ PGSum 'PGinterval = 'PGinterval
447+ PGSum 'PGmoney = 'PGmoney
448+ PGSum pg = TypeError
449+ ( 'Text "Squeal type error: Cannot sum with argument type "
450+ ':<>: 'ShowType pg )
451+
452+-- | A type family that calculates `PGAvg` type of a `PGType`.
453+type family PGAvg ty where
454+ PGAvg 'PGint2 = 'PGnumeric
455+ PGAvg 'PGint4 = 'PGnumeric
456+ PGAvg 'PGint8 = 'PGnumeric
457+ PGAvg 'PGnumeric = 'PGnumeric
458+ PGAvg 'PGfloat4 = 'PGfloat8
459+ PGAvg 'PGfloat8 = 'PGfloat8
460+ PGAvg 'PGinterval = 'PGinterval
461+ PGAvg pg = TypeError
462+ ('Text "Squeal type error: No average for " ':<>: 'ShowType pg)
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Collection.hsnew file+169
@@ -0,0 +1,169 @@
1+{-|
2+Module: Squeal.PostgreSQL.Expression.Collection
3+Description: Array and composite functions
4+Copyright: (c) Eitan Chatav, 2019
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Array and composite functions
9+-}
10+
11+{-# LANGUAGE
12+ AllowAmbiguousTypes
13+ , DataKinds
14+ , FlexibleContexts
15+ , FlexibleInstances
16+ , MultiParamTypeClasses
17+ , OverloadedLabels
18+ , OverloadedStrings
19+ , RankNTypes
20+ , ScopedTypeVariables
21+ , TypeApplications
22+ , TypeFamilies
23+ , TypeOperators
24+ , UndecidableInstances
25+#-}
26+
27+module Squeal.PostgreSQL.Expression.Collection
28+ ( array
29+ , array1
30+ , array2
31+ , cardinality
32+ , index
33+ , unnest
34+ , row
35+ , field
36+ ) where
37+
38+import Data.String
39+import Data.Word (Word64)
40+
41+import qualified Generics.SOP as SOP
42+
43+import Squeal.PostgreSQL.Alias
44+import Squeal.PostgreSQL.Expression
45+import Squeal.PostgreSQL.Expression.Set
46+import Squeal.PostgreSQL.List
47+import Squeal.PostgreSQL.Render
48+import Squeal.PostgreSQL.Schema
49+
50+-- $setup
51+-- >>> import Squeal.PostgreSQL
52+
53+-- | >>> printSQL $ array [null_, false, true]
54+-- ARRAY[NULL, FALSE, TRUE]
55+array
56+ :: [Expression outer commons grp schemas params from ty]
57+ -- ^ array elements
58+ -> Expression outer commons grp schemas params from (null ('PGvararray ty))
59+array xs = UnsafeExpression $ "ARRAY" <>
60+ bracketed (commaSeparated (renderSQL <$> xs))
61+
62+{- | construct a 1-dimensional fixed length array
63+
64+>>> printSQL $ array1 (null_ :* false *: true)
65+ARRAY[NULL, FALSE, TRUE]
66+
67+>>> :type array1 (null_ :* false *: true)
68+array1 (null_ :* false *: true)
69+ :: Expression
70+ outer
71+ commons
72+ grp
73+ schemas
74+ params
75+ from
76+ (null ('PGfixarray '[3] ('Null 'PGbool)))
77+-}
78+array1
79+ :: (n ~ Length tys, SOP.All ((~) ty) tys)
80+ => NP (Expression outer commons grp schemas params from) tys
81+ -> Expression outer commons grp schemas params from (null ('PGfixarray '[n] ty))
82+array1 xs = UnsafeExpression $ "ARRAY" <>
83+ bracketed (renderCommaSeparated renderSQL xs)
84+
85+{- | construct a 2-dimensional fixed length array
86+
87+>>> printSQL $ array2 ((null_ :* false *: true) *: (false :* null_ *: true))
88+ARRAY[[NULL, FALSE, TRUE], [FALSE, NULL, TRUE]]
89+
90+>>> :type array2 ((null_ :* false *: true) *: (false :* null_ *: true))
91+array2 ((null_ :* false *: true) *: (false :* null_ *: true))
92+ :: Expression
93+ outer
94+ commons
95+ grp
96+ schemas
97+ params
98+ from
99+ (null ('PGfixarray '[2, 3] ('Null 'PGbool)))
100+-}
101+array2
102+ :: ( SOP.All ((~) tys) tyss
103+ , SOP.All SOP.SListI tyss
104+ , Length tyss ~ n1
105+ , SOP.All ((~) ty) tys
106+ , Length tys ~ n2 )
107+ => NP (NP (Expression outer commons grp schemas params from)) tyss
108+ -> Expression outer commons grp schemas params from (null ('PGfixarray '[n1,n2] ty))
109+array2 xss = UnsafeExpression $ "ARRAY" <>
110+ bracketed (renderCommaSeparatedConstraint @SOP.SListI (bracketed . renderCommaSeparated renderSQL) xss)
111+
112+-- | >>> printSQL $ cardinality (array [null_, false, true])
113+-- cardinality(ARRAY[NULL, FALSE, TRUE])
114+cardinality :: null ('PGvararray ty) --> null 'PGint8
115+cardinality = unsafeFunction "cardinality"
116+
117+-- | >>> printSQL $ array [null_, false, true] & index 2
118+-- (ARRAY[NULL, FALSE, TRUE])[2]
119+index
120+ :: Word64 -- ^ index
121+ -> null ('PGvararray ty) --> NullifyType ty
122+index n expr = UnsafeExpression $
123+ parenthesized (renderSQL expr) <> "[" <> fromString (show n) <> "]"
124+
125+-- | Expand an array to a set of rows
126+unnest :: SetFunction "unnest" (null ('PGvararray ty)) '["unnest" ::: ty]
127+unnest = unsafeSetFunction
128+
129+-- | A row constructor is an expression that builds a row value
130+-- (also called a composite value) using values for its member fields.
131+--
132+-- >>> :{
133+-- type Complex = 'PGcomposite
134+-- '[ "real" ::: 'NotNull 'PGfloat8
135+-- , "imaginary" ::: 'NotNull 'PGfloat8 ]
136+-- :}
137+--
138+-- >>> let i = row (0 `as` #real :* 1 `as` #imaginary) :: Expression outer commons grp schemas params from ('NotNull Complex)
139+-- >>> printSQL i
140+-- ROW(0, 1)
141+row
142+ :: SOP.SListI row
143+ => NP (Aliased (Expression outer commons grp schemas params from)) row
144+ -- ^ zero or more expressions for the row field values
145+ -> Expression outer commons grp schemas params from (null ('PGcomposite row))
146+row exprs = UnsafeExpression $ "ROW" <> parenthesized
147+ (renderCommaSeparated (\ (expr `As` _) -> renderSQL expr) exprs)
148+
149+-- | >>> :{
150+-- type Complex = 'PGcomposite
151+-- '[ "real" ::: 'NotNull 'PGfloat8
152+-- , "imaginary" ::: 'NotNull 'PGfloat8 ]
153+-- type Schema = '["complex" ::: 'Typedef Complex]
154+-- :}
155+--
156+-- >>> let i = row (0 `as` #real :* 1 `as` #imaginary) :: Expression outer '[] grp (Public Schema) from params ('NotNull Complex)
157+-- >>> printSQL $ i & field #complex #imaginary
158+-- (ROW(0, 1)::"complex")."imaginary"
159+field
160+ :: ( Has sch schemas schema
161+ , Has tydef schema ('Typedef ('PGcomposite row))
162+ , Has field row ty)
163+ => QualifiedAlias sch tydef -- ^ row type
164+ -> Alias field -- ^ field name
165+ -> Expression outer commons grp schemas params from ('NotNull ('PGcomposite row))
166+ -> Expression outer commons grp schemas params from ty
167+field td fld expr = UnsafeExpression $
168+ parenthesized (renderSQL expr <> "::" <> renderSQL td)
169+ <> "." <> renderSQL fld
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Comparison.hsnew file+206
@@ -0,0 +1,206 @@
1+{-|
2+Module: Squeal.PostgreSQL.Expression.Comparison
3+Description: Comparison expressions
4+Copyright: (c) Eitan Chatav, 2019
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Comparison functions and operators
9+-}
10+
11+{-# LANGUAGE
12+ OverloadedStrings
13+ , RankNTypes
14+ , TypeInType
15+ , TypeOperators
16+#-}
17+
18+module Squeal.PostgreSQL.Expression.Comparison
19+ ( (.==)
20+ , (./=)
21+ , (.>=)
22+ , (.<)
23+ , (.<=)
24+ , (.>)
25+ , greatest
26+ , least
27+ , BetweenExpr
28+ , between
29+ , notBetween
30+ , betweenSymmetric
31+ , notBetweenSymmetric
32+ , isDistinctFrom
33+ , isNotDistinctFrom
34+ , isTrue
35+ , isNotTrue
36+ , isFalse
37+ , isNotFalse
38+ , isUnknown
39+ , isNotUnknown
40+ ) where
41+
42+import Data.ByteString
43+
44+import Squeal.PostgreSQL.Expression
45+import Squeal.PostgreSQL.Expression.Logic
46+import Squeal.PostgreSQL.Render
47+import Squeal.PostgreSQL.Schema
48+
49+-- $setup
50+-- >>> import Squeal.PostgreSQL
51+
52+-- | Comparison operations like `.==`, `./=`, `.>`, `.>=`, `.<` and `.<=`
53+-- will produce @NULL@s if one of their arguments is @NULL@.
54+--
55+-- >>> printSQL $ true .== null_
56+-- (TRUE = NULL)
57+(.==) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
58+(.==) = unsafeBinaryOp "="
59+infix 4 .==
60+
61+-- | >>> printSQL $ true ./= null_
62+-- (TRUE <> NULL)
63+(./=) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
64+(./=) = unsafeBinaryOp "<>"
65+infix 4 ./=
66+
67+-- | >>> printSQL $ true .>= null_
68+-- (TRUE >= NULL)
69+(.>=) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
70+(.>=) = unsafeBinaryOp ">="
71+infix 4 .>=
72+
73+-- | >>> printSQL $ true .< null_
74+-- (TRUE < NULL)
75+(.<) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
76+(.<) = unsafeBinaryOp "<"
77+infix 4 .<
78+
79+-- | >>> printSQL $ true .<= null_
80+-- (TRUE <= NULL)
81+(.<=) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
82+(.<=) = unsafeBinaryOp "<="
83+infix 4 .<=
84+
85+-- | >>> printSQL $ true .> null_
86+-- (TRUE > NULL)
87+(.>) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
88+(.>) = unsafeBinaryOp ">"
89+infix 4 .>
90+
91+-- | >>> let expr = greatest [param @1] currentTimestamp :: Expression outer commons grp schemas '[ 'NotNull 'PGtimestamptz] from ('NotNull 'PGtimestamptz)
92+-- >>> printSQL expr
93+-- GREATEST(($1 :: timestamp with time zone), CURRENT_TIMESTAMP)
94+greatest :: FunctionVar ty ty ty
95+greatest = unsafeFunctionVar "GREATEST"
96+
97+-- | >>> printSQL $ least [null_] currentTimestamp
98+-- LEAST(NULL, CURRENT_TIMESTAMP)
99+least :: FunctionVar ty ty ty
100+least = unsafeFunctionVar "LEAST"
101+
102+{- |
103+A @RankNType@ for comparison expressions like `between`.
104+-}
105+type BetweenExpr
106+ = forall outer commons grp schemas params from ty
107+ . Expression outer commons grp schemas params from ty
108+ -> ( Expression outer commons grp schemas params from ty
109+ , Expression outer commons grp schemas params from ty ) -- ^ bounds
110+ -> Condition outer commons grp schemas params from
111+
112+unsafeBetweenExpr :: ByteString -> BetweenExpr
113+unsafeBetweenExpr fun a (x,y) = UnsafeExpression $
114+ renderSQL a <+> fun <+> renderSQL x <+> "AND" <+> renderSQL y
115+
116+{- | >>> printSQL $ true `between` (null_, false)
117+TRUE BETWEEN NULL AND FALSE
118+-}
119+between :: BetweenExpr
120+between = unsafeBetweenExpr "BETWEEN"
121+
122+{- | >>> printSQL $ true `notBetween` (null_, false)
123+TRUE NOT BETWEEN NULL AND FALSE
124+-}
125+notBetween :: BetweenExpr
126+notBetween = unsafeBetweenExpr "NOT BETWEEN"
127+
128+{- | between, after sorting the comparison values
129+
130+>>> printSQL $ true `betweenSymmetric` (null_, false)
131+TRUE BETWEEN SYMMETRIC NULL AND FALSE
132+-}
133+betweenSymmetric :: BetweenExpr
134+betweenSymmetric = unsafeBetweenExpr "BETWEEN SYMMETRIC"
135+
136+{- | not between, after sorting the comparison values
137+
138+>>> printSQL $ true `notBetweenSymmetric` (null_, false)
139+TRUE NOT BETWEEN SYMMETRIC NULL AND FALSE
140+-}
141+notBetweenSymmetric :: BetweenExpr
142+notBetweenSymmetric = unsafeBetweenExpr "NOT BETWEEN SYMMETRIC"
143+
144+{- | not equal, treating null like an ordinary value
145+
146+>>> printSQL $ true `isDistinctFrom` null_
147+(TRUE IS DISTINCT FROM NULL)
148+-}
149+isDistinctFrom :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
150+isDistinctFrom = unsafeBinaryOp "IS DISTINCT FROM"
151+
152+{- | equal, treating null like an ordinary value
153+
154+>>> printSQL $ true `isNotDistinctFrom` null_
155+(TRUE IS NOT DISTINCT FROM NULL)
156+-}
157+isNotDistinctFrom :: Operator (null0 ty) (null1 ty) ('NotNull 'PGbool)
158+isNotDistinctFrom = unsafeBinaryOp "IS NOT DISTINCT FROM"
159+
160+{- | is true
161+
162+>>> printSQL $ true & isTrue
163+(TRUE IS TRUE)
164+-}
165+isTrue :: null0 'PGbool --> null1 'PGbool
166+isTrue = unsafeRightOp "IS TRUE"
167+
168+{- | is false or unknown
169+
170+>>> printSQL $ true & isNotTrue
171+(TRUE IS NOT TRUE)
172+-}
173+isNotTrue :: null0 'PGbool --> null1 'PGbool
174+isNotTrue = unsafeRightOp "IS NOT TRUE"
175+
176+{- | is false
177+
178+>>> printSQL $ true & isFalse
179+(TRUE IS FALSE)
180+-}
181+isFalse :: null0 'PGbool --> null1 'PGbool
182+isFalse = unsafeRightOp "IS FALSE"
183+
184+{- | is true or unknown
185+
186+>>> printSQL $ true & isNotFalse
187+(TRUE IS NOT FALSE)
188+-}
189+isNotFalse :: null0 'PGbool --> null1 'PGbool
190+isNotFalse = unsafeRightOp "IS NOT FALSE"
191+
192+{- | is unknown
193+
194+>>> printSQL $ true & isUnknown
195+(TRUE IS UNKNOWN)
196+-}
197+isUnknown :: null0 'PGbool --> null1 'PGbool
198+isUnknown = unsafeRightOp "IS UNKNOWN"
199+
200+{- | is true or false
201+
202+>>> printSQL $ true & isNotUnknown
203+(TRUE IS NOT UNKNOWN)
204+-}
205+isNotUnknown :: null0 'PGbool --> null1 'PGbool
206+isNotUnknown = unsafeRightOp "IS NOT UNKNOWN"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Json.hsnew file+462
@@ -0,0 +1,462 @@
1+{-|
2+Module: Squeal.PostgreSQL.Expression.Json
3+Description: Json and Jsonb functions and operators
4+Copyright: (c) Eitan Chatav, 2019
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Json and Jsonb functions and operators
9+-}
10+
11+{-# LANGUAGE
12+ DataKinds
13+ , FlexibleContexts
14+ , FlexibleInstances
15+ , GADTs
16+ , OverloadedLabels
17+ , OverloadedStrings
18+ , PolyKinds
19+ , RankNTypes
20+ , ScopedTypeVariables
21+ , TypeApplications
22+ , TypeOperators
23+ , UndecidableInstances
24+ , UndecidableSuperClasses
25+#-}
26+
27+module Squeal.PostgreSQL.Expression.Json
28+ ( -- * Json and Jsonb operators
29+ (.->)
30+ , (.->>)
31+ , (.#>)
32+ , (.#>>)
33+ -- * Jsonb operators
34+ , (.?)
35+ , (.?|)
36+ , (.?&)
37+ , (.-.)
38+ , (#-.)
39+ -- * Json and Jsonb functions
40+ , toJson
41+ , toJsonb
42+ , arrayToJson
43+ , rowToJson
44+ , jsonBuildArray
45+ , jsonbBuildArray
46+ , JsonBuildObject (..)
47+ , jsonObject
48+ , jsonbObject
49+ , jsonZipObject
50+ , jsonbZipObject
51+ , jsonArrayLength
52+ , jsonbArrayLength
53+ , jsonTypeof
54+ , jsonbTypeof
55+ , jsonStripNulls
56+ , jsonbStripNulls
57+ , jsonbSet
58+ , jsonbInsert
59+ , jsonbPretty
60+ -- * Json and Jsonb set returning functions
61+ , jsonEach
62+ , jsonbEach
63+ , jsonEachText
64+ , jsonbEachText
65+ , jsonObjectKeys
66+ , jsonbObjectKeys
67+ , JsonPopulateFunction
68+ , jsonPopulateRecord
69+ , jsonbPopulateRecord
70+ , jsonPopulateRecordSet
71+ , jsonbPopulateRecordSet
72+ , JsonToRecordFunction
73+ , jsonToRecord
74+ , jsonbToRecord
75+ , jsonToRecordSet
76+ , jsonbToRecordSet
77+ ) where
78+
79+import Data.ByteString (ByteString)
80+import GHC.TypeLits
81+
82+import Squeal.PostgreSQL.Alias
83+import Squeal.PostgreSQL.Expression
84+import Squeal.PostgreSQL.Expression.Set
85+import Squeal.PostgreSQL.Expression.Type
86+import Squeal.PostgreSQL.List
87+import Squeal.PostgreSQL.Query
88+import Squeal.PostgreSQL.Render
89+import Squeal.PostgreSQL.Schema
90+
91+import qualified Generics.SOP as SOP
92+
93+-- $setup
94+-- >>> import Squeal.PostgreSQL
95+-- >>> import Data.Aeson
96+
97+{-----------------------------------------
98+ -- json and jsonb support
99+
100+See https://www.postgresql.org/docs/10/static/functions-json.html -- most
101+comments lifted directly from this page.
102+
103+Table 9.44: json and jsonb operators
104+-----------------------------------------}
105+
106+-- | Get JSON value (object field or array element) at a key.
107+(.->)
108+ :: (json `In` PGJsonType, key `In` PGJsonKey)
109+ => Operator (null json) (null key) ('Null json)
110+infixl 8 .->
111+(.->) = unsafeBinaryOp "->"
112+
113+-- | Get JSON value (object field or array element) at a key, as text.
114+(.->>)
115+ :: (json `In` PGJsonType, key `In` PGJsonKey)
116+ => Operator (null json) (null key) ('Null 'PGtext)
117+infixl 8 .->>
118+(.->>) = unsafeBinaryOp "->>"
119+
120+-- | Get JSON value at a specified path.
121+(.#>)
122+ :: json `In` PGJsonType
123+ => Operator (null json) (null ('PGvararray ('NotNull 'PGtext))) ('Null json)
124+infixl 8 .#>
125+(.#>) = unsafeBinaryOp "#>"
126+
127+-- | Get JSON value at a specified path as text.
128+(.#>>)
129+ :: json `In` PGJsonType
130+ => Operator (null json) (null ('PGvararray ('NotNull 'PGtext))) ('Null 'PGtext)
131+infixl 8 .#>>
132+(.#>>) = unsafeBinaryOp "#>>"
133+
134+-- Additional jsonb operators
135+
136+-- | Does the string exist as a top-level key within the JSON value?
137+(.?) :: Operator (null 'PGjsonb) (null 'PGtext) ('Null 'PGbool)
138+infixl 9 .?
139+(.?) = unsafeBinaryOp "?"
140+
141+-- | Do any of these array strings exist as top-level keys?
142+(.?|) :: Operator
143+ (null 'PGjsonb)
144+ (null ('PGvararray ('NotNull 'PGtext)))
145+ ('Null 'PGbool)
146+infixl 9 .?|
147+(.?|) = unsafeBinaryOp "?|"
148+
149+-- | Do all of these array strings exist as top-level keys?
150+(.?&) :: Operator
151+ (null 'PGjsonb)
152+ (null ('PGvararray ('NotNull 'PGtext)))
153+ ('Null 'PGbool)
154+infixl 9 .?&
155+(.?&) = unsafeBinaryOp "?&"
156+
157+-- | Delete a key or keys from a JSON object, or remove an array element.
158+--
159+-- If the right operand is
160+--
161+-- @ text @: Delete key / value pair or string element from left operand.
162+-- Key / value pairs are matched based on their key value,
163+--
164+-- @ text[] @: Delete multiple key / value pairs or string elements
165+-- from left operand. Key / value pairs are matched based on their key value,
166+--
167+-- @ integer @: Delete the array element with specified index (Negative integers
168+-- count from the end). Throws an error if top level container is not an array.
169+(.-.)
170+ :: key `In` '[ 'PGtext, 'PGvararray ('NotNull 'PGtext), 'PGint4, 'PGint2 ]
171+ => Operator (null 'PGjsonb) (null key) (null 'PGjsonb)
172+infixl 6 .-.
173+(.-.) = unsafeBinaryOp "-"
174+
175+-- | Delete the field or element with specified path (for JSON arrays, negative
176+-- integers count from the end)
177+(#-.) :: Operator (null 'PGjsonb) (null ('PGvararray ('NotNull 'PGtext))) (null 'PGjsonb)
178+infixl 6 #-.
179+(#-.) = unsafeBinaryOp "#-"
180+
181+{-----------------------------------------
182+Table 9.45: JSON creation functions
183+-----------------------------------------}
184+
185+-- | Returns the value as json. Arrays and composites are converted
186+-- (recursively) to arrays and objects; otherwise, if there is a cast from the
187+-- type to json, the cast function will be used to perform the conversion;
188+-- otherwise, a scalar value is produced. For any scalar type other than a
189+-- number, a Boolean, or a null value, the text representation will be used, in
190+-- such a fashion that it is a valid json value.
191+toJson :: null ty --> null 'PGjson
192+toJson = unsafeFunction "to_json"
193+
194+-- | Returns the value as jsonb. Arrays and composites are converted
195+-- (recursively) to arrays and objects; otherwise, if there is a cast from the
196+-- type to json, the cast function will be used to perform the conversion;
197+-- otherwise, a scalar value is produced. For any scalar type other than a
198+-- number, a Boolean, or a null value, the text representation will be used, in
199+-- such a fashion that it is a valid jsonb value.
200+toJsonb :: null ty --> null 'PGjsonb
201+toJsonb = unsafeFunction "to_jsonb"
202+
203+-- | Returns the array as a JSON array. A PostgreSQL multidimensional array
204+-- becomes a JSON array of arrays.
205+arrayToJson :: null ('PGvararray ty) --> null 'PGjson
206+arrayToJson = unsafeFunction "array_to_json"
207+
208+-- | Returns the row as a JSON object.
209+rowToJson :: null ('PGcomposite ty) --> null 'PGjson
210+rowToJson = unsafeFunction "row_to_json"
211+
212+-- | Builds a possibly-heterogeneously-typed JSON array out of a variadic
213+-- argument list.
214+jsonBuildArray :: SOP.SListI tuple => tuple ---> null 'PGjson
215+jsonBuildArray = unsafeFunctionN "json_build_array"
216+
217+-- | Builds a possibly-heterogeneously-typed (binary) JSON array out of a
218+-- variadic argument list.
219+jsonbBuildArray :: SOP.SListI tuple => tuple ---> null 'PGjsonb
220+jsonbBuildArray = unsafeFunctionN "jsonb_build_array"
221+
222+-- | Builds a possibly-heterogeneously-typed JSON object out of a variadic
223+-- argument list. The elements of the argument list must alternate between text
224+-- and values.
225+class SOP.SListI tys => JsonBuildObject tys where
226+
227+ jsonBuildObject :: tys ---> null 'PGjson
228+ jsonBuildObject = unsafeFunctionN "json_build_object"
229+
230+ jsonbBuildObject :: tys ---> null 'PGjsonb
231+ jsonbBuildObject = unsafeFunctionN "jsonb_build_object"
232+
233+instance JsonBuildObject '[]
234+instance (JsonBuildObject tys, key `In` PGJsonKey)
235+ => JsonBuildObject ('NotNull key ': value ': tys)
236+
237+-- | Builds a JSON object out of a text array.
238+-- The array must have two dimensions
239+-- such that each inner array has exactly two elements,
240+-- which are taken as a key/value pair.
241+jsonObject
242+ :: null ('PGfixarray '[n,2] ('NotNull 'PGtext))
243+ --> null 'PGjson
244+jsonObject = unsafeFunction "json_object"
245+
246+-- | Builds a binary JSON object out of a text array.
247+-- The array must have two dimensions
248+-- such that each inner array has exactly two elements,
249+-- which are taken as a key/value pair.
250+jsonbObject
251+ :: null ('PGfixarray '[n,2] ('NotNull 'PGtext))
252+ --> null 'PGjsonb
253+jsonbObject = unsafeFunction "jsonb_object"
254+
255+-- | This is an alternate form of 'jsonObject' that takes two arrays; one for
256+-- keys and one for values, that are zipped pairwise to create a JSON object.
257+jsonZipObject ::
258+ '[ null ('PGvararray ('NotNull 'PGtext))
259+ , null ('PGvararray ('NotNull 'PGtext)) ]
260+ ---> null 'PGjson
261+jsonZipObject = unsafeFunctionN "json_object"
262+
263+-- | This is an alternate form of 'jsonbObject' that takes two arrays; one for
264+-- keys and one for values, that are zipped pairwise to create a binary JSON
265+-- object.
266+jsonbZipObject ::
267+ '[ null ('PGvararray ('NotNull 'PGtext))
268+ , null ('PGvararray ('NotNull 'PGtext)) ]
269+ ---> null 'PGjsonb
270+jsonbZipObject = unsafeFunctionN "jsonb_object"
271+
272+{-----------------------------------------
273+Table 9.46: JSON processing functions
274+-----------------------------------------}
275+
276+-- | Returns the number of elements in the outermost JSON array.
277+jsonArrayLength :: null 'PGjson --> null 'PGint4
278+jsonArrayLength = unsafeFunction "json_array_length"
279+
280+-- | Returns the number of elements in the outermost binary JSON array.
281+jsonbArrayLength :: null 'PGjsonb --> null 'PGint4
282+jsonbArrayLength = unsafeFunction "jsonb_array_length"
283+
284+-- | Returns the type of the outermost JSON value as a text string. Possible
285+-- types are object, array, string, number, boolean, and null.
286+jsonTypeof :: null 'PGjson --> null 'PGtext
287+jsonTypeof = unsafeFunction "json_typeof"
288+
289+-- | Returns the type of the outermost binary JSON value as a text string.
290+-- Possible types are object, array, string, number, boolean, and null.
291+jsonbTypeof :: null 'PGjsonb --> null 'PGtext
292+jsonbTypeof = unsafeFunction "jsonb_typeof"
293+
294+-- | Returns its argument with all object fields that have null values omitted.
295+-- Other null values are untouched.
296+jsonStripNulls :: null 'PGjson --> null 'PGjson
297+jsonStripNulls = unsafeFunction "json_strip_nulls"
298+
299+-- | Returns its argument with all object fields that have null values omitted.
300+-- Other null values are untouched.
301+jsonbStripNulls :: null 'PGjsonb --> null 'PGjsonb
302+jsonbStripNulls = unsafeFunction "jsonb_strip_nulls"
303+
304+-- | @ jsonbSet target path new_value create_missing @
305+--
306+-- Returns target with the section designated by path replaced by @new_value@,
307+-- or with @new_value@ added if create_missing is
308+-- `Squeal.PostgreSQL.Expression.Logic.true` and the
309+-- item designated by path does not exist. As with the path orientated
310+-- operators, negative integers that appear in path count from the end of JSON
311+-- arrays.
312+jsonbSet ::
313+ '[ null 'PGjsonb, null ('PGvararray ('NotNull 'PGtext))
314+ , null 'PGjsonb, null 'PGbool ] ---> null 'PGjsonb
315+jsonbSet = unsafeFunctionN "jsonbSet"
316+
317+-- | @ jsonbInsert target path new_value insert_after @
318+--
319+-- Returns target with @new_value@ inserted. If target section designated by
320+-- path is in a JSONB array, @new_value@ will be inserted before target or after
321+-- if @insert_after@ is `Squeal.PostgreSQL.Expression.Logic.true`.
322+-- If target section designated by
323+-- path is in JSONB object, @new_value@ will be inserted only if target does not
324+-- exist. As with the path orientated operators, negative integers that appear
325+-- in path count from the end of JSON arrays.
326+jsonbInsert ::
327+ '[ null 'PGjsonb, null ('PGvararray ('NotNull 'PGtext))
328+ , null 'PGjsonb, null 'PGbool ] ---> null 'PGjsonb
329+jsonbInsert = unsafeFunctionN "jsonb_insert"
330+
331+-- | Returns its argument as indented JSON text.
332+jsonbPretty :: null 'PGjsonb --> null 'PGtext
333+jsonbPretty = unsafeFunction "jsonb_pretty"
334+
335+{- | Expands the outermost JSON object into a set of key/value pairs.
336+
337+>>> printSQL (select Star (from (jsonEach (literal (Json (object ["a" .= "foo", "b" .= "bar"]))))))
338+SELECT * FROM json_each(('{"a":"foo","b":"bar"}' :: json))
339+-}
340+jsonEach :: SetFunction "json_each" (null 'PGjson)
341+ '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGjson]
342+jsonEach = unsafeSetFunction
343+
344+{- | Expands the outermost binary JSON object into a set of key/value pairs.
345+
346+>>> printSQL (select Star (from (jsonbEach (literal (Jsonb (object ["a" .= "foo", "b" .= "bar"]))))))
347+SELECT * FROM jsonb_each(('{"a":"foo","b":"bar"}' :: jsonb))
348+-}
349+jsonbEach
350+ :: SetFunction "jsonb_each" (nullity 'PGjsonb)
351+ '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGjson]
352+jsonbEach = unsafeSetFunction
353+
354+{- | Expands the outermost JSON object into a set of key/value pairs.
355+
356+>>> printSQL (select Star (from (jsonEachText (literal (Json (object ["a" .= "foo", "b" .= "bar"]))))))
357+SELECT * FROM json_each_text(('{"a":"foo","b":"bar"}' :: json))
358+-}
359+jsonEachText
360+ :: SetFunction "json_each_text" (null 'PGjson)
361+ '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext]
362+jsonEachText = unsafeSetFunction
363+
364+{- | Expands the outermost binary JSON object into a set of key/value pairs.
365+
366+>>> printSQL (select Star (from (jsonbEachText (literal (Jsonb (object ["a" .= "foo", "b" .= "bar"]))))))
367+SELECT * FROM jsonb_each_text(('{"a":"foo","b":"bar"}' :: jsonb))
368+-}
369+jsonbEachText
370+ :: SetFunction "jsonb_each_text" (null 'PGjsonb)
371+ '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext]
372+jsonbEachText = unsafeSetFunction
373+
374+{- | Returns set of keys in the outermost JSON object.
375+
376+>>> printSQL (jsonObjectKeys (literal (Json (object ["a" .= "foo", "b" .= "bar"]))))
377+json_object_keys(('{"a":"foo","b":"bar"}' :: json))
378+-}
379+jsonObjectKeys
380+ :: SetFunction "json_object_keys" (nullity 'PGjson)
381+ '["json_object_keys" ::: 'NotNull 'PGtext]
382+jsonObjectKeys = unsafeSetFunction
383+
384+{- | Returns set of keys in the outermost JSON object.
385+
386+>>> printSQL (jsonbObjectKeys (literal (Jsonb (object ["a" .= "foo", "b" .= "bar"]))))
387+jsonb_object_keys(('{"a":"foo","b":"bar"}' :: jsonb))
388+-}
389+jsonbObjectKeys
390+ :: SetFunction "jsonb_object_keys" (null 'PGjsonb)
391+ '["jsonb_object_keys" ::: 'NotNull 'PGtext]
392+jsonbObjectKeys = unsafeSetFunction
393+
394+-- | Build rows from Json types.
395+type JsonPopulateFunction fun json
396+ = forall schemas row outer commons params
397+ . json `In` PGJsonType
398+ => TypeExpression schemas ('NotNull ('PGcomposite row)) -- ^ row type
399+ -> Expression outer commons 'Ungrouped schemas params '[] ('NotNull json)
400+ -- ^ json type
401+ -> FromClause outer commons schemas params '[fun ::: row]
402+
403+unsafePopulateFunction
404+ :: forall fun ty
405+ . KnownSymbol fun => Alias fun -> JsonPopulateFunction fun ty
406+unsafePopulateFunction _fun ty expr = UnsafeFromClause $ renderSymbol @fun
407+ <> parenthesized ("null::" <> renderSQL ty <> ", " <> renderSQL expr)
408+
409+-- | Expands the JSON expression to a row whose columns match the record
410+-- type defined by the given table.
411+jsonPopulateRecord :: JsonPopulateFunction "json_populate_record" 'PGjson
412+jsonPopulateRecord = unsafePopulateFunction #json_populate_record
413+
414+-- | Expands the binary JSON expression to a row whose columns match the record
415+-- type defined by the given table.
416+jsonbPopulateRecord :: JsonPopulateFunction "jsonb_populate_record" 'PGjsonb
417+jsonbPopulateRecord = unsafePopulateFunction #jsonb_populate_record
418+
419+-- | Expands the outermost array of objects in the given JSON expression to a
420+-- set of rows whose columns match the record type defined by the given table.
421+jsonPopulateRecordSet :: JsonPopulateFunction "json_populate_record_set" 'PGjson
422+jsonPopulateRecordSet = unsafePopulateFunction #json_populate_record_set
423+
424+-- | Expands the outermost array of objects in the given binary JSON expression
425+-- to a set of rows whose columns match the record type defined by the given
426+-- table.
427+jsonbPopulateRecordSet :: JsonPopulateFunction "jsonb_populate_record_set" 'PGjsonb
428+jsonbPopulateRecordSet = unsafePopulateFunction #jsonb_populate_record_set
429+
430+-- | Build rows from Json types.
431+type JsonToRecordFunction json
432+ = forall outer commons schemas params tab row
433+ . (SOP.SListI row, json `In` PGJsonType)
434+ => Expression outer commons 'Ungrouped schemas params '[] ('NotNull json)
435+ -- ^ json type
436+ -> Aliased (NP (Aliased (TypeExpression schemas))) (tab ::: row)
437+ -- ^ row type
438+ -> FromClause outer commons schemas params '[tab ::: row]
439+
440+unsafeRecordFunction :: ByteString -> JsonToRecordFunction json
441+unsafeRecordFunction fun expr (types `As` tab) = UnsafeFromClause $
442+ fun <> parenthesized (renderSQL expr) <+> "AS" <+> renderSQL tab
443+ <> parenthesized (renderCommaSeparated renderTy types)
444+ where
445+ renderTy :: Aliased (TypeExpression schemas) ty -> ByteString
446+ renderTy (ty `As` alias) = renderSQL alias <+> renderSQL ty
447+
448+-- | Builds an arbitrary record from a JSON object.
449+jsonToRecord :: JsonToRecordFunction 'PGjson
450+jsonToRecord = unsafeRecordFunction "json_to_record"
451+
452+-- | Builds an arbitrary record from a binary JSON object.
453+jsonbToRecord :: JsonToRecordFunction 'PGjsonb
454+jsonbToRecord = unsafeRecordFunction "jsonb_to_record"
455+
456+-- | Builds an arbitrary set of records from a JSON array of objects.
457+jsonToRecordSet :: JsonToRecordFunction 'PGjson
458+jsonToRecordSet = unsafeRecordFunction "json_to_record_set"
459+
460+-- | Builds an arbitrary set of records from a binary JSON array of objects.
461+jsonbToRecordSet :: JsonToRecordFunction 'PGjsonb
462+jsonbToRecordSet = unsafeRecordFunction "jsonb_to_record_set"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Literal.hsnew file+87
@@ -0,0 +1,87 @@
1+{-|
2+Module: Squeal.PostgreSQL.Expression.Literal
3+Description: Literal expressions
4+Copyright: (c) Eitan Chatav, 2019
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Literal expressions
9+-}
10+
11+{-# LANGUAGE
12+ FlexibleContexts
13+ , FlexibleInstances
14+ , LambdaCase
15+ , OverloadedStrings
16+ , RankNTypes
17+ , ScopedTypeVariables
18+ , TypeApplications
19+ , TypeSynonymInstances
20+ , UndecidableInstances
21+#-}
22+
23+module Squeal.PostgreSQL.Expression.Literal (Literal (..)) where
24+
25+import ByteString.StrictBuilder (builderBytes)
26+import Data.ByteString.Lazy (toStrict)
27+import Data.Int
28+import Data.String
29+import Data.Text (Text)
30+
31+import qualified Data.Aeson as JSON
32+import qualified Data.Text as Text
33+import qualified Data.Text.Lazy as Lazy (Text)
34+import qualified Data.Text.Lazy as Lazy.Text
35+
36+import Squeal.PostgreSQL.Binary
37+import Squeal.PostgreSQL.Expression
38+import Squeal.PostgreSQL.Expression.Logic
39+import Squeal.PostgreSQL.PG
40+import Squeal.PostgreSQL.Render
41+
42+{- |
43+The `Literal` class allows embedding a Haskell value directly
44+as an `Expression` using `literal`.
45+
46+>>> printSQL (literal 'a')
47+E'a'
48+
49+>>> printSQL (literal (1 :: Double))
50+1.0
51+
52+>>> printSQL (literal (Json [1 :: Double, 2]))
53+('[1.0,2.0]' :: json)
54+
55+>>> printSQL (literal (Enumerated GT))
56+'GT'
57+-}
58+class Literal hask where literal :: hask -> Expr (null (PG hask))
59+instance Literal Bool where
60+ literal = \case
61+ True -> true
62+ False -> false
63+instance JSON.ToJSON hask => Literal (Json hask) where
64+ literal = UnsafeExpression . parenthesized . (<> " :: json")
65+ . singleQuotedUtf8 . toStrict . JSON.encode . getJson
66+instance JSON.ToJSON hask => Literal (Jsonb hask) where
67+ literal = UnsafeExpression . parenthesized . (<> " :: jsonb")
68+ . singleQuotedUtf8 . toStrict . JSON.encode . getJsonb
69+instance Literal Char where
70+ literal chr = UnsafeExpression $
71+ "E\'" <> fromString (escape chr) <> "\'"
72+instance Literal String where literal = fromString
73+instance Literal Int16 where literal = fromIntegral
74+instance Literal Int32 where literal = fromIntegral
75+instance Literal Int64 where literal = fromIntegral
76+instance Literal Float where literal = fromRational . toRational
77+instance Literal Double where literal = fromRational . toRational
78+instance Literal Text where literal = fromString . Text.unpack
79+instance Literal Lazy.Text where literal = fromString . Lazy.Text.unpack
80+instance ToParam (Enumerated enum) (PG (Enumerated enum))
81+ => Literal (Enumerated enum) where
82+ literal
83+ = UnsafeExpression
84+ . singleQuotedUtf8
85+ . builderBytes
86+ . unK
87+ . toParam @(Enumerated enum) @(PG (Enumerated enum))
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Logic.hsnew file+105
@@ -0,0 +1,105 @@
1+{-|
2+Module: Squeal.PostgreSQL.Expression.Logic
3+Description: Logical expressions
4+Copyright: (c) Eitan Chatav, 2019
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Logical expressions and operators
9+-}
10+
11+{-# LANGUAGE
12+ DataKinds
13+ , OverloadedStrings
14+ , TypeOperators
15+#-}
16+
17+module Squeal.PostgreSQL.Expression.Logic
18+ ( Condition
19+ , true
20+ , false
21+ , not_
22+ , (.&&)
23+ , (.||)
24+ , caseWhenThenElse
25+ , ifThenElse
26+ ) where
27+
28+import Squeal.PostgreSQL.Expression
29+import Squeal.PostgreSQL.Render
30+import Squeal.PostgreSQL.Schema
31+
32+-- | A `Condition` is an `Expression`, which can evaluate
33+-- to `true`, `false` or `Squeal.PostgreSQL.Null.null_`. This is because SQL uses
34+-- a three valued logic.
35+type Condition outer commons grp schemas params from =
36+ Expression outer commons grp schemas params from ('Null 'PGbool)
37+
38+-- | >>> printSQL true
39+-- TRUE
40+true :: Expr (null 'PGbool)
41+true = UnsafeExpression "TRUE"
42+
43+-- | >>> printSQL false
44+-- FALSE
45+false :: Expr (null 'PGbool)
46+false = UnsafeExpression "FALSE"
47+
48+-- | >>> printSQL $ not_ true
49+-- (NOT TRUE)
50+not_ :: null 'PGbool --> null 'PGbool
51+not_ = unsafeLeftOp "NOT"
52+
53+-- | >>> printSQL $ true .&& false
54+-- (TRUE AND FALSE)
55+(.&&) :: Operator (null 'PGbool) (null 'PGbool) (null 'PGbool)
56+infixr 3 .&&
57+(.&&) = unsafeBinaryOp "AND"
58+
59+-- | >>> printSQL $ true .|| false
60+-- (TRUE OR FALSE)
61+(.||) :: Operator (null 'PGbool) (null 'PGbool) (null 'PGbool)
62+infixr 2 .||
63+(.||) = unsafeBinaryOp "OR"
64+
65+-- | >>> :{
66+-- let
67+-- expression :: Expression outer commons grp schemas params from (null 'PGint2)
68+-- expression = caseWhenThenElse [(true, 1), (false, 2)] 3
69+-- in printSQL expression
70+-- :}
71+-- CASE WHEN TRUE THEN 1 WHEN FALSE THEN 2 ELSE 3 END
72+caseWhenThenElse
73+ :: [ ( Condition outer commons grp schemas params from
74+ , Expression outer commons grp schemas params from ty
75+ ) ]
76+ -- ^ whens and thens
77+ -> Expression outer commons grp schemas params from ty
78+ -- ^ else
79+ -> Expression outer commons grp schemas params from ty
80+caseWhenThenElse whenThens else_ = UnsafeExpression $ mconcat
81+ [ "CASE"
82+ , mconcat
83+ [ mconcat
84+ [ " WHEN ", renderSQL when_
85+ , " THEN ", renderSQL then_
86+ ]
87+ | (when_,then_) <- whenThens
88+ ]
89+ , " ELSE ", renderSQL else_
90+ , " END"
91+ ]
92+
93+-- | >>> :{
94+-- let
95+-- expression :: Expression outer commons grp schemas params from (null 'PGint2)
96+-- expression = ifThenElse true 1 0
97+-- in printSQL expression
98+-- :}
99+-- CASE WHEN TRUE THEN 1 ELSE 0 END
100+ifThenElse
101+ :: Condition outer commons grp schemas params from
102+ -> Expression outer commons grp schemas params from ty -- ^ then
103+ -> Expression outer commons grp schemas params from ty -- ^ else
104+ -> Expression outer commons grp schemas params from ty
105+ifThenElse if_ then_ else_ = caseWhenThenElse [(if_,then_)] else_
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Math.hsnew file+100
@@ -0,0 +1,100 @@
1+{-|
2+Module: Squeal.PostgreSQL.Expression.Math
3+Description: Math expressions
4+Copyright: (c) Eitan Chatav, 2019
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Mathematical functions and operators
9+-}
10+
11+{-# LANGUAGE
12+ DataKinds
13+ , OverloadedStrings
14+ , TypeOperators
15+#-}
16+
17+module Squeal.PostgreSQL.Expression.Math
18+ ( atan2_
19+ , quot_
20+ , rem_
21+ , trunc
22+ , round_
23+ , ceiling_
24+ ) where
25+
26+import Squeal.PostgreSQL.Expression
27+import Squeal.PostgreSQL.List
28+import Squeal.PostgreSQL.Schema
29+
30+-- $setup
31+-- >>> import Squeal.PostgreSQL
32+
33+-- | >>> :{
34+-- let
35+-- expression :: Expr (null 'PGfloat4)
36+-- expression = atan2_ (pi *: 2)
37+-- in printSQL expression
38+-- :}
39+-- atan2(pi(), 2)
40+atan2_ :: float `In` PGFloating => '[ null float, null float] ---> null float
41+atan2_ = unsafeFunctionN "atan2"
42+
43+
44+-- | integer division, truncates the result
45+--
46+-- >>> :{
47+-- let
48+-- expression :: Expression outer commons grp schemas params from (null 'PGint2)
49+-- expression = 5 `quot_` 2
50+-- in printSQL expression
51+-- :}
52+-- (5 / 2)
53+quot_
54+ :: int `In` PGIntegral
55+ => Operator (null int) (null int) (null int)
56+quot_ = unsafeBinaryOp "/"
57+
58+-- | remainder upon integer division
59+--
60+-- >>> :{
61+-- let
62+-- expression :: Expression outer commons grp schemas params from (null 'PGint2)
63+-- expression = 5 `rem_` 2
64+-- in printSQL expression
65+-- :}
66+-- (5 % 2)
67+rem_
68+ :: int `In` PGIntegral
69+ => Operator (null int) (null int) (null int)
70+rem_ = unsafeBinaryOp "%"
71+
72+-- | >>> :{
73+-- let
74+-- expression :: Expression outer commons grp schemas params from (null 'PGfloat4)
75+-- expression = trunc pi
76+-- in printSQL expression
77+-- :}
78+-- trunc(pi())
79+trunc :: frac `In` PGFloating => null frac --> null frac
80+trunc = unsafeFunction "trunc"
81+
82+-- | >>> :{
83+-- let
84+-- expression :: Expression outer commons grp schemas params from (null 'PGfloat4)
85+-- expression = round_ pi
86+-- in printSQL expression
87+-- :}
88+-- round(pi())
89+round_ :: frac `In` PGFloating => null frac --> null frac
90+round_ = unsafeFunction "round"
91+
92+-- | >>> :{
93+-- let
94+-- expression :: Expression outer commons grp schemas params from (null 'PGfloat4)
95+-- expression = ceiling_ pi
96+-- in printSQL expression
97+-- :}
98+-- ceiling(pi())
99+ceiling_ :: frac `In` PGFloating => null frac --> null frac
100+ceiling_ = unsafeFunction "ceiling"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Null.hsnew file+104
@@ -0,0 +1,104 @@
1+{-|
2+Module: Squeal.PostgreSQL.Expression.Null
3+Description: Null
4+Copyright: (c) Eitan Chatav, 2019
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Null values and null handling functions
9+-}
10+
11+{-# LANGUAGE
12+ DataKinds
13+ , OverloadedStrings
14+ , TypeOperators
15+#-}
16+
17+module Squeal.PostgreSQL.Expression.Null
18+ ( null_
19+ , notNull
20+ , coalesce
21+ , fromNull
22+ , isNull
23+ , isNotNull
24+ , matchNull
25+ , nullIf
26+ ) where
27+
28+import Squeal.PostgreSQL.Expression
29+import Squeal.PostgreSQL.Expression.Logic
30+import Squeal.PostgreSQL.Render
31+import Squeal.PostgreSQL.Schema
32+
33+-- $setup
34+-- >>> import Squeal.PostgreSQL
35+
36+-- | analagous to `Nothing`
37+--
38+-- >>> printSQL null_
39+-- NULL
40+null_ :: Expr ('Null ty)
41+null_ = UnsafeExpression "NULL"
42+
43+-- | analagous to `Just`
44+--
45+-- >>> printSQL $ notNull true
46+-- TRUE
47+notNull :: 'NotNull ty --> 'Null ty
48+notNull = UnsafeExpression . renderSQL
49+
50+-- | return the leftmost value which is not NULL
51+--
52+-- >>> printSQL $ coalesce [null_, true] false
53+-- COALESCE(NULL, TRUE, FALSE)
54+coalesce :: FunctionVar ('Null ty) ('NotNull ty) ('NotNull ty)
55+coalesce nullxs notNullx = UnsafeExpression $
56+ "COALESCE" <> parenthesized (commaSeparated
57+ ((renderSQL <$> nullxs) <> [renderSQL notNullx]))
58+
59+-- | analagous to `Data.Maybe.fromMaybe` using @COALESCE@
60+--
61+-- >>> printSQL $ fromNull true null_
62+-- COALESCE(NULL, TRUE)
63+fromNull
64+ :: Expression outer commons grp schemas params from ('NotNull ty)
65+ -- ^ what to convert @NULL@ to
66+ -> Expression outer commons grp schemas params from ('Null ty)
67+ -> Expression outer commons grp schemas params from ('NotNull ty)
68+fromNull notNullx nullx = coalesce [nullx] notNullx
69+
70+-- | >>> printSQL $ null_ & isNull
71+-- NULL IS NULL
72+isNull :: 'Null ty --> null 'PGbool
73+isNull x = UnsafeExpression $ renderSQL x <+> "IS NULL"
74+
75+-- | >>> printSQL $ null_ & isNotNull
76+-- NULL IS NOT NULL
77+isNotNull :: 'Null ty --> null 'PGbool
78+isNotNull x = UnsafeExpression $ renderSQL x <+> "IS NOT NULL"
79+
80+-- | analagous to `maybe` using @IS NULL@
81+--
82+-- >>> printSQL $ matchNull true not_ null_
83+-- CASE WHEN NULL IS NULL THEN TRUE ELSE (NOT NULL) END
84+matchNull
85+ :: Expression outer commons grp schemas params from (nullty)
86+ -- ^ what to convert @NULL@ to
87+ -> ( Expression outer commons grp schemas params from ('NotNull ty)
88+ -> Expression outer commons grp schemas params from (nullty) )
89+ -- ^ function to perform when @NULL@ is absent
90+ -> Expression outer commons grp schemas params from ('Null ty)
91+ -> Expression outer commons grp schemas params from (nullty)
92+matchNull y f x = ifThenElse (isNull x) y
93+ (f (UnsafeExpression (renderSQL x)))
94+
95+{-| right inverse to `fromNull`, if its arguments are equal then
96+`nullIf` gives @NULL@.
97+
98+>>> :set -XTypeApplications -XDataKinds
99+>>> let expr = nullIf (false *: param @1) :: Expression outer commons grp schemas '[ 'NotNull 'PGbool] from ('Null 'PGbool)
100+>>> printSQL expr
101+NULLIF(FALSE, ($1 :: bool))
102+-}
103+nullIf :: '[ 'NotNull ty, 'NotNull ty] ---> 'Null ty
104+nullIf = unsafeFunctionN "NULLIF"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Parameter.hsnew file+80
@@ -0,0 +1,80 @@
1+{-|
2+Module: Squeal.PostgreSQL.Expression.Parameter
3+Description: Parameters
4+Copyright: (c) Eitan Chatav, 2019
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Parameters, out-of-line data values
9+-}
10+
11+{-# LANGUAGE
12+ AllowAmbiguousTypes
13+ , DataKinds
14+ , FlexibleContexts
15+ , FlexibleInstances
16+ , FunctionalDependencies
17+ , KindSignatures
18+ , MultiParamTypeClasses
19+ , OverloadedStrings
20+ , RankNTypes
21+ , ScopedTypeVariables
22+ , TypeApplications
23+ , TypeOperators
24+ , UndecidableInstances
25+#-}
26+
27+module Squeal.PostgreSQL.Expression.Parameter
28+ ( HasParameter (parameter)
29+ , param
30+ ) where
31+
32+import GHC.TypeLits
33+
34+import Squeal.PostgreSQL.Expression
35+import Squeal.PostgreSQL.Expression.Type
36+import Squeal.PostgreSQL.Render
37+import Squeal.PostgreSQL.Schema
38+
39+-- $setup
40+-- >>> import Squeal.PostgreSQL
41+
42+{- | A `HasParameter` constraint is used to indicate a value that is
43+supplied externally to a SQL statement.
44+`Squeal.PostgreSQL.PQ.manipulateParams`,
45+`Squeal.PostgreSQL.PQ.queryParams` and
46+`Squeal.PostgreSQL.PQ.traversePrepared` support specifying data values
47+separately from the SQL command string, in which case `param`s are used to
48+refer to the out-of-line data values.
49+-}
50+class KnownNat n => HasParameter
51+ (n :: Nat)
52+ (params :: [NullityType])
53+ (ty :: NullityType)
54+ | n params -> ty where
55+ -- | `parameter` takes a `Nat` using type application and a `TypeExpression`.
56+ --
57+ -- >>> let expr = parameter @1 int4 :: Expression outer '[] grp schemas '[ 'Null 'PGint4] from ('Null 'PGint4)
58+ -- >>> printSQL expr
59+ -- ($1 :: int4)
60+ parameter
61+ :: TypeExpression schemas ty
62+ -> Expression outer commons grp schemas params from ty
63+ parameter ty = UnsafeExpression $ parenthesized $
64+ "$" <> renderNat @n <+> "::"
65+ <+> renderSQL ty
66+instance {-# OVERLAPPING #-} HasParameter 1 (ty1:tys) ty1
67+instance {-# OVERLAPPABLE #-} (KnownNat n, HasParameter (n-1) params ty)
68+ => HasParameter n (ty' : params) ty
69+
70+-- | `param` takes a `Nat` using type application and for basic types,
71+-- infers a `TypeExpression`.
72+--
73+-- >>> let expr = param @1 :: Expression outer commons grp schemas '[ 'Null 'PGint4] from ('Null 'PGint4)
74+-- >>> printSQL expr
75+-- ($1 :: int4)
76+param
77+ :: forall n outer commons schemas params from grp ty
78+ . (PGTyped schemas ty, HasParameter n params ty)
79+ => Expression outer commons grp schemas params from ty -- ^ param
80+param = parameter @n (pgtype @schemas)
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Range.hsnew file+230
@@ -0,0 +1,230 @@
1+{-|
2+Module: Squeal.PostgreSQL.Expression.Range
3+Description: range types and functions
4+Copyright: (c) Eitan Chatav, 2019
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Range types and functions
9+-}
10+
11+{-# LANGUAGE
12+ AllowAmbiguousTypes
13+ , DataKinds
14+ , DeriveAnyClass
15+ , DeriveGeneric
16+ , DeriveFoldable
17+ , DerivingStrategies
18+ , DeriveTraversable
19+ , FlexibleContexts
20+ , FlexibleInstances
21+ , LambdaCase
22+ , MultiParamTypeClasses
23+ , OverloadedLabels
24+ , OverloadedStrings
25+ , PatternSynonyms
26+ , RankNTypes
27+ , ScopedTypeVariables
28+ , TypeApplications
29+ , TypeFamilies
30+ , TypeOperators
31+ , UndecidableInstances
32+#-}
33+
34+module Squeal.PostgreSQL.Expression.Range
35+ ( range
36+ , Range (..)
37+ , (<=..<=), (<..<), (<=..<), (<..<=)
38+ , moreThan, atLeast, lessThan, atMost
39+ , singleton, whole
40+ , Bound (..)
41+ , (.<@)
42+ , (@>.)
43+ , (<<@)
44+ , (@>>)
45+ , (&<)
46+ , (&>)
47+ , (-|-)
48+ , (@+)
49+ , (@*)
50+ , (@-)
51+ , lowerBound
52+ , upperBound
53+ , isEmpty
54+ , lowerInc
55+ , lowerInf
56+ , upperInc
57+ , upperInf
58+ , rangeMerge
59+ ) where
60+
61+import BinaryParser
62+import ByteString.StrictBuilder
63+import Data.Bits
64+import qualified GHC.Generics as GHC
65+import qualified Generics.SOP as SOP
66+import qualified PostgreSQL.Binary.Decoding as Decoding
67+
68+import Squeal.PostgreSQL.Binary
69+import Squeal.PostgreSQL.Expression
70+import Squeal.PostgreSQL.Expression.Type hiding (bool)
71+import Squeal.PostgreSQL.PG
72+import Squeal.PostgreSQL.Render
73+import Squeal.PostgreSQL.Schema
74+
75+-- $setup
76+-- >>> import Squeal.PostgreSQL
77+
78+-- | Construct a `range`
79+--
80+-- >>> printSQL $ range tstzrange (atLeast now)
81+-- tstzrange(now(), NULL, '[)')
82+-- >>> printSQL $ range numrange (0 <=..< 2*pi)
83+-- numrange(0, (2 * pi()), '[)')
84+-- >>> printSQL $ range int4range Empty
85+-- ('empty' :: int4range)
86+range
87+ :: TypeExpression schemas (null ('PGrange ty))
88+ -> Range (Expression outer commons grp schemas params from ('NotNull ty))
89+ -> Expression outer commons grp schemas params from (null ('PGrange ty))
90+range ty = \case
91+ Empty -> UnsafeExpression $ parenthesized
92+ (emp <+> "::" <+> renderSQL ty)
93+ NonEmpty l u -> UnsafeExpression $ renderSQL ty <> parenthesized
94+ (commaSeparated (args l u))
95+ where
96+ emp = singleQuote <> "empty" <> singleQuote
97+ args l u = [arg l, arg u, singleQuote <> bra l <> ket u <> singleQuote]
98+ singleQuote = "\'"
99+ arg = \case
100+ Infinite -> "NULL"; Closed x -> renderSQL x; Open x -> renderSQL x
101+ bra = \case Infinite -> "("; Closed _ -> "["; Open _ -> "("
102+ ket = \case Infinite -> ")"; Closed _ -> "]"; Open _ -> ")"
103+
104+data Bound x = Infinite | Closed x | Open x
105+ deriving
106+ ( Eq, Ord, Show, Read, GHC.Generic
107+ , Functor, Foldable, Traversable )
108+
109+data Range x = Empty | NonEmpty (Bound x) (Bound x)
110+ deriving
111+ ( Eq, Ord, Show, Read, GHC.Generic
112+ , Functor, Foldable, Traversable )
113+ deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
114+type instance PG (Range x) = 'PGrange (PG x)
115+instance ToParam x pg => ToParam (Range x) ('PGrange pg) where
116+ toParam rng = K $
117+ word8 (setFlags rng 0) <>
118+ case rng of
119+ Empty -> mempty
120+ NonEmpty lower upper -> putBound lower <> putBound upper
121+ where
122+ putBound = \case
123+ Infinite -> mempty
124+ Closed value -> putValue (unK (toParam @x @pg value))
125+ Open value -> putValue (unK (toParam @x @pg value))
126+ putValue value = int32BE (fromIntegral (builderLength value)) <> value
127+ setFlags = \case
128+ Empty -> (`setBit` 0)
129+ NonEmpty lower upper ->
130+ setLowerFlags lower . setUpperFlags upper
131+ setLowerFlags = \case
132+ Infinite -> (`setBit` 3)
133+ Closed _ -> (`setBit` 1)
134+ Open _ -> id
135+ setUpperFlags = \case
136+ Infinite -> (`setBit` 4)
137+ Closed _ -> (`setBit` 2)
138+ Open _ -> id
139+instance FromValue pg y => FromValue ('PGrange pg) (Range y) where
140+ fromValue = do
141+ flag <- byte
142+ if testBit flag 0 then return Empty else do
143+ lower <-
144+ if testBit flag 3
145+ then return Infinite
146+ else do
147+ len <- sized 4 Decoding.int
148+ l <- sized len (fromValue @pg)
149+ return $ if testBit flag 1 then Closed l else Open l
150+ upper <-
151+ if testBit flag 4
152+ then return Infinite
153+ else do
154+ len <- sized 4 Decoding.int
155+ l <- sized len (fromValue @pg)
156+ return $ if testBit flag 2 then Closed l else Open l
157+ return $ NonEmpty lower upper
158+
159+(<=..<=), (<..<), (<=..<), (<..<=) :: x -> x -> Range x
160+infix 4 <=..<=, <..<, <=..<, <..<=
161+x <=..<= y = NonEmpty (Closed x) (Closed y)
162+x <..< y = NonEmpty (Open x) (Open y)
163+x <=..< y = NonEmpty (Closed x) (Open y)
164+x <..<= y = NonEmpty (Open x) (Closed y)
165+
166+moreThan, atLeast, lessThan, atMost :: x -> Range x
167+moreThan x = NonEmpty (Open x) Infinite
168+atLeast x = NonEmpty (Closed x) Infinite
169+lessThan x = NonEmpty Infinite (Open x)
170+atMost x = NonEmpty Infinite (Closed x)
171+
172+singleton :: x -> Range x
173+singleton x = x <=..<= x
174+
175+whole :: Range x
176+whole = NonEmpty Infinite Infinite
177+
178+(.<@) :: Operator ('NotNull ty) (null ('PGrange ty)) ('Null 'PGbool)
179+(.<@) = unsafeBinaryOp "<@"
180+
181+(@>.) :: Operator (null ('PGrange ty)) ('NotNull ty) ('Null 'PGbool)
182+(@>.) = unsafeBinaryOp "<@"
183+
184+(<<@) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)
185+(<<@) = unsafeBinaryOp "<<"
186+
187+(@>>) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)
188+(@>>) = unsafeBinaryOp ">>"
189+
190+(&<) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)
191+(&<) = unsafeBinaryOp "&<"
192+
193+(&>) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)
194+(&>) = unsafeBinaryOp "&>"
195+
196+(-|-) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)
197+(-|-) = unsafeBinaryOp "-|-"
198+
199+(@+) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) (null ('PGrange ty))
200+(@+) = unsafeBinaryOp "+"
201+
202+(@*) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) (null ('PGrange ty))
203+(@*) = unsafeBinaryOp "*"
204+
205+(@-) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) (null ('PGrange ty))
206+(@-) = unsafeBinaryOp "-"
207+
208+lowerBound :: null ('PGrange ty) --> 'Null ty
209+lowerBound = unsafeFunction "lower"
210+
211+upperBound :: null ('PGrange ty) --> 'Null ty
212+upperBound = unsafeFunction "upper"
213+
214+isEmpty :: null ('PGrange ty) --> 'Null 'PGbool
215+isEmpty = unsafeFunction "isempty"
216+
217+lowerInc :: null ('PGrange ty) --> 'Null 'PGbool
218+lowerInc = unsafeFunction "lower_inc"
219+
220+lowerInf :: null ('PGrange ty) --> 'Null 'PGbool
221+lowerInf = unsafeFunction "lower_inf"
222+
223+upperInc :: null ('PGrange ty) --> 'Null 'PGbool
224+upperInc = unsafeFunction "upper_inc"
225+
226+upperInf :: null ('PGrange ty) --> 'Null 'PGbool
227+upperInf = unsafeFunction "upper_inf"
228+
229+rangeMerge :: '[null ('PGrange ty), null ('PGrange ty)] ---> null ('PGrange ty)
230+rangeMerge = unsafeFunctionN "range_merge"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Set.hsnew file+139
@@ -0,0 +1,139 @@
1+{-|
2+Module: Squeal.PostgreSQL.Expression.Set
3+Description: Set returning functions
4+Copyright: (c) Eitan Chatav, 2019
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Set returning functions
9+-}
10+
11+{-# LANGUAGE
12+ AllowAmbiguousTypes
13+ , DataKinds
14+ , FlexibleContexts
15+ , OverloadedStrings
16+ , PolyKinds
17+ , RankNTypes
18+ , ScopedTypeVariables
19+ , TypeApplications
20+ , TypeOperators
21+#-}
22+
23+module Squeal.PostgreSQL.Expression.Set
24+ ( generateSeries
25+ , generateSeriesStep
26+ , generateSeriesTimestamp
27+ , SetFunction
28+ , unsafeSetFunction
29+ , SetFunctionDB
30+ , setFunction
31+ , SetFunctionN
32+ , unsafeSetFunctionN
33+ , SetFunctionNDB
34+ , setFunctionN
35+ ) where
36+
37+import GHC.TypeLits
38+
39+import qualified Generics.SOP as SOP
40+
41+import Squeal.PostgreSQL.Alias
42+import Squeal.PostgreSQL.Expression
43+import Squeal.PostgreSQL.List
44+import Squeal.PostgreSQL.Render
45+import Squeal.PostgreSQL.Query
46+import Squeal.PostgreSQL.Schema
47+
48+{- |
49+A @RankNType@ for set returning functions with 1 argument.
50+-}
51+type SetFunction fun ty row
52+ = forall outer commons schemas params
53+ . Expression outer commons 'Ungrouped schemas params '[] ty
54+ -- ^ input
55+ -> FromClause outer commons schemas params '[fun ::: row]
56+ -- ^ output
57+
58+type SetFunctionDB fun schemas ty row
59+ = forall outer commons params
60+ . Expression outer commons 'Ungrouped schemas params '[] ty
61+ -- ^ input
62+ -> FromClause outer commons schemas params '[fun ::: row]
63+ -- ^ output
64+
65+-- | Escape hatch for a set returning function with 1 argument.
66+unsafeSetFunction
67+ :: forall fun ty row. KnownSymbol fun
68+ => SetFunction fun ty row -- ^ set returning function
69+unsafeSetFunction x = UnsafeFromClause $
70+ renderSymbol @fun <> parenthesized (renderSQL x)
71+
72+setFunction
73+ :: ( Has sch schemas schema
74+ , Has fun schema ('Function ('[ty] :=> 'ReturnsTable row)) )
75+ => QualifiedAlias sch fun
76+ -> SetFunctionDB fun schemas ty row
77+setFunction _ = unsafeSetFunction
78+
79+{- |
80+A @RankNType@ for set returning functions with multiple argument.
81+-}
82+type SetFunctionN fun tys row
83+ = forall outer commons schemas params
84+ . NP (Expression outer commons 'Ungrouped schemas params '[]) tys
85+ -- ^ inputs
86+ -> FromClause outer commons schemas params '[fun ::: row]
87+ -- ^ output
88+
89+-- | Escape hatch for a set returning function with multiple argument.
90+unsafeSetFunctionN
91+ :: forall fun tys row. (SOP.SListI tys, KnownSymbol fun)
92+ => SetFunctionN fun tys row -- ^ set returning function
93+unsafeSetFunctionN xs = UnsafeFromClause $
94+ renderSymbol @fun <> parenthesized (renderCommaSeparated renderSQL xs)
95+
96+type SetFunctionNDB fun schemas tys row
97+ = forall outer commons params
98+ . NP (Expression outer commons 'Ungrouped schemas params '[]) tys
99+ -- ^ inputs
100+ -> FromClause outer commons schemas params '[fun ::: row]
101+ -- ^ output
102+
103+setFunctionN
104+ :: ( Has sch schemas schema
105+ , Has fun schema ('Function (tys :=> 'ReturnsTable row))
106+ , SOP.SListI tys )
107+ => QualifiedAlias sch fun
108+ -> SetFunctionNDB fun schemas tys row
109+setFunctionN _ = unsafeSetFunctionN
110+
111+{- | @generateSeries (start *: stop)@
112+
113+Generate a series of values, from @start@ to @stop@ with a step size of one
114+-}
115+generateSeries
116+ :: ty `In` '[ 'PGint4, 'PGint8, 'PGnumeric]
117+ => SetFunctionN "generate_series" '[ null ty, null ty]
118+ '["generate_series" ::: null ty] -- ^ set returning function
119+generateSeries = unsafeSetFunctionN
120+
121+{- | @generateSeries (start :* stop *: step)@
122+
123+Generate a series of values, from @start@ to @stop@ with a step size of @step@
124+-}
125+generateSeriesStep
126+ :: ty `In` '[ 'PGint4, 'PGint8, 'PGnumeric]
127+ => SetFunctionN "generate_series" '[null ty, null ty, null ty]
128+ '["generate_series" ::: null ty] -- ^ set returning function
129+generateSeriesStep = unsafeSetFunctionN
130+
131+{- | @generateSeries (start :* stop *: step)@
132+
133+Generate a series of values, from @start@ to @stop@ with a step size of @step@
134+-}
135+generateSeriesTimestamp
136+ :: ty `In` '[ 'PGtimestamp, 'PGtimestamptz]
137+ => SetFunctionN "generate_series" '[null ty, null ty, null 'PGinterval]
138+ '["generate_series" ::: null ty] -- ^ set returning function
139+generateSeriesTimestamp = unsafeSetFunctionN
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Sort.hsnew file+85
@@ -0,0 +1,85 @@
1+{-|
2+Module: Squeal.PostgreSQL.Expression.Sort
3+Description: Sort expressions
4+Copyright: (c) Eitan Chatav, 2019
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Sort expressions
9+-}
10+
11+{-# LANGUAGE
12+ DataKinds
13+ , GADTs
14+ , LambdaCase
15+ , OverloadedStrings
16+ , StandaloneDeriving
17+#-}
18+
19+module Squeal.PostgreSQL.Expression.Sort
20+ ( SortExpression (..)
21+ , OrderBy (..)
22+ ) where
23+
24+import Squeal.PostgreSQL.Expression
25+import Squeal.PostgreSQL.Render
26+import Squeal.PostgreSQL.Schema
27+
28+-- | `SortExpression`s are used by `orderBy` to optionally sort the results
29+-- of a `Squeal.PostgreSQL.Query.Query`. `Asc` or `Desc`
30+-- set the sort direction of a `NotNull` result
31+-- column to ascending or descending. Ascending order puts smaller values
32+-- first, where "smaller" is defined in terms of the
33+-- `Squeal.PostgreSQL.Expression.Comparison..<` operator. Similarly,
34+-- descending order is determined with the
35+-- `Squeal.PostgreSQL.Expression.Comparison..>` operator. `AscNullsFirst`,
36+-- `AscNullsLast`, `DescNullsFirst` and `DescNullsLast` options are used to
37+-- determine whether nulls appear before or after non-null values in the sort
38+-- ordering of a `Null` result column.
39+data SortExpression outer commons grp schemas params from where
40+ Asc
41+ :: Expression outer commons grp schemas params from ('NotNull ty)
42+ -> SortExpression outer commons grp schemas params from
43+ Desc
44+ :: Expression outer commons grp schemas params from ('NotNull ty)
45+ -> SortExpression outer commons grp schemas params from
46+ AscNullsFirst
47+ :: Expression outer commons grp schemas params from ('Null ty)
48+ -> SortExpression outer commons grp schemas params from
49+ AscNullsLast
50+ :: Expression outer commons grp schemas params from ('Null ty)
51+ -> SortExpression outer commons grp schemas params from
52+ DescNullsFirst
53+ :: Expression outer commons grp schemas params from ('Null ty)
54+ -> SortExpression outer commons grp schemas params from
55+ DescNullsLast
56+ :: Expression outer commons grp schemas params from ('Null ty)
57+ -> SortExpression outer commons grp schemas params from
58+deriving instance Show (SortExpression outer commons grp schemas params from)
59+instance RenderSQL (SortExpression outer commons grp schemas params from) where
60+ renderSQL = \case
61+ Asc expression -> renderSQL expression <+> "ASC"
62+ Desc expression -> renderSQL expression <+> "DESC"
63+ AscNullsFirst expression -> renderSQL expression
64+ <+> "ASC NULLS FIRST"
65+ DescNullsFirst expression -> renderSQL expression
66+ <+> "DESC NULLS FIRST"
67+ AscNullsLast expression -> renderSQL expression <+> "ASC NULLS LAST"
68+ DescNullsLast expression -> renderSQL expression <+> "DESC NULLS LAST"
69+
70+{- |
71+The `orderBy` clause causes the result rows of a `Squeal.PostgreSQL.Query.TableExpression`
72+to be sorted according to the specified `SortExpression`(s).
73+If two rows are equal according to the leftmost expression,
74+they are compared according to the next expression and so on.
75+If they are equal according to all specified expressions,
76+they are returned in an implementation-dependent order.
77+
78+You can also control the order in which rows are processed by window functions
79+using `orderBy` within `Squeal.PostgreSQL.Query.Over`.
80+-}
81+class OrderBy expr where
82+ orderBy
83+ :: [SortExpression outer commons grp schemas params from]
84+ -> expr outer commons grp schemas params from
85+ -> expr outer commons grp schemas params from
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Subquery.hsnew file+120
@@ -0,0 +1,120 @@
1+{-|
2+Module: Squeal.PostgreSQL.Expression.Subquery
3+Description: Subquery expressions
4+Copyright: (c) Eitan Chatav, 2019
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Subquery expressions
9+-}
10+
11+{-# LANGUAGE
12+ DataKinds
13+ , OverloadedStrings
14+ , RankNTypes
15+ , TypeOperators
16+#-}
17+
18+module Squeal.PostgreSQL.Expression.Subquery
19+ ( exists
20+ , in_
21+ , notIn
22+ , subAll
23+ , subAny
24+ ) where
25+
26+import Squeal.PostgreSQL.Alias
27+import Squeal.PostgreSQL.Expression
28+import Squeal.PostgreSQL.Expression.Logic
29+import Squeal.PostgreSQL.List
30+import Squeal.PostgreSQL.Query
31+import Squeal.PostgreSQL.Render
32+import Squeal.PostgreSQL.Schema
33+
34+-- $setup
35+-- >>> import Squeal.PostgreSQL
36+
37+{- |
38+The argument of `exists` is an arbitrary subquery. The subquery is evaluated
39+to determine whether it returns any rows. If it returns at least one row,
40+the result of `exists` is `true`; if the subquery returns no rows,
41+the result of `exists` is `false`.
42+
43+The subquery can refer to variables from the surrounding query,
44+which will act as constants during any one evaluation of the subquery.
45+
46+The subquery will generally only be executed long enough to determine whether
47+at least one row is returned, not all the way to completion.
48+-}
49+exists
50+ :: Query (Join outer from) commons schemas params row
51+ -> Condition outer commons grp schemas params from
52+exists query = UnsafeExpression $ "EXISTS" <+> parenthesized (renderSQL query)
53+
54+{- |
55+The right-hand side is a parenthesized subquery, which must return
56+exactly one column. The left-hand expression is evaluated and compared to each
57+row of the subquery result using the given `Operator`,
58+which must yield a Boolean result. The result of `subAll` is `true`
59+if all rows yield true (including the case where the subquery returns no rows).
60+The result is `false` if any `false` result is found.
61+The result is `Squeal.PostgreSQL.Expression.Null.null_` if
62+ no comparison with a subquery row returns `false`,
63+and at least one comparison returns `Squeal.PostgreSQL.Expression.Null.null_`.
64+
65+>>> printSQL $ subAll true (.==) (values_ (true `as` #foo))
66+(TRUE = ALL (SELECT * FROM (VALUES (TRUE)) AS t ("foo")))
67+-}
68+subAll
69+ :: Expression outer commons grp schemas params from ty1 -- ^ expression
70+ -> Operator ty1 ty2 ('Null 'PGbool) -- ^ operator
71+ -> Query (Join outer from) commons schemas params '[col ::: ty2] -- ^ subquery
72+ -> Condition outer commons grp schemas params from
73+subAll expr (?) qry = expr ?
74+ (UnsafeExpression $ "ALL" <+> parenthesized (renderSQL qry))
75+
76+{- |
77+The right-hand side is a parenthesized subquery, which must return exactly one column.
78+The left-hand expression is evaluated and compared to each row of the subquery result
79+using the given `Operator`, which must yield a Boolean result. The result of `subAny` is `true`
80+if any `true` result is obtained. The result is `false` if no true result is found
81+(including the case where the subquery returns no rows).
82+
83+>>> printSQL $ subAny "foo" like (values_ ("foobar" `as` #foo))
84+(E'foo' LIKE ANY (SELECT * FROM (VALUES (E'foobar')) AS t ("foo")))
85+-}
86+subAny
87+ :: Expression outer commons grp schemas params from ty1 -- ^ expression
88+ -> Operator ty1 ty2 ('Null 'PGbool) -- ^ operator
89+ -> Query (Join outer from) commons schemas params '[col ::: ty2] -- ^ subquery
90+ -> Condition outer commons grp schemas params from
91+subAny expr (?) qry = expr ?
92+ (UnsafeExpression $ "ANY" <+> parenthesized (renderSQL qry))
93+
94+{- |
95+The result is `true` if the left-hand expression's result is equal
96+to any of the right-hand expressions.
97+
98+>>> printSQL $ true `in_` [true, false, null_]
99+TRUE IN (TRUE, FALSE, NULL)
100+-}
101+in_
102+ :: Expression outer commons grp schemas params from ty -- ^ expression
103+ -> [Expression outer commons grp schemas params from ty]
104+ -> Condition outer commons grp schemas params from
105+expr `in_` exprs = UnsafeExpression $ renderSQL expr <+> "IN"
106+ <+> parenthesized (commaSeparated (renderSQL <$> exprs))
107+
108+{- |
109+The result is `true` if the left-hand expression's result is not equal
110+to any of the right-hand expressions.
111+
112+>>> printSQL $ true `notIn` [false, null_]
113+TRUE NOT IN (FALSE, NULL)
114+-}
115+notIn
116+ :: Expression outer commons grp schemas params from ty -- ^ expression
117+ -> [Expression outer commons grp schemas params from ty]
118+ -> Condition outer commons grp schemas params from
119+expr `notIn` exprs = UnsafeExpression $ renderSQL expr <+> "NOT IN"
120+ <+> parenthesized (commaSeparated (renderSQL <$> exprs))
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Text.hsnew file+64
@@ -0,0 +1,64 @@
1+{-|
2+Module: Squeal.PostgreSQL.Expression.Text
3+Description: Text expressions
4+Copyright: (c) Eitan Chatav, 2019
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+String functions and operators
9+-}
10+
11+{-# LANGUAGE
12+ DataKinds
13+ , OverloadedStrings
14+ , TypeOperators
15+#-}
16+
17+module Squeal.PostgreSQL.Expression.Text
18+ ( lower
19+ , upper
20+ , charLength
21+ , like
22+ , ilike
23+ ) where
24+
25+import Squeal.PostgreSQL.Expression
26+import Squeal.PostgreSQL.Schema
27+
28+-- $setup
29+-- >>> import Squeal.PostgreSQL
30+
31+-- | >>> printSQL $ lower "ARRRGGG"
32+-- lower(E'ARRRGGG')
33+lower :: null 'PGtext --> null 'PGtext
34+lower = unsafeFunction "lower"
35+
36+-- | >>> printSQL $ upper "eeee"
37+-- upper(E'eeee')
38+upper :: null 'PGtext --> null 'PGtext
39+upper = unsafeFunction "upper"
40+
41+-- | >>> printSQL $ charLength "four"
42+-- char_length(E'four')
43+charLength :: null 'PGtext --> null 'PGint4
44+charLength = unsafeFunction "char_length"
45+
46+-- | The `like` expression returns true if the @string@ matches
47+-- the supplied @pattern@. If @pattern@ does not contain percent signs
48+-- or underscores, then the pattern only represents the string itself;
49+-- in that case `like` acts like the equals operator. An underscore (_)
50+-- in pattern stands for (matches) any single character; a percent sign (%)
51+-- matches any sequence of zero or more characters.
52+--
53+-- >>> printSQL $ "abc" `like` "a%"
54+-- (E'abc' LIKE E'a%')
55+like :: Operator (null 'PGtext) (null 'PGtext) ('Null 'PGbool)
56+like = unsafeBinaryOp "LIKE"
57+
58+-- | The key word ILIKE can be used instead of LIKE to make the
59+-- match case-insensitive according to the active locale.
60+--
61+-- >>> printSQL $ "abc" `ilike` "a%"
62+-- (E'abc' ILIKE E'a%')
63+ilike :: Operator (null 'PGtext) (null 'PGtext) ('Null 'PGbool)
64+ilike = unsafeBinaryOp "ILIKE"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/TextSearch.hsnew file+157
@@ -0,0 +1,157 @@
1+{-|
2+Module: Squeal.PostgreSQL.Expression.TextSearch
3+Description: Text search expressions
4+Copyright: (c) Eitan Chatav, 2019
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Text search functions and operators
9+-}
10+
11+{-# LANGUAGE
12+ DataKinds
13+ , OverloadedStrings
14+ , TypeOperators
15+#-}
16+
17+module Squeal.PostgreSQL.Expression.TextSearch
18+ ( (@@)
19+ , (.&)
20+ , (.|)
21+ , (.!)
22+ , (<->)
23+ , arrayToTSvector
24+ , tsvectorLength
25+ , numnode
26+ , plainToTSquery
27+ , phraseToTSquery
28+ , websearchToTSquery
29+ , queryTree
30+ , toTSquery
31+ , toTSvector
32+ , setWeight
33+ , strip
34+ , jsonToTSvector
35+ , jsonbToTSvector
36+ , tsDelete
37+ , tsFilter
38+ , tsHeadline
39+ ) where
40+
41+import Squeal.PostgreSQL.Expression
42+import Squeal.PostgreSQL.List
43+import Squeal.PostgreSQL.Schema
44+
45+-- | `Squeal.PostgreSQL.Expression.Type.tsvector` matches tsquery ?
46+(@@) :: Operator (null 'PGtsvector) (null 'PGtsquery) ('Null 'PGbool)
47+(@@) = unsafeBinaryOp "@@"
48+
49+-- | AND `Squeal.PostgreSQL.Expression.Type.tsquery`s together
50+(.&) :: Operator (null 'PGtsquery) (null 'PGtsquery) (null 'PGtsquery)
51+(.&) = unsafeBinaryOp "&&"
52+
53+-- | OR `Squeal.PostgreSQL.Expression.Type.tsquery`s together
54+(.|) :: Operator (null 'PGtsquery) (null 'PGtsquery) (null 'PGtsquery)
55+(.|) = unsafeBinaryOp "||"
56+
57+-- | negate a `Squeal.PostgreSQL.Expression.Type.tsquery`
58+(.!) :: null 'PGtsquery --> null 'PGtsquery
59+(.!) = unsafeLeftOp "!!"
60+
61+-- | `Squeal.PostgreSQL.Expression.Type.tsquery` followed by
62+-- `Squeal.PostgreSQL.Expression.Type.tsquery`
63+(<->) :: Operator (null 'PGtsquery) (null 'PGtsquery) (null 'PGtsquery)
64+(<->) = unsafeBinaryOp "<->"
65+
66+-- | convert array of lexemes to `Squeal.PostgreSQL.Expression.Type.tsvector`
67+arrayToTSvector
68+ :: null ('PGvararray ('NotNull 'PGtext))
69+ --> null 'PGtsvector
70+arrayToTSvector = unsafeFunction "array_to_tsvector"
71+
72+-- | number of lexemes in `Squeal.PostgreSQL.Expression.Type.tsvector`
73+tsvectorLength :: null 'PGtsvector --> null 'PGint4
74+tsvectorLength = unsafeFunction "length"
75+
76+-- | number of lexemes plus operators in `Squeal.PostgreSQL.Expression.Type.tsquery`
77+numnode :: null 'PGtsquery --> null 'PGint4
78+numnode = unsafeFunction "numnode"
79+
80+-- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` ignoring punctuation
81+plainToTSquery :: null 'PGtext --> null 'PGtsquery
82+plainToTSquery = unsafeFunction "plainto_tsquery"
83+
84+-- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` that searches for a phrase,
85+-- ignoring punctuation
86+phraseToTSquery :: null 'PGtext --> null 'PGtsquery
87+phraseToTSquery = unsafeFunction "phraseto_tsquery"
88+
89+-- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` from a web search style query
90+websearchToTSquery :: null 'PGtext --> null 'PGtsquery
91+websearchToTSquery = unsafeFunction "websearch_to_tsquery"
92+
93+-- | get indexable part of a `Squeal.PostgreSQL.Expression.Type.tsquery`
94+queryTree :: null 'PGtsquery --> null 'PGtext
95+queryTree = unsafeFunction "query_tree"
96+
97+-- | normalize words and convert to `Squeal.PostgreSQL.Expression.Type.tsquery`
98+toTSquery :: null 'PGtext --> null 'PGtsquery
99+toTSquery = unsafeFunction "to_tsquery"
100+
101+-- | reduce document text to `Squeal.PostgreSQL.Expression.Type.tsvector`
102+toTSvector
103+ :: ty `In` '[ 'PGtext, 'PGjson, 'PGjsonb]
104+ => null ty --> null 'PGtsvector
105+toTSvector = unsafeFunction "to_tsvector"
106+
107+-- | assign weight to each element of `Squeal.PostgreSQL.Expression.Type.tsvector`
108+setWeight :: '[null 'PGtsvector, null ('PGchar 1)] ---> null 'PGtsvector
109+setWeight = unsafeFunctionN "set_weight"
110+
111+-- | remove positions and weights from `Squeal.PostgreSQL.Expression.Type.tsvector`
112+strip :: null 'PGtsvector --> null 'PGtsvector
113+strip = unsafeFunction "strip"
114+
115+-- | @jsonToTSvector (document *: filter)@
116+-- reduce each value in the document, specified by filter to a `Squeal.PostgreSQL.Expression.Type.tsvector`,
117+-- and then concatenate those in document order to produce a single `Squeal.PostgreSQL.Expression.Type.tsvector`.
118+-- filter is a `Squeal.PostgreSQL.Expression.Type.json` array, that enumerates what kind of elements
119+-- need to be included into the resulting `Squeal.PostgreSQL.Expression.Type.tsvector`.
120+-- Possible values for filter are "string" (to include all string values),
121+-- "numeric" (to include all numeric values in the string format),
122+-- "boolean" (to include all Boolean values in the string format "true"/"false"),
123+-- "key" (to include all keys) or "all" (to include all above).
124+-- These values can be combined together to include, e.g. all string and numeric values.
125+jsonToTSvector :: '[null 'PGjson, null 'PGjson] ---> null 'PGtsvector
126+jsonToTSvector = unsafeFunctionN "json_to_tsvector"
127+
128+-- | @jsonbToTSvector (document *: filter)@
129+-- reduce each value in the document, specified by filter to a `Squeal.PostgreSQL.Expression.Type.tsvector`,
130+-- and then concatenate those in document order to produce a single `Squeal.PostgreSQL.Expression.Type.tsvector`.
131+-- filter is a `Squeal.PostgreSQL.Expression.Type.jsonb` array, that enumerates what kind of elements
132+-- need to be included into the resulting `Squeal.PostgreSQL.Expression.Type.tsvector`.
133+-- Possible values for filter are "string" (to include all string values),
134+-- "numeric" (to include all numeric values in the string format),
135+-- "boolean" (to include all Boolean values in the string format "true"/"false"),
136+-- "key" (to include all keys) or "all" (to include all above).
137+-- These values can be combined together to include, e.g. all string and numeric values.
138+jsonbToTSvector :: '[null 'PGjsonb, null 'PGjsonb] ---> null 'PGtsvector
139+jsonbToTSvector = unsafeFunctionN "jsonb_to_tsvector"
140+
141+-- | remove given lexeme from `Squeal.PostgreSQL.Expression.Type.tsvector`
142+tsDelete ::
143+ '[null 'PGtsvector, null ('PGvararray ('NotNull 'PGtext))]
144+ ---> null 'PGtsvector
145+tsDelete = unsafeFunctionN "ts_delete"
146+
147+-- | select only elements with given weights from `Squeal.PostgreSQL.Expression.Type.tsvector`
148+tsFilter ::
149+ '[null 'PGtsvector, null ('PGvararray ('NotNull ('PGchar 1)))]
150+ ---> null 'PGtsvector
151+tsFilter = unsafeFunctionN "ts_filter"
152+
153+-- | display a `Squeal.PostgreSQL.Expression.Type.tsquery` match
154+tsHeadline
155+ :: document `In` '[ 'PGtext, 'PGjson, 'PGjsonb]
156+ => '[null document, null 'PGtsquery] ---> null 'PGtext
157+tsHeadline = unsafeFunctionN "ts_headline"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Time.hsnew file+192
@@ -0,0 +1,192 @@
1+{-|
2+Module: Squeal.PostgreSQL.Expression.Time
3+Description: Date/Time expressions
4+Copyright: (c) Eitan Chatav, 2019
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Date/Time functions and operators
9+-}
10+
11+{-# LANGUAGE
12+ DataKinds
13+ , DeriveGeneric
14+ , FunctionalDependencies
15+ , LambdaCase
16+ , MultiParamTypeClasses
17+ , OverloadedStrings
18+ , PolyKinds
19+ , RankNTypes
20+ , TypeOperators
21+#-}
22+
23+module Squeal.PostgreSQL.Expression.Time
24+ ( TimeOp (..)
25+ , currentDate
26+ , currentTime
27+ , currentTimestamp
28+ , localTime
29+ , localTimestamp
30+ , now
31+ , makeDate
32+ , makeTime
33+ , makeTimestamp
34+ , makeTimestamptz
35+ , interval_
36+ , TimeUnit (..)
37+ ) where
38+
39+import Data.String
40+
41+import qualified GHC.Generics as GHC
42+import qualified Generics.SOP as SOP
43+
44+import Squeal.PostgreSQL.Expression
45+import Squeal.PostgreSQL.Render
46+import Squeal.PostgreSQL.Schema
47+
48+-- $setup
49+-- >>> import Squeal.PostgreSQL
50+
51+-- | >>> printSQL currentDate
52+-- CURRENT_DATE
53+currentDate :: Expr (null 'PGdate)
54+currentDate = UnsafeExpression "CURRENT_DATE"
55+
56+-- | >>> printSQL currentTime
57+-- CURRENT_TIME
58+currentTime :: Expr (null 'PGtimetz)
59+currentTime = UnsafeExpression "CURRENT_TIME"
60+
61+-- | >>> printSQL currentTimestamp
62+-- CURRENT_TIMESTAMP
63+currentTimestamp :: Expr (null 'PGtimestamptz)
64+currentTimestamp = UnsafeExpression "CURRENT_TIMESTAMP"
65+
66+-- | >>> printSQL localTime
67+-- LOCALTIME
68+localTime :: Expr (null 'PGtime)
69+localTime = UnsafeExpression "LOCALTIME"
70+
71+-- | >>> printSQL localTimestamp
72+-- LOCALTIMESTAMP
73+localTimestamp :: Expr (null 'PGtimestamp)
74+localTimestamp = UnsafeExpression "LOCALTIMESTAMP"
75+
76+-- | Current date and time (equivalent to `currentTimestamp`)
77+--
78+-- >>> printSQL now
79+-- now()
80+now :: Expr (null 'PGtimestamptz)
81+now = UnsafeExpression "now()"
82+
83+{-|
84+Create date from year, month and day fields
85+
86+>>> printSQL (makeDate (1984 :* 7 *: 3))
87+make_date(1984, 7, 3)
88+-}
89+makeDate :: '[ null 'PGint4, null 'PGint4, null 'PGint4 ] ---> null 'PGdate
90+makeDate = unsafeFunctionN "make_date"
91+
92+{-|
93+Create time from hour, minute and seconds fields
94+
95+>>> printSQL (makeTime (8 :* 15 *: 23.5))
96+make_time(8, 15, 23.5)
97+-}
98+makeTime :: '[ null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtime
99+makeTime = unsafeFunctionN "make_time"
100+
101+{-|
102+Create timestamp from year, month, day, hour, minute and seconds fields
103+
104+>>> printSQL (makeTimestamp (2013 :* 7 :* 15 :* 8 :* 15 *: 23.5))
105+make_timestamp(2013, 7, 15, 8, 15, 23.5)
106+-}
107+makeTimestamp ::
108+ '[ null 'PGint4, null 'PGint4, null 'PGint4
109+ , null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtimestamp
110+makeTimestamp = unsafeFunctionN "make_timestamp"
111+
112+{-|
113+Create timestamp with time zone from
114+year, month, day, hour, minute and seconds fields;
115+the current time zone is used
116+
117+>>> printSQL (makeTimestamptz (2013 :* 7 :* 15 :* 8 :* 15 *: 23.5))
118+make_timestamptz(2013, 7, 15, 8, 15, 23.5)
119+-}
120+makeTimestamptz ::
121+ '[ null 'PGint4, null 'PGint4, null 'PGint4
122+ , null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtimestamptz
123+makeTimestamptz = unsafeFunctionN "make_timestamptz"
124+
125+{-|
126+Affine space operations on time types.
127+-}
128+class TimeOp time diff | time -> diff where
129+ {-|
130+ >>> printSQL (makeDate (1984 :* 7 *: 3) !+ 365)
131+ (make_date(1984, 7, 3) + 365)
132+ -}
133+ (!+) :: Operator (null time) (null diff) (null time)
134+ (!+) = unsafeBinaryOp "+"
135+ {-|
136+ >>> printSQL (365 +! makeDate (1984 :* 7 *: 3))
137+ (365 + make_date(1984, 7, 3))
138+ -}
139+ (+!) :: Operator (null diff) (null time) (null time)
140+ (+!) = unsafeBinaryOp "+"
141+ {-|
142+ >>> printSQL (makeDate (1984 :* 7 *: 3) !- 365)
143+ (make_date(1984, 7, 3) - 365)
144+ -}
145+ (!-) :: Operator (null time) (null diff) (null time)
146+ (!-) = unsafeBinaryOp "-"
147+ {-|
148+ >>> printSQL (makeDate (1984 :* 7 *: 3) !-! currentDate)
149+ (make_date(1984, 7, 3) - CURRENT_DATE)
150+ -}
151+ (!-!) :: Operator (null time) (null time) (null diff)
152+ (!-!) = unsafeBinaryOp "-"
153+instance TimeOp 'PGtimestamp 'PGinterval
154+instance TimeOp 'PGtimestamptz 'PGinterval
155+instance TimeOp 'PGtime 'PGinterval
156+instance TimeOp 'PGtimetz 'PGinterval
157+instance TimeOp 'PGinterval 'PGinterval
158+instance TimeOp 'PGdate 'PGint4
159+infixl 6 !+
160+infixl 6 +!
161+infixl 6 !-
162+infixl 6 !-!
163+
164+-- | A `TimeUnit` to use in `interval_` construction.
165+data TimeUnit
166+ = Years | Months | Weeks | Days
167+ | Hours | Minutes | Seconds
168+ | Microseconds | Milliseconds
169+ | Decades | Centuries | Millennia
170+ deriving (Eq, Ord, Show, Read, Enum, GHC.Generic)
171+instance SOP.Generic TimeUnit
172+instance SOP.HasDatatypeInfo TimeUnit
173+instance RenderSQL TimeUnit where
174+ renderSQL = \case
175+ Years -> "years"
176+ Months -> "months"
177+ Weeks -> "weeks"
178+ Days -> "days"
179+ Hours -> "hours"
180+ Minutes -> "minutes"
181+ Seconds -> "seconds"
182+ Microseconds -> "microseconds"
183+ Milliseconds -> "milliseconds"
184+ Decades -> "decades"
185+ Centuries -> "centuries"
186+ Millennia -> "millennia"
187+
188+-- | >>> printSQL $ interval_ 7 Days
189+-- (INTERVAL '7.0 days')
190+interval_ :: Double -> TimeUnit -> Expr (null 'PGinterval)
191+interval_ num unit = UnsafeExpression . parenthesized $ "INTERVAL" <+>
192+ "'" <> fromString (show num) <+> renderSQL unit <> "'"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Type.hsnew file+446
@@ -0,0 +1,446 @@
1+{-|
2+Module: Squeal.PostgreSQL.Expression
3+Description: Type expressions
4+Copyright: (c) Eitan Chatav, 2019
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Type expressions.
9+-}
10+
11+{-# LANGUAGE
12+ AllowAmbiguousTypes
13+ , DataKinds
14+ , DeriveGeneric
15+ , FlexibleContexts
16+ , FlexibleInstances
17+ , GADTs
18+ , GeneralizedNewtypeDeriving
19+ , KindSignatures
20+ , MultiParamTypeClasses
21+ , OverloadedStrings
22+ , RankNTypes
23+ , ScopedTypeVariables
24+ , TypeApplications
25+ , TypeOperators
26+ , UndecidableInstances
27+#-}
28+
29+module Squeal.PostgreSQL.Expression.Type
30+ ( -- * type casting
31+ cast
32+ , astype
33+ , inferredtype
34+ -- * type expressions
35+ , TypeExpression (..)
36+ , typedef
37+ , typetable
38+ , typeview
39+ , bool
40+ , int2
41+ , smallint
42+ , int4
43+ , int
44+ , integer
45+ , int8
46+ , bigint
47+ , numeric
48+ , float4
49+ , real
50+ , float8
51+ , doublePrecision
52+ , money
53+ , text
54+ , char
55+ , character
56+ , varchar
57+ , characterVarying
58+ , bytea
59+ , timestamp
60+ , timestampWithTimeZone
61+ , timestamptz
62+ , date
63+ , time
64+ , timeWithTimeZone
65+ , timetz
66+ , interval
67+ , uuid
68+ , inet
69+ , json
70+ , jsonb
71+ , vararray
72+ , fixarray
73+ , tsvector
74+ , tsquery
75+ , oid
76+ , int4range
77+ , int8range
78+ , numrange
79+ , tsrange
80+ , tstzrange
81+ , daterange
82+ -- * column type definitions
83+ , ColumnTypeExpression (..)
84+ , nullable
85+ , notNullable
86+ , default_
87+ , serial2
88+ , smallserial
89+ , serial4
90+ , serial
91+ , serial8
92+ , bigserial
93+ , hask
94+ -- * type inference
95+ , PGTyped (..)
96+ , PGNullityTyped (..)
97+ , FieldTyped (..)
98+ ) where
99+
100+import Control.DeepSeq
101+import Data.ByteString
102+import Data.String
103+import GHC.TypeLits
104+
105+import qualified Data.ByteString as ByteString
106+import qualified GHC.Generics as GHC
107+import qualified Generics.SOP as SOP
108+
109+import Squeal.PostgreSQL.Alias
110+import Squeal.PostgreSQL.Expression
111+import Squeal.PostgreSQL.PG
112+import Squeal.PostgreSQL.Render
113+import Squeal.PostgreSQL.Schema
114+
115+-- $setup
116+-- >>> import Squeal.PostgreSQL
117+
118+-- When a `cast` is applied to an `Expression` of a known type, it
119+-- represents a run-time type conversion. The cast will succeed only if a
120+-- suitable type conversion operation has been defined.
121+--
122+-- | >>> printSQL $ true & cast int4
123+-- (TRUE :: int4)
124+cast
125+ :: TypeExpression schemas ty1
126+ -- ^ type to cast as
127+ -> Expression outer commons grp schemas params from ty0
128+ -- ^ value to convert
129+ -> Expression outer commons grp schemas params from ty1
130+cast ty x = UnsafeExpression $ parenthesized $
131+ renderSQL x <+> "::" <+> renderSQL ty
132+
133+-- | A safe version of `cast` which just matches a value with its type.
134+--
135+-- >>> printSQL (1 & astype int)
136+-- (1 :: int)
137+astype
138+ :: TypeExpression schemas ty
139+ -- ^ type to specify as
140+ -> Expression outer commons grp schemas params from ty
141+ -- ^ value
142+ -> Expression outer commons grp schemas params from ty
143+astype = cast
144+
145+-- | `inferredtype` will add a type annotation to an `Expression`
146+-- which can be useful for fixing the storage type of a value.
147+--
148+-- >>> printSQL (inferredtype true)
149+-- (TRUE :: bool)
150+inferredtype
151+ :: PGTyped schemas ty
152+ => Expression outer common grp schemas params from ty
153+ -- ^ value
154+ -> Expression outer common grp schemas params from ty
155+inferredtype = astype pgtype
156+
157+{-----------------------------------------
158+type expressions
159+-----------------------------------------}
160+
161+-- | `TypeExpression`s are used in `cast`s and
162+-- `Squeal.PostgreSQL.Definition.createTable` commands.
163+newtype TypeExpression (schemas :: SchemasType) (ty :: NullityType)
164+ = UnsafeTypeExpression { renderTypeExpression :: ByteString }
165+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
166+instance RenderSQL (TypeExpression schemas ty) where
167+ renderSQL = renderTypeExpression
168+
169+-- | The enum or composite type in a `Typedef` can be expressed by its alias.
170+typedef
171+ :: (Has sch schemas schema, Has td schema ('Typedef ty))
172+ => QualifiedAlias sch td
173+ -- ^ type alias
174+ -> TypeExpression schemas (null ty)
175+typedef = UnsafeTypeExpression . renderSQL
176+
177+-- | The composite type corresponding to a `Table` definition can be expressed
178+-- by its alias.
179+typetable
180+ :: (Has sch schemas schema, Has tab schema ('Table table))
181+ => QualifiedAlias sch tab
182+ -- ^ table alias
183+ -> TypeExpression schemas (null ('PGcomposite (TableToRow table)))
184+typetable = UnsafeTypeExpression . renderSQL
185+
186+-- | The composite type corresponding to a `View` definition can be expressed
187+-- by its alias.
188+typeview
189+ :: (Has sch schemas schema, Has vw schema ('View view))
190+ => QualifiedAlias sch vw
191+ -- ^ view alias
192+ -> TypeExpression schemas (null ('PGcomposite view))
193+typeview = UnsafeTypeExpression . renderSQL
194+
195+-- | logical Boolean (true/false)
196+bool :: TypeExpression schemas (null 'PGbool)
197+bool = UnsafeTypeExpression "bool"
198+-- | signed two-byte integer
199+int2, smallint :: TypeExpression schemas (null 'PGint2)
200+int2 = UnsafeTypeExpression "int2"
201+smallint = UnsafeTypeExpression "smallint"
202+-- | signed four-byte integer
203+int4, int, integer :: TypeExpression schemas (null 'PGint4)
204+int4 = UnsafeTypeExpression "int4"
205+int = UnsafeTypeExpression "int"
206+integer = UnsafeTypeExpression "integer"
207+-- | signed eight-byte integer
208+int8, bigint :: TypeExpression schemas (null 'PGint8)
209+int8 = UnsafeTypeExpression "int8"
210+bigint = UnsafeTypeExpression "bigint"
211+-- | arbitrary precision numeric type
212+numeric :: TypeExpression schemas (null 'PGnumeric)
213+numeric = UnsafeTypeExpression "numeric"
214+-- | single precision floating-point number (4 bytes)
215+float4, real :: TypeExpression schemas (null 'PGfloat4)
216+float4 = UnsafeTypeExpression "float4"
217+real = UnsafeTypeExpression "real"
218+-- | double precision floating-point number (8 bytes)
219+float8, doublePrecision :: TypeExpression schemas (null 'PGfloat8)
220+float8 = UnsafeTypeExpression "float8"
221+doublePrecision = UnsafeTypeExpression "double precision"
222+-- | currency amount
223+money :: TypeExpression schema (null 'PGmoney)
224+money = UnsafeTypeExpression "money"
225+-- | variable-length character string
226+text :: TypeExpression schemas (null 'PGtext)
227+text = UnsafeTypeExpression "text"
228+-- | fixed-length character string
229+char, character
230+ :: forall n schemas null. (KnownNat n, 1 <= n)
231+ => TypeExpression schemas (null ('PGchar n))
232+char = UnsafeTypeExpression $ "char(" <> renderNat @n <> ")"
233+character = UnsafeTypeExpression $ "character(" <> renderNat @n <> ")"
234+-- | variable-length character string
235+varchar, characterVarying
236+ :: forall n schemas null. (KnownNat n, 1 <= n)
237+ => TypeExpression schemas (null ('PGvarchar n))
238+varchar = UnsafeTypeExpression $ "varchar(" <> renderNat @n <> ")"
239+characterVarying = UnsafeTypeExpression $
240+ "character varying(" <> renderNat @n <> ")"
241+-- | binary data ("byte array")
242+bytea :: TypeExpression schemas (null 'PGbytea)
243+bytea = UnsafeTypeExpression "bytea"
244+-- | date and time (no time zone)
245+timestamp :: TypeExpression schemas (null 'PGtimestamp)
246+timestamp = UnsafeTypeExpression "timestamp"
247+-- | date and time, including time zone
248+timestampWithTimeZone, timestamptz :: TypeExpression schemas (null 'PGtimestamptz)
249+timestampWithTimeZone = UnsafeTypeExpression "timestamp with time zone"
250+timestamptz = UnsafeTypeExpression "timestamptz"
251+-- | calendar date (year, month, day)
252+date :: TypeExpression schemas (null 'PGdate)
253+date = UnsafeTypeExpression "date"
254+-- | time of day (no time zone)
255+time :: TypeExpression schemas (null 'PGtime)
256+time = UnsafeTypeExpression "time"
257+-- | time of day, including time zone
258+timeWithTimeZone, timetz :: TypeExpression schemas (null 'PGtimetz)
259+timeWithTimeZone = UnsafeTypeExpression "time with time zone"
260+timetz = UnsafeTypeExpression "timetz"
261+-- | time span
262+interval :: TypeExpression schemas (null 'PGinterval)
263+interval = UnsafeTypeExpression "interval"
264+-- | universally unique identifier
265+uuid :: TypeExpression schemas (null 'PGuuid)
266+uuid = UnsafeTypeExpression "uuid"
267+-- | IPv4 or IPv6 host address
268+inet :: TypeExpression schemas (null 'PGinet)
269+inet = UnsafeTypeExpression "inet"
270+-- | textual JSON data
271+json :: TypeExpression schemas (null 'PGjson)
272+json = UnsafeTypeExpression "json"
273+-- | binary JSON data, decomposed
274+jsonb :: TypeExpression schemas (null 'PGjsonb)
275+jsonb = UnsafeTypeExpression "jsonb"
276+-- | variable length array
277+vararray
278+ :: TypeExpression schemas pg
279+ -> TypeExpression schemas (null ('PGvararray pg))
280+vararray ty = UnsafeTypeExpression $ renderSQL ty <> "[]"
281+-- | fixed length array
282+--
283+-- >>> renderSQL (fixarray @'[2] json)
284+-- "json[2]"
285+fixarray
286+ :: forall dims schemas null pg. SOP.All KnownNat dims
287+ => TypeExpression schemas pg
288+ -> TypeExpression schemas (null ('PGfixarray dims pg))
289+fixarray ty = UnsafeTypeExpression $
290+ renderSQL ty <> renderDims @dims
291+ where
292+ renderDims :: forall ns. SOP.All KnownNat ns => ByteString
293+ renderDims =
294+ ("[" <>)
295+ . (<> "]")
296+ . ByteString.intercalate "]["
297+ . SOP.hcollapse
298+ $ SOP.hcmap (SOP.Proxy @KnownNat)
299+ (K . fromString . show . natVal)
300+ (SOP.hpure SOP.Proxy :: SOP.NP SOP.Proxy ns)
301+-- | text search query
302+tsvector :: TypeExpression schemas (null 'PGtsvector)
303+tsvector = UnsafeTypeExpression "tsvector"
304+-- | text search document
305+tsquery :: TypeExpression schemas (null 'PGtsquery)
306+tsquery = UnsafeTypeExpression "tsquery"
307+-- | Object identifiers (OIDs) are used internally by PostgreSQL
308+-- as primary keys for various system tables.
309+oid :: TypeExpression schemas (null 'PGoid)
310+oid = UnsafeTypeExpression "oid"
311+-- | Range of integer
312+int4range :: TypeExpression schemas (null ('PGrange 'PGint4))
313+int4range = UnsafeTypeExpression "int4range"
314+-- | Range of bigint
315+int8range :: TypeExpression schemas (null ('PGrange 'PGint8))
316+int8range = UnsafeTypeExpression "int8range"
317+-- | Range of numeric
318+numrange :: TypeExpression schemas (null ('PGrange 'PGnumeric))
319+numrange = UnsafeTypeExpression "numrange"
320+-- | Range of timestamp without time zone
321+tsrange :: TypeExpression schemas (null ('PGrange 'PGtimestamp))
322+tsrange = UnsafeTypeExpression "tsrange"
323+-- | Range of timestamp with time zone
324+tstzrange :: TypeExpression schemas (null ('PGrange 'PGtimestamptz))
325+tstzrange = UnsafeTypeExpression "tstzrange"
326+-- | Range of date
327+daterange :: TypeExpression schemas (null ('PGrange 'PGdate))
328+daterange = UnsafeTypeExpression "daterange"
329+
330+-- | `pgtype` is a demoted version of a `PGType`
331+class PGTyped schemas (ty :: NullityType) where
332+ pgtype :: TypeExpression schemas ty
333+instance PGTyped schemas (null 'PGbool) where pgtype = bool
334+instance PGTyped schemas (null 'PGint2) where pgtype = int2
335+instance PGTyped schemas (null 'PGint4) where pgtype = int4
336+instance PGTyped schemas (null 'PGint8) where pgtype = int8
337+instance PGTyped schemas (null 'PGnumeric) where pgtype = numeric
338+instance PGTyped schemas (null 'PGfloat4) where pgtype = float4
339+instance PGTyped schemas (null 'PGfloat8) where pgtype = float8
340+instance PGTyped schemas (null 'PGmoney) where pgtype = money
341+instance PGTyped schemas (null 'PGtext) where pgtype = text
342+instance (KnownNat n, 1 <= n)
343+ => PGTyped schemas (null ('PGchar n)) where pgtype = char @n
344+instance (KnownNat n, 1 <= n)
345+ => PGTyped schemas (null ('PGvarchar n)) where pgtype = varchar @n
346+instance PGTyped schemas (null 'PGbytea) where pgtype = bytea
347+instance PGTyped schemas (null 'PGtimestamp) where pgtype = timestamp
348+instance PGTyped schemas (null 'PGtimestamptz) where pgtype = timestampWithTimeZone
349+instance PGTyped schemas (null 'PGdate) where pgtype = date
350+instance PGTyped schemas (null 'PGtime) where pgtype = time
351+instance PGTyped schemas (null 'PGtimetz) where pgtype = timeWithTimeZone
352+instance PGTyped schemas (null 'PGinterval) where pgtype = interval
353+instance PGTyped schemas (null 'PGuuid) where pgtype = uuid
354+instance PGTyped schemas (null 'PGjson) where pgtype = json
355+instance PGTyped schemas (null 'PGjsonb) where pgtype = jsonb
356+instance PGTyped schemas ty
357+ => PGTyped schemas (null ('PGvararray ty)) where
358+ pgtype = vararray (pgtype @schemas @ty)
359+instance (SOP.All KnownNat dims, PGTyped schemas ty)
360+ => PGTyped schemas (null ('PGfixarray dims ty)) where
361+ pgtype = fixarray @dims (pgtype @schemas @ty)
362+instance PGTyped schemas (null 'PGtsvector) where pgtype = tsvector
363+instance PGTyped schemas (null 'PGtsquery) where pgtype = tsquery
364+instance PGTyped schemas (null 'PGoid) where pgtype = oid
365+instance PGTyped schemas (null ('PGrange 'PGint4)) where pgtype = int4range
366+instance PGTyped schemas (null ('PGrange 'PGint8)) where pgtype = int8range
367+instance PGTyped schemas (null ('PGrange 'PGnumeric)) where pgtype = numrange
368+instance PGTyped schemas (null ('PGrange 'PGtimestamp)) where pgtype = tsrange
369+instance PGTyped schemas (null ('PGrange 'PGtimestamptz)) where pgtype = tstzrange
370+instance PGTyped schemas (null ('PGrange 'PGdate)) where pgtype = daterange
371+
372+-- | Lift `PGTyped` to a field
373+class FieldTyped schemas ty where
374+ fieldtype :: Aliased (TypeExpression schemas) ty
375+instance (KnownSymbol alias, PGTyped schemas ty)
376+ => FieldTyped schemas (alias ::: ty) where
377+ fieldtype = pgtype `As` Alias
378+
379+-- | `ColumnTypeExpression`s are used in `createTable` commands.
380+newtype ColumnTypeExpression (schemas :: SchemasType) (ty :: ColumnType)
381+ = UnsafeColumnTypeExpression { renderColumnTypeExpression :: ByteString }
382+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
383+instance RenderSQL (ColumnTypeExpression schemas ty) where
384+ renderSQL = renderColumnTypeExpression
385+
386+-- | used in `createTable` commands as a column constraint to note that
387+-- @NULL@ may be present in a column
388+nullable
389+ :: TypeExpression schemas (nullity ty)
390+ -> ColumnTypeExpression schemas ('NoDef :=> 'Null ty)
391+nullable ty = UnsafeColumnTypeExpression $ renderSQL ty <+> "NULL"
392+
393+-- | used in `createTable` commands as a column constraint to ensure
394+-- @NULL@ is not present in a column
395+notNullable
396+ :: TypeExpression schemas (nullity ty)
397+ -> ColumnTypeExpression schemas ('NoDef :=> 'NotNull ty)
398+notNullable ty = UnsafeColumnTypeExpression $ renderSQL ty <+> "NOT NULL"
399+
400+-- | used in `createTable` commands as a column constraint to give a default
401+default_
402+ :: Expression '[] '[] 'Ungrouped schemas '[] '[] ty
403+ -> ColumnTypeExpression schemas ('NoDef :=> ty)
404+ -> ColumnTypeExpression schemas ('Def :=> ty)
405+default_ x ty = UnsafeColumnTypeExpression $
406+ renderSQL ty <+> "DEFAULT" <+> renderExpression x
407+
408+-- | not a true type, but merely a notational convenience for creating
409+-- unique identifier columns with type `PGint2`
410+serial2, smallserial
411+ :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint2)
412+serial2 = UnsafeColumnTypeExpression "serial2"
413+smallserial = UnsafeColumnTypeExpression "smallserial"
414+-- | not a true type, but merely a notational convenience for creating
415+-- unique identifier columns with type `PGint4`
416+serial4, serial
417+ :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint4)
418+serial4 = UnsafeColumnTypeExpression "serial4"
419+serial = UnsafeColumnTypeExpression "serial"
420+-- | not a true type, but merely a notational convenience for creating
421+-- unique identifier columns with type `PGint8`
422+serial8, bigserial
423+ :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint8)
424+serial8 = UnsafeColumnTypeExpression "serial8"
425+bigserial = UnsafeColumnTypeExpression "bigserial"
426+
427+-- | Like @PGTyped@ but also accounts for nullity.
428+class PGNullityTyped schemas (nullty :: NullityType) where
429+ pgNullityType :: ColumnTypeExpression schemas ('NoDef :=> nullty)
430+
431+instance PGTyped schemas ('Null ty) => PGNullityTyped schemas ('Null ty) where
432+ pgNullityType = nullable (pgtype @_ @('Null ty))
433+
434+instance PGTyped schemas ('NotNull ty) => PGNullityTyped schemas ('NotNull ty) where
435+ pgNullityType = notNullable (pgtype @_ @('NotNull ty))
436+
437+-- | Allow you to specify pg column types in relation to haskell types.
438+-- >>> printSQL $ hask @(Maybe String)
439+-- text NULL
440+--
441+-- >>> printSQL $ hask @Double
442+-- float8 NOT NULL
443+hask
444+ :: forall hask schemas. PGNullityTyped schemas (NullPG hask)
445+ => ColumnTypeExpression schemas ('NoDef :=> NullPG hask)
446+hask = pgNullityType
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Window.hsnew file+284
@@ -0,0 +1,284 @@
1+{-|
2+Module: Squeal.PostgreSQL.Expression.Window
3+Description: Window functions
4+Copyright: (c) Eitan Chatav, 2019
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Window functions and definitions
9+-}
10+
11+{-# LANGUAGE
12+ DataKinds
13+ , DeriveGeneric
14+ , FlexibleContexts
15+ , FlexibleInstances
16+ , GADTs
17+ , GeneralizedNewtypeDeriving
18+ , LambdaCase
19+ , MultiParamTypeClasses
20+ , OverloadedStrings
21+ , RankNTypes
22+ , KindSignatures
23+#-}
24+
25+module Squeal.PostgreSQL.Expression.Window
26+ ( -- * functions
27+ partitionBy
28+ , rank
29+ , rowNumber
30+ , denseRank
31+ , percentRank
32+ , cumeDist
33+ , ntile
34+ , lag
35+ , lead
36+ , firstValue
37+ , lastValue
38+ , nthValue
39+ , unsafeWindowFunction1
40+ , unsafeWindowFunctionN
41+ -- * types
42+ , WindowFunction (..)
43+ , WindowDefinition (..)
44+ , WinFun0
45+ , WinFun1
46+ , WinFunN
47+ ) where
48+
49+import Control.DeepSeq
50+import Data.ByteString
51+
52+import qualified GHC.Generics as GHC
53+import qualified Generics.SOP as SOP
54+
55+import Squeal.PostgreSQL.Alias
56+import Squeal.PostgreSQL.Expression
57+import Squeal.PostgreSQL.Expression.Aggregate
58+import Squeal.PostgreSQL.Expression.Sort
59+import Squeal.PostgreSQL.List
60+import Squeal.PostgreSQL.Render
61+import Squeal.PostgreSQL.Schema
62+
63+instance Aggregate
64+ (Expression outer commons grp schemas params from)
65+ (NP (Expression outer commons grp schemas params from))
66+ (WindowFunction outer commons grp schemas params from) where
67+ countStar = UnsafeWindowFunction "count(*)"
68+ count = unsafeWindowFunction1 "count"
69+ sum_ = unsafeWindowFunction1 "sum"
70+ arrayAgg = unsafeWindowFunction1 "array_agg"
71+ jsonAgg = unsafeWindowFunction1 "json_agg"
72+ jsonbAgg = unsafeWindowFunction1 "jsonb_agg"
73+ bitAnd = unsafeWindowFunction1 "bit_and"
74+ bitOr = unsafeWindowFunction1 "bit_or"
75+ boolAnd = unsafeWindowFunction1 "bool_and"
76+ boolOr = unsafeWindowFunction1 "bool_or"
77+ every = unsafeWindowFunction1 "every"
78+ max_ = unsafeWindowFunction1 "max"
79+ min_ = unsafeWindowFunction1 "min"
80+ avg = unsafeWindowFunction1 "avg"
81+ corr = unsafeWindowFunctionN "corr"
82+ covarPop = unsafeWindowFunctionN "covar_pop"
83+ covarSamp = unsafeWindowFunctionN "covar_samp"
84+ regrAvgX = unsafeWindowFunctionN "regr_avgx"
85+ regrAvgY = unsafeWindowFunctionN "regr_avgy"
86+ regrCount = unsafeWindowFunctionN "regr_count"
87+ regrIntercept = unsafeWindowFunctionN "regr_intercept"
88+ regrR2 = unsafeWindowFunctionN "regr_r2"
89+ regrSlope = unsafeWindowFunctionN "regr_slope"
90+ regrSxx = unsafeWindowFunctionN "regr_sxx"
91+ regrSxy = unsafeWindowFunctionN "regr_sxy"
92+ regrSyy = unsafeWindowFunctionN "regr_syy"
93+ stddev = unsafeWindowFunction1 "stddev"
94+ stddevPop = unsafeWindowFunction1 "stddev_pop"
95+ stddevSamp = unsafeWindowFunction1 "stddev_samp"
96+ variance = unsafeWindowFunction1 "variance"
97+ varPop = unsafeWindowFunction1 "var_pop"
98+ varSamp = unsafeWindowFunction1 "var_samp"
99+
100+-- | A `WindowDefinition` is a set of table rows that are somehow related
101+-- to the current row
102+data WindowDefinition outer commons grp schemas params from where
103+ WindowDefinition
104+ :: SOP.SListI bys
105+ => NP (Expression outer commons grp schemas params from) bys
106+ -- ^ `partitionBy` clause
107+ -> [SortExpression outer commons grp schemas params from]
108+ -- ^ `Squeal.PostgreSQL.Expression.Sort.orderBy` clause
109+ -> WindowDefinition outer commons grp schemas params from
110+
111+instance OrderBy WindowDefinition where
112+ orderBy sortsR (WindowDefinition parts sortsL)
113+ = WindowDefinition parts (sortsL ++ sortsR)
114+
115+instance RenderSQL (WindowDefinition outer commons schemas from grp params) where
116+ renderSQL (WindowDefinition part ord) =
117+ renderPartitionByClause part <> renderOrderByClause ord
118+ where
119+ renderPartitionByClause = \case
120+ Nil -> ""
121+ parts -> "PARTITION" <+> "BY" <+> renderCommaSeparated renderExpression parts
122+ renderOrderByClause = \case
123+ [] -> ""
124+ srts -> " ORDER" <+> "BY"
125+ <+> commaSeparated (renderSQL <$> srts)
126+
127+{- |
128+The `partitionBy` clause within `Squeal.PostgreSQL.Query.Over` divides the rows into groups,
129+or partitions, that share the same values of the `partitionBy` `Expression`(s).
130+For each row, the window function is computed across the rows that fall into
131+the same partition as the current row.
132+-}
133+partitionBy
134+ :: SOP.SListI bys
135+ => NP (Expression outer commons grp schemas params from) bys -- ^ partitions
136+ -> WindowDefinition outer commons grp schemas params from
137+partitionBy bys = WindowDefinition bys []
138+
139+{- |
140+A window function performs a calculation across a set of table rows
141+that are somehow related to the current row. This is comparable to the type
142+of calculation that can be done with an aggregate function.
143+However, window functions do not cause rows to become grouped into a single
144+output row like non-window aggregate calls would.
145+Instead, the rows retain their separate identities.
146+Behind the scenes, the window function is able to access more than
147+just the current row of the query result.
148+-}
149+newtype WindowFunction
150+ (outer :: FromType)
151+ (commons :: FromType)
152+ (grp :: Grouping)
153+ (schemas :: SchemasType)
154+ (params :: [NullityType])
155+ (from :: FromType)
156+ (ty :: NullityType)
157+ = UnsafeWindowFunction { renderWindowFunction :: ByteString }
158+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
159+
160+instance RenderSQL (WindowFunction outer commons grp schemas params from ty) where
161+ renderSQL = renderWindowFunction
162+
163+{- |
164+A @RankNType@ for window functions with no arguments.
165+-}
166+type WinFun0 x
167+ = forall outer commons grp schemas params from
168+ . WindowFunction outer commons grp schemas params from x
169+ -- ^ cannot reference aliases
170+
171+{- |
172+A @RankNType@ for window functions with 1 argument.
173+-}
174+type WinFun1 x y
175+ = forall outer commons grp schemas params from
176+ . Expression outer commons grp schemas params from x
177+ -- ^ input
178+ -> WindowFunction outer commons grp schemas params from y
179+ -- ^ output
180+
181+{- | A @RankNType@ for window functions with a fixed-length
182+list of heterogeneous arguments.
183+Use the `*:` operator to end your argument lists.
184+-}
185+type WinFunN xs y
186+ = forall outer commons grp schemas params from
187+ . NP (Expression outer commons grp schemas params from) xs
188+ -- ^ inputs
189+ -> WindowFunction outer commons grp schemas params from y
190+ -- ^ output
191+
192+-- | escape hatch for defining window functions
193+unsafeWindowFunction1 :: ByteString -> WinFun1 x y
194+unsafeWindowFunction1 fun x
195+ = UnsafeWindowFunction $ fun <> parenthesized (renderSQL x)
196+
197+-- | escape hatch for defining multi-argument window functions
198+unsafeWindowFunctionN :: SOP.SListI xs => ByteString -> WinFunN xs y
199+unsafeWindowFunctionN fun xs = UnsafeWindowFunction $ fun <>
200+ parenthesized (renderCommaSeparated renderSQL xs)
201+
202+{- | rank of the current row with gaps; same as `rowNumber` of its first peer
203+
204+>>> printSQL rank
205+rank()
206+-}
207+rank :: WinFun0 ('NotNull 'PGint8)
208+rank = UnsafeWindowFunction "rank()"
209+
210+{- | number of the current row within its partition, counting from 1
211+
212+>>> printSQL rowNumber
213+row_number()
214+-}
215+rowNumber :: WinFun0 ('NotNull 'PGint8)
216+rowNumber = UnsafeWindowFunction "row_number()"
217+
218+{- | rank of the current row without gaps; this function counts peer groups
219+
220+>>> printSQL denseRank
221+dense_rank()
222+-}
223+denseRank :: WinFun0 ('NotNull 'PGint8)
224+denseRank = UnsafeWindowFunction "dense_rank()"
225+
226+{- | relative rank of the current row: (rank - 1) / (total partition rows - 1)
227+
228+>>> printSQL percentRank
229+percent_rank()
230+-}
231+percentRank :: WinFun0 ('NotNull 'PGfloat8)
232+percentRank = UnsafeWindowFunction "percent_rank()"
233+
234+{- | cumulative distribution: (number of partition rows
235+preceding or peer with current row) / total partition rows
236+
237+>>> printSQL cumeDist
238+cume_dist()
239+-}
240+cumeDist :: WinFun0 ('NotNull 'PGfloat8)
241+cumeDist = UnsafeWindowFunction "cume_dist()"
242+
243+{- | integer ranging from 1 to the argument value,
244+dividing the partition as equally as possible
245+
246+>>> printSQL $ ntile 5
247+ntile(5)
248+-}
249+ntile :: WinFun1 ('NotNull 'PGint4) ('NotNull 'PGint4)
250+ntile = unsafeWindowFunction1 "ntile"
251+
252+{- | returns value evaluated at the row that is offset rows before the current
253+row within the partition; if there is no such row, instead return default
254+(which must be of the same type as value). Both offset and default are
255+evaluated with respect to the current row.
256+-}
257+lag :: WinFunN '[ty, 'NotNull 'PGint4, ty] ty
258+lag = unsafeWindowFunctionN "lag"
259+
260+{- | returns value evaluated at the row that is offset rows after the current
261+row within the partition; if there is no such row, instead return default
262+(which must be of the same type as value). Both offset and default are
263+evaluated with respect to the current row.
264+-}
265+lead :: WinFunN '[ty, 'NotNull 'PGint4, ty] ty
266+lead = unsafeWindowFunctionN "lead"
267+
268+{- | returns value evaluated at the row that is the
269+first row of the window frame
270+-}
271+firstValue :: WinFun1 ty ty
272+firstValue = unsafeWindowFunction1 "first_value"
273+
274+{- | returns value evaluated at the row that is the
275+last row of the window frame
276+-}
277+lastValue :: WinFun1 ty ty
278+lastValue = unsafeWindowFunction1 "last_value"
279+
280+{- | returns value evaluated at the row that is the nth
281+row of the window frame (counting from 1); null if no such row
282+-}
283+nthValue :: WinFunN '[null ty, 'NotNull 'PGint4] ('Null ty)
284+nthValue = unsafeWindowFunctionN "nth_value"
squeal-postgresql/src/Squeal/PostgreSQL/List.hsnew file+112
@@ -0,0 +1,112 @@
1+{-|
2+Module: Squeal.PostgreSQL.List
3+Description: List related types and functions
4+Copyright: (c) Eitan Chatav, 2019
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Haskell singly-linked lists are very powerful. This module
9+provides functionality for type-level lists, heterogeneous
10+lists and type aligned lists.
11+-}
12+
13+{-# LANGUAGE
14+ DataKinds
15+ , FlexibleContexts
16+ , GADTs
17+ , LambdaCase
18+ , MultiParamTypeClasses
19+ , OverloadedStrings
20+ , PolyKinds
21+ , QuantifiedConstraints
22+ , RankNTypes
23+ , ScopedTypeVariables
24+ , TypeApplications
25+ , TypeFamilies
26+ , TypeOperators
27+ , UndecidableInstances
28+#-}
29+
30+module Squeal.PostgreSQL.List
31+ ( SOP.NP (..)
32+ , (*:)
33+ , Join
34+ , disjoin
35+ , Additional (..)
36+ , Path (..)
37+ , CFunctor (..)
38+ , CFoldable (..)
39+ , CFree (..)
40+ , Elem
41+ , In
42+ , Length
43+ ) where
44+
45+import Control.Category.Free
46+import Data.Function ((&))
47+import Data.Kind
48+import Data.Type.Bool
49+import GHC.TypeLits
50+
51+import Generics.SOP as SOP
52+
53+-- | `Join` is simply promoted `++` and is used in @JOIN@s in
54+-- `Squeal.PostgreSQL.Query.FromClause`s.
55+type family Join xs ys where
56+ Join '[] ys = ys
57+ Join (x ': xs) ys = x ': Join xs ys
58+
59+-- | `disjoin` is a utility function for splitting an `NP` list into pieces.
60+disjoin
61+ :: forall xs ys expr. SListI xs
62+ => NP expr (Join xs ys)
63+ -> (NP expr xs, NP expr ys)
64+disjoin = case sList @xs of
65+ SNil -> \ys -> (Nil, ys)
66+ SCons -> \(x :* xsys) ->
67+ case disjoin xsys of (xs,ys) -> (x :* xs, ys)
68+
69+-- | The `Additional` class is for appending
70+-- type-level list parameterized constructors such as `NP`,
71+-- `Squeal.PostgreSQL.Query.Selection`, and `Squeal.PostgreSQL.Query.FromClause`.
72+class Additional expr where
73+ also :: expr ys -> expr xs -> expr (Join xs ys)
74+instance Additional (NP expr) where
75+ also ys = \case
76+ Nil -> ys
77+ x :* xs -> x :* (xs & also ys)
78+
79+-- | A useful operator for ending an `NP` list of length at least 2 without `Nil`.
80+(*:) :: f x -> f y -> NP f '[x,y]
81+x *: y = x :* y :* Nil
82+infixl 9 *:
83+
84+-- | @Elem@ is a promoted `Data.List.elem`.
85+type family Elem x xs where
86+ Elem x '[] = 'False
87+ Elem x (x ': _) = 'True
88+ Elem x (_ ': x ': _) = 'True
89+ Elem x (_ ': _ ': x ': _) = 'True
90+ Elem x (_ ': _ ': _ ': x ': _) = 'True
91+ Elem x (_ ': _ ': _ ': _ ': x ': _) = 'True
92+ Elem x (_ ': _ ': _ ': _ ': _ ': x ': _) = 'True
93+ Elem x (_ ': xs) = Elem x xs
94+
95+-- | @In x xs@ is a constraint that proves that @x@ is in @xs@.
96+type family In x xs :: Constraint where
97+ In x xs = If (Elem x xs) (() :: Constraint)
98+ (TypeError ('ShowType x ':<>: 'Text " is not in " ':<>: 'ShowType xs))
99+
100+{- | Calculate the `Length` of a type level list
101+
102+>>> :kind! Length '[Char,String,Bool,Double]
103+Length '[Char,String,Bool,Double] :: Nat
104+= 4
105+-}
106+type family Length (xs :: [k]) :: Nat where
107+ Length (_ ': _ ': _ ': _ ': _ : xs) = 5 + Length xs
108+ Length (_ ': _ ': _ ': _ : xs) = 4 + Length xs
109+ Length (_ ': _ ': _ : xs) = 3 + Length xs
110+ Length (_ ': _ : xs) = 2 + Length xs
111+ Length (_ : xs) = 1 + Length xs
112+ Length '[] = 0
squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hsnew file+578
@@ -0,0 +1,578 @@
1+{-|
2+Module: Squeal.PostgreSQL.Manipulation
3+Description: Squeal data manipulation language
4+Copyright: (c) Eitan Chatav, 2017
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Squeal data manipulation language.
9+-}
10+
11+{-# LANGUAGE
12+ DeriveGeneric
13+ , FlexibleContexts
14+ , FlexibleInstances
15+ , GADTs
16+ , GeneralizedNewtypeDeriving
17+ , LambdaCase
18+ , MultiParamTypeClasses
19+ , OverloadedStrings
20+ , PatternSynonyms
21+ , QuantifiedConstraints
22+ , RankNTypes
23+ , ScopedTypeVariables
24+ , TypeApplications
25+ , TypeFamilies
26+ , TypeInType
27+ , TypeOperators
28+ , UndecidableInstances
29+#-}
30+
31+module Squeal.PostgreSQL.Manipulation
32+ ( -- * Manipulation
33+ Manipulation_
34+ , Manipulation (..)
35+ , queryStatement
36+ -- * Insert
37+ , insertInto
38+ , insertInto_
39+ -- * Update
40+ , update
41+ , update_
42+ -- * Delete
43+ , 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
56+
57+import Control.DeepSeq
58+import Data.ByteString hiding (foldr)
59+import Data.Kind (Type)
60+
61+import qualified Generics.SOP as SOP
62+import qualified GHC.Generics as GHC
63+
64+import Squeal.PostgreSQL.Alias
65+import Squeal.PostgreSQL.Expression
66+import Squeal.PostgreSQL.Expression.Logic
67+import Squeal.PostgreSQL.List
68+import Squeal.PostgreSQL.PG
69+import Squeal.PostgreSQL.Render
70+import Squeal.PostgreSQL.Query
71+import Squeal.PostgreSQL.Schema
72+
73+-- $setup
74+-- >>> import Squeal.PostgreSQL
75+-- >>> import Data.Int
76+-- >>> import Data.Time
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+-}
90+newtype Manipulation
91+ (commons :: FromType)
92+ (schemas :: SchemasType)
93+ (params :: [NullityType])
94+ (columns :: RowType)
95+ = UnsafeManipulation { renderManipulation :: ByteString }
96+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
97+instance RenderSQL (Manipulation commons schemas params columns) where
98+ renderSQL = renderManipulation
99+instance With Manipulation where
100+ with Done manip = manip
101+ with ctes manip = UnsafeManipulation $
102+ "WITH" <+> commaSeparated (ctoList renderSQL ctes) <+> renderSQL manip
103+
104+{- |
105+The top level `Manipulation_` type is parameterized by a @schemas@ `SchemasType`,
106+against which the query is type-checked, an input @parameters@ Haskell `Type`,
107+and an ouput row Haskell `Type`.
108+
109+A top-level `Manipulation_` can be run
110+using `Squeal.PostgreSQL.PQ.manipulateParams`, or if @parameters = ()@
111+using `Squeal.PostgreSQL.PQ.manipulate`.
112+
113+Generally, @parameters@ will be a Haskell tuple or record whose entries
114+may be referenced using positional
115+`Squeal.PostgreSQL.Expression.Parameter.parameter`s and @row@ will be a
116+Haskell record, whose entries will be targeted using overloaded labels.
117+
118+>>> :set -XDeriveAnyClass -XDerivingStrategies
119+>>> :{
120+data Row a b = Row { col1 :: a, col2 :: b }
121+ deriving stock (GHC.Generic)
122+ deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
123+:}
124+
125+simple insert:
126+
127+>>> type Columns = '["col1" ::: 'NoDef :=> 'Null 'PGint4, "col2" ::: 'Def :=> 'NotNull 'PGint4]
128+>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]
129+>>> :{
130+let
131+ manipulation :: Manipulation_ (Public Schema) () ()
132+ manipulation =
133+ insertInto_ #tab (Values_ (Set 2 `as` #col1 :* Default `as` #col2))
134+in printSQL manipulation
135+:}
136+INSERT INTO "tab" ("col1", "col2") VALUES (2, DEFAULT)
137+
138+parameterized insert:
139+
140+>>> type Columns = '["col1" ::: 'NoDef :=> 'NotNull 'PGint4, "col2" ::: 'NoDef :=> 'NotNull 'PGint4]
141+>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]
142+>>> :{
143+let
144+ manipulation :: Manipulation_ (Public Schema) (Int32, Int32) ()
145+ manipulation =
146+ insertInto_ #tab (Values_ (Set (param @1) `as` #col1 :* Set (param @2) `as` #col2))
147+in printSQL manipulation
148+:}
149+INSERT INTO "tab" ("col1", "col2") VALUES (($1 :: int4), ($2 :: int4))
150+
151+returning insert:
152+
153+>>> :{
154+let
155+ manipulation :: Manipulation_ (Public Schema) () (Only Int32)
156+ manipulation =
157+ insertInto #tab (Values_ (Set 2 `as` #col1 :* Set 3 `as` #col2))
158+ OnConflictDoRaise (Returning (#col1 `as` #fromOnly))
159+in printSQL manipulation
160+:}
161+INSERT INTO "tab" ("col1", "col2") VALUES (2, 3) 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+
181+query insert:
182+
183+>>> :{
184+let
185+ manipulation :: Manipulation_ (Public Schema) () ()
186+ manipulation = insertInto_ #tab (Subquery (select Star (from (table #tab))))
187+in printSQL manipulation
188+:}
189+INSERT INTO "tab" SELECT * FROM "tab" AS "tab"
190+
191+update:
192+
193+>>> :{
194+let
195+ manipulation :: Manipulation_ (Public Schema) () ()
196+ manipulation = update_ #tab (Set 2 `as` #col1) (#col1 ./= #col2)
197+in printSQL manipulation
198+:}
199+UPDATE "tab" SET "col1" = 2 WHERE ("col1" <> "col2")
200+
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+:}
209+DELETE FROM "tab" WHERE ("col1" = "col2") RETURNING *
210+
211+delete and using clause:
212+
213+>>> :{
214+type Schema3 =
215+ '[ "tab" ::: 'Table ('[] :=> Columns)
216+ , "other_tab" ::: 'Table ('[] :=> Columns)
217+ , "third_tab" ::: 'Table ('[] :=> Columns) ]
218+:}
219+
220+>>> :{
221+let
222+ manipulation :: Manipulation_ (Public Schema3) () ()
223+ manipulation =
224+ deleteFrom #tab (Using (table #other_tab & also (table #third_tab)))
225+ ( (#tab ! #col2 .== #other_tab ! #col2)
226+ .&& (#tab ! #col2 .== #third_tab ! #col2) )
227+ (Returning_ Nil)
228+in printSQL manipulation
229+:}
230+DELETE FROM "tab" USING "other_tab" AS "other_tab", "third_tab" AS "third_tab" WHERE (("tab"."col2" = "other_tab"."col2") AND ("tab"."col2" = "third_tab"."col2"))
231+
232+with manipulation:
233+
234+>>> type ProductsColumns = '["product" ::: 'NoDef :=> 'NotNull 'PGtext, "date" ::: 'Def :=> 'NotNull 'PGdate]
235+>>> type ProductsSchema = '["products" ::: 'Table ('[] :=> ProductsColumns), "products_deleted" ::: 'Table ('[] :=> ProductsColumns)]
236+>>> :{
237+let
238+ manipulation :: Manipulation_ (Public ProductsSchema) (Only Day) ()
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+:}
244+WITH "del" AS (DELETE FROM "products" WHERE ("date" < ($1 :: date)) RETURNING *) INSERT INTO "products_deleted" SELECT * FROM "del" AS "del"
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+-}
267+insertInto
268+ :: ( Has sch schemas schema
269+ , Has tab schema ('Table table)
270+ , columns ~ TableToColumns table
271+ , row0 ~ TableToRow table
272+ , SOP.SListI columns
273+ , SOP.SListI row1 )
274+ => QualifiedAlias sch tab
275+ -- ^ table
276+ -> QueryClause commons schemas params columns
277+ -- ^ what to insert
278+ -> ConflictClause tab commons schemas params table
279+ -- ^ what to do in case of conflict
280+ -> ReturningClause commons schemas params '[tab ::: row0] row1
281+ -- ^ what to return
282+ -> Manipulation commons schemas params row1
283+insertInto tab qry conflict ret = UnsafeManipulation $
284+ "INSERT" <+> "INTO" <+> renderSQL tab
285+ <+> renderSQL qry
286+ <> renderSQL conflict
287+ <> renderSQL ret
288+
289+-- | Like `insertInto` but with `OnConflictDoRaise` and `no` `ReturningClause`.
290+insertInto_
291+ :: ( Has sch schemas schema
292+ , Has tab schema ('Table table)
293+ , columns ~ TableToColumns table
294+ , row ~ TableToRow table
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
360+ => NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[]))) columns
361+ -- ^ row of values
362+ -> QueryClause commons schemas params columns
363+pattern Values_ vals = Values vals []
364+
365+-- | `Optional` is either `Default` or a value, parameterized by an appropriate
366+-- `ColumnConstraint`.
367+data Optional expr ty where
368+ -- | Use the `Default` value for a column.
369+ Default :: Optional expr ('Def :=> ty)
370+ -- | `Set` a value for a column.
371+ Set :: expr ty -> Optional expr (def :=> ty)
372+
373+instance (forall x. RenderSQL (expr x)) => RenderSQL (Optional expr ty) where
374+ renderSQL = \case
375+ Default -> "DEFAULT"
376+ Set expr -> renderSQL expr
377+
378+-- | A `ReturningClause` computes and return value(s) based
379+-- on each row actually inserted, updated or deleted. This is primarily
380+-- useful for obtaining values that were supplied by defaults, such as a
381+-- serial sequence number. However, any expression using the table's columns
382+-- is allowed. Only rows that were successfully inserted or updated or
383+-- deleted will be returned. For example, if a row was locked
384+-- but not updated because an `OnConflict` `DoUpdate` condition was not satisfied,
385+-- the row will not be returned. `Returning` `Star` will return all columns
386+-- in the row. Use `Returning` `Nil` in the common case where no return
387+-- values are desired.
388+newtype ReturningClause commons schemas params from row =
389+ Returning (Selection '[] commons 'Ungrouped schemas params from row)
390+
391+instance RenderSQL (ReturningClause commons schemas params from row) where
392+ renderSQL = \case
393+ Returning (List Nil) -> ""
394+ Returning selection -> " RETURNING" <+> renderSQL selection
395+
396+-- | `Returning` a `List`
397+pattern Returning_
398+ :: SOP.SListI row
399+ => NP (Aliased (Expression '[] commons 'Ungrouped schemas params from)) row
400+ -- ^ row of values
401+ -> ReturningClause commons schemas params from row
402+pattern Returning_ list = Returning (List list)
403+
404+-- | A `ConflictClause` specifies an action to perform upon a constraint
405+-- violation. `OnConflictDoRaise` will raise an error.
406+-- `OnConflict` `DoNothing` simply avoids inserting a row.
407+-- `OnConflict` `DoUpdate` updates the existing row that conflicts with the row
408+-- proposed for insertion.
409+data ConflictClause tab commons schemas params table where
410+ OnConflictDoRaise :: ConflictClause tab commons schemas params table
411+ OnConflict
412+ :: ConflictTarget constraints
413+ -- ^ conflict target
414+ -> ConflictAction tab commons schemas params columns
415+ -- ^ conflict action
416+ -> ConflictClause tab commons schemas params (constraints :=> columns)
417+
418+-- | Render a `ConflictClause`.
419+instance SOP.SListI (TableToColumns table)
420+ => RenderSQL (ConflictClause tab commons schemas params table) where
421+ renderSQL = \case
422+ OnConflictDoRaise -> ""
423+ OnConflict target action -> " ON CONFLICT"
424+ <+> renderSQL target <+> renderSQL action
425+
426+{- |
427+`ConflictAction` specifies an alternative `OnConflict` action.
428+It can be either `DoNothing`, or a `DoUpdate` clause specifying
429+the exact details of the `update` action to be performed in case of a conflict.
430+The `Set` and WHERE `Condition`s in `OnConflict` `DoUpdate` have access to the
431+existing row using the table's name (or an alias), and to rows proposed
432+for insertion using the special @#excluded@ table.
433+`OnConflict` `DoNothing` simply avoids inserting a row as its alternative action.
434+`OnConflict` `DoUpdate` updates the existing row that conflicts
435+with the row proposed for insertion as its alternative action.
436+-}
437+data ConflictAction tab commons schemas params columns where
438+ DoNothing :: ConflictAction tab commons schemas params columns
439+ DoUpdate
440+ :: ( row ~ ColumnsToRow columns
441+ , SOP.SListI columns
442+ , columns ~ (col0 ': cols)
443+ , SOP.All (HasIn columns) subcolumns
444+ , AllUnique subcolumns )
445+ => NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[tab ::: row, "excluded" ::: row]))) subcolumns
446+ -> [Condition '[] commons 'Ungrouped schemas params '[tab ::: row, "excluded" ::: row]]
447+ -- ^ WHERE `Condition`s
448+ -> ConflictAction tab commons schemas params columns
449+
450+instance RenderSQL (ConflictAction tab commons schemas params columns) where
451+ renderSQL = \case
452+ DoNothing -> "DO NOTHING"
453+ DoUpdate updates whs'
454+ -> "DO UPDATE SET"
455+ <+> renderCommaSeparated renderUpdate updates
456+ <> case whs' of
457+ [] -> ""
458+ wh:whs -> " WHERE" <+> renderSQL (foldr (.&&) wh whs)
459+
460+renderUpdate
461+ :: (forall x. RenderSQL (expr x))
462+ => Aliased (Optional expr) ty
463+ -> ByteString
464+renderUpdate (expr `As` col) = renderSQL col <+> "=" <+> renderSQL expr
465+
466+-- | A `ConflictTarget` specifies the constraint violation that triggers a
467+-- `ConflictAction`.
468+data ConflictTarget constraints where
469+ OnConstraint
470+ :: Has con constraints constraint
471+ => Alias con
472+ -> ConflictTarget constraints
473+
474+-- | Render a `ConflictTarget`
475+instance RenderSQL (ConflictTarget constraints) where
476+ renderSQL (OnConstraint con) =
477+ "ON" <+> "CONSTRAINT" <+> renderSQL con
478+
479+{-----------------------------------------
480+UPDATE statements
481+-----------------------------------------}
482+
483+-- | An `update` command changes the values of the specified columns
484+-- in all rows that satisfy the condition.
485+update
486+ :: ( SOP.SListI columns
487+ , SOP.SListI row1
488+ , Has sch schemas schema
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
497+ -> Condition '[] commons 'Ungrouped schemas params '[tab ::: row0]
498+ -- ^ condition under which to perform update on a row
499+ -> ReturningClause commons schemas params '[tab ::: row0] row1 -- ^ results to return
500+ -> Manipulation commons schemas params row1
501+update tab columns wh returning = UnsafeManipulation $
502+ "UPDATE"
503+ <+> renderSQL tab
504+ <+> "SET"
505+ <+> renderCommaSeparated renderUpdate columns
506+ <+> "WHERE" <+> renderSQL wh
507+ <> renderSQL returning
508+
509+-- | Update a row returning `Nil`.
510+update_
511+ :: ( SOP.SListI columns
512+ , Has sch schemas schema
513+ , Has tab schema ('Table table)
514+ , row ~ TableToRow table
515+ , columns ~ TableToColumns table
516+ , SOP.All (HasIn columns) subcolumns
517+ , AllUnique subcolumns )
518+ => QualifiedAlias sch tab -- ^ table to update
519+ -> NP (Aliased (Optional (Expression '[] '[] 'Ungrouped schemas params '[tab ::: row]))) subcolumns
520+ -- ^ modified values to replace old values
521+ -> Condition '[] commons 'Ungrouped schemas params '[tab ::: row]
522+ -- ^ condition under which to perform update on a row
523+ -> Manipulation commons schemas params '[]
524+update_ tab columns wh = update tab columns wh (Returning_ Nil)
525+
526+{-----------------------------------------
527+DELETE statements
528+-----------------------------------------}
529+
530+-- | Specify additional tables with `Using`
531+-- an `also` list of table expressions, allowing columns
532+-- from other tables to appear in the WHERE condition.
533+-- This is similar to the list of tables that can be specified
534+-- in the FROM Clause of a SELECT statement;
535+-- for example, an alias for the table name can be specified.
536+-- Do not repeat the target table in the `Using` list,
537+-- unless you wish to set up a self-join.
538+-- `NoUsing` if no additional tables are to be used.
539+data UsingClause commons schemas params from where
540+ NoUsing :: UsingClause commons schemas params '[]
541+ Using
542+ :: FromClause '[] commons schemas params from
543+ -- ^ what to use
544+ -> UsingClause commons schemas params from
545+
546+-- | Delete rows from a table.
547+deleteFrom
548+ :: ( SOP.SListI row1
549+ , Has sch schemas schema
550+ , Has tab schema ('Table table)
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
577+ -> Manipulation commons schemas params '[]
578+deleteFrom_ tab wh = deleteFrom tab NoUsing wh (Returning_ Nil)
squeal-postgresql/src/Squeal/PostgreSQL/Migration.hsnew file+448
@@ -0,0 +1,448 @@
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.hsnew file+388
@@ -0,0 +1,388 @@
1+{-|
2+Module: Squeal.PostgreSQL.PG
3+Description: Embedding of Haskell types into Postgres's type system
4+Copyright: (c) Eitan Chatav, 2010
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+`Squeal.PostgreSQL.PG` provides type families for turning Haskell
9+`Type`s into corresponding Postgres types.
10+-}
11+{-# LANGUAGE
12+ AllowAmbiguousTypes
13+ , DeriveAnyClass
14+ , DeriveFoldable
15+ , DeriveFunctor
16+ , DeriveGeneric
17+ , DeriveTraversable
18+ , DerivingStrategies
19+ , DefaultSignatures
20+ , FlexibleContexts
21+ , FlexibleInstances
22+ , FunctionalDependencies
23+ , GADTs
24+ , LambdaCase
25+ , MultiParamTypeClasses
26+ , OverloadedStrings
27+ , ScopedTypeVariables
28+ , TypeApplications
29+ , TypeFamilies
30+ , TypeInType
31+ , TypeOperators
32+ , UndecidableInstances
33+ , UndecidableSuperClasses
34+#-}
35+
36+module Squeal.PostgreSQL.PG
37+ ( -- * PG embeddings
38+ PG
39+ , NullPG
40+ , TuplePG
41+ , RowPG
42+ -- * Storage newtypes
43+ , Money (..)
44+ , Json (..)
45+ , Jsonb (..)
46+ , Composite (..)
47+ , Enumerated (..)
48+ , VarArray (..)
49+ , FixArray (..)
50+ , LibPQ.Oid (..)
51+ -- * Type families
52+ , LabelsPG
53+ , DimPG
54+ , FixPG
55+ , TupleOf
56+ , TupleCodeOf
57+ , RowOf
58+ , ConstructorsOf
59+ , ConstructorNameOf
60+ , ConstructorNamesOf
61+ ) where
62+
63+import Data.Aeson (Value)
64+import Data.Kind (Type)
65+import Data.Int (Int16, Int32, Int64)
66+import Data.Scientific (Scientific)
67+import Data.Time (Day, DiffTime, LocalTime, TimeOfDay, TimeZone, UTCTime)
68+import Data.Vector (Vector)
69+import Data.UUID.Types (UUID)
70+import GHC.TypeLits
71+import Network.IP.Addr (NetAddr, IP)
72+
73+import qualified Data.ByteString.Lazy as Lazy (ByteString)
74+import qualified Data.ByteString as Strict (ByteString)
75+import qualified Data.Text.Lazy as Lazy (Text)
76+import qualified Data.Text as Strict (Text)
77+import qualified Database.PostgreSQL.LibPQ as LibPQ
78+import qualified GHC.Generics as GHC
79+import qualified Generics.SOP as SOP
80+import qualified Generics.SOP.Record as SOP
81+import qualified Generics.SOP.Type.Metadata as Type
82+
83+import Squeal.PostgreSQL.Alias
84+import Squeal.PostgreSQL.Schema
85+
86+-- $setup
87+-- >>> import Squeal.PostgreSQL
88+-- >>> import Data.Text (Text)
89+
90+{- | The `PG` type family embeds a subset of Haskell types
91+as Postgres types. As an open type family, `PG` is extensible.
92+
93+>>> :kind! PG LocalTime
94+PG LocalTime :: PGType
95+= 'PGtimestamp
96+
97+>>> newtype MyDouble = My Double
98+>>> :set -XTypeFamilies
99+>>> type instance PG MyDouble = 'PGfloat8
100+-}
101+type family PG (hask :: Type) :: PGType
102+-- | `PGbool`
103+type instance PG Bool = 'PGbool
104+-- | `PGint2`
105+type instance PG Int16 = 'PGint2
106+-- | `PGint4`
107+type instance PG Int32 = 'PGint4
108+-- | `PGint8`
109+type instance PG Int64 = 'PGint8
110+-- | `PGint2`
111+type instance PG LibPQ.Oid = 'PGoid
112+-- | `PGnumeric`
113+type instance PG Scientific = 'PGnumeric
114+-- | `PGfloat4`
115+type instance PG Float = 'PGfloat4
116+-- | `PGfloat8`
117+type instance PG Double = 'PGfloat8
118+-- | `PGchar` @1@
119+type instance PG Char = 'PGchar 1
120+-- | `PGtext`
121+type instance PG Strict.Text = 'PGtext
122+-- | `PGtext`
123+type instance PG Lazy.Text = 'PGtext
124+-- | `PGtext`
125+type instance PG String = 'PGtext
126+-- | `PGbytea`
127+type instance PG Strict.ByteString = 'PGbytea
128+-- | `PGbytea`
129+type instance PG Lazy.ByteString = 'PGbytea
130+-- | `PGtimestamp`
131+type instance PG LocalTime = 'PGtimestamp
132+-- | `PGtimestamptz`
133+type instance PG UTCTime = 'PGtimestamptz
134+-- | `PGdate`
135+type instance PG Day = 'PGdate
136+-- | `PGtime`
137+type instance PG TimeOfDay = 'PGtime
138+-- | `PGtimetz`
139+type instance PG (TimeOfDay, TimeZone) = 'PGtimetz
140+-- | `PGinterval`
141+type instance PG DiffTime = 'PGinterval
142+-- | `PGuuid`
143+type instance PG UUID = 'PGuuid
144+-- | `PGinet`
145+type instance PG (NetAddr IP) = 'PGinet
146+-- | `PGjson`
147+type instance PG Value = 'PGjson
148+
149+{-| The `LabelsPG` type family calculates the constructors of a
150+Haskell enum type.
151+
152+>>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic
153+>>> instance SOP.Generic Schwarma
154+>>> instance SOP.HasDatatypeInfo Schwarma
155+>>> :kind! LabelsPG Schwarma
156+LabelsPG Schwarma :: [Type.ConstructorName]
157+= '["Beef", "Lamb", "Chicken"]
158+-}
159+type family LabelsPG (hask :: Type) :: [Type.ConstructorName] where
160+ LabelsPG hask =
161+ ConstructorNamesOf (ConstructorsOf (SOP.DatatypeInfoOf hask))
162+
163+{- |
164+`RowPG` turns a Haskell `Type` into a `RowType`.
165+
166+`RowPG` may be applied to normal Haskell record types provided they
167+have `SOP.Generic` and `SOP.HasDatatypeInfo` instances;
168+
169+>>> data Person = Person { name :: Strict.Text, age :: Int32 } deriving GHC.Generic
170+>>> instance SOP.Generic Person
171+>>> instance SOP.HasDatatypeInfo Person
172+>>> :kind! RowPG Person
173+RowPG Person :: [(Symbol, NullityType)]
174+= '["name" ::: 'NotNull 'PGtext, "age" ::: 'NotNull 'PGint4]
175+-}
176+type family RowPG (hask :: Type) :: RowType where
177+ RowPG hask = RowOf (SOP.RecordCodeOf hask)
178+
179+-- | `RowOf` applies `NullPG` to the fields of a list.
180+type family RowOf (record :: [(Symbol, Type)]) :: RowType where
181+ RowOf (col ::: ty ': col1 ::: ty1 ': col2 ::: ty2 ': col3 ::: ty3 ': col4 ::: ty4 ': record) =
182+ col ::: NullPG ty ': col1 ::: NullPG ty1 ': col2 ::: NullPG ty2 ': col3 ::: NullPG ty3 ': col4 ::: NullPG ty4 ': RowOf record
183+ RowOf (col ::: ty ': col1 ::: ty1 ': col2 ::: ty2 ': col3 ::: ty3 ': record) =
184+ col ::: NullPG ty ': col1 ::: NullPG ty1 ': col2 ::: NullPG ty2 ': col3 ::: NullPG ty3 ': RowOf record
185+ RowOf (col ::: ty ': col1 ::: ty1 ': col2 ::: ty2 ': record) =
186+ col ::: NullPG ty ': col1 ::: NullPG ty1 ': col2 ::: NullPG ty2 ': RowOf record
187+ RowOf (col ::: ty ': col1 ::: ty1 ': record) =
188+ col ::: NullPG ty ': col1::: NullPG ty1 ': RowOf record
189+ RowOf (col ::: ty ': record) = col ::: NullPG ty ': RowOf record
190+ RowOf '[] = '[]
191+
192+{- | `NullPG` turns a Haskell type into a `NullityType`.
193+
194+>>> :kind! NullPG Double
195+NullPG Double :: NullityType
196+= 'NotNull 'PGfloat8
197+>>> :kind! NullPG (Maybe Double)
198+NullPG (Maybe Double) :: NullityType
199+= 'Null 'PGfloat8
200+-}
201+type family NullPG (hask :: Type) :: NullityType where
202+ NullPG (Maybe hask) = 'Null (PG hask)
203+ NullPG hask = 'NotNull (PG hask)
204+
205+{- | `TuplePG` turns a Haskell tuple type (including record types) into
206+the corresponding list of `NullityType`s.
207+
208+>>> :kind! TuplePG (Double, Maybe Char)
209+TuplePG (Double, Maybe Char) :: [NullityType]
210+= '[ 'NotNull 'PGfloat8, 'Null ('PGchar 1)]
211+-}
212+type family TuplePG (hask :: Type) :: [NullityType] where
213+ TuplePG hask = TupleOf (TupleCodeOf hask (SOP.Code hask))
214+
215+-- | `TupleOf` turns a list of Haskell `Type`s into a list of `NullityType`s.
216+type family TupleOf (tuple :: [Type]) :: [NullityType] where
217+ TupleOf (hask ': hask1 ': hask2 ': hask3 ': hask4 ': hask5 ': tuple) =
218+ NullPG hask ': NullPG hask1 ': NullPG hask2 ': NullPG hask3 ': NullPG hask4 ': NullPG hask5 ': TupleOf tuple
219+ TupleOf (hask ': hask1 ': hask2 ': hask3 ': hask4 ': tuple) =
220+ NullPG hask ': NullPG hask1 ': NullPG hask2 ': NullPG hask3 ': NullPG hask4 ': TupleOf tuple
221+ TupleOf (hask ': hask1 ': hask2 ': hask3 ': tuple) =
222+ NullPG hask ': NullPG hask1 ': NullPG hask2 ': NullPG hask3 ': TupleOf tuple
223+ TupleOf (hask ': hask1 ': hask2 ': tuple) =
224+ NullPG hask ': NullPG hask1 ': NullPG hask2 ': TupleOf tuple
225+ TupleOf (hask ': hask1 ': tuple) = NullPG hask ': NullPG hask1 ': TupleOf tuple
226+ TupleOf (hask ': tuple) = NullPG hask ': TupleOf tuple
227+ TupleOf '[] = '[]
228+
229+-- | `TupleCodeOf` takes the `SOP.Code` of a haskell `Type`
230+-- and if it's a simple product returns it, otherwise giving a `TypeError`.
231+type family TupleCodeOf (hask :: Type) (code :: [[Type]]) :: [Type] where
232+ TupleCodeOf hask '[tuple] = tuple
233+ TupleCodeOf hask '[] =
234+ TypeError
235+ ( 'Text "The type `" ':<>: 'ShowType hask ':<>: 'Text "' is not a tuple type."
236+ ':$$: 'Text "It is a void type with no constructors."
237+ )
238+ TupleCodeOf hask (_ ': _ ': _) =
239+ TypeError
240+ ( 'Text "The type `" ':<>: 'ShowType hask ':<>: 'Text "' is not a tuple type."
241+ ':$$: 'Text "It is a sum type with more than one constructor."
242+ )
243+
244+-- | Calculates constructors of a datatype.
245+type family ConstructorsOf (datatype :: Type.DatatypeInfo)
246+ :: [Type.ConstructorInfo] where
247+ ConstructorsOf ('Type.ADT _module _datatype constructors) =
248+ constructors
249+ ConstructorsOf ('Type.Newtype _module _datatype constructor) =
250+ '[constructor]
251+
252+-- | Calculates the name of a nullary constructor, otherwise
253+-- generates a type error.
254+type family ConstructorNameOf (constructor :: Type.ConstructorInfo)
255+ :: Type.ConstructorName where
256+ ConstructorNameOf ('Type.Constructor name) = name
257+ ConstructorNameOf ('Type.Infix name _assoc _fix) = TypeError
258+ ('Text "ConstructorNameOf error: non-nullary constructor "
259+ ':<>: 'Text name)
260+ ConstructorNameOf ('Type.Record name _fields) = TypeError
261+ ('Text "ConstructorNameOf error: non-nullary constructor "
262+ ':<>: 'Text name)
263+
264+-- | Calculate the names of nullary constructors.
265+type family ConstructorNamesOf (constructors :: [Type.ConstructorInfo])
266+ :: [Type.ConstructorName] where
267+ ConstructorNamesOf '[] = '[]
268+ ConstructorNamesOf (constructor ': constructors) =
269+ ConstructorNameOf constructor ': ConstructorNamesOf constructors
270+
271+-- | `DimPG` turns Haskell nested homogeneous tuples into a list of lengths.
272+type family DimPG (hask :: Type) :: [Nat] where
273+ DimPG (x,x) = 2 ': DimPG x
274+ DimPG (x,x,x) = 3 ': DimPG x
275+ DimPG (x,x,x,x) = 4 ': DimPG x
276+ DimPG (x,x,x,x,x) = 5 ': DimPG x
277+ DimPG (x,x,x,x,x,x) = 6 ': DimPG x
278+ DimPG (x,x,x,x,x,x,x) = 7 ': DimPG x
279+ DimPG (x,x,x,x,x,x,x,x) = 8 ': DimPG x
280+ DimPG (x,x,x,x,x,x,x,x,x) = 9 ': DimPG x
281+ DimPG (x,x,x,x,x,x,x,x,x,x) = 10 ': DimPG x
282+ DimPG x = '[]
283+
284+-- | `FixPG` extracts `NullPG` of the base type of nested homogeneous tuples.
285+type family FixPG (hask :: Type) :: NullityType where
286+ FixPG (x,x) = FixPG x
287+ FixPG (x,x,x) = FixPG x
288+ FixPG (x,x,x,x) = FixPG x
289+ FixPG (x,x,x,x,x) = FixPG x
290+ FixPG (x,x,x,x,x,x) = FixPG x
291+ FixPG (x,x,x,x,x,x,x) = FixPG x
292+ FixPG (x,x,x,x,x,x,x,x) = FixPG x
293+ FixPG (x,x,x,x,x,x,x,x,x) = FixPG x
294+ FixPG (x,x,x,x,x,x,x,x,x,x) = FixPG x
295+ FixPG (x,x,x,x,x,x,x,x,x,x,x) = FixPG x
296+ FixPG x = NullPG x
297+
298+{- | The `Money` newtype stores a monetary value in terms
299+of the number of cents, i.e. @$2,000.20@ would be expressed as
300+@Money { cents = 200020 }@.
301+
302+>>> import Control.Monad (void)
303+>>> import Control.Monad.IO.Class (liftIO)
304+>>> import Squeal.PostgreSQL
305+>>> :{
306+let
307+ roundTrip :: Query_ (Public '[]) (Only Money) (Only Money)
308+ roundTrip = values_ $ parameter @1 money `as` #fromOnly
309+:}
310+
311+>>> let input = Only (Money 20020)
312+
313+>>> :{
314+withConnection "host=localhost port=5432 dbname=exampledb" $ do
315+ result <- runQueryParams roundTrip input
316+ Just output <- firstRow result
317+ liftIO . print $ input == output
318+:}
319+True
320+-}
321+newtype Money = Money { cents :: Int64 }
322+ deriving stock (Eq, Ord, Show, Read, GHC.Generic)
323+ deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
324+-- | `PGmoney`
325+type instance PG Money = 'PGmoney
326+
327+{- | The `Json` newtype is an indication that the Haskell
328+type it's applied to should be stored as a `PGjson`.
329+-}
330+newtype Json hask = Json {getJson :: hask}
331+ deriving stock (Eq, Ord, Show, Read, GHC.Generic)
332+ deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
333+-- | `PGjson`
334+type instance PG (Json hask) = 'PGjson
335+
336+{- | The `Jsonb` newtype is an indication that the Haskell
337+type it's applied to should be stored as a `PGjsonb`.
338+-}
339+newtype Jsonb hask = Jsonb {getJsonb :: hask}
340+ deriving stock (Eq, Ord, Show, Read, GHC.Generic)
341+ deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
342+-- | `PGjsonb`
343+type instance PG (Jsonb hask) = 'PGjsonb
344+
345+{- | The `Composite` newtype is an indication that the Haskell
346+type it's applied to should be stored as a `PGcomposite`.
347+-}
348+newtype Composite record = Composite {getComposite :: record}
349+ deriving stock (Eq, Ord, Show, Read, GHC.Generic)
350+ deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
351+-- | `PGcomposite` @(@`RowPG` @hask)@
352+type instance PG (Composite hask) = 'PGcomposite (RowPG hask)
353+
354+{- | The `Enumerated` newtype is an indication that the Haskell
355+type it's applied to should be stored as a `PGenum`.
356+-}
357+newtype Enumerated enum = Enumerated {getEnumerated :: enum}
358+ deriving stock (Eq, Ord, Show, Read, GHC.Generic)
359+ deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
360+-- | `PGenum` @(@`LabelsPG` @hask)@
361+type instance PG (Enumerated hask) = 'PGenum (LabelsPG hask)
362+
363+{- | The `VarArray` newtype is an indication that the Haskell
364+type it's applied to should be stored as a `PGvararray`.
365+
366+>>> :kind! PG (VarArray (Vector Double))
367+PG (VarArray (Vector Double)) :: PGType
368+= 'PGvararray ('NotNull 'PGfloat8)
369+-}
370+newtype VarArray arr = VarArray {getVarArray :: arr}
371+ deriving stock (Eq, Ord, Show, Read, GHC.Generic)
372+ deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
373+-- | `PGvararray` @(@`NullPG` @hask)@
374+type instance PG (VarArray (Vector hask)) = 'PGvararray (NullPG hask)
375+type instance PG (VarArray [hask]) = 'PGvararray (NullPG hask)
376+
377+{- | The `FixArray` newtype is an indication that the Haskell
378+type it's applied to should be stored as a `PGfixarray`.
379+
380+>>> :kind! PG (FixArray ((Double, Double), (Double, Double)))
381+PG (FixArray ((Double, Double), (Double, Double))) :: PGType
382+= 'PGfixarray '[2, 2] ('NotNull 'PGfloat8)
383+-}
384+newtype FixArray arr = FixArray {getFixArray :: arr}
385+ deriving stock (Eq, Ord, Show, Read, GHC.Generic)
386+ deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
387+-- | `PGfixarray` @(@`DimPG` @hask) (@`FixPG` @hask)@
388+type instance PG (FixArray hask) = 'PGfixarray (DimPG hask) (FixPG hask)
squeal-postgresql/src/Squeal/PostgreSQL/PQ.hsnew file+712
@@ -0,0 +1,712 @@
1+{-|
2+Module: Squeal.PostgreSQL.PQ
3+Description: PQ monad
4+Copyright: (c) Eitan Chatav, 2017
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+This module is where Squeal commands actually get executed by
9+`Database.PostgreSQL.LibPQ`. It containts two typeclasses, `IndexedMonadTransPQ` for executing
10+a `Definition` and `MonadPQ` for executing 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+-}
20+
21+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
22+{-# LANGUAGE
23+ DefaultSignatures
24+ , FunctionalDependencies
25+ , FlexibleContexts
26+ , FlexibleInstances
27+ , InstanceSigs
28+ , OverloadedStrings
29+ , RankNTypes
30+ , ScopedTypeVariables
31+ , TypeApplications
32+ , TypeFamilies
33+ , TypeInType
34+ , TypeOperators
35+ , UndecidableInstances
36+#-}
37+
38+module Squeal.PostgreSQL.PQ
39+ ( -- * Connection
40+ LibPQ.Connection
41+ , connectdb
42+ , finish
43+ , withConnection
44+ , lowerConnection
45+ -- * PQ
46+ , PQ (PQ, unPQ)
47+ , runPQ
48+ , execPQ
49+ , evalPQ
50+ , IndexedMonadTransPQ (..)
51+ , MonadPQ (..)
52+ -- * Results
53+ , LibPQ.Result
54+ , LibPQ.Row
55+ , ntuples
56+ , getRow
57+ , getRows
58+ , nextRow
59+ , firstRow
60+ , 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
73+
74+import Control.Exception (Exception, throw)
75+import Control.Monad.Except
76+import Control.Monad.Morph
77+import UnliftIO (MonadUnliftIO (..), bracket, catch, handle, try)
78+import Data.ByteString (ByteString)
79+import Data.Foldable
80+import Data.Function ((&))
81+import Data.Functor ((<&>))
82+import Data.Kind
83+import Data.Text (pack, Text)
84+import Data.Traversable
85+import Generics.SOP
86+import PostgreSQL.Binary.Encoding (encodingBytes)
87+
88+import qualified Control.Monad.Fail as Fail
89+import qualified Database.PostgreSQL.LibPQ as LibPQ
90+import qualified PostgreSQL.Binary.Encoding as Encoding
91+
92+import Squeal.PostgreSQL.Binary
93+import Squeal.PostgreSQL.Definition
94+import Squeal.PostgreSQL.Manipulation
95+import Squeal.PostgreSQL.Query
96+import Squeal.PostgreSQL.Schema
97+
98+-- For `MonadPQ` transformer instances
99+import Control.Monad.Trans.Identity
100+import Control.Monad.Trans.Reader
101+import Control.Monad.Trans.Maybe
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+
114+{- | Makes a new connection to the database server.
115+
116+This function opens a new database connection using the parameters taken
117+from the string conninfo.
118+
119+The passed string can be empty to use all default parameters, or it can
120+contain one or more parameter settings separated by whitespace.
121+Each parameter setting is in the form keyword = value. Spaces around the equal
122+sign are optional. To write an empty value or a value containing spaces,
123+surround it with single quotes, e.g., keyword = 'a value'. Single quotes and
124+backslashes within the value must be escaped with a backslash, i.e., ' and \.
125+
126+To specify the schema you wish to connect with, use type application.
127+
128+>>> :set -XDataKinds
129+>>> :set -XPolyKinds
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+
136+Note that, for now, squeal doesn't offer any protection from connecting
137+with the wrong schema!
138+-}
139+connectdb
140+ :: forall schemas io
141+ . MonadIO io
142+ => ByteString -- ^ conninfo
143+ -> io (K LibPQ.Connection schemas)
144+connectdb = fmap K . liftIO . LibPQ.connectdb
145+
146+-- | Closes the connection to the server.
147+finish :: MonadIO io => K LibPQ.Connection schemas -> io ()
148+finish = liftIO . LibPQ.finish . unK
149+
150+-- | Do `connectdb` and `finish` before and after a computation.
151+withConnection
152+ :: forall schemas0 schemas1 io x
153+ . MonadUnliftIO io
154+ => ByteString
155+ -> PQ schemas0 schemas1 io x
156+ -> io x
157+withConnection connString action = do
158+ K x <- bracket (connectdb connString) finish (unPQ action)
159+ return x
160+
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+
167+-- | We keep track of the schema via an Atkey indexed state monad transformer,
168+-- `PQ`.
169+newtype PQ
170+ (schemas0 :: SchemasType)
171+ (schemas1 :: SchemasType)
172+ (m :: Type -> Type)
173+ (x :: Type) =
174+ PQ { unPQ :: K LibPQ.Connection schemas0 -> m (K x schemas1) }
175+
176+instance Monad m => Functor (PQ schemas0 schemas1 m) where
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`.
192+execPQ
193+ :: Functor m
194+ => PQ schemas0 schemas1 m x
195+ -> K LibPQ.Connection schemas0
196+ -> m (K LibPQ.Connection schemas1)
197+execPQ (PQ pq) conn = mapKK (\ _ -> unK conn) <$> pq conn
198+
199+-- | Evaluate a `PQ` and discard the `LibPQ.Connection` but keep the result.
200+evalPQ
201+ :: Functor m
202+ => PQ schemas0 schemas1 m x
203+ -> K LibPQ.Connection schemas0
204+ -> m x
205+evalPQ (PQ pq) conn = unK <$> pq conn
206+
207+-- | An [Atkey indexed monad](https://bentnib.org/paramnotions-jfp.pdf) is a `Functor`
208+-- [enriched category](https://ncatlab.org/nlab/show/enriched+category).
209+-- An indexed monad transformer transforms a `Monad` into an indexed monad.
210+-- And, `IndexedMonadTransPQ` is a class for indexed monad transformers that
211+-- support running `Definition`s using `define`.
212+class IndexedMonadTransPQ pq where
213+
214+ -- | indexed analog of `<*>`
215+ pqAp
216+ :: Monad m
217+ => pq schemas0 schemas1 m (x -> y)
218+ -> pq schemas1 schemas2 m x
219+ -> pq schemas0 schemas2 m y
220+
221+ -- | indexed analog of `join`
222+ pqJoin
223+ :: Monad m
224+ => pq schemas0 schemas1 m (pq schemas1 schemas2 m y)
225+ -> pq schemas0 schemas2 m y
226+ pqJoin pq = pq & pqBind id
227+
228+ -- | indexed analog of `=<<`
229+ pqBind
230+ :: Monad m
231+ => (x -> pq schemas1 schemas2 m y)
232+ -> pq schemas0 schemas1 m x
233+ -> pq schemas0 schemas2 m y
234+
235+ -- | indexed analog of flipped `>>`
236+ pqThen
237+ :: Monad m
238+ => pq schemas1 schemas2 m y
239+ -> pq schemas0 schemas1 m x
240+ -> pq schemas0 schemas2 m y
241+ pqThen pq2 pq1 = pq1 & pqBind (\ _ -> pq2)
242+
243+ -- | indexed analog of `<=<`
244+ pqAndThen
245+ :: Monad m
246+ => (y -> pq schemas1 schemas2 m z)
247+ -> (x -> pq schemas0 schemas1 m y)
248+ -> x -> pq schemas0 schemas2 m z
249+ pqAndThen g f x = pqBind g (f x)
250+
251+ -- | Run a `Definition` with `LibPQ.exec`.
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+
283+* `manipulateParams` runs a `Manipulation` with params from a type
284+ with a `ToParams` constraint. It calls `LibPQ.execParams` and
285+ doesn't afraid of anything.
286+
287+* `manipulateParams_` is like `manipulateParams` for a returning-free statement.
288+
289+* `manipulate` is like `manipulateParams` for a parameter-free statement.
290+
291+* `manipulate_` is like `manipulate` for a returning-free statement.
292+
293+* `runQueryParams` is like `manipulateParams` for query statements.
294+
295+* `runQuery` is like `runQueryParams` for a parameter-free statement.
296+
297+* `traversePrepared` has the same type signature as a composition of
298+ `traverse` and `manipulateParams` but provides an optimization by
299+ preparing the statement with `LibPQ.prepare` and then traversing a
300+ `Traversable` container with `LibPQ.execPrepared`. The temporary prepared
301+ statement is then deallocated.
302+
303+* `forPrepared` is a flipped `traversePrepared`
304+
305+* `traversePrepared_` is like `traversePrepared` but works on `Foldable`
306+ containers for a returning-free statement.
307+
308+* `forPrepared_` is a flipped `traversePrepared_`.
309+
310+* `liftPQ` lets you lift actions from `Database.PostgreSQL.LibPQ` that require a connection
311+ into your monad.
312+
313+To define an instance, you can minimally define only `manipulateParams`,
314+`traversePrepared`, `traversePrepared_` and `liftPQ`. Monad transformers get
315+a default instance.
316+
317+-}
318+class Monad pq => MonadPQ schemas pq | pq -> schemas where
319+ manipulateParams
320+ :: (ToParams x params, All OidOfParam params)
321+ => Manipulation '[] schemas params ys
322+ -- ^ `insertInto`, `update` or `deleteFrom`
323+ -> x -> pq (K LibPQ.Result ys)
324+ default manipulateParams
325+ :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)
326+ => (ToParams x params, All OidOfParam params)
327+ => Manipulation '[] schemas params ys
328+ -- ^ `insertInto`, `update` or `deleteFrom`
329+ -> x -> pq (K LibPQ.Result ys)
330+ manipulateParams manipulation params = lift $
331+ manipulateParams manipulation params
332+
333+ manipulateParams_
334+ :: (ToParams x params, All OidOfParam params)
335+ => Manipulation '[] schemas params '[]
336+ -- ^ `insertInto`, `update` or `deleteFrom`
337+ -> x -> pq ()
338+ manipulateParams_ q x = void $ manipulateParams q x
339+
340+ manipulate :: Manipulation '[] schemas '[] ys -> pq (K LibPQ.Result ys)
341+ manipulate statement = manipulateParams statement ()
342+
343+ manipulate_ :: Manipulation '[] schemas '[] '[] -> pq ()
344+ manipulate_ = void . manipulate
345+
346+ runQueryParams
347+ :: (ToParams x params, All OidOfParam params)
348+ => Query '[] '[] schemas params ys
349+ -- ^ `select` and friends
350+ -> x -> pq (K LibPQ.Result ys)
351+ runQueryParams = manipulateParams . queryStatement
352+
353+ runQuery
354+ :: Query '[] '[] schemas '[] ys
355+ -- ^ `select` and friends
356+ -> pq (K LibPQ.Result ys)
357+ runQuery q = runQueryParams q ()
358+
359+ traversePrepared
360+ :: (ToParams x params, Traversable list, All OidOfParam params)
361+ => Manipulation '[] schemas params ys
362+ -- ^ `insertInto`, `update`, or `deleteFrom`, and friends
363+ -> list x -> pq (list (K LibPQ.Result ys))
364+ default traversePrepared
365+ :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)
366+ => (ToParams x params, Traversable list, All OidOfParam params)
367+ => Manipulation '[] schemas params ys -> list x -> pq (list (K LibPQ.Result ys))
368+ traversePrepared manipulation params = lift $
369+ traversePrepared manipulation params
370+
371+ forPrepared
372+ :: (ToParams x params, Traversable list, All OidOfParam params)
373+ => list x
374+ -> Manipulation '[] schemas params ys
375+ -- ^ `insertInto`, `update` or `deleteFrom`
376+ -> pq (list (K LibPQ.Result ys))
377+ forPrepared = flip traversePrepared
378+
379+ traversePrepared_
380+ :: (ToParams x params, Foldable list, All OidOfParam params)
381+ => Manipulation '[] schemas params '[]
382+ -- ^ `insertInto`, `update` or `deleteFrom`
383+ -> list x -> pq ()
384+ default traversePrepared_
385+ :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)
386+ => (ToParams x params, Foldable list, All OidOfParam params)
387+ => Manipulation '[] schemas params '[]
388+ -- ^ `insertInto`, `update` or `deleteFrom`
389+ -> list x -> pq ()
390+ traversePrepared_ manipulation params = lift $
391+ traversePrepared_ manipulation params
392+
393+ forPrepared_
394+ :: (ToParams x params, Foldable list, All OidOfParam params)
395+ => list x
396+ -> Manipulation '[] schemas params '[]
397+ -- ^ `insertInto`, `update` or `deleteFrom`
398+ -> pq ()
399+ forPrepared_ = flip traversePrepared_
400+
401+ liftPQ :: (LibPQ.Connection -> IO a) -> pq a
402+ default liftPQ
403+ :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)
404+ => (LibPQ.Connection -> IO a) -> pq a
405+ liftPQ = lift . liftPQ
406+
407+instance (MonadIO io, schemas0 ~ schemas, schemas1 ~ schemas)
408+ => MonadPQ schemas (PQ schemas0 schemas1 io) where
409+
410+ manipulateParams
411+ (UnsafeManipulation q :: Manipulation '[] schemas ps ys) (params :: x) =
412+ PQ $ \ (K conn) -> do
413+ let
414+ paramSet
415+ :: forall param. OidOfParam param
416+ => K (Maybe Encoding.Encoding) param
417+ -> K (Maybe (LibPQ.Oid, ByteString, LibPQ.Format)) param
418+ paramSet (K maybeEncoding) = K $
419+ maybeEncoding <&> \encoding ->
420+ (oidOfParam @param, encodingBytes encoding, LibPQ.Binary)
421+ params'
422+ = hcollapse
423+ . hcmap (Proxy @OidOfParam) paramSet
424+ $ toParams @x @ps params
425+ q' = q <> ";"
426+ resultMaybe <- liftIO $ LibPQ.execParams conn q' params' LibPQ.Binary
427+ case resultMaybe of
428+ Nothing -> throw $ ResultException
429+ "manipulateParams: LibPQ.execParams returned no results"
430+ Just result -> do
431+ okResult_ result
432+ return $ K (K result)
433+
434+ traversePrepared
435+ (UnsafeManipulation q :: Manipulation '[] schemas xs ys) (list :: list x) =
436+ PQ $ \ (K conn) -> liftIO $ do
437+ let
438+ temp = "temporary_statement"
439+ paramOid :: forall p. OidOfParam p => K LibPQ.Oid p
440+ paramOid = K (oidOfParam @p)
441+ paramOids :: NP (K LibPQ.Oid) xs
442+ paramOids = hcpure (Proxy @OidOfParam) paramOid
443+ paramOids' :: [LibPQ.Oid]
444+ paramOids' = hcollapse paramOids
445+ prepResultMaybe <- LibPQ.prepare conn temp q (Just paramOids')
446+ case prepResultMaybe of
447+ Nothing -> throw $ ResultException
448+ "traversePrepared: LibPQ.prepare returned no results"
449+ Just prepResult -> okResult_ prepResult
450+ results <- for list $ \ params -> do
451+ let
452+ toParam' encoding = (encodingBytes encoding, LibPQ.Binary)
453+ params' = fmap (fmap toParam') (hcollapse (toParams @x @xs params))
454+ resultMaybe <- LibPQ.execPrepared conn temp params' LibPQ.Binary
455+ case resultMaybe of
456+ Nothing -> throw $ ResultException
457+ "traversePrepared: LibPQ.execParams returned no results"
458+ Just result -> do
459+ okResult_ result
460+ return $ K result
461+ deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")
462+ case deallocResultMaybe of
463+ Nothing -> throw $ ResultException
464+ "traversePrepared: LibPQ.exec DEALLOCATE returned no results"
465+ Just deallocResult -> okResult_ deallocResult
466+ return (K results)
467+
468+ traversePrepared_
469+ (UnsafeManipulation q :: Manipulation '[] schemas xs '[]) (list :: list x) =
470+ PQ $ \ (K conn) -> liftIO $ do
471+ let
472+ temp = "temporary_statement"
473+ paramOid :: forall p. OidOfParam p => K LibPQ.Oid p
474+ paramOid = K (oidOfParam @p)
475+ paramOids :: NP (K LibPQ.Oid) xs
476+ paramOids = hcpure (Proxy @OidOfParam) paramOid
477+ paramOids' :: [LibPQ.Oid]
478+ paramOids' = hcollapse paramOids
479+ prepResultMaybe <- LibPQ.prepare conn temp q (Just paramOids')
480+ case prepResultMaybe of
481+ Nothing -> throw $ ResultException
482+ "traversePrepared_: LibPQ.prepare returned no results"
483+ Just prepResult -> okResult_ prepResult
484+ for_ list $ \ params -> do
485+ let
486+ toParam' encoding = (encodingBytes encoding, LibPQ.Binary)
487+ params' = fmap (fmap toParam') (hcollapse (toParams @x @xs params))
488+ resultMaybe <- LibPQ.execPrepared conn temp params' LibPQ.Binary
489+ case resultMaybe of
490+ Nothing -> throw $ ResultException
491+ "traversePrepared_: LibPQ.execParams returned no results"
492+ Just result -> okResult_ result
493+ deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")
494+ case deallocResultMaybe of
495+ Nothing -> throw $ ResultException
496+ "traversePrepared: LibPQ.exec DEALLOCATE returned no results"
497+ Just deallocResult -> okResult_ deallocResult
498+ return (K ())
499+
500+ liftPQ pq = PQ $ \ (K conn) -> do
501+ y <- liftIO $ pq conn
502+ return (K y)
503+
504+instance MonadPQ schemas m => MonadPQ schemas (IdentityT m)
505+instance MonadPQ schemas m => MonadPQ schemas (ReaderT r m)
506+instance MonadPQ schemas m => MonadPQ schemas (Strict.StateT s m)
507+instance MonadPQ schemas m => MonadPQ schemas (Lazy.StateT s m)
508+instance (Monoid w, MonadPQ schemas m) => MonadPQ schemas (Strict.WriterT w m)
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
520+
521+instance (Monad m, schemas0 ~ schemas1)
522+ => Monad (PQ schemas0 schemas1 m) where
523+ return = pure
524+ (>>=) = flip pqBind
525+
526+instance (Monad m, schemas0 ~ schemas1)
527+ => Fail.MonadFail (PQ schemas0 schemas1 m) where
528+ fail = Fail.fail
529+
530+instance schemas0 ~ schemas1 => MFunctor (PQ schemas0 schemas1) where
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
536+ return (K x)
537+
538+instance schemas0 ~ schemas1 => MMonad (PQ schemas0 schemas1) where
539+ embed f (PQ pq) = PQ $ \ conn -> do
540+ evalPQ (f (pq conn)) conn
541+
542+instance (MonadIO m, schema0 ~ schema1)
543+ => MonadIO (PQ schema0 schema1 m) where
544+ liftIO = lift . liftIO
545+
546+instance (MonadUnliftIO m, schemas0 ~ schemas1)
547+ => MonadUnliftIO (PQ schemas0 schemas1 m) where
548+ withRunInIO
549+ :: ((forall a . PQ schemas0 schema1 m a -> IO a) -> IO b)
550+ -> PQ schemas0 schema1 m b
551+ withRunInIO inner = PQ $ \conn ->
552+ withRunInIO $ \(run :: (forall x . m x -> IO x)) ->
553+ K <$> inner (\pq -> run $ unK <$> unPQ pq conn)
554+
555+-- | Get a row corresponding to a given row number from a `LibPQ.Result`,
556+-- throwing an exception if the row number is out of bounds.
557+getRow
558+ :: (FromRow columns y, MonadIO io)
559+ => LibPQ.Row
560+ -- ^ row number
561+ -> K LibPQ.Result columns
562+ -- ^ result
563+ -> io y
564+getRow r (K result :: K LibPQ.Result columns) = liftIO $ do
565+ numRows <- LibPQ.ntuples result
566+ when (numRows < r) $ throw $ ResultException $
567+ "getRow: expected at least " <> pack (show r) <> "rows but only saw "
568+ <> pack (show numRows)
569+ let len = fromIntegral (lengthSList (Proxy @columns))
570+ row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]
571+ case fromList row' of
572+ Nothing -> throw $ ResultException "getRow: found unexpected length"
573+ Just row -> case fromRow @columns row of
574+ Left parseError -> throw $ ParseException $ "getRow: " <> parseError
575+ Right y -> return y
576+
577+-- | Intended to be used for unfolding in streaming libraries, `nextRow`
578+-- takes a total number of rows (which can be found with `ntuples`)
579+-- and a `LibPQ.Result` and given a row number if it's too large returns `Nothing`,
580+-- otherwise returning the row along with the next row number.
581+nextRow
582+ :: (FromRow columns y, MonadIO io)
583+ => LibPQ.Row -- ^ total number of rows
584+ -> K LibPQ.Result columns -- ^ result
585+ -> LibPQ.Row -- ^ row number
586+ -> io (Maybe (LibPQ.Row,y))
587+nextRow total (K result :: K LibPQ.Result columns) r
588+ = liftIO $ if r >= total then return Nothing else do
589+ let len = fromIntegral (lengthSList (Proxy @columns))
590+ row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]
591+ case fromList row' of
592+ Nothing -> throw $ ResultException "nextRow: found unexpected length"
593+ Just row -> case fromRow @columns row of
594+ Left parseError -> throw $ ParseException $ "nextRow: " <> parseError
595+ Right y -> return $ Just (r+1, y)
596+
597+-- | Get all rows from a `LibPQ.Result`.
598+getRows
599+ :: (FromRow columns y, MonadIO io)
600+ => K LibPQ.Result columns -- ^ result
601+ -> io [y]
602+getRows (K result :: K LibPQ.Result columns) = liftIO $ do
603+ let len = fromIntegral (lengthSList (Proxy @columns))
604+ numRows <- LibPQ.ntuples result
605+ for [0 .. numRows - 1] $ \ r -> do
606+ row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]
607+ case fromList row' of
608+ Nothing -> throw $ ResultException "getRows: found unexpected length"
609+ Just row -> case fromRow @columns row of
610+ Left parseError -> throw $ ParseException $ "getRows: " <> parseError
611+ Right y -> return y
612+
613+-- | Get the first row if possible from a `LibPQ.Result`.
614+firstRow
615+ :: (FromRow columns y, MonadIO io)
616+ => K LibPQ.Result columns -- ^ result
617+ -> io (Maybe y)
618+firstRow (K result :: K LibPQ.Result columns) = liftIO $ do
619+ numRows <- LibPQ.ntuples result
620+ if numRows <= 0 then return Nothing else do
621+ let len = fromIntegral (lengthSList (Proxy @columns))
622+ row' <- traverse (LibPQ.getvalue result 0) [0 .. len - 1]
623+ case fromList row' of
624+ Nothing -> throw $ ResultException "firstRow: found unexpected length"
625+ Just row -> case fromRow @columns row of
626+ Left parseError -> throw $ ParseException $ "firstRow: " <> parseError
627+ Right y -> return $ Just y
628+
629+-- | Lifts actions on results from @LibPQ@.
630+liftResult
631+ :: MonadIO io
632+ => (LibPQ.Result -> IO x)
633+ -> K LibPQ.Result results -> io x
634+liftResult f (K result) = liftIO $ 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.hsnew file+122
@@ -0,0 +1,122 @@
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/Query.hsnew file+1098
@@ -0,0 +1,1098 @@
1+{-|
2+Module: Squeal.PostgreSQL.Query
3+Description: Squeal queries
4+Copyright: (c) Eitan Chatav, 2019
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Squeal queries.
9+-}
10+
11+{-# LANGUAGE
12+ ConstraintKinds
13+ , DeriveGeneric
14+ , FlexibleContexts
15+ , FlexibleInstances
16+ , GADTs
17+ , GeneralizedNewtypeDeriving
18+ , LambdaCase
19+ , MultiParamTypeClasses
20+ , OverloadedLabels
21+ , OverloadedStrings
22+ , QuantifiedConstraints
23+ , ScopedTypeVariables
24+ , StandaloneDeriving
25+ , TypeApplications
26+ , TypeFamilies
27+ , TypeInType
28+ , TypeOperators
29+ , RankNTypes
30+ , UndecidableInstances
31+ #-}
32+
33+module Squeal.PostgreSQL.Query
34+ ( -- * Queries
35+ Query_
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
50+ , unionAll
51+ , intersect
52+ , intersectAll
53+ , except
54+ , exceptAll
55+ -- ** With
56+ , With (..)
57+ , CommonTableExpression (..)
58+ , withRecursive
59+ -- * Table Expressions
60+ , TableExpression (..)
61+ , from
62+ , where_
63+ , groupBy
64+ , having
65+ , limit
66+ , offset
67+ -- * From Clauses
68+ , FromClause (..)
69+ , table
70+ , subquery
71+ , view
72+ , common
73+ , crossJoin
74+ , innerJoin
75+ , leftOuterJoin
76+ , rightOuterJoin
77+ , fullOuterJoin
78+ -- * Grouping
79+ , By (..)
80+ , GroupByClause (..)
81+ , HavingClause (..)
82+ ) where
83+
84+import Control.DeepSeq
85+import Data.ByteString (ByteString)
86+import Data.Kind (Type)
87+import Data.String
88+import Data.Word
89+import Generics.SOP hiding (from)
90+import GHC.TypeLits
91+
92+import qualified GHC.Generics as GHC
93+
94+import Squeal.PostgreSQL.Alias
95+import Squeal.PostgreSQL.Expression
96+import Squeal.PostgreSQL.Expression.Logic
97+import Squeal.PostgreSQL.Expression.Sort
98+import Squeal.PostgreSQL.Expression.Window
99+import Squeal.PostgreSQL.List
100+import Squeal.PostgreSQL.PG
101+import Squeal.PostgreSQL.Render
102+import Squeal.PostgreSQL.Schema
103+
104+-- $setup
105+-- >>> import Squeal.PostgreSQL
106+-- >>> import Data.Int (Int32, Int64)
107+-- >>> import Data.Monoid (Sum (..))
108+-- >>> import Data.Text (Text)
109+-- >>> import qualified Generics.SOP as SOP
110+
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+{- |
134+The top level `Query_` type is parameterized by a @schemas@ `SchemasType`,
135+against which the query is type-checked, an input @parameters@ Haskell `Type`,
136+and an ouput row Haskell `Type`.
137+
138+A top-level query can be run
139+using `Squeal.PostgreSQL.PQ.runQueryParams`, or if @parameters = ()@
140+using `Squeal.PostgreSQL.PQ.runQuery`.
141+
142+Generally, @parameters@ will be a Haskell tuple or record whose entries
143+may be referenced using positional
144+`Squeal.PostgreSQL.Expression.Parameter.parameter`s and @row@ will be a
145+Haskell record, whose entries will be targeted using overloaded labels.
146+
147+Let's see some examples of queries.
148+
149+>>> :set -XDeriveAnyClass -XDerivingStrategies
150+>>> :{
151+data Row a b = Row { col1 :: a, col2 :: b }
152+ deriving stock (GHC.Generic)
153+ deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
154+:}
155+
156+simple query:
157+
158+>>> type Columns = '["col1" ::: 'NoDef :=> 'NotNull 'PGint4, "col2" ::: 'NoDef :=> 'NotNull 'PGint4]
159+>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]
160+>>> :{
161+let
162+ query :: Query_ (Public Schema) () (Row Int32 Int32)
163+ query = select Star (from (table #tab))
164+in printSQL query
165+:}
166+SELECT * FROM "tab" AS "tab"
167+
168+restricted query:
169+
170+>>> :{
171+let
172+ query :: Query_ (Public Schema) () (Row Int32 Int32)
173+ query =
174+ select_ ((#col1 + #col2) `as` #col1 :* #col1 `as` #col2)
175+ ( from (table #tab)
176+ & where_ (#col1 .> #col2)
177+ & where_ (#col2 .> 0) )
178+in printSQL query
179+:}
180+SELECT ("col1" + "col2") AS "col1", "col1" AS "col2" FROM "tab" AS "tab" WHERE (("col1" > "col2") AND ("col2" > 0))
181+
182+subquery:
183+
184+>>> :{
185+let
186+ query :: Query_ (Public Schema) () (Row Int32 Int32)
187+ query = select Star (from (subquery (select Star (from (table #tab)) `as` #sub)))
188+in printSQL query
189+:}
190+SELECT * FROM (SELECT * FROM "tab" AS "tab") AS "sub"
191+
192+limits and offsets:
193+
194+>>> :{
195+let
196+ query :: Query_ (Public Schema) () (Row Int32 Int32)
197+ query = select Star (from (table #tab) & limit 100 & offset 2 & limit 50 & offset 2)
198+in printSQL query
199+:}
200+SELECT * FROM "tab" AS "tab" LIMIT 50 OFFSET 4
201+
202+parameterized query:
203+
204+>>> :{
205+let
206+ query :: Query_ (Public Schema) (Only Int32) (Row Int32 Int32)
207+ query = select Star (from (table #tab) & where_ (#col1 .> param @1))
208+in printSQL query
209+:}
210+SELECT * FROM "tab" AS "tab" WHERE ("col1" > ($1 :: int4))
211+
212+aggregation query:
213+
214+>>> :{
215+let
216+ query :: Query_ (Public Schema) () (Row Int64 Int32)
217+ query =
218+ select_ ((fromNull 0 (sum_ (All #col2))) `as` #col1 :* #col1 `as` #col2)
219+ ( from (table (#tab `as` #table1))
220+ & groupBy #col1
221+ & having (sum_ (Distinct #col2) .> 1) )
222+in printSQL query
223+:}
224+SELECT COALESCE(sum(ALL "col2"), 0) AS "col1", "col1" AS "col2" FROM "tab" AS "table1" GROUP BY "col1" HAVING (sum(DISTINCT "col2") > 1)
225+
226+sorted query:
227+
228+>>> :{
229+let
230+ query :: Query_ (Public Schema) () (Row Int32 Int32)
231+ query = select Star (from (table #tab) & orderBy [#col1 & Asc])
232+in printSQL query
233+:}
234+SELECT * FROM "tab" AS "tab" ORDER BY "col1" ASC
235+
236+joins:
237+
238+>>> :{
239+type OrdersColumns =
240+ '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4
241+ , "price" ::: 'NoDef :=> 'NotNull 'PGfloat4
242+ , "customer_id" ::: 'NoDef :=> 'NotNull 'PGint4
243+ , "shipper_id" ::: 'NoDef :=> 'NotNull 'PGint4 ]
244+:}
245+
246+>>> :{
247+type OrdersConstraints =
248+ '["pk_orders" ::: PrimaryKey '["id"]
249+ ,"fk_customers" ::: ForeignKey '["customer_id"] "customers" '["id"]
250+ ,"fk_shippers" ::: ForeignKey '["shipper_id"] "shippers" '["id"] ]
251+:}
252+
253+>>> type NamesColumns = '["id" ::: 'NoDef :=> 'NotNull 'PGint4, "name" ::: 'NoDef :=> 'NotNull 'PGtext]
254+>>> type CustomersConstraints = '["pk_customers" ::: PrimaryKey '["id"]]
255+>>> type ShippersConstraints = '["pk_shippers" ::: PrimaryKey '["id"]]
256+>>> :{
257+type OrdersSchema =
258+ '[ "orders" ::: 'Table (OrdersConstraints :=> OrdersColumns)
259+ , "customers" ::: 'Table (CustomersConstraints :=> NamesColumns)
260+ , "shippers" ::: 'Table (ShippersConstraints :=> NamesColumns) ]
261+:}
262+
263+>>> :{
264+data Order = Order
265+ { price :: Float
266+ , customerName :: Text
267+ , shipperName :: Text
268+ } deriving GHC.Generic
269+instance SOP.Generic Order
270+instance SOP.HasDatatypeInfo Order
271+:}
272+
273+>>> :{
274+let
275+ query :: Query_ (Public OrdersSchema) () Order
276+ query = select_
277+ ( #o ! #price `as` #price :*
278+ #c ! #name `as` #customerName :*
279+ #s ! #name `as` #shipperName )
280+ ( from (table (#orders `as` #o)
281+ & innerJoin (table (#customers `as` #c))
282+ (#o ! #customer_id .== #c ! #id)
283+ & innerJoin (table (#shippers `as` #s))
284+ (#o ! #shipper_id .== #s ! #id)) )
285+in printSQL query
286+:}
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")
288+
289+self-join:
290+
291+>>> :{
292+let
293+ query :: Query_ (Public Schema) () (Row Int32 Int32)
294+ query = select
295+ (#t1 & DotStar)
296+ (from (table (#tab `as` #t1) & crossJoin (table (#tab `as` #t2))))
297+in printSQL query
298+:}
299+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+
313+set operations:
314+
315+>>> :{
316+let
317+ query :: Query_ (Public Schema) () (Row Int32 Int32)
318+ query = select Star (from (table #tab)) `unionAll` select Star (from (table #tab))
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 =
354+ select (#col1 `as` #fromOnly) (from (table (#tab `as` #t1))
355+ & where_ (exists (
356+ select Star (from (table (#tab `as` #t2))
357+ & where_ (#t2 ! #col2 .== #t1 ! #col1)))))
358+in printSQL query
359+:}
360+SELECT "col1" AS "fromOnly" FROM "tab" AS "t1" WHERE EXISTS (SELECT * FROM "tab" AS "t2" WHERE ("t2"."col2" = "t1"."col1"))
361+
362+-}
363+type family Query_
364+ (schemas :: SchemasType)
365+ (parameters :: Type)
366+ (row :: Type) where
367+ Query_ schemas params row =
368+ Query '[] '[] schemas (TuplePG params) (RowPG row)
369+
370+-- | The results of two queries can be combined using the set operation
371+-- `union`. Duplicate rows are eliminated.
372+union
373+ :: Query outer commons schemas params columns
374+ -> Query outer commons schemas params columns
375+ -> Query outer commons schemas params columns
376+q1 `union` q2 = UnsafeQuery $
377+ parenthesized (renderSQL q1)
378+ <+> "UNION"
379+ <+> parenthesized (renderSQL q2)
380+
381+-- | The results of two queries can be combined using the set operation
382+-- `unionAll`, the disjoint union. Duplicate rows are retained.
383+unionAll
384+ :: Query outer commons schemas params columns
385+ -> Query outer commons schemas params columns
386+ -> Query outer commons schemas params columns
387+q1 `unionAll` q2 = UnsafeQuery $
388+ parenthesized (renderSQL q1)
389+ <+> "UNION" <+> "ALL"
390+ <+> parenthesized (renderSQL q2)
391+
392+-- | The results of two queries can be combined using the set operation
393+-- `intersect`, the intersection. Duplicate rows are eliminated.
394+intersect
395+ :: Query outer commons schemas params columns
396+ -> Query outer commons schemas params columns
397+ -> Query outer commons schemas params columns
398+q1 `intersect` q2 = UnsafeQuery $
399+ parenthesized (renderSQL q1)
400+ <+> "INTERSECT"
401+ <+> parenthesized (renderSQL q2)
402+
403+-- | The results of two queries can be combined using the set operation
404+-- `intersectAll`, the intersection. Duplicate rows are retained.
405+intersectAll
406+ :: Query outer commons schemas params columns
407+ -> Query outer commons schemas params columns
408+ -> Query outer commons schemas params columns
409+q1 `intersectAll` q2 = UnsafeQuery $
410+ parenthesized (renderSQL q1)
411+ <+> "INTERSECT" <+> "ALL"
412+ <+> parenthesized (renderSQL q2)
413+
414+-- | The results of two queries can be combined using the set operation
415+-- `except`, the set difference. Duplicate rows are eliminated.
416+except
417+ :: Query outer commons schemas params columns
418+ -> Query outer commons schemas params columns
419+ -> Query outer commons schemas params columns
420+q1 `except` q2 = UnsafeQuery $
421+ parenthesized (renderSQL q1)
422+ <+> "EXCEPT"
423+ <+> parenthesized (renderSQL q2)
424+
425+-- | The results of two queries can be combined using the set operation
426+-- `exceptAll`, the set difference. Duplicate rows are retained.
427+exceptAll
428+ :: Query outer commons schemas params columns
429+ -> Query outer commons schemas params columns
430+ -> Query outer commons schemas params columns
431+q1 `exceptAll` q2 = UnsafeQuery $
432+ parenthesized (renderSQL q1)
433+ <+> "EXCEPT" <+> "ALL"
434+ <+> parenthesized (renderSQL q2)
435+
436+{-----------------------------------------
437+SELECT queries
438+-----------------------------------------}
439+
440+{- | The simplest kinds of `Selection` are `Star` and `DotStar` which
441+emits all columns that a `TableExpression` produces. A select `List`
442+is a list of `Expression`s. A `Selection` could be a list of
443+`WindowFunction`s `Over` `WindowDefinition`. `Additional` `Selection`s can
444+be selected with `Also`.
445+-}
446+data Selection outer commons grp schemas params from row where
447+ Star
448+ :: HasUnique tab from row
449+ => Selection outer commons 'Ungrouped schemas params from row
450+ -- ^ `HasUnique` table in the `FromClause`
451+ DotStar
452+ :: Has tab from row
453+ => Alias tab
454+ -- ^ `Has` table with `Alias`
455+ -> Selection outer commons 'Ungrouped schemas params from row
456+ List
457+ :: SListI row
458+ => NP (Aliased (Expression outer commons grp schemas params from)) row
459+ -- ^ `NP` list of `Aliased` `Expression`s
460+ -> Selection outer commons grp schemas params from row
461+ Over
462+ :: SListI row
463+ => NP (Aliased (WindowFunction outer commons grp schemas params from)) row
464+ -- ^ `NP` list of `Aliased` `WindowFunction`s
465+ -> WindowDefinition outer commons grp schemas params from
466+ -> Selection outer commons grp schemas params from row
467+ Also
468+ :: Selection outer commons grp schemas params from right
469+ -- ^ `Additional` `Selection`
470+ -> Selection outer commons grp schemas params from left
471+ -> Selection outer commons grp schemas params from (Join left right)
472+instance Additional (Selection outer commons grp schemas params from) where
473+ also = Also
474+instance (KnownSymbol col, row ~ '[col ::: ty])
475+ => Aliasable col
476+ (Expression outer commons grp schemas params from ty)
477+ (Selection outer commons grp schemas params from row) where
478+ expr `as` col = List (expr `as` col)
479+instance (Has tab (Join outer from) row0, Has col row0 ty, row1 ~ '[col ::: ty])
480+ => IsQualified tab col
481+ (Selection outer commons 'Ungrouped schemas params from row1) where
482+ tab ! col = tab ! col `as` col
483+instance
484+ ( Has tab (Join outer from) row0
485+ , Has col row0 ty
486+ , row1 ~ '[col ::: ty]
487+ , GroupedBy tab col bys )
488+ => IsQualified tab col
489+ (Selection outer commons ('Grouped bys) schemas params from row1) where
490+ tab ! col = tab ! col `as` col
491+instance (HasUnique tab (Join outer from) row0, Has col row0 ty, row1 ~ '[col ::: ty])
492+ => IsLabel col
493+ (Selection outer commons 'Ungrouped schemas params from row1) where
494+ fromLabel = fromLabel @col `as` Alias
495+instance
496+ ( HasUnique tab (Join outer from) row0
497+ , Has col row0 ty
498+ , row1 ~ '[col ::: ty]
499+ , GroupedBy tab col bys )
500+ => IsLabel col
501+ (Selection outer commons ('Grouped bys) schemas params from row1) where
502+ fromLabel = fromLabel @col `as` Alias
503+
504+instance RenderSQL (Selection outer commons grp schemas params from row) where
505+ renderSQL = \case
506+ List list -> renderCommaSeparated (renderAliased renderSQL) list
507+ Star -> "*"
508+ DotStar tab -> renderSQL tab <> ".*"
509+ Also right left -> renderSQL left <> ", " <> renderSQL right
510+ Over winFns winDef ->
511+ let
512+ renderOver
513+ :: Aliased (WindowFunction outer commons grp schemas params from) field
514+ -> ByteString
515+ renderOver (winFn `As` col) = renderSQL winFn
516+ <+> "OVER" <+> parenthesized (renderSQL winDef)
517+ <+> "AS" <+> renderSQL col
518+ in
519+ renderCommaSeparated renderOver winFns
520+
521+instance IsString
522+ (Selection outer commons grp schemas params from '["fromOnly" ::: 'NotNull 'PGtext]) where
523+ fromString str = fromString str `as` Alias
524+
525+-- | the `TableExpression` in the `select` command constructs an intermediate
526+-- virtual table by possibly combining tables, views, eliminating rows,
527+-- grouping, etc. This table is finally passed on to processing by
528+-- the select list. The `Selection` determines which columns of
529+-- the intermediate table are actually output.
530+select
531+ :: (SListI row, row ~ (x ': xs))
532+ => Selection outer commons grp schemas params from row
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
548+ -> TableExpression outer commons grp schemas params from
549+ -- ^ intermediate virtual table
550+ -> Query outer commons schemas params row
551+select_ = select . List
552+
553+-- | After the select list has been processed, the result table can
554+-- be subject to the elimination of duplicate rows using `selectDistinct`.
555+selectDistinct
556+ :: (SListI columns, columns ~ (col ': cols))
557+ => Selection outer commons grp schemas params from columns
558+ -- ^ selection
559+ -> TableExpression outer commons grp schemas params from
560+ -- ^ intermediate virtual table
561+ -> Query outer commons schemas params columns
562+selectDistinct selection tabexpr = UnsafeQuery $
563+ "SELECT DISTINCT"
564+ <+> renderSQL selection
565+ <+> renderSQL tabexpr
566+
567+-- | Like `selectDistinct` but takes an `NP` list of `Expression`s instead
568+-- of a general `Selection`.
569+selectDistinct_
570+ :: (SListI columns, columns ~ (col ': cols))
571+ => NP (Aliased (Expression outer commons grp schemas params from)) columns
572+ -- ^ select list
573+ -> TableExpression outer commons grp schemas params from
574+ -- ^ intermediate virtual table
575+ -> Query outer commons schemas params columns
576+selectDistinct_ = selectDistinct . List
577+
578+{-|
579+`selectDistinctOn` keeps only the first row of each set of rows where
580+the given expressions evaluate to equal. The DISTINCT ON expressions are
581+interpreted using the same rules as for ORDER BY. ORDER BY is used to
582+ensure that the desired row appears first.
583+
584+The DISTINCT ON expression(s) must match the leftmost ORDER BY expression(s).
585+The ORDER BY clause will normally contain additional expression(s) that
586+determine the desired precedence of rows within each DISTINCT ON group.
587+
588+In order to guarantee they match and reduce redundancy, this function
589+will prepend the The DISTINCT ON expressions to the ORDER BY clause.
590+-}
591+selectDistinctOn
592+ :: (SListI columns, columns ~ (col ': cols))
593+ => [SortExpression outer commons grp schemas params from]
594+ -- ^ DISTINCT ON expression(s) and prepended to ORDER BY clause
595+ -> Selection outer commons grp schemas params from columns
596+ -- ^ selection
597+ -> TableExpression outer commons grp schemas params from
598+ -- ^ intermediate virtual table
599+ -> Query outer commons schemas params columns
600+selectDistinctOn distincts selection tab = UnsafeQuery $
601+ "SELECT DISTINCT ON"
602+ <+> parenthesized (commaSeparated (renderDistinctOn <$> distincts))
603+ <+> renderSQL selection
604+ <+> renderSQL (tab {orderByClause = distincts <> orderByClause tab})
605+ where
606+ renderDistinctOn = \case
607+ Asc expression -> renderSQL expression
608+ Desc expression -> renderSQL expression
609+ AscNullsFirst expression -> renderSQL expression
610+ DescNullsFirst expression -> renderSQL expression
611+ AscNullsLast expression -> renderSQL expression
612+ DescNullsLast expression -> renderSQL expression
613+
614+-- | Like `selectDistinctOn` but takes an `NP` list of `Expression`s instead
615+-- of a general `Selection`.
616+selectDistinctOn_
617+ :: (SListI columns, columns ~ (col ': cols))
618+ => [SortExpression outer commons grp schemas params from]
619+ -- ^ distinct on and return the first row in ordering
620+ -> NP (Aliased (Expression outer commons grp schemas params from)) columns
621+ -- ^ selection
622+ -> TableExpression outer commons grp schemas params from
623+ -- ^ intermediate virtual table
624+ -> Query outer commons schemas params columns
625+selectDistinctOn_ distincts = selectDistinctOn distincts . List
626+
627+-- | `values` computes a row value or set of row values
628+-- specified by value expressions. It is most commonly used
629+-- to generate a “constant table” within a larger command,
630+-- but it can be used on its own.
631+--
632+-- >>> type Row = '["a" ::: 'NotNull 'PGint4, "b" ::: 'NotNull 'PGtext]
633+-- >>> let query = values (1 `as` #a :* "one" `as` #b) [] :: Query outer commons schemas '[] Row
634+-- >>> printSQL query
635+-- SELECT * FROM (VALUES (1, E'one')) AS t ("a", "b")
636+values
637+ :: SListI cols
638+ => NP (Aliased (Expression outer commons 'Ungrouped schemas params '[] )) cols
639+ -> [NP (Aliased (Expression outer commons 'Ungrouped schemas params '[] )) cols]
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+
666+{-----------------------------------------
667+Table Expressions
668+-----------------------------------------}
669+
670+-- | A `TableExpression` computes a table. The table expression contains
671+-- a `fromClause` that is optionally followed by a `whereClause`,
672+-- `groupByClause`, `havingClause`, `orderByClause`, `limitClause`
673+-- and `offsetClause`s. Trivial table expressions simply refer
674+-- 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.
676+data TableExpression
677+ (outer :: FromType)
678+ (commons :: FromType)
679+ (grp :: Grouping)
680+ (schemas :: SchemasType)
681+ (params :: [NullityType])
682+ (from :: FromType)
683+ = TableExpression
684+ { fromClause :: FromClause outer commons schemas params from
685+ -- ^ 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.
687+ , whereClause :: [Condition outer commons 'Ungrouped schemas params from]
688+ -- ^ optional search coditions, combined with `.&&`. After the processing
689+ -- of the `fromClause` is done, each row of the derived virtual table
690+ -- is checked against the search condition. If the result of the
691+ -- condition is true, the row is kept in the output table,
692+ -- otherwise it is discarded. The search condition typically references
693+ -- at least one column of the table generated in the `fromClause`;
694+ -- this is not required, but otherwise the WHERE clause will
695+ -- be fairly useless.
696+ , groupByClause :: GroupByClause grp from
697+ -- ^ 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
699+ -- 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
701+ -- rows in the group. This is done to eliminate redundancy in the output
702+ -- and/or compute aggregates that apply to these groups.
703+ , havingClause :: HavingClause outer commons grp schemas params from
704+ -- ^ If a table has been grouped using `groupBy`, but only certain groups
705+ -- are of interest, the `havingClause` can be used, much like a
706+ -- `whereClause`, to eliminate groups from the result. Expressions in the
707+ -- `havingClause` can refer both to grouped expressions and to ungrouped
708+ -- expressions (which necessarily involve an aggregate function).
709+ , orderByClause :: [SortExpression outer commons grp schemas params from]
710+ -- ^ The `orderByClause` is for optional sorting. When more than one
711+ -- `SortExpression` is specified, the later (right) values are used to sort
712+ -- rows that are equal according to the earlier (left) values.
713+ , limitClause :: [Word64]
714+ -- ^ The `limitClause` is combined with `min` to give a limit count
715+ -- if nonempty. If a limit count is given, no more than that many rows
716+ -- will be returned (but possibly fewer, if the query itself yields
717+ -- fewer rows).
718+ , offsetClause :: [Word64]
719+ -- ^ The `offsetClause` is combined with `Prelude.+` to give an offset count
720+ -- 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
722+ -- is applied.
723+ } deriving (GHC.Generic)
724+
725+-- | Render a `TableExpression`
726+instance RenderSQL (TableExpression outer commons grp schemas params from) where
727+ renderSQL
728+ (TableExpression frm' whs' grps' hvs' srts' lims' offs') = mconcat
729+ [ "FROM ", renderSQL frm'
730+ , renderWheres whs'
731+ , renderSQL grps'
732+ , renderSQL hvs'
733+ , renderOrderByClause srts'
734+ , renderLimits lims'
735+ , renderOffsets offs' ]
736+ where
737+ renderWheres = \case
738+ [] -> ""
739+ wh:[] -> " WHERE" <+> renderSQL wh
740+ wh:whs -> " WHERE" <+> renderSQL (foldr (.&&) wh whs)
741+ renderOrderByClause = \case
742+ [] -> ""
743+ srts -> " ORDER BY"
744+ <+> commaSeparated (renderSQL <$> srts)
745+ renderLimits = \case
746+ [] -> ""
747+ lims -> " LIMIT" <+> fromString (show (minimum lims))
748+ renderOffsets = \case
749+ [] -> ""
750+ offs -> " OFFSET" <+> fromString (show (sum offs))
751+
752+-- | 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,
754+-- or complex combinations of these. A `from` may be transformed by `where_`,
755+-- `groupBy`, `having`, `orderBy`, `limit` and `offset`, using the `&` operator
756+-- to match the left-to-right sequencing of their placement in SQL.
757+from
758+ :: FromClause outer commons schemas params from -- ^ table reference
759+ -> TableExpression outer commons 'Ungrouped schemas params from
760+from tab = TableExpression tab [] noGroups NoHaving [] [] []
761+
762+-- | A `where_` is an endomorphism of `TableExpression`s which adds a
763+-- search condition to the `whereClause`.
764+where_
765+ :: Condition outer commons 'Ungrouped schemas params from -- ^ filtering condition
766+ -> TableExpression outer commons grp schemas params from
767+ -> TableExpression outer commons grp schemas params from
768+where_ wh rels = rels {whereClause = wh : whereClause rels}
769+
770+-- | A `groupBy` is a transformation of `TableExpression`s which switches
771+-- its `Grouping` from `Ungrouped` to `Grouped`. Use @groupBy Nil@ to perform
772+-- a "grand total" aggregation query.
773+groupBy
774+ :: SListI bys
775+ => NP (By from) bys -- ^ grouped columns
776+ -> TableExpression outer commons 'Ungrouped schemas params from
777+ -> TableExpression outer commons ('Grouped bys) schemas params from
778+groupBy bys rels = TableExpression
779+ { fromClause = fromClause rels
780+ , whereClause = whereClause rels
781+ , groupByClause = group bys
782+ , havingClause = Having []
783+ , orderByClause = []
784+ , limitClause = limitClause rels
785+ , offsetClause = offsetClause rels
786+ }
787+
788+-- | A `having` is an endomorphism of `TableExpression`s which adds a
789+-- search condition to the `havingClause`.
790+having
791+ :: Condition outer commons ('Grouped bys) schemas params from -- ^ having condition
792+ -> TableExpression outer commons ('Grouped bys) schemas params from
793+ -> TableExpression outer commons ('Grouped bys) schemas params from
794+having hv rels = rels
795+ { havingClause = case havingClause rels of Having hvs -> Having (hv:hvs) }
796+
797+instance OrderBy TableExpression where
798+ orderBy srts rels = rels {orderByClause = orderByClause rels ++ srts}
799+
800+-- | A `limit` is an endomorphism of `TableExpression`s which adds to the
801+-- `limitClause`.
802+limit
803+ :: Word64 -- ^ limit parameter
804+ -> TableExpression outer commons grp schemas params from
805+ -> TableExpression outer commons grp schemas params from
806+limit lim rels = rels {limitClause = lim : limitClause rels}
807+
808+-- | An `offset` is an endomorphism of `TableExpression`s which adds to the
809+-- `offsetClause`.
810+offset
811+ :: Word64 -- ^ offset parameter
812+ -> TableExpression outer commons grp schemas params from
813+ -> TableExpression outer commons grp schemas params from
814+offset off rels = rels {offsetClause = off : offsetClause rels}
815+
816+{-----------------------------------------
817+FROM clauses
818+-----------------------------------------}
819+
820+{- |
821+A `FromClause` can be a table name, or a derived table such
822+as 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+
864+{- |
865+@left & crossJoin right@. For every possible combination of rows from
866+@left@ and @right@ (i.e., a Cartesian product), the joined table will contain
867+a row consisting of all columns in @left@ followed by all columns in @right@.
868+If the tables have @n@ and @m@ rows respectively, the joined table will
869+have @n * m@ rows.
870+-}
871+crossJoin
872+ :: FromClause outer commons schemas params right
873+ -- ^ right
874+ -> FromClause outer commons schemas params left
875+ -- ^ left
876+ -> FromClause outer commons schemas params (Join left right)
877+crossJoin right left = UnsafeFromClause $
878+ renderSQL left <+> "CROSS JOIN" <+> renderSQL right
879+
880+{- | @left & innerJoin right on@. The joined table is filtered by
881+the @on@ condition.
882+-}
883+innerJoin
884+ :: FromClause outer commons schemas params right
885+ -- ^ right
886+ -> Condition outer commons 'Ungrouped schemas params (Join left right)
887+ -- ^ @on@ condition
888+ -> FromClause outer commons schemas params left
889+ -- ^ left
890+ -> FromClause outer commons schemas params (Join left right)
891+innerJoin right on left = UnsafeFromClause $
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
916+ have a row for each row in @right@.
917+-}
918+rightOuterJoin
919+ :: FromClause outer commons schemas params right
920+ -- ^ right
921+ -> Condition outer commons 'Ungrouped schemas params (Join left right)
922+ -- ^ @on@ condition
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.
936+-}
937+fullOuterJoin
938+ :: FromClause outer commons schemas params right
939+ -- ^ right
940+ -> Condition outer commons 'Ungrouped schemas params (Join left right)
941+ -- ^ @on@ condition
942+ -> FromClause outer commons schemas params left
943+ -- ^ left
944+ -> FromClause outer commons schemas params
945+ (Join (NullifyFrom left) (NullifyFrom right))
946+fullOuterJoin right on left = UnsafeFromClause $
947+ renderSQL left <+> "FULL OUTER JOIN" <+> renderSQL right
948+ <+> "ON" <+> renderSQL on
949+
950+{-----------------------------------------
951+Grouping
952+-----------------------------------------}
953+
954+-- | `By`s are used in `groupBy` to reference a list of columns which are then
955+-- 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
957+-- column @col@; otherwise @By2 (\#tab \! \#col)@ will reference a table
958+-- qualified column @tab.col@.
959+data By
960+ (from :: FromType)
961+ (by :: (Symbol,Symbol)) where
962+ By1
963+ :: (HasUnique table from columns, Has column columns ty)
964+ => Alias column
965+ -> By from '(table, column)
966+ By2
967+ :: (Has table from columns, Has column columns ty)
968+ => Alias table
969+ -> Alias column
970+ -> By from '(table, column)
971+deriving instance Show (By from by)
972+deriving instance Eq (By from by)
973+deriving instance Ord (By from by)
974+instance RenderSQL (By from by) where
975+ renderSQL = \case
976+ By1 column -> renderSQL column
977+ By2 rel column -> renderSQL rel <> "." <> renderSQL column
978+
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+
989+-- | A `GroupByClause` indicates the `Grouping` of a `TableExpression`.
990+-- A `NoGroups` indicates `Ungrouped` while a `Group` indicates `Grouped`.
991+-- @NoGroups@ is distinguised from @Group Nil@ since no aggregation can be
992+-- done on @NoGroups@ while all output `Expression`s must be aggregated
993+-- in @Group Nil@. In general, all output `Expression`s in the
994+-- complement of @bys@ must be aggregated in @Group bys@.
995+newtype GroupByClause grp from = UnsafeGroupByClause
996+ { renderGroupByClause :: ByteString }
997+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
998+instance RenderSQL (GroupByClause grp from) where
999+ renderSQL = renderGroupByClause
1000+noGroups :: GroupByClause 'Ungrouped from
1001+noGroups = UnsafeGroupByClause ""
1002+group
1003+ :: SListI bys
1004+ => NP (By from) bys
1005+ -> GroupByClause ('Grouped bys) from
1006+group bys = UnsafeGroupByClause $ case bys of
1007+ Nil -> ""
1008+ bys' -> " GROUP BY" <+> renderCommaSeparated renderSQL bys'
1009+
1010+-- | A `HavingClause` is used to eliminate groups that are not of interest.
1011+-- An `Ungrouped` `TableExpression` may only use `NoHaving` while a `Grouped`
1012+-- `TableExpression` must use `Having` whose conditions are combined with
1013+-- `.&&`.
1014+data HavingClause outer commons grp schemas params from where
1015+ NoHaving :: HavingClause outer commons 'Ungrouped schemas params from
1016+ Having
1017+ :: [Condition outer commons ('Grouped bys) schemas params from]
1018+ -> HavingClause outer commons ('Grouped bys) schemas params from
1019+deriving instance Show (HavingClause outer commons grp schemas params from)
1020+deriving instance Eq (HavingClause outer commons grp schemas params from)
1021+deriving instance Ord (HavingClause outer commons grp schemas params from)
1022+
1023+-- | Render a `HavingClause`.
1024+instance RenderSQL (HavingClause outer commons grp schemas params from) where
1025+ renderSQL = \case
1026+ NoHaving -> ""
1027+ Having [] -> ""
1028+ Having conditions ->
1029+ " HAVING" <+> commaSeparated (renderSQL <$> 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+
1075+{- |
1076+>>> import Data.Monoid (Sum (..))
1077+>>> import Data.Int (Int64)
1078+>>> :{
1079+ let
1080+ query :: Query_ schema () (Sum Int64)
1081+ query = withRecursive
1082+ ( values_ ((1 & astype int) `as` #n)
1083+ `unionAll`
1084+ select_ ((#n + 1) `as` #n)
1085+ (from (common #t) & where_ (#n .< 100)) `as` #t )
1086+ ( select_ (fromNull 0 (sum_ (All #n)) `as` #getSum) (from (common #t) & groupBy Nil))
1087+ in printSQL query
1088+:}
1089+WITH RECURSIVE "t" AS ((SELECT * FROM (VALUES ((1 :: int))) AS t ("n")) UNION ALL (SELECT ("n" + 1) AS "n" FROM "t" AS "t" WHERE ("n" < 100))) SELECT COALESCE(sum(ALL "n"), 0) AS "getSum" FROM "t" AS "t"
1090+-}
1091+withRecursive
1092+ :: Aliased (Query outer (recursive ': commons) schemas params) recursive
1093+ -> Query outer (recursive ': commons) schemas params row
1094+ -> Query outer commons schemas params row
1095+withRecursive (recursive `As` cte) query = UnsafeQuery $
1096+ "WITH RECURSIVE" <+> renderSQL cte
1097+ <+> "AS" <+> parenthesized (renderSQL recursive)
1098+ <+> renderSQL query
squeal-postgresql/src/Squeal/PostgreSQL/Render.hsnew file+145
@@ -0,0 +1,145 @@
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.hsnew file+596
@@ -0,0 +1,596 @@
1+{-|
2+Module: Squeal.PostgreSQL.Schema
3+Description: Embedding of PostgreSQL type and alias system
4+Copyright: (c) Eitan Chatav, 2019
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+`Squeal.PostgreSQL.Schema` provides a type-level DSL for kinds of Postgres types,
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+-}
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.Schema
37+ ( -- * Postgres Types
38+ PGType (..)
39+ , NullityType (..)
40+ , RowType
41+ , FromType
42+ -- * Schema Types
43+ , ColumnType
44+ , ColumnsType
45+ , TableType
46+ , SchemumType (..)
47+ , IndexType (..)
48+ , FunctionType
49+ , OperatorType (..)
50+ , ReturnsType (..)
51+ , SchemaType
52+ , SchemasType
53+ , Public
54+ -- * 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
81+ , PGIntegral
82+ , PGFloating
83+ , PGTypeOf
84+ , PGJsonType
85+ , PGJsonKey
86+ , SamePGType
87+ , AllNotNull
88+ , NotAllNull
89+ -- * Nullifications
90+ , NullifyType
91+ , NullifyRow
92+ , NullifyFrom
93+ -- * Table Conversions
94+ , TableToColumns
95+ , ColumnsToRow
96+ , TableToRow
97+ ) where
98+
99+import Control.Category
100+import Data.Kind
101+import Data.Monoid hiding (All)
102+import Data.Type.Bool
103+import Generics.SOP
104+import GHC.TypeLits
105+import Prelude hiding (id, (.))
106+
107+import Squeal.PostgreSQL.Alias
108+import Squeal.PostgreSQL.List
109+import Squeal.PostgreSQL.Render
110+
111+-- $setup
112+-- >>> import Squeal.PostgreSQL
113+
114+-- | `PGType` is the promoted datakind of PostgreSQL types.
115+--
116+-- >>> :kind 'PGbool
117+-- 'PGbool :: PGType
118+data PGType
119+ = PGbool -- ^ logical Boolean (true/false)
120+ | PGint2 -- ^ signed two-byte integer
121+ | PGint4 -- ^ signed four-byte integer
122+ | PGint8 -- ^ signed eight-byte integer
123+ | PGnumeric -- ^ arbitrary precision numeric type
124+ | PGfloat4 -- ^ single precision floating-point number (4 bytes)
125+ | PGfloat8 -- ^ double precision floating-point number (8 bytes)
126+ | PGmoney -- ^ currency amount
127+ | PGchar Nat -- ^ fixed-length character string
128+ | PGvarchar Nat -- ^ variable-length character string
129+ | PGtext -- ^ variable-length character string
130+ | PGbytea -- ^ binary data ("byte array")
131+ | PGtimestamp -- ^ date and time (no time zone)
132+ | PGtimestamptz -- ^ date and time, including time zone
133+ | PGdate -- ^ calendar date (year, month, day)
134+ | PGtime -- ^ time of day (no time zone)
135+ | PGtimetz -- ^ time of day, including time zone
136+ | PGinterval -- ^ time span
137+ | PGuuid -- ^ universally unique identifier
138+ | PGinet -- ^ IPv4 or IPv6 host address
139+ | PGjson -- ^ textual JSON data
140+ | 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
150+
151+-- | `NullityType` encodes the potential presence or definite absence of a
152+-- @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
158+data NullityType
159+ = Null PGType -- ^ @NULL@ may be present
160+ | NotNull PGType -- ^ @NULL@ is absent
161+
162+-- | The constraint operator, `:=>` is a type level pair
163+-- between a "constraint" and some type, for use in pairing
164+-- a `ColumnConstraint` with a `NullityType` to produce a `ColumnType`
165+-- or a `TableConstraints` and a `ColumnsType` to produce a `TableType`.
166+type (:=>) constraint ty = '(constraint,ty)
167+infixr 7 :=>
168+
169+-- | `ColumnConstraint` encodes the availability of @DEFAULT@ for inserts and updates.
170+-- A column can be assigned a default value.
171+-- A data `Squeal.PostgreSQL.Manipulations.Manipulation` command can also
172+-- request explicitly that a column be set to its default value,
173+-- without having to know what that value is.
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+-- :}
196+type ColumnsType = [(Symbol,ColumnType)]
197+
198+-- | `TableConstraint` encodes various forms of data constraints
199+-- of columns in a table.
200+-- `TableConstraint`s give you as much control over the data in your tables
201+-- as you wish. If a user attempts to store data in a column that would
202+-- violate a constraint, an error is raised. This applies
203+-- even if the value came from the default value definition.
204+data TableConstraint
205+ = Check [Symbol]
206+ | Unique [Symbol]
207+ | PrimaryKey [Symbol]
208+ | ForeignKey [Symbol] Symbol [Symbol]
209+
210+{- | A `TableConstraints` is a row of `TableConstraint`s.
211+
212+>>> :{
213+type family UsersConstraints :: TableConstraints where
214+ UsersConstraints = '[ "pk_users" ::: 'PrimaryKey '["id"] ]
215+:}
216+-}
217+type TableConstraints = [(Symbol,TableConstraint)]
218+
219+-- | A `ForeignKey` must reference columns that either are
220+-- a `PrimaryKey` or form a `Unique` constraint.
221+type family Uniquely
222+ (key :: [Symbol])
223+ (constraints :: TableConstraints) :: Constraint where
224+ Uniquely key (uq ::: 'Unique key ': constraints) = ()
225+ Uniquely key (pk ::: 'PrimaryKey key ': constraints) = ()
226+ Uniquely key (_ ': constraints) = Uniquely key constraints
227+
228+-- | `TableType` encodes a row of constraints on a table as well as the types
229+-- of its columns.
230+--
231+-- >>> :{
232+-- type family UsersTable :: TableType where
233+-- UsersTable =
234+-- '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
235+-- '[ "id" ::: 'Def :=> 'NotNull 'PGint4
236+-- , "name" ::: 'NoDef :=> 'NotNull 'PGtext
237+-- ]
238+-- :}
239+type TableType = (TableConstraints,ColumnsType)
240+
241+{- | A `RowType` is a row of `NullityType`. They correspond to Haskell
242+record types by means of `Squeal.PostgreSQL.Binary.RowPG` and are used in many places.
243+
244+>>> :{
245+type family PersonRow :: RowType where
246+ PersonRow =
247+ '[ "name" ::: 'NotNull 'PGtext
248+ , "age" ::: 'NotNull 'PGint4
249+ , "dateOfBirth" ::: 'Null 'PGdate
250+ ]
251+:}
252+-}
253+type RowType = [(Symbol,NullityType)]
254+
255+{- | `FromType` is a row of `RowType`s. It can be thought of as
256+a product, or horizontal gluing and is used in `Squeal.PostgreSQL.Query.FromClause`s
257+and `Squeal.PostgreSQL.Query.TableExpression`s.
258+-}
259+type FromType = [(Symbol,RowType)]
260+
261+-- | `ColumnsToRow` removes column constraints.
262+type family ColumnsToRow (columns :: ColumnsType) :: RowType where
263+ ColumnsToRow (column ::: _ :=> ty ': column1 ::: _ :=> ty1 ': column2 ::: _ :=> ty2 ': column3 ::: _ :=> ty3 ': column4 ::: _ :=> ty4 ': column5 ::: _ :=> ty5 ': columns) =
264+ column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': column3 ::: ty3 ': column4 ::: ty4 ': column5 ::: ty5 ': ColumnsToRow columns
265+ ColumnsToRow (column ::: _ :=> ty ': column1 ::: _ :=> ty1 ': column2 ::: _ :=> ty2 ': column3 ::: _ :=> ty3 ': column4 ::: _ :=> ty4 ': columns) =
266+ column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': column3 ::: ty3 ': column4 ::: ty4 ': ColumnsToRow columns
267+ ColumnsToRow (column ::: _ :=> ty ': column1 ::: _ :=> ty1 ': column2 ::: _ :=> ty2 ': column3 ::: _ :=> ty3 ': columns) =
268+ column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': column3 ::: ty3 ': ColumnsToRow columns
269+ ColumnsToRow (column ::: _ :=> ty ': column1 ::: _ :=> ty1 ': column2 ::: _ :=> ty2 ': columns) =
270+ column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': ColumnsToRow columns
271+ ColumnsToRow (column ::: _ :=> ty ': column1 ::: _ :=> ty1 ': columns) =
272+ column ::: ty ': column1 ::: ty1 ': ColumnsToRow columns
273+ ColumnsToRow (column ::: _ :=> ty ': columns) =
274+ column ::: ty ': ColumnsToRow columns
275+ ColumnsToRow '[] = '[]
276+
277+-- | `TableToColumns` removes table constraints.
278+type family TableToColumns (table :: TableType) :: ColumnsType where
279+ TableToColumns (constraints :=> columns) = columns
280+
281+-- | Convert a table to a row type.
282+type family TableToRow (table :: TableType) :: RowType where
283+ TableToRow tab = ColumnsToRow (TableToColumns tab)
284+
285+-- | Numeric Postgres types.
286+type PGNum =
287+ '[ 'PGint2, 'PGint4, 'PGint8, 'PGnumeric, 'PGfloat4, 'PGfloat8]
288+
289+-- | Floating Postgres types.
290+type PGFloating = '[ 'PGfloat4, 'PGfloat8, 'PGnumeric]
291+
292+-- | Integral Postgres types.
293+type PGIntegral = '[ 'PGint2, 'PGint4, 'PGint8]
294+
295+-- | `PGTypeOf` forgets about @NULL@ and any column constraints.
296+type family PGTypeOf (ty :: NullityType) :: PGType where
297+ PGTypeOf (nullity pg) = pg
298+
299+-- | Equality constraint on the underlying `PGType` of two columns.
300+class SamePGType
301+ (ty0 :: (Symbol,ColumnType)) (ty1 :: (Symbol,ColumnType)) where
302+instance ty0 ~ ty1 => SamePGType
303+ (alias0 ::: def0 :=> nullity0 ty0)
304+ (alias1 ::: def1 :=> nullity1 ty1)
305+
306+-- | `AllNotNull` is a constraint that proves a `ColumnsType` has no @NULL@s.
307+type 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 '[] = ()
315+
316+-- | `NotAllNull` is a constraint that proves a `ColumnsType` has some
317+-- @NOT NULL@.
318+type family NotAllNull (columns :: ColumnsType) :: Constraint where
319+ NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()
320+ NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()
321+ NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()
322+ NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()
323+ NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()
324+ NotAllNull (_ ::: _ :=> 'NotNull _ ': _) = ()
325+ NotAllNull (_ ::: _ :=> 'Null _ ': columns) = NotAllNull columns
326+
327+-- | `NullifyType` is an idempotent that nullifies a `NullityType`.
328+type family NullifyType (ty :: NullityType) :: NullityType where
329+ NullifyType ('Null ty) = 'Null ty
330+ NullifyType ('NotNull ty) = 'Null ty
331+
332+-- | `NullifyRow` is an idempotent that nullifies a `RowType`.
333+type family NullifyRow (columns :: RowType) :: RowType where
334+ NullifyRow (column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': column3 ::: ty3 ': column4 ::: ty4 ': column5 ::: ty5 ': columns) =
335+ column ::: NullifyType ty ': column1 ::: NullifyType ty1 ': column2 ::: NullifyType ty2 ': column3 ::: NullifyType ty3 ': column4 ::: NullifyType ty4 ': column5 ::: NullifyType ty5 ': NullifyRow columns
336+ NullifyRow (column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': column3 ::: ty3 ': column4 ::: ty4 ': columns) =
337+ column ::: NullifyType ty ': column1 ::: NullifyType ty1 ': column2 ::: NullifyType ty2 ': column3 ::: NullifyType ty3 ': column4 ::: NullifyType ty4 ': NullifyRow columns
338+ NullifyRow (column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': column3 ::: ty3 ': columns) =
339+ column ::: NullifyType ty ': column1 ::: NullifyType ty1 ': column2 ::: NullifyType ty2 ': column3 ::: NullifyType ty3 ': NullifyRow columns
340+ NullifyRow (column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': columns) =
341+ column ::: NullifyType ty ': column1 ::: NullifyType ty1 ': column2 ::: NullifyType ty2 ': NullifyRow columns
342+ NullifyRow (column ::: ty ': column1 ::: ty1 ': columns) =
343+ column ::: NullifyType ty ': column1 ::: NullifyType ty1 ': NullifyRow columns
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
350+-- in a `Squeal.PostgreSQL.Query.FromClause`.
351+type family NullifyFrom (tables :: FromType) :: FromType where
352+ NullifyFrom (table ::: columns ': table1 ::: columns1 ': table2 ::: columns2 ': table3 ::: columns3 ': table4 ::: columns4 ': table5 ::: columns5 ': tables) =
353+ table ::: NullifyRow columns ': table1 ::: NullifyRow columns1 ': table2 ::: NullifyRow columns2 ': table3 ::: NullifyRow columns3 ': table4 ::: NullifyRow columns5 ': table5 ::: NullifyRow columns4 ': NullifyFrom tables
354+ NullifyFrom (table ::: columns ': table1 ::: columns1 ': table2 ::: columns2 ': table3 ::: columns3 ': table4 ::: columns4 ': tables) =
355+ table ::: NullifyRow columns ': table1 ::: NullifyRow columns1 ': table2 ::: NullifyRow columns2 ': table3 ::: NullifyRow columns3 ': table4 ::: NullifyRow columns4 ': NullifyFrom tables
356+ NullifyFrom (table ::: columns ': table1 ::: columns1 ': table2 ::: columns2 ': table3 ::: columns3 ': tables) =
357+ table ::: NullifyRow columns ': table1 ::: NullifyRow columns1 ': table2 ::: NullifyRow columns2 ': table3 ::: NullifyRow columns3 ': NullifyFrom tables
358+ NullifyFrom (table ::: columns ': table1 ::: columns1 ': table2 ::: columns2 ': tables) =
359+ table ::: NullifyRow columns ': table1 ::: NullifyRow columns1 ': table2 ::: NullifyRow columns2 ': NullifyFrom tables
360+ NullifyFrom (table ::: columns ': table1 ::: columns1 ': tables) =
361+ table ::: NullifyRow columns ': table1 ::: NullifyRow columns1 ': NullifyFrom tables
362+ NullifyFrom (table ::: columns ': tables) =
363+ table ::: NullifyRow columns ': NullifyFrom tables
364+ NullifyFrom '[] = '[]
365+
366+-- | @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@
368+-- `Squeal.PostgreSQL.Definition.addColumn`.
369+type family Create alias x xs where
370+ 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
376+
377+type family CreateIfNotExists alias x xs where
378+ CreateIfNotExists alias x '[] = '[alias ::: x]
379+ CreateIfNotExists alias x (alias ::: y ': xs) = alias ::: y ': xs
380+ CreateIfNotExists alias y (x ': xs) = x ': CreateIfNotExists alias y xs
381+
382+type family CreateOrReplace alias x xs where
383+ CreateOrReplace alias x '[] = '[alias ::: x]
384+ CreateOrReplace alias x (alias ::: x ': xs) = alias ::: x ': xs
385+ CreateOrReplace alias x (alias ::: y ': xs) = TypeError
386+ ('Text "CreateOrReplace: expected type "
387+ ':<>: 'ShowType x
388+ ':<>: 'Text " but alias "
389+ ':<>: 'ShowType alias
390+ ':<>: 'Text " has type "
391+ ':<>: 'ShowType y)
392+ CreateOrReplace alias y (x ': xs) = x ': CreateOrReplace alias y xs
393+
394+-- | @Drop alias xs@ removes the type associated with @alias@ in @xs@
395+-- and is used in `Squeal.PostgreSQL.Definition.dropTable` statements
396+-- and in @ALTER TABLE@ `Squeal.PostgreSQL.Definition.dropColumn` statements.
397+type family Drop alias xs where
398+ Drop alias '[] = TypeError
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
404+
405+type family DropSchemum alias sch xs where
406+ DropSchemum alias sch '[] = TypeError
407+ ('Text "DropSchemum: alias "
408+ ':<>: 'ShowType alias
409+ ':<>: 'Text " does not exist" )
410+ DropSchemum alias sch (alias ::: sch x ': xs) = xs
411+ DropSchemum alias sch0 (alias ::: sch1 x ': xs) = TypeError
412+ ('Text "DropSchemum: expected schemum "
413+ ':<>: 'ShowType sch0
414+ ':<>: 'Text " but alias "
415+ ':<>: 'ShowType alias
416+ ':<>: 'Text " has schemum "
417+ ':<>: 'ShowType sch1)
418+ DropSchemum alias sch (x ': xs) = x ': DropSchemum alias sch xs
419+
420+type family DropIfExists alias xs where
421+ DropIfExists alias '[] = '[]
422+ DropIfExists alias (alias ::: x ': xs) = xs
423+ DropIfExists alias (x ': xs) = x ': DropIfExists alias xs
424+
425+type family DropSchemumIfExists alias sch xs where
426+ DropSchemumIfExists alias sch '[] = '[]
427+ DropSchemumIfExists alias sch (alias ::: sch x ': xs) = xs
428+ DropSchemumIfExists alias sch0 (alias ::: sch1 x ': xs) = TypeError
429+ ('Text "DropSchemumIfExists: expected schemum "
430+ ':<>: 'ShowType sch1
431+ ':<>: 'Text " but alias "
432+ ':<>: 'ShowType alias
433+ ':<>: 'Text " has schemum "
434+ ':<>: 'ShowType sch0)
435+ DropSchemumIfExists alias sch (x ': xs) = x ': DropSchemumIfExists alias sch xs
436+
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`.
440+type family Alter alias x xs where
441+ Alter alias x '[] = TypeError
442+ ('Text "Alter: alias "
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+
453+-- | @Rename alias0 alias1 xs@ replaces the alias @alias0@ by @alias1@ in @xs@
454+-- and is used in `Squeal.PostgreSQL.Definition.alterTableRename` and
455+-- `Squeal.PostgreSQL.Definition.renameColumn`.
456+type 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
462+ Rename alias0 alias1 (x ': xs) = x ': Rename alias0 alias1 xs
463+
464+type family RenameIfExists alias0 alias1 xs where
465+ RenameIfExists alias x '[] = '[]
466+ RenameIfExists alias0 alias1 ((alias0 ::: x0) ': xs) = (alias1 ::: x0) ': xs
467+ RenameIfExists alias0 alias1 (x ': xs) = x ': RenameIfExists alias0 alias1 xs
468+
469+-- | Check if a `TableConstraint` involves a column
470+type family ConstraintInvolves column constraint where
471+ ConstraintInvolves column ('Check columns) = column `Elem` columns
472+ ConstraintInvolves column ('Unique columns) = column `Elem` columns
473+ ConstraintInvolves column ('PrimaryKey columns) = column `Elem` columns
474+ ConstraintInvolves column ('ForeignKey columns tab refcolumns)
475+ = column `Elem` columns
476+
477+-- | Drop all `TableConstraint`s that involve a column
478+type family DropIfConstraintsInvolve column constraints where
479+ DropIfConstraintsInvolve column '[] = '[]
480+ DropIfConstraintsInvolve column (alias ::: constraint ': constraints)
481+ = If (ConstraintInvolves column constraint)
482+ (DropIfConstraintsInvolve column constraints)
483+ (alias ::: constraint ': DropIfConstraintsInvolve column constraints)
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.hsnew file+252
@@ -0,0 +1,252 @@
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.hsnew file+6
@@ -0,0 +1,6 @@
1+module Main (main) where
2+
3+import Test.DocTest
4+
5+main :: IO ()
6+main = doctest [ "-isrc", "src" ]
squeal-postgresql/test/Property.hsnew file+166
@@ -0,0 +1,166 @@
1+{-# LANGUAGE
2+ DataKinds
3+ , GADTs
4+ , LambdaCase
5+ , OverloadedLabels
6+ , OverloadedStrings
7+ , TypeApplications
8+ , TypeOperators
9+#-}
10+
11+module Main (main) where
12+
13+import Control.Monad.Trans
14+import Data.ByteString (ByteString)
15+import Data.ByteString.Char8 (unpack)
16+import Data.Scientific (fromFloatDigits)
17+import Data.Fixed (Fixed(MkFixed), Micro, Pico)
18+import Data.String (IsString(fromString))
19+import Data.Time
20+import Squeal.PostgreSQL hiding (check, defaultMain, Group)
21+import Hedgehog hiding (Range)
22+import qualified Hedgehog.Gen as Gen
23+import qualified Hedgehog.Main as Main
24+import qualified Hedgehog.Range as Range
25+
26+main :: IO ()
27+main = Main.defaultMain [checkSequential roundtrips]
28+
29+roundtrips :: Group
30+roundtrips = Group "roundtrips"
31+ [ roundtrip int2 genInt16
32+ , roundtrip int4 genInt32
33+ , roundtrip int8 genInt64
34+ , roundtrip bool Gen.bool
35+ , roundtrip numeric genScientific
36+ , roundtrip float4 genFloat
37+ , roundtrip float8 genDouble
38+ , roundtripOn normalizeTimeOfDay time genTimeOfDay
39+ -- , roundtrip timetz genTimeWithZone normalizeTimeWithZone
40+ , roundtripOn normalizeLocalTime timestamp genLocalTime
41+ , roundtrip timestamptz genUTCTime
42+ , roundtrip date genDay
43+ , roundtrip interval genDiffTime
44+ , roundtripOn normalizeIntRange int4range (genRange genInt32)
45+ , roundtripOn normalizeIntRange int8range (genRange genInt64)
46+ , roundtrip numrange (genRange genScientific)
47+ , roundtripOn (fmap normalizeLocalTime) tsrange (genRange genLocalTime)
48+ , roundtrip tstzrange (genRange genUTCTime)
49+ , roundtripOn normalizeIntRange daterange (genRange genDay)
50+ ]
51+ where
52+ genInt16 = Gen.int16 Range.exponentialBounded
53+ genInt32 = Gen.int32 Range.exponentialBounded
54+ genInt64 = Gen.int64 Range.exponentialBounded
55+ genScientific = fromFloatDigits <$> genFloat
56+ genPosFloat = Gen.float
57+ (Range.exponentialFloatFrom 1 minPosFloat maxPosFloat)
58+ genFloat = Gen.prune $ Gen.choice
59+ [ genPosFloat
60+ , negate <$> genPosFloat
61+ , Gen.element [0,1/0] ]
62+ genPosDouble = Gen.double
63+ (Range.exponentialFloatFrom 1 minPosFloat maxPosFloat)
64+ genDouble = Gen.prune $ Gen.choice
65+ [ genPosDouble
66+ , negate <$> genPosDouble
67+ , Gen.element [0,1/0] ]
68+ genRange gen = do
69+ lb <- gen
70+ ub <- Gen.filter (lb <) gen
71+ Gen.element
72+ [ Empty, singleton lb, whole
73+ , lb <=..<= ub , lb <=..< ub, lb <..<= ub, lb <..< ub
74+ , atLeast lb, moreThan lb, atMost ub, lessThan ub ]
75+ genDay = do
76+ y <- toInteger <$> Gen.int (Range.constant 2000 2019)
77+ m <- Gen.int (Range.constant 1 12)
78+ d <- Gen.int (Range.constant 1 28)
79+ return $ fromGregorian y m d
80+ genDiffTime = secondsToDiffTime . toInteger <$>
81+ Gen.int (Range.constant 0 86401)
82+ genUTCTime = UTCTime <$> genDay <*> genDiffTime
83+ genTimeOfDay = do
84+ h <- Gen.int (Range.constant 0 23)
85+ m <- Gen.int (Range.constant 0 59)
86+ s <- MkFixed . toInteger <$> Gen.int (Range.constant 0 59)
87+ return $ TimeOfDay h m s
88+ genLocalTime = LocalTime <$> genDay <*> genTimeOfDay
89+ -- genTimeZone = Gen.element $ map (read @TimeZone)
90+ -- [ "UTC", "UT", "GMT", "EST", "EDT", "CST"
91+ -- , "CDT", "MST", "MDT", "PST", "PDT" ]
92+ -- genTimeWithZone = (,) <$> genTimeOfDay <*> genTimeZone
93+
94+roundtrip
95+ :: (OidOf ty, ToParam x ty, FromValue ty x, Show x, Eq x)
96+ => TypeExpression schemas ('NotNull ty)
97+ -> Gen x
98+ -> (PropertyName, Property)
99+roundtrip = roundtripOn id
100+
101+roundtripOn
102+ :: (OidOf ty, ToParam x ty, FromValue ty x, Show x, Eq x)
103+ => (x -> x)
104+ -> TypeExpression schemas ('NotNull ty)
105+ -> Gen x
106+ -> (PropertyName, Property)
107+roundtripOn norm ty gen = propertyWithName $ do
108+ x <- forAll gen
109+ Just (Only y) <- lift . withConnection connectionString $
110+ firstRow =<< runQueryParams
111+ (values_ (parameter @1 ty `as` #fromOnly)) (Only x)
112+ norm x === y
113+ where
114+ propertyWithName prop =
115+ (fromString (unpack (renderSQL ty)), property prop)
116+
117+maxPosFloat :: RealFloat a => a
118+maxPosFloat = x
119+ where
120+ n = floatDigits x
121+ b = floatRadix x
122+ (_, u) = floatRange x
123+ x = encodeFloat (b^n - 1) (u - n)
124+
125+minPosFloat :: RealFloat a => a
126+minPosFloat = x
127+ where
128+ n = floatDigits x
129+ b = floatRadix x
130+ (l, _) = floatRange x
131+ x = encodeFloat (b^n - 1) (l - n - 1)
132+
133+connectionString :: ByteString
134+connectionString = "host=localhost port=5432 dbname=exampledb"
135+
136+normalizeIntRange :: (Enum int, Ord int) => Range int -> Range int
137+normalizeIntRange = \case
138+ Empty -> Empty
139+ NonEmpty l u ->
140+ let
141+ l' = normalizeL l
142+ u' = normalizeU u
143+ in if emptyNormalized l' u' then Empty else NonEmpty l' u'
144+ where
145+ normalizeL = \case
146+ Open l -> Closed (succ l)
147+ normalized -> normalized
148+ normalizeU = \case
149+ Closed u -> Open (succ u)
150+ normalized -> normalized
151+ emptyNormalized (Closed l) (Open u) = l >= u
152+ emptyNormalized _ _ = False
153+
154+normalizeTimeOfDay :: TimeOfDay -> TimeOfDay
155+normalizeTimeOfDay (TimeOfDay h m s) = TimeOfDay h m
156+ . fromRational @Pico
157+ . toRational @Micro
158+ . fromRational @Micro
159+ . toRational @Pico
160+ $ s
161+
162+normalizeLocalTime :: LocalTime -> LocalTime
163+normalizeLocalTime (LocalTime d t) = LocalTime d (normalizeTimeOfDay t)
164+
165+-- normalizeTimeWithZone :: (TimeOfDay, TimeZone) -> (TimeOfDay, TimeZone)
166+-- normalizeTimeWithZone (t, z) = (normalizeTimeOfDay t, z)
squeal-postgresql/test/Spec.hsnew file+136
@@ -0,0 +1,136 @@
1+{-# LANGUAGE
2+ DataKinds
3+ , DeriveAnyClass
4+ , DeriveGeneric
5+ , DerivingStrategies
6+ , DuplicateRecordFields
7+ , FlexibleContexts
8+ , OverloadedLabels
9+ , OverloadedLists
10+ , OverloadedStrings
11+ , TypeApplications
12+ , TypeFamilies
13+ , TypeInType
14+ , TypeOperators
15+#-}
16+
17+module Main (main) where
18+
19+import Control.Concurrent.Async (replicateConcurrently)
20+import Data.ByteString (ByteString)
21+import Data.Int (Int32)
22+import Data.Text (Text)
23+import Test.Hspec
24+
25+import qualified Generics.SOP as SOP
26+import qualified GHC.Generics as GHC
27+
28+import Squeal.PostgreSQL
29+
30+main :: IO ()
31+main = hspec spec
32+
33+type Schemas = Public
34+ '[ "users" ::: 'Table (
35+ '[ "pk_users" ::: 'PrimaryKey '["id"]
36+ , "unique_names" ::: 'Unique '["name"]
37+ ] :=>
38+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
39+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext ] ) ]
40+
41+data User = User
42+ { userName :: Text
43+ } deriving stock (Eq, Show, GHC.Generic)
44+ deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
45+
46+insertUser :: Manipulation_ Schemas User ()
47+insertUser = insertInto_ #users
48+ (Values_ (Default `as` #id :* Set (param @1) `as` #name))
49+
50+setup :: Definition (Public '[]) Schemas
51+setup =
52+ createTable #users
53+ ( serial `as` #id :*
54+ notNullable text `as` #name )
55+ ( primaryKey #id `as` #pk_users :*
56+ unique #name `as` #unique_names )
57+
58+teardown :: Definition Schemas (Public '[])
59+teardown = dropTable #users
60+
61+silence :: MonadPQ schemas pq => pq ()
62+silence = manipulate_ $
63+ UnsafeManipulation "SET client_min_messages TO WARNING;"
64+
65+setupDB :: IO ()
66+setupDB = withConnection connectionString $
67+ silence & pqThen (define setup)
68+
69+dropDB :: IO ()
70+dropDB = withConnection connectionString $
71+ silence & pqThen (define teardown)
72+
73+connectionString :: ByteString
74+connectionString = "host=localhost port=5432 dbname=exampledb"
75+
76+spec :: Spec
77+spec = before_ setupDB . after_ dropDB $ do
78+
79+ describe "Exceptions" $ do
80+
81+ let
82+ testUser = User "TestUser"
83+ newUser = manipulateParams_ insertUser
84+ insertUserTwice = newUser testUser >> newUser testUser
85+ err23505 = PQException $ PQState FatalError (Just "23505")
86+ (Just "ERROR: duplicate key value violates unique constraint \"unique_names\"\nDETAIL: Key (name)=(TestUser) already exists.\n")
87+
88+ it "should be thrown for constraint violation" $
89+ withConnection connectionString insertUserTwice
90+ `shouldThrow` (== err23505)
91+
92+ it "should be rethrown for constraint violation in a transaction" $
93+ withConnection connectionString (transactionally_ insertUserTwice)
94+ `shouldThrow` (== err23505)
95+
96+ describe "Pools" $
97+
98+ it "should manage concurrent transactions" $ do
99+ pool <- createConnectionPool
100+ "host=localhost port=5432 dbname=exampledb" 1 0.5 10
101+ let
102+ query :: Query_ (Public '[]) () (Only Char)
103+ query = values_ (literal 'a' `as` #fromOnly)
104+ session = usingConnectionPool pool . transactionally_ $ do
105+ result <- runQuery query
106+ Just (Only chr) <- firstRow result
107+ return chr
108+ chrs <- replicateConcurrently 10 session
109+ chrs `shouldSatisfy` all (== 'a')
110+
111+ describe "Ranges" $
112+
113+ it "should correctly decode ranges" $ do
114+
115+ rangesOut <- withConnection connectionString $ do
116+ let
117+ query :: Query_ (Public '[]) () (Only (Range Int32))
118+ query = values
119+ ( range int4range (atLeast 3) `as` #fromOnly )
120+ [ range int4range (3 <=..< 5) `as` #fromOnly
121+ , range int4range Empty `as` #fromOnly
122+ , range int4range whole `as` #fromOnly ]
123+ getRows =<< runQuery query
124+ (fromOnly <$> rangesOut :: [Range Int32]) `shouldBe`
125+ [ atLeast 3, 3 <=..< 5, Empty, whole ]
126+
127+ describe "Parameters" $ do
128+
129+ it "should run queries that don't reference all their parameters" $ do
130+
131+ out <- withConnection connectionString $ do
132+ let
133+ query :: Query_ (Public '[]) (Char,Int32) (Only Int32)
134+ query = values_ (param @2 `as` #fromOnly)
135+ firstRow =<< runQueryParams query ('a', 3 :: Int32)
136+ (fromOnly <$> out :: Maybe Int32) `shouldBe` Just 3
squeal-presentation-raveline.mdnew file+794
@@ -0,0 +1,794 @@
1+# Squeal
2+
3+_A bridge between SQL and Haskell_
4+
5+by [@Raveline](https://github.com/raveline)
6+
7+---
8+
9+# Rationale
10+
11+Using `postgresql-simple` you have a typical "Trial, error, despair" workflow:
12+
13+- Write query manually or semi-automatically
14+
15+- Write haskell code using the query
16+
17+- Pray that the query syntax is correct
18+
19+- Pray that it returns what you want
20+
21+- Realize the inefficiency of prayer when it comes to SQL
22+
23+- Iterate till it works
24+
25+---
26+
27+![Can't take this anymore](http://gif.eraveline.eu/static/img/0x16e.gif)
28+
29+---
30+
31+# Use your best friend: GHC
32+
33+Squeal provides several eDSL to make your SQL typesafe:
34+
35+- Type level eDSL to express schema;
36+
37+- Value level eDSL to manipulate schema (plus migration, yeehaw !);
38+
39+- Type level eDSL to express queries;
40+
41+- Value level eDSL to perform queries
42+
43+However, it's not an ORM. There's no caching, lazy loading - you retain control over your memory. Also, joins - and mostly aggregation after joins - have to be handled manually.
44+
45+---
46+
47+# Part I. Schema & migration
48+
49+---
50+
51+# The Schema
52+
53+- The schema will be used to validate _everything_: migration, queries, etc.
54+
55+- A schema is mostly a collection of tables.
56+
57+- In this presentation, we will create a very basic database modeling a parliament. We will store _members of parliament_ and _parliamentary groups_.
58+
59+- A simple Schema to represent a Parliament could be:
60+
61+```haskell
62+type Schema = '[ "mp" ::: 'Table MemberOfParliament
63+ , "groupp" ::: 'Table ParliamentGroup ]
64+```
65+
66+---
67+
68+> _note_ We need the `DataKinds` extension to be able to express heterogenous lists containing
69+> specific types like this one.
70+
71+> You can perfectly call your table "group" and not "groupp" even though it is a
72+> keyword in SQL - Squeal queries will be properly escaped.
73+
74+---
75+
76+# A small example
77+
78+```haskell
79+type ParliamentaryGroup =
80+ '[ "pk_groupp" ::: 'PrimaryKey '["groupp_id"]]
81+ :=>
82+ '[ "groupp_id" ::: 'NoDef :=> 'NotNull 'PGuuid
83+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext
84+ ]
85+```
86+
87+- That's a whole simple table defined in one go.
88+
89+- `:::` lets us define a column or a constraint.
90+
91+- `:=>` associates the constraints to the column.
92+
93+- Let's split constraints and column to study the syntax a bit more.
94+
95+---
96+
97+> _note_ We are using `:::` and `:=>` to quickly express associations when writing
98+> our schema. We need the `TypeOperators` extension.]
99+
100+---
101+
102+![What does this means ?!](http://gif.eraveline.eu/static/img/0x27e.gif)
103+
104+---
105+
106+# Defining a table
107+
108+```haskell
109+type MemberOfParliament =
110+ '[ "pk_mp" ::: 'PrimaryKey '["mp_id"]
111+ , "fk_mp_groupp" ::: 'ForeignKey '["mp_group"] "groupp" '["groupp_id"]
112+ ] :=> MpCols
113+```
114+
115+- A table is a collection of constraints associated to a collection of columns.
116+
117+- We defined a table named "mp".
118+
119+- It has a constraint named "pk_mp", defining its primary key on column "mp_id".
120+
121+- It has a constraint named "fk_mp_groupp" defining a foreign key on column "mg_group", connected to the column "groupp_id" of table "groupp".
122+
123+- These constraints will be associated to the columns defined in `MpCols`.
124+
125+---
126+
127+# Defining columns
128+
129+```haskell
130+type MpCols =
131+ '[ "mp_id" ::: 'NoDef :=> 'NotNull 'PGuuid
132+ , "first_name" ::: 'NoDef :=> 'NotNull 'PGtext
133+ , "last_name" ::: 'NoDef :=> 'NotNull 'PGtext
134+ ]
135+```
136+
137+- A listing of column associate, for each element:
138+
139+ * a name;
140+
141+ * the mention of an eventual default value;
142+
143+ * the nullability;
144+
145+ * the type (obviously).
146+
147+---
148+
149+> _note_ GHC is already helping. If I named the "mp_id" column differently,
150+> GHC would yell because I promised a primary key constraint on a column named `mp_id`, so there must be one.]
151+
152+---
153+
154+# Implementating the schema
155+
156+- We will carry this schema type pretty much everywhere.
157+
158+- But before we play with this schema, we need to implement it.
159+
160+---
161+
162+```haskell
163+setup :: Definition '[] Schema
164+setup =
165+ createTable #groupp
166+ ( notNullable uuid `as` #groupp_id
167+ :* notNullable text `as` #name)
168+ ( primaryKey #groupp_id `as` #pk_groupp )
169+ >>> createTable #mp
170+ ( notNullable uuid `as` #mp_id
171+ :* notNullable text `as` #first_name
172+ :* notNullable text `as` #last_name
173+ :* notNullable text `as` #mp_group)
174+ ( primaryKey #mp_id `as` #pk_mp
175+ :* foreignKey #mp_group #groupp #groupp_id
176+ OnDeleteCascade OnUpdateCascade
177+ `as` #fk_mp_groupp)
178+```
179+
180+---
181+
182+# Damn, that's verbose
183+
184+- Yes. But you need verbosity to get type safety.
185+
186+- On the plus side, it's fairly straightforward.
187+
188+- You use `:*` to compose the element of the heterogenous list of columns.
189+
190+- You use `>>>` to compose table creation.
191+
192+> _note_ The compiler will catch any mistype between Schema and
193+> definition; wrong nullability, wrong type, wrong name, etc.
194+
195+---
196+
197+> _note_ You'll also need `OverloadedLabels`, for naming stuff.
198+> This is mostly to avoid having to write manual proxies all
199+> the time and for convenience.
200+
201+---
202+
203+# Setting up the schema
204+
205+- Squeal comes with a very good migration manager, handling _upgrades_ AND
206+_downgrades_.
207+
208+- A migration is a simple type:
209+
210+```haskell
211+Migration io schema0 schema1
212+```
213+
214+- The first parameter is a BaseMonad (typically, IO).
215+
216+- The second parameter is "the current schema of your DB".
217+
218+- The last one is "what you will migrate to".
219+
220+- The `Definition` type used to define upgrade and downgrade functions use the
221+ same logic (from one schema to the other).
222+
223+---
224+
225+# Defining our first migration
226+
227+- We have the setup bit, we need the teardown:
228+
229+```haskell
230+tearDown :: Definition Schema '[]
231+tearDown = dropTable #mp >>> dropTable #groupp
232+```
233+
234+> _note_ GHC will also detect the _proper_ order of what you typed in
235+> downgrade and upgrade should there be any conflict (with foreign keys).
236+
237+```haskell
238+initDB :: Migration IO '[] Schema
239+initDB =
240+ Migration { name = "Schema creation"
241+ , up = void $ define setup
242+ , down = void $ define tearDown }
243+```
244+
245+---
246+
247+# Simple migrator example
248+
249+```haskell
250+main :: IO ()
251+main = do
252+ printSQL setup
253+ void $ withConnection connectionString $
254+ migrateUp $ single initDB
255+```
256+
257+- We print the migration query; you can do this for all queries generated through Squeal.
258+
259+- We use `migrateUp` to perform the migration.
260+
261+- You can run several migration at the same time, to run only one use `single`.
262+
263+---
264+
265+![That was easy](http://gif.eraveline.eu/static/img/0x47f.gif)
266+
267+---
268+
269+# Part II. Insertions
270+
271+---
272+
273+# Manipulations & Queries
274+
275+Besides the specific case of migration, you will mostly perform:
276+
277+- `Manipulation` : inserting, updating and deleting data.
278+
279+- `Query` : fetching data.
280+
281+- Both types are parametric over the same things:
282+
283+ * A schema
284+
285+ * Input parameters
286+
287+ * Output
288+
289+- Simplified, they look like this:
290+
291+```haskell
292+Manipulation schema params columns
293+
294+Query schema params columns
295+```
296+
297+
298+---
299+
300+# Our Haskell model
301+
302+```haskell
303+type Parliament = [Group]
304+
305+data Group =
306+ Group { name :: Text
307+ , members :: [MemberOfParliament] }
308+
309+data MemberOfParliament =
310+ MemberOfParliament { firstName :: Text
311+ , lastName :: Text }
312+```
313+
314+> _note_ We didn't use anything from Squeal.
315+> The model can be entirely separated from the persistence layer.
316+
317+---
318+
319+# Inserting a Parliamentary Group
320+
321+- A group is very simple: it's a uuid and a name. Let's define our params:
322+
323+```haskell
324+type GroupInsertionParams = '[ 'NotNull 'PGuuid
325+ , 'NotNull 'PGtext ]
326+```
327+
328+- Params are not named, but they are indexed. You just need nullability and type.
329+
330+---
331+
332+```haskell
333+groupInsertion :: Manipulation Schema GroupInsertionParams '[]
334+groupInsertion =
335+ insertRow_ #groupp ( Set (param @1) `as` #groupp_id
336+ :* Set (param @2) `as` #name )
337+```
338+
339+---
340+
341+- `TypeApplication` lets us use the index of parameters (counting from 1).
342+
343+- Once again: all this is checked by the compiler. Wrong name, wrong type... you'll get a compile error.
344+
345+- `insertRow_` is a simplified version of `insertRow`. `insertRow` lets you express a `RETURNING` clause and the expected behaviour in case of conflict.
346+
347+---
348+
349+_Inserting a Member of Parliament_
350+# Doing an INSERT INTO ... SELECT
351+
352+- We could create a naive query that takes MP uuid, first name, last name and group uuid...
353+
354+---
355+
356+- But that's boring. So let's use the `INSERT INTO ... SELECT`.
357+
358+---
359+
360+- We will build a query that will return as constants our MP's uuid, first name and last name...
361+
362+---
363+
364+- ... and fetch the uuid of a group given the name of the group.
365+
366+---
367+
368+- There's a `insertQuery` utility function for that. All we have to do is write the `select` !
369+
370+```haskell
371+mpInsertion :: Manipulation Schema MpParams '[]
372+mpInsertion =
373+ insertQuery_ #mp selectGroup -- we just have to write selectGroup !
374+```
375+
376+---
377+
378+_Inserting a Member of Parliament_
379+# The query type
380+
381+- A query looks just like a `Manipulation`:
382+
383+```haskell
384+Query schema params returns
385+```
386+
387+- Returns use a special syntax, that demands names, nullability and types:
388+
389+```haskell
390+type ExampleReturnType = '[ "some_column" ::: 'NotNull 'PGuuid
391+ , "other_column" ::: 'Null 'PGtext ]
392+```
393+
394+- It is not the same as the column definition we used in the schema. That one also expects that you specify, for each column, an eventual default:
395+
396+```haskell
397+type ExampleSchemaCols =
398+ '[ "some_column" ::: 'NoDef :=> 'NotNull 'PGuuid
399+ , "other_column" ::: 'NoDef :=> 'Null 'PGtext ]
400+```
401+
402+---
403+
404+_Inserting a Member of Parliament_
405+# Don't rewrite column definitions
406+
407+- We want our return type to be "all columns from table MP expressed as return type".
408+
409+- But we cannot reuse our neat `MpCols` alias, since the type do not match as we've just seen.
410+
411+- Hopefully, there's a neat Type Family that will let you convert any table you defined to the type of the equivalent row: `TableToRow`.
412+
413+- We finally have the signature for our SELECT query.
414+
415+```haskell
416+selectGroup :: Query Schema MpParams (TableToRow MemberOfParliament)
417+```
418+
419+---
420+
421+_Inserting a Member of Parliament_
422+# Our final Select query
423+
424+- Our intermediate query looks like this:
425+
426+```haskell
427+selectGroup =
428+ select
429+ ( param @1 `as` #mp_id
430+ :* param @2 `as` #first_name
431+ :* param @3 `as` #last_name
432+ :* #groupp ! #groupp_id `as` #mp_group
433+ )
434+ ( from (table #groupp)
435+ & where_ ( #groupp ! #name .== param @4 )
436+ )
437+```
438+
439+- The first three columns are constant defined through our params;
440+
441+- ... we alias the column name using `as`...
442+
443+- ... and when we need the result from the table we use the `#table ! #column` syntax.
444+
445+- We'll go back to the "from" block later.
446+
447+---
448+
449+# Dealing with the connection context
450+
451+- Queries are runned in a connection context:
452+
453+ * When dealing with a single-connection context, use the type `PQ`.
454+
455+ * When dealing with a pool of connection, use the type `PoolPQ`.
456+
457+- Or get rid of the context and use `mtl` style, with the typeclass `MonadPQ`.
458+
459+- We'll use that to demonstrate how to actually run our queries.
460+
461+---
462+
463+# Inserting a whole group
464+
465+```haskell
466+insertGroup :: (MonadPQ Schema m, MonadBaseControl IO m) => Group -> m ()
467+insertGroup g@(Group name _) = do
468+ uuid' <- liftBase nextRandom
469+ void $ manipulateParams groupInsertion (uuid', name)
470+ insertMps g
471+```
472+
473+- Remember that we defined a group as a name and a list of MPs.
474+
475+- We are in `MonadBaseControl`, so we cannot use `liftIO`, we need `liftBase`.
476+
477+- To perform a simple insertion, use `manipulateParams`. It takes into parameter
478+instances of `ToParam`, but you will typically use tuples or Generic-SOP.
479+
480+---
481+
482+# Inserting a bunch of MPs
483+
484+```haskell
485+insertMps :: (MonadPQ Schema m, MonadBaseControl IO m) => Group -> m ()
486+insertMps (Group groupName mps) =
487+ let tuplify Mp{..} = (, firstName, lastName, groupName) <$> nextRandom
488+ params = traverse tuplify mps
489+ in void $ liftBase params >>= traversePrepared mpInsertion
490+```
491+
492+- This time, we want to do a `preparedStatement`. We'll use `traversePrepare`
493+which behaves like `manipulateParams`, but expect a list of `ToParam`
494+instances.
495+
496+- We build our tuple manually again, mostly because we want to generate UUID on
497+the fly and we don't want to have them in our model.
498+
499+---
500+
501+# Inserting a whole parliament
502+
503+```haskell
504+insertParliament ::
505+ (MonadPQ Schema m, MonadBaseControl IO m) => Parliament -> m ()
506+insertParliament = traverse_ insertGroup
507+```
508+
509+- That's simple enough !
510+
511+- If we want to be a bit safer, though, we can wrap this call in a
512+`transactionally_` function, which will put all that in a transaction.
513+
514+---
515+
516+![Very simple](https://media1.tenor.com/images/0188c63209aced59f1583e1ca94e509e/tenor.gif?itemid=3550689)
517+
518+
519+---
520+
521+# Part III. Selects
522+
523+---
524+
525+# Composable queries
526+
527+- Building basic queries is easy, and is well documented.
528+
529+- However, the real interest of a tool like Squeal is in DRYness, and the documentation is still lacking in "how-to" related to composability.
530+
531+- I'll build an example showing how column selections and from clause can be factorized.
532+
533+- We want to write two queries:
534+
535+ * One to get all members of a specific group.
536+
537+ * One to get all the parliament.
538+
539+---
540+
541+# Decomposing a `Query`
542+
543+- A query typically stars with `select` (variants are available).
544+
545+- It then takes:
546+
547+ * A heterogenous list of fields with a scary signature;
548+
549+ * A virtual table (the from clause and filter clauses), called a `TableExpression`.
550+
551+- And return fields. Ours will look like this:
552+
553+```haskell
554+type GroupRowResult =
555+ '[ "groupName" ::: 'NotNull 'PGtext
556+ , "firstName" ::: 'NotNull 'PGtext
557+ , "lastName" ::: 'NotNull 'PGtext ]
558+```
559+
560+---
561+
562+# The Table Expression
563+
564+- It necessarily contains a `fromClause` (table, view or subquery, plus optional joins).
565+
566+- You can add where, groups, "HAVING" clause, order, etc.
567+
568+- `from` creates a basic `TableExpression` that you extend through various function to add clauses.
569+
570+- For our queries, we will share a common `FromClause`.
571+
572+---
573+
574+# The From Clause
575+
576+```
577+FromClause schema params from
578+```
579+
580+- We need Schema, input parameters and a `FromType` giving the available fields of the expression.
581+
582+- In our case, we'll join the table `mp` and the table `groupp`, meaning the `from` will be all fields of these tables.
583+
584+- We can use `TableToRow` to be more DRY:
585+
586+```haskell
587+type BaseParliamentSelection =
588+ '[ "g" ::: TableToRow GroupCols
589+ , "m" ::: TableToRow MpCols ]
590+```
591+
592+> _note_ We've also put everything with table aliases: "g" and "m".
593+
594+---
595+
596+# Writing our from clause
597+
598+```haskell
599+baseParliamentTables ::
600+ FromClause Schema (param :: [NullityType]) BaseParliamentSelection
601+baseParliamentTables =
602+ table
603+ (#groupp `as` #g)
604+ & innerJoin
605+ (table (#mp `as` #m))
606+ (#m ! #mp_group .== #g ! #groupp_id)
607+```
608+
609+- When picking "from" something, you need to specify the type with a function: `table` for a table, `view` for a view, etc.
610+
611+- All joins are available. `innerJoin` is the most basic one. It takes the joined table and the joining condition.
612+
613+- We have to specifiy the type of `param` (current limitation of the lib), even though _any_ params will be compatible with this, so we can plug `where` clauses depending on params should we need to !
614+
615+---
616+
617+# Typing the common selection
618+
619+- Both our querie will need the same fields. This has to be factorized too.
620+
621+- The scary signature of selection fields:
622+
623+```haskell
624+NP (Aliased (Expression schema from grouping params)) cols
625+```
626+
627+- `NP` is for heterogenous lists ("n-ary product").
628+
629+- `from` is the virtual table type, so our `BaseParliamentSelection`.
630+
631+- `grouping` is there to make a distinction between aggregated / unaggregated queries.
632+
633+- And finally, cols is the return type.
634+
635+---
636+
637+# Our common selection
638+
639+```haskell
640+groupSelection ::
641+ NP (Aliased (Expression Schema BaseParliamentSelection 'Ungrouped param))
642+ GroupRowResult
643+groupSelection =
644+ #g ! #name `as` #groupName
645+ :* #m ! #first_name `as` #firstName
646+ :* #m ! #last_name `as` #lastName
647+```
648+
649+- I hope you like big signatures.
650+
651+- But it's what let GHC checks that all alias and columns are available.
652+
653+- And that you're returning what you really intend to return.
654+
655+---
656+
657+# Putting it all together
658+
659+```haskell
660+selectParliament :: Query Schema '[] GroupRowResult
661+selectParliament =
662+ select groupSelection (from baseParliamentTables)
663+```
664+
665+```haskell
666+selectGroupMembers :: Query Schema '[ 'NotNull 'PGtext] GroupRowResult
667+selectGroupMembers =
668+ select groupSelection
669+ (from baseParliamentTables
670+ & where_ (#g ! #name .== param @1))
671+```
672+
673+- That is fairly DRY. And _entirely typesafe_.
674+
675+---
676+
677+# Actually fetching the data
678+
679+- We'll build an intermediary datatype representing our rows.
680+
681+- We'll make it match our row.
682+
683+- And we'll add generic-SOP so that we can build them from query results.
684+
685+```haskell
686+type GroupRowResult =
687+ '[ "groupName" ::: 'NotNull 'PGtext
688+ , "firstName" ::: 'NotNull 'PGtext
689+ , "lastName" ::: 'NotNull 'PGtext ]
690+```
691+
692+```haskell
693+data GroupRow =
694+ GroupRow { groupName :: Text
695+ , firstName :: Text
696+ , lastName :: Text }
697+ deriving (Generic)
698+
699+instance SOP.Generic GroupRow
700+instance SOP.HasDatatypeInfo GroupRow
701+```
702+
703+---
704+
705+# Aggregate result logic
706+
707+- We will get tabular, SQL data.
708+
709+- Our results will be `[GroupRow]`.
710+
711+- We'll build `Groups` from this:
712+
713+```haskell
714+buildGroup :: NE.NonEmpty GroupRow -> Group
715+buildGroup grs =
716+ let buildMP (GroupRow _ f l) = Mp f l
717+ name = groupName . NE.head $ grs
718+ members = NE.toList (buildMP <$> grs)
719+ in Group{..}
720+
721+rowToGroups :: [GroupRow] -> [Group]
722+rowToGroups =
723+ let grouped = fmap NE.fromList . L.groupBy ((==) `on` groupName)
724+ in fmap buildGroup . grouped
725+```
726+
727+---
728+
729+# Finally calling our queries
730+
731+- Query with params will use `runQueryParams`.
732+
733+- Query without params will use `runQuery`.
734+
735+- Result is inside a `MonadPQ` and of type `K` from generic-sop.
736+
737+- You get your actual result using `getRows`. Exemple:
738+
739+```haskell
740+getParliament :: (MonadPQ Schema m, MonadBaseControl IO m) => m [Group]
741+getParliament = do
742+ res <- runQuery selectParliament
743+ rows <- getRows res
744+ pure $ rowToGroups rows
745+```
746+
747+- In real life of course you'll write:
748+
749+```haskell
750+getParliament =
751+ rowToGroups <$> (runQuery selectParliament >>= getRows)
752+```
753+
754+---
755+
756+# Our query with params
757+
758+```haskell
759+getGroupMembers ::
760+ (MonadPQ Schema m, MonadBaseControl IO m) => Text -> m (Maybe Group)
761+getGroupMembers =
762+ listToMaybe . rowToGroups <$>
763+ (runQueryParams selectGroupMembers (Only t) >>= getRows)
764+```
765+
766+- And that's it.
767+
768+---
769+
770+![Eazy](https://media.tenor.com/images/8fc7c4077efe11b4a3a3b9ae4e643e87/tenor.gif)
771+
772+---
773+
774+# Conclusion
775+
776+---
777+
778+# Pros & Cons
779+
780+- Not everything is included: some cool stuff like array_agg and window functions are not available yet.
781+
782+- But development is _very_ active. `IN` clauses were missing but were added in the 4.0 released recently.
783+
784+- It's bleeding edge. You need latest LTS to be comfortable and psql >= 9.5.
785+
786+- It's Postgres-only but I would say that's a feature. Multi-DB tools are even more complex.
787+
788+- The author & maintainer is <3.
789+
790+- Typesafe. 'nuff said.
791+
792+---
793+
794+# Thank you !
squeal-presentation.pdfnew file

Binary file not shown.

squeel-postgresql/exe/Example.hsdeleted−86
@@ -1,86 +0,0 @@
1−{-# LANGUAGE
2− DataKinds
3− , DeriveGeneric
4− , FlexibleInstances
5− , MultiParamTypeClasses
6− , OverloadedLabels
7− , OverloadedStrings
8− , TypeApplications
9− , TypeOperators
10− , TypeSynonymInstances
11−#-}
12−
13−module Main (main,col1,col2) where
14−
15−import Control.Category ((>>>))
16−import Control.Monad.Base
17−import Data.Function ((&))
18−import Data.Int
19−import Data.Monoid
20−import Generics.SOP hiding (from)
21−import Squeel.PostgreSQL
22−
23−import qualified Data.ByteString.Char8 as Char8
24−import qualified GHC.Generics as GHC
25−
26−main :: IO ()
27−main = do
28− Char8.putStrLn "squeel"
29− connectionString <- pure
30− "host=localhost port=5432 dbname=exampledb"
31− Char8.putStrLn $ "connecting to " <> connectionString
32− connection0 <- connectdb connectionString
33− Char8.putStrLn "setting up schema"
34− connection1 <- runPQ (connection0 :: Connection '[]) $ pqExec $
35− createTable #students ((text & notNull) `As` #name :* Nil ) []
36− >>>
37− createTable #table1
38− ((int4 & notNull) `As` #col1 :* (int4 & notNull) `As` #col2 :* Nil) []
39− connection2 <- runPQ (connection1 :: Connection Schema) $ do
40− let
41− manipulation :: Manipulation Schema
42− '[ 'Required ('NotNull 'PGInt4)
43− , 'Required ('NotNull 'PGInt4)
44− , 'Required ('NotNull 'PGInt4)
45− , 'Required ('NotNull 'PGInt4)
46− ] '[]
47− manipulation =
48− insertInto #table1
49− ( Values
50− (param (Proxy @1) `As` #col1 :* param (Proxy @2) `As` #col2 :* Nil)
51− [param (Proxy @3) `As` #col1 :* param (Proxy @4) `As` #col2 :* Nil]
52− ) Conflict ReturningNil
53− liftBase $ Char8.putStrLn "manipulating"
54− _ <- pqExecParams manipulation (1::Int32,2::Int32,3::Int32,4::Int32)
55− liftBase $ Char8.putStrLn "querying"
56− Just result <- pqExecNil . query $
57− selectStar (from (Table (#table1 `As` #table1)))
58− value00 <- getValue (RowNumber 0) (columnNumber @0) result
59− value01 <- getValue (RowNumber 0) (columnNumber @1) result
60− value10 <- getValue (RowNumber 1) (columnNumber @0) result
61− value11 <- getValue (RowNumber 1) (columnNumber @1) result
62− row0 <- getRow (RowNumber 0) result
63− row1 <- getRow (RowNumber 1) result
64− liftBase $ do
65− print (value00 :: Int32)
66− print (value01 :: Int32)
67− print (value10 :: Int32)
68− print (value11 :: Int32)
69− print (row0 :: Table1Row)
70− print (row1 :: Table1Row)
71− Char8.putStrLn "tearing down schema"
72− connection3 <- runPQ (connection2 :: Connection Schema) $ pqExec $
73− dropTable #table1 >>> dropTable #students
74− finish (connection3 :: Connection '[])
75−
76−data Table1Row = Table1Row { col1 :: Int32, col2 :: Int32 }
77− deriving (Show, GHC.Generic)
78−instance Generic Table1Row
79−
80−type Schema =
81− '[ "students" ::: '["name" ::: 'Required ('NotNull 'PGText)]
82− , "table1" :::
83− '[ "col1" ::: 'Required ('NotNull 'PGInt4)
84− , "col2" ::: 'Required ('NotNull 'PGInt4)
85− ]
86− ]
squeel-postgresql/squeel-postgresql.cabaldeleted−72
@@ -1,72 +0,0 @@
1−name: squeel-postgresql
2−version: 0.0.0.1
3−synopsis: Squeel PostgreSQL Library
4−description: Squeel is a type-safe embedding of PostgreSQL and libpq in Haskell
5−homepage: https://github.com/echatav/squeel
6−author: Eitan Chatav
7−maintainer: eitan.chatav@gmail.com
8−copyright: 2017 Morphism, LLC
9−category: Database
10−build-type: Simple
11−cabal-version: >=1.10
12−
13−library
14− hs-source-dirs: src
15− exposed-modules:
16− Squeel.PostgreSQL
17− Squeel.PostgreSQL.Binary
18− Squeel.PostgreSQL.Binary2
19− Squeel.PostgreSQL.PQ
20− Squeel.PostgreSQL.Statement
21− Squeel.PostgreSQL.Schema
22− default-language: Haskell2010
23− ghc-options: -Wall -Werror -fprint-explicit-kinds
24− build-depends:
25− aeson
26− , base
27− , bytestring
28− , generics-sop
29− , lifted-base
30− , monad-control
31− , mtl
32− , network-ip
33− , postgresql-binary
34− , postgresql-libpq
35− , scientific
36− , text
37− , time
38− , transformers
39− , transformers-base
40− , uuid
41−
42−test-suite squeel-postgresql-test
43− default-language: Haskell2010
44− type: exitcode-stdio-1.0
45− hs-source-dirs: test
46− ghc-options: -Wall -Werror
47− main-is: Spec.hs
48− other-modules:
49− Squeel.PostgreSQL.StatementSpec
50− build-depends:
51− base
52− , generics-sop
53− , hspec
54− , squeel-postgresql
55−
56−executable squeel-postgresql-example
57− default-language: Haskell2010
58− hs-source-dirs: exe
59− ghc-options: -Wall -Werror
60− main-is: Example.hs
61− build-depends:
62− base
63− , bytestring
64− , generics-sop
65− , mtl
66− , squeel-postgresql
67− , transformers
68− , transformers-base
69−
70−source-repository head
71− type: git
72− location: https://github.com/echatav/squeel
squeel-postgresql/src/Squeel/PostgreSQL.hsdeleted−11
@@ -1,11 +0,0 @@
1−module Squeel.PostgreSQL
2− ( module Squeel.PostgreSQL.Binary2
3− , module Squeel.PostgreSQL.PQ
4− , module Squeel.PostgreSQL.Schema
5− , module Squeel.PostgreSQL.Statement
6− ) where
7−
8−import Squeel.PostgreSQL.Binary2
9−import Squeel.PostgreSQL.PQ
10−import Squeel.PostgreSQL.Schema
11−import Squeel.PostgreSQL.Statement
squeel-postgresql/src/Squeel/PostgreSQL/Binary.hsdeleted−145
@@ -1,145 +0,0 @@
1−{-# LANGUAGE
2− DataKinds
3− , FlexibleContexts
4− , FlexibleInstances
5− , GADTs
6− , LambdaCase
7− , MagicHash
8− , MultiParamTypeClasses
9− , PolyKinds
10− , ScopedTypeVariables
11− , TypeOperators
12−#-}
13−
14−module Squeel.PostgreSQL.Binary where
15−
16−import Data.ByteString (ByteString)
17−import Data.Int (Int16,Int32,Int64)
18−import Generics.SOP
19−import Data.Scientific (Scientific)
20−import Data.Text (Text)
21−import Data.Time (Day, TimeOfDay, TimeZone, LocalTime, UTCTime, DiffTime)
22−import Data.UUID (UUID)
23−
24−import qualified Data.Aeson as Aeson
25−import qualified Data.ByteString.Lazy as Lazy (ByteString)
26−import qualified Data.Text.Lazy as Lazy (Text)
27−import qualified PostgreSQL.Binary.Decoding as Decoder
28−import qualified PostgreSQL.Binary.Encoding as Encoder
29−
30−import Squeel.PostgreSQL.Schema
31−
32−decodeValue :: HasDecoding pg x => proxy pg -> ByteString -> Either Text x
33−decodeValue p = Decoder.valueParser $ decoding p
34−
35−class HasDecoding pg x where
36− decoding :: proxy pg -> Decoder.Value x
37−instance HasDecoding (column ::: 'Required ('NotNull 'PGInt2)) Int16 where
38− decoding _ = Decoder.int
39−instance HasDecoding (column ::: 'Required ('NotNull 'PGInt4)) Int32 where
40− decoding _ = Decoder.int
41−instance HasDecoding (column ::: 'Required ('NotNull 'PGInt8)) Int64 where
42− decoding _ = Decoder.int
43−instance HasDecoding (column ::: 'Required ('NotNull 'PGFloat4)) Float where
44− decoding _ = Decoder.float4
45−instance HasDecoding (column ::: 'Required ('NotNull 'PGFloat8)) Double where
46− decoding _ = Decoder.float8
47−instance HasDecoding (column ::: 'Required ('NotNull 'PGBool)) Bool where
48− decoding _ = Decoder.bool
49−instance HasDecoding (column ::: 'Required ('NotNull 'PGBytea)) ByteString where
50− decoding _ = Decoder.bytea_strict
51−instance HasDecoding (column ::: 'Required ('NotNull 'PGBytea)) Lazy.ByteString where
52− decoding _ = Decoder.bytea_lazy
53−instance HasDecoding (column ::: 'Required ('NotNull 'PGText)) Text where
54− decoding _ = Decoder.text_strict
55−instance HasDecoding (column ::: 'Required ('NotNull 'PGText)) Lazy.Text where
56− decoding _ = Decoder.text_lazy
57−instance HasDecoding (column ::: 'Required ('NotNull ('PGChar 1))) Char where
58− decoding _ = Decoder.char
59−instance HasDecoding (column ::: 'Required ('NotNull 'PGNumeric)) Scientific where
60− decoding _ = Decoder.numeric
61−instance HasDecoding (column ::: 'Required ('NotNull 'PGUuid)) UUID where
62− decoding _ = Decoder.uuid
63−instance HasDecoding (column ::: 'Required ('NotNull 'PGJson)) Aeson.Value where
64− decoding _ = Decoder.json_ast
65−instance HasDecoding (column ::: 'Required ('NotNull 'PGJsonb)) Aeson.Value where
66− decoding _ = Decoder.jsonb_ast
67−instance HasDecoding (column ::: 'Required ('NotNull 'PGDate)) Day where
68− decoding _ = Decoder.date
69−instance HasDecoding (column ::: 'Required ('NotNull 'PGTime)) TimeOfDay where
70− decoding _ = Decoder.time_int
71−instance HasDecoding (column ::: 'Required ('NotNull 'PGTimeTZ)) (TimeOfDay, TimeZone) where
72− decoding _ = Decoder.timetz_int
73−instance HasDecoding (column ::: 'Required ('NotNull 'PGTimestamp)) LocalTime where
74− decoding _ = Decoder.timestamp_int
75−instance HasDecoding (column ::: 'Required ('NotNull 'PGTimestampTZ)) UTCTime where
76− decoding _ = Decoder.timestamptz_int
77−instance HasDecoding (column ::: 'Required ('NotNull 'PGInterval)) DiffTime where
78− decoding _ = Decoder.interval_int
79−
80−decodings
81− :: AllZip HasDecoding pgs xs
82− => proxy pgs
83− -> NP (K ByteString) xs -> Either Text (NP I xs)
84−decodings _ Nil = return Nil
85−decodings (_ :: proxy pgs) (K bytestring :* bytestrings) =
86− case (hpure Proxy :: NP Proxy pgs) of
87− proxy :* proxies -> (:*)
88− <$> (I <$> Decoder.valueParser (decoding proxy) bytestring)
89− <*> decodings proxies bytestrings
90−
91−class HasEncoding pg x where
92− encoding :: proxy pg -> x -> Encoder.Encoding
93−instance HasEncoding ('Required ('NotNull 'PGInt2)) Int16 where
94− encoding _ = Encoder.int2_int16
95−instance HasEncoding ('Required ('NotNull 'PGInt4)) Int32 where
96− encoding _ = Encoder.int4_int32
97−instance HasEncoding ('Required ('NotNull 'PGInt8)) Int64 where
98− encoding _ = Encoder.int8_int64
99−instance HasEncoding ('Required ('NotNull 'PGFloat4)) Float where
100− encoding _ = Encoder.float4
101−instance HasEncoding ('Required ('NotNull 'PGFloat8)) Double where
102− encoding _ = Encoder.float8
103−instance HasEncoding ('Required ('NotNull 'PGBool)) Bool where
104− encoding _ = Encoder.bool
105−instance HasEncoding ('Required ('NotNull 'PGBytea)) ByteString where
106− encoding _ = Encoder.bytea_strict
107−instance HasEncoding ('Required ('NotNull 'PGBytea)) Lazy.ByteString where
108− encoding _ = Encoder.bytea_lazy
109−instance HasEncoding ('Required ('NotNull 'PGText)) Text where
110− encoding _ = Encoder.text_strict
111−instance HasEncoding ('Required ('NotNull 'PGText)) Lazy.Text where
112− encoding _ = Encoder.text_lazy
113−instance HasEncoding ('Required ('NotNull ('PGChar 1))) Char where
114− encoding _ = Encoder.char_utf8
115−instance HasEncoding ('Required ('NotNull 'PGNumeric)) Scientific where
116− encoding _ = Encoder.numeric
117−instance HasEncoding ('Required ('NotNull 'PGUuid)) UUID where
118− encoding _ = Encoder.uuid
119−instance HasEncoding ('Required ('NotNull 'PGJson)) Aeson.Value where
120− encoding _ = Encoder.json_ast
121−instance HasEncoding ('Required ('NotNull 'PGJsonb)) Aeson.Value where
122− encoding _ = Encoder.jsonb_ast
123−instance HasEncoding ('Required ('NotNull 'PGDate)) Day where
124− encoding _ = Encoder.date
125−instance HasEncoding ('Required ('NotNull 'PGTime)) TimeOfDay where
126− encoding _ = Encoder.time_int
127−instance HasEncoding ('Required ('NotNull 'PGTimeTZ)) (TimeOfDay, TimeZone) where
128− encoding _ = Encoder.timetz_int
129−instance HasEncoding ('Required ('NotNull 'PGTimestamp)) LocalTime where
130− encoding _ = Encoder.timestamp_int
131−instance HasEncoding ('Required ('NotNull 'PGTimestampTZ)) UTCTime where
132− encoding _ = Encoder.timestamptz_int
133−instance HasEncoding ('Required ('NotNull 'PGInterval)) DiffTime where
134− encoding _ = Encoder.interval_int
135−
136−encodings
137− :: AllZip HasEncoding pgs xs
138− => proxy pgs
139− -> NP I xs
140− -> [ByteString]
141−encodings _ Nil = []
142−encodings (_ :: proxy pgs) (I x :* xs) =
143− case (hpure Proxy :: NP Proxy pgs) of
144− proxy :* proxies -> Encoder.encodingBytes (encoding proxy x)
145− : encodings proxies xs
squeel-postgresql/src/Squeel/PostgreSQL/Binary2.hsdeleted−153
@@ -1,153 +0,0 @@
1−{-# LANGUAGE
2− DataKinds
3− , DefaultSignatures
4− , FlexibleContexts
5− , FlexibleInstances
6− , GADTs
7− , LambdaCase
8− , KindSignatures
9− , MultiParamTypeClasses
10− , ScopedTypeVariables
11− , TypeApplications
12− , TypeOperators
13− , UndecidableInstances
14−#-}
15−
16−module Squeel.PostgreSQL.Binary2 where
17−
18−import Data.Aeson hiding (Null)
19−import Data.Bits
20−import Data.Int
21−import Data.Scientific
22−import Data.Time
23−import Data.Word
24−import Data.UUID
25−import Generics.SOP
26−import Network.IP.Addr
27−
28−import qualified Data.ByteString.Lazy as Lazy
29−import qualified Data.ByteString as Strict hiding (unpack)
30−import qualified Data.Text.Lazy as Lazy
31−import qualified Data.Text as Strict
32−import qualified PostgreSQL.Binary.Decoding as Decoding
33−import qualified PostgreSQL.Binary.Encoding as Encoding
34−
35−import Squeel.PostgreSQL.Schema
36−
37−class ToParam x (pg :: PGType) where toParam :: x -> K Encoding.Encoding pg
38−instance ToParam Bool 'PGBool where toParam = K . Encoding.bool
39−instance ToParam Int16 'PGInt2 where toParam = K . Encoding.int2_int16
40−instance ToParam Word16 'PGInt2 where toParam = K . Encoding.int2_word16
41−instance ToParam Int32 'PGInt4 where toParam = K . Encoding.int4_int32
42−instance ToParam Word32 'PGInt4 where toParam = K . Encoding.int4_word32
43−instance ToParam Int64 'PGInt8 where toParam = K . Encoding.int8_int64
44−instance ToParam Word64 'PGInt8 where toParam = K . Encoding.int8_word64
45−instance ToParam Float 'PGFloat4 where toParam = K . Encoding.float4
46−instance ToParam Double 'PGFloat8 where toParam = K . Encoding.float8
47−instance ToParam Scientific 'PGNumeric where toParam = K . Encoding.numeric
48−instance ToParam UUID 'PGUuid where toParam = K . Encoding.uuid
49−instance ToParam (NetAddr IP) 'PGInet where toParam = K . Encoding.inet
50−instance ToParam Char ('PGChar 1) where toParam = K . Encoding.char_utf8
51−instance ToParam Strict.Text 'PGText where toParam = K . Encoding.text_strict
52−instance ToParam Lazy.Text 'PGText where toParam = K . Encoding.text_lazy
53−instance ToParam Strict.ByteString 'PGBytea where
54− toParam = K . Encoding.bytea_strict
55−instance ToParam Lazy.ByteString 'PGBytea where
56− toParam = K . Encoding.bytea_lazy
57−instance ToParam Day 'PGDate where toParam = K . Encoding.date
58−instance ToParam TimeOfDay 'PGTime where toParam = K . Encoding.time_int
59−instance ToParam (TimeOfDay, TimeZone) 'PGTimeTZ where
60− toParam = K . Encoding.timetz_int
61−instance ToParam LocalTime 'PGTimestamp where
62− toParam = K . Encoding.timestamp_int
63−instance ToParam UTCTime 'PGTimestampTZ where
64− toParam = K . Encoding.timestamptz_int
65−instance ToParam DiffTime 'PGInterval where toParam = K . Encoding.interval_int
66−instance ToParam Value 'PGJson where toParam = K . Encoding.json_ast
67−instance ToParam Value 'PGJsonb where toParam = K . Encoding.jsonb_ast
68−
69−class ToColumnParam x (ty :: ColumnType) where
70− toColumnParam :: x -> K (Maybe Strict.ByteString) ty
71−instance ToParam x pg => ToColumnParam x ('Required ('NotNull pg)) where
72− toColumnParam = K . Just . Encoding.encodingBytes . unK . toParam @x @pg
73−instance ToParam x pg => ToColumnParam (Maybe x) ('Required ('Null pg)) where
74− toColumnParam = K . fmap (Encoding.encodingBytes . unK . toParam @x @pg)
75−instance ToParam x pg => ToColumnParam (Maybe x) ('Optional (nullity pg)) where
76− toColumnParam = K . fmap (Encoding.encodingBytes . unK . toParam @x @pg)
77−
78−class SListI tys => ToParams x (tys :: [ColumnType]) where
79− toParams :: x -> NP (K (Maybe Strict.ByteString)) tys
80−instance ToColumnParam x ty => ToParams x '[ty] where
81− toParams x = toColumnParam x :* Nil
82−instance (SListI tys, IsProductType x xs, AllZip ToColumnParam xs tys)
83− => ToParams x tys where
84− toParams
85− = htrans (Proxy @ToColumnParam) (toColumnParam . unI)
86− . unZ . unSOP . from
87−
88−class FromValue (pg :: PGType) y where
89− fromValue :: proxy pg -> Decoding.Value y
90−instance FromValue 'PGBool Bool where fromValue _ = Decoding.bool
91−instance (Integral int, Bits int) => FromValue 'PGInt2 int where
92− fromValue _ = Decoding.int
93−instance (Integral int, Bits int) => FromValue 'PGInt4 int where
94− fromValue _ = Decoding.int
95−instance (Integral int, Bits int) => FromValue 'PGInt8 int where
96− fromValue _ = Decoding.int
97−instance FromValue 'PGFloat4 Float where fromValue _ = Decoding.float4
98−instance FromValue 'PGFloat8 Double where fromValue _ = Decoding.float8
99−instance FromValue 'PGNumeric Scientific where fromValue _ = Decoding.numeric
100−instance FromValue 'PGUuid UUID where fromValue _ = Decoding.uuid
101−instance FromValue 'PGInet (NetAddr IP) where fromValue _ = Decoding.inet
102−instance FromValue ('PGChar 1) Char where fromValue _ = Decoding.char
103−instance FromValue 'PGText Strict.Text where fromValue _ = Decoding.text_strict
104−instance FromValue 'PGText Lazy.Text where fromValue _ = Decoding.text_lazy
105−instance FromValue 'PGBytea Strict.ByteString where
106− fromValue _ = Decoding.bytea_strict
107−instance FromValue 'PGBytea Lazy.ByteString where
108− fromValue _ = Decoding.bytea_lazy
109−instance FromValue 'PGDate Day where fromValue _ = Decoding.date
110−instance FromValue 'PGTime TimeOfDay where fromValue _ = Decoding.time_int
111−instance FromValue 'PGTimeTZ (TimeOfDay, TimeZone) where
112− fromValue _ = Decoding.timetz_int
113−instance FromValue 'PGTimestamp LocalTime where
114− fromValue _ = Decoding.timestamp_int
115−instance FromValue 'PGTimestampTZ UTCTime where
116− fromValue _ = Decoding.timestamptz_int
117−instance FromValue 'PGInterval DiffTime where
118− fromValue _ = Decoding.interval_int
119−instance FromValue 'PGJson Value where fromValue _ = Decoding.json_ast
120−instance FromValue 'PGJsonb Value where fromValue _ = Decoding.jsonb_ast
121−
122−class FromColumnValue (colty :: (Symbol,ColumnType)) y where
123− fromColumnValue :: K (Maybe Strict.ByteString) colty -> y
124−instance FromValue pg y
125− => FromColumnValue (column ::: ('Required ('NotNull pg))) y where
126− fromColumnValue = \case
127− K Nothing -> error "fromColumnValue: saw NULL when expecting NOT NULL"
128− K (Just bytes) ->
129− let
130− errOrValue =
131− Decoding.valueParser (fromValue @pg @y Proxy) bytes
132− err str = error $ "fromColumnValue: " ++ Strict.unpack str
133− in
134− either err id errOrValue
135−instance FromValue pg y
136− => FromColumnValue (column ::: ('Required ('Null pg))) (Maybe y) where
137− fromColumnValue (K nullOrBytes)
138− = either err id
139− . Decoding.valueParser (fromValue @pg @y Proxy)
140− <$> nullOrBytes
141− where
142− err str = error $ "fromColumnValue: " ++ Strict.unpack str
143−
144−class SListI columns => FromRow (columns :: [(Symbol,ColumnType)]) y where
145− fromRow :: NP (K (Maybe Strict.ByteString)) columns -> y
146−instance FromColumnValue ty y => FromRow '[ty] y where
147− fromRow (y :* Nil) = fromColumnValue y
148−instance
149− ( SListI columns, IsProductType y ys
150− , AllZip FromColumnValue columns ys
151− ) => FromRow columns y where
152− fromRow
153− = to . SOP . Z . htrans (Proxy @FromColumnValue) (I . fromColumnValue)
squeel-postgresql/src/Squeel/PostgreSQL/PQ.hsdeleted−206
@@ -1,206 +0,0 @@
1−{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
2−{-# LANGUAGE
3− DataKinds
4− , DefaultSignatures
5− , FunctionalDependencies
6− , PolyKinds
7− , DeriveFunctor
8− , FlexibleContexts
9− , FlexibleInstances
10− , MagicHash
11− , MultiParamTypeClasses
12− , RankNTypes
13− , ScopedTypeVariables
14− , TypeApplications
15− , TypeFamilies
16− , TypeOperators
17− , UndecidableInstances
18−#-}
19−
20−module Squeel.PostgreSQL.PQ where
21−
22−import Control.Exception.Lifted
23−import Control.Monad.Base
24−import Control.Monad.Except
25−import Control.Monad.Trans.Control
26−import Data.ByteString (ByteString)
27−import Data.Function ((&))
28−import Generics.SOP
29−import GHC.Exts hiding (fromList)
30−import GHC.TypeLits
31−
32−import qualified Database.PostgreSQL.LibPQ as LibPQ
33−
34−import Squeel.PostgreSQL.Binary2
35−import Squeel.PostgreSQL.Statement
36−import Squeel.PostgreSQL.Schema
37−
38−newtype Connection (schema :: [(Symbol,[(Symbol,ColumnType)])]) =
39− Connection { unConnection :: LibPQ.Connection }
40−
41−newtype PQ
42− (schema0 :: [(Symbol,[(Symbol,ColumnType)])])
43− (schema1 :: [(Symbol,[(Symbol,ColumnType)])])
44− (m :: * -> *)
45− (x :: *) =
46− PQ { unPQ :: Connection schema0 -> m (x, Connection schema1) }
47− deriving Functor
48−
49−evalPQ :: Functor m => Connection schema0 -> PQ schema0 schema1 m x -> m x
50−evalPQ conn (PQ pq) = fmap fst $ pq conn
51−
52−runPQ
53− :: Functor m
54− => Connection schema0
55− -> PQ schema0 schema1 m x
56− -> m (Connection schema1)
57−runPQ conn (PQ pq) = fmap snd $ pq conn
58−
59−pqAp
60− :: Monad m
61− => PQ schema0 schema1 m (x -> y)
62− -> PQ schema1 schema2 m x
63− -> PQ schema0 schema2 m y
64−pqAp (PQ f) (PQ x) = PQ $ \ conn -> do
65− (f', conn') <- f conn
66− (x', conn'') <- x conn'
67− return (f' x', conn'')
68−
69−pqBind
70− :: Monad m
71− => (x -> PQ schema1 schema2 m y)
72− -> PQ schema0 schema1 m x
73− -> PQ schema0 schema2 m y
74−pqBind f (PQ x) = PQ $ \ conn -> do
75− (x', conn') <- x conn
76− unPQ (f x') conn'
77−
78−pqThen
79− :: Monad m
80− => PQ schema1 schema2 m y
81− -> PQ schema0 schema1 m x
82− -> PQ schema0 schema2 m y
83−pqThen pq2 pq1 = pq1 & pqBind (\ _ -> pq2)
84−
85−pqExec
86− :: MonadBase IO io
87− => Definition schema0 schema1
88− -> PQ schema0 schema1 io (Maybe (Result '[]))
89−pqExec (UnsafeDefinition q) = PQ $ \ (Connection conn) -> do
90− result <- liftBase $ LibPQ.exec conn q
91− return (Result <$> result, Connection conn)
92−
93−pqThenExec
94− :: MonadBase IO io
95− => Definition schema1 schema2
96− -> PQ schema0 schema1 io x
97− -> PQ schema0 schema2 io (Maybe (Result '[]))
98−pqThenExec = pqThen . pqExec
99−
100−class Monad m => MonadPQ schema m | m -> schema where
101−
102− pqExecParams
103− :: ToParams x params
104− => Manipulation schema params ys -> x -> m (Maybe (Result ys))
105− default pqExecParams
106− :: (MonadTrans t, MonadPQ schema m1, m ~ t m1)
107− => ToParams x params
108− => Manipulation schema params ys -> x -> m (Maybe (Result ys))
109− pqExecParams manipulation params = lift $ pqExecParams manipulation params
110−
111− pqExecNil :: Manipulation schema '[] ys -> m (Maybe (Result ys))
112− pqExecNil statement = pqExecParams statement ()
113−
114−instance MonadBase IO io => MonadPQ schema (PQ schema schema io) where
115−
116− pqExecParams (UnsafeManipulation q :: Manipulation schema ps ys) (params :: x) =
117− PQ $ \ (Connection conn) -> do
118− let
119− toParam' bytes = (LibPQ.invalidOid,bytes,LibPQ.Binary)
120− params' = fmap (fmap toParam') (hcollapse (toParams @x @ps params))
121− result <- liftBase $ LibPQ.execParams conn q params' LibPQ.Binary
122− return (Result <$> result, Connection conn)
123−
124−instance Monad m => Applicative (PQ schema schema m) where
125− pure x = PQ $ \ conn -> pure (x, conn)
126− (<*>) = pqAp
127−
128−instance Monad m => Monad (PQ schema schema m) where
129− return = pure
130− (>>=) = flip pqBind
131−
132−instance MonadTrans (PQ schema schema) where
133− lift m = PQ $ \ conn -> do
134− x <- m
135− return (x, conn)
136−
137−instance MonadBase b m => MonadBase b (PQ schema schema m) where
138− liftBase = lift . liftBase
139−
140−type PQRun schema =
141− forall m x. Monad m => PQ schema schema m x -> m (x, Connection schema)
142−
143−pqliftWith :: Functor m => (PQRun schema -> m a) -> PQ schema schema m a
144−pqliftWith f = PQ $ \ conn ->
145− fmap (\ x -> (x, conn)) (f $ \ pq -> unPQ pq conn)
146−
147−instance MonadBaseControl b m => MonadBaseControl b (PQ schema schema m) where
148− type StM (PQ schema schema m) x = StM m (x, Connection schema)
149− liftBaseWith f =
150− pqliftWith $ \ run -> liftBaseWith $ \ runInBase -> f $ runInBase . run
151− restoreM = PQ . const . restoreM
152−
153−connectdb :: MonadBase IO io => ByteString -> io (Connection schema)
154−connectdb = fmap Connection . liftBase . LibPQ.connectdb
155−
156−finish :: MonadBase IO io => Connection schema -> io ()
157−finish = liftBase . LibPQ.finish . unConnection
158−
159−withConnection
160− :: MonadBaseControl IO io
161− => ByteString
162− -> (Connection schema -> io x)
163− -> io x
164−withConnection connString action =
165− bracket (connectdb connString) finish action
166−
167−newtype Result (xs :: [(Symbol,ColumnType)])
168− = Result { unResult :: LibPQ.Result }
169−
170−newtype RowNumber = RowNumber { unRowNumber :: LibPQ.Row }
171−
172−newtype ColumnNumber n cs c =
173− UnsafeColumnNumber { getColumnNumber :: LibPQ.Column }
174−
175−class KnownNat n => HasColumnNumber n columns column
176− | n columns -> column where
177− columnNumber :: ColumnNumber n columns column
178− columnNumber =
179− UnsafeColumnNumber . fromIntegral $ natVal' (proxy# :: Proxy# n)
180−instance {-# OVERLAPPING #-} HasColumnNumber 0 (column1:columns) column1
181−instance {-# OVERLAPPABLE #-}
182− (KnownNat n, HasColumnNumber (n-1) columns column)
183− => HasColumnNumber n (column' : columns) column
184−
185−getValue
186− :: (FromColumnValue colty y, MonadBase IO io)
187− => RowNumber
188− -> ColumnNumber n columns colty
189− -> Result columns
190− -> io y
191−getValue
192− (RowNumber r)
193− (UnsafeColumnNumber c :: ColumnNumber n columns colty)
194− (Result result)
195− = fromColumnValue @colty . K <$>
196− liftBase (LibPQ.getvalue result r c)
197−
198−getRow
199− :: (FromRow columns y, MonadBase IO io)
200− => RowNumber -> Result columns -> io y
201−getRow (RowNumber r) (Result result :: Result columns) = do
202− let len = fromIntegral (lengthSList (Proxy @columns))
203− row' <- traverse (liftBase . LibPQ.getvalue result r) [0 .. len - 1]
204− case fromList row' of
205− Nothing -> error "getRow: found unexpected length"
206− Just row -> return $ fromRow @columns row
squeel-postgresql/src/Squeel/PostgreSQL/Schema.hsdeleted−180
@@ -1,180 +0,0 @@
1−{-# LANGUAGE
2− DataKinds
3− , FlexibleContexts
4− , FlexibleInstances
5− , GADTs
6− , MagicHash
7− , MultiParamTypeClasses
8− , OverloadedStrings
9− , PolyKinds
10− , RankNTypes
11− , ScopedTypeVariables
12− , TypeFamilies
13− , TypeOperators
14−#-}
15−
16−module Squeel.PostgreSQL.Schema
17− ( PGType (..)
18− , ToOid (..)
19− , ToOids (..)
20− , PGNum (..)
21− , PGFractional
22− , PGFloating
23− , (:::)
24− , Alias (Alias)
25− , renderAlias
26− , Aliased (As)
27− , renderAliased
28− , NullityType (..)
29− , NullifyType
30− , NullifyColumns
31− , NullifyTables
32− , ColumnType (..)
33− , BaseType
34− , Create
35− , Drop
36− , Alter
37− , Rename
38− , Join
39− , Grouping (..)
40− , IsTableColumn (..)
41− , module GHC.OverloadedLabels
42− , module GHC.TypeLits
43− ) where
44−
45−import Data.ByteString
46−import Data.Monoid
47−import Data.String
48−import GHC.Exts
49−import GHC.OverloadedLabels
50−import GHC.TypeLits
51−
52−import qualified Database.PostgreSQL.LibPQ as LibPQ
53−
54−data PGType
55− = PGBool
56− | PGInt2
57− | PGInt4
58− | PGInt8
59− | PGNumeric
60− | PGFloat4
61− | PGFloat8
62− | PGMoney
63− | PGChar Nat
64− | PGVarChar Nat
65− | PGText
66− | PGBytea
67− | PGTimestamp
68− | PGTimestampTZ
69− | PGDate
70− | PGTime
71− | PGTimeTZ
72− | PGInterval
73− | PGUuid
74− | PGInet
75− | PGJson
76− | PGJsonb
77−
78−class ToOid pg where toOid :: Proxy# pg -> LibPQ.Oid
79−--staticTypeInfo
80−instance ToOid ('Required ('NotNull 'PGBool)) where toOid _ = LibPQ.Oid 16
81−instance ToOid ('Required ('NotNull 'PGBytea)) where toOid _ = LibPQ.Oid 17
82−instance ToOid ('Required ('NotNull 'PGInt8)) where toOid _ = LibPQ.Oid 20
83−instance ToOid ('Required ('NotNull 'PGInt2)) where toOid _ = LibPQ.Oid 21
84−instance ToOid ('Required ('NotNull 'PGInt4)) where toOid _ = LibPQ.Oid 23
85−instance ToOid ('Required ('NotNull 'PGText)) where toOid _ = LibPQ.Oid 26
86−class ToOids pgs where toOids :: Proxy# pgs -> [LibPQ.Oid]
87−instance ToOids '[] where toOids _ = []
88−instance (ToOid pg, ToOids pgs) => ToOids (pg ': pgs) where
89− toOids _ = toOid (proxy# :: Proxy# pg) : toOids (proxy# :: Proxy# pgs)
90−
91−class PGNum (ty :: PGType) where
92− decimal :: proxy ty -> Bool
93−instance PGNum 'PGInt2 where decimal _ = False
94−instance PGNum 'PGInt4 where decimal _ = False
95−instance PGNum 'PGInt8 where decimal _ = False
96−instance PGNum 'PGNumeric where decimal _ = True
97−instance PGNum 'PGFloat4 where decimal _ = True
98−instance PGNum 'PGFloat8 where decimal _ = True
99−
100−class PGNum ty => PGFractional (ty :: PGType) where
101−instance PGFractional 'PGNumeric
102−instance PGFractional 'PGFloat4
103−instance PGFractional 'PGFloat8
104−
105−class PGFractional ty => PGFloating (ty :: PGType) where
106−instance PGFloating 'PGNumeric
107−instance PGFloating 'PGFloat4
108−instance PGFloating 'PGFloat8
109−
110−type (:::) (alias :: Symbol) (ty :: polykind) = '(alias,ty)
111−
112−data Alias (alias :: Symbol) = Alias (Proxy# alias)
113−
114−renderAlias :: KnownSymbol alias => Alias alias -> ByteString
115−renderAlias (Alias alias) = fromString (symbolVal' alias)
116−
117−instance alias1 ~ alias2 => IsLabel alias1 (Alias alias2) where
118− fromLabel = Alias
119−
120−data Aliased expression aliased where
121− As
122− :: KnownSymbol alias
123− => expression ty
124− -> Alias alias
125− -> Aliased expression (alias ::: ty)
126−
127−renderAliased
128− :: (forall ty. expression ty -> ByteString)
129− -> Aliased expression aliased
130− -> ByteString
131−renderAliased render (expression `As` Alias alias) =
132− render expression <> " AS " <> fromString (symbolVal' alias)
133−
134−data NullityType = Null PGType | NotNull PGType
135−
136−data ColumnType = Optional NullityType | Required NullityType
137−
138−type family BaseType (ty :: ColumnType) where
139− BaseType (optionality (nullity pg)) = pg
140−
141−type family NullifyType (ty :: ColumnType) where
142− NullifyType (optionality ('Null ty)) = optionality ('Null ty)
143− NullifyType (optionality ('NotNull ty)) = optionality ('Null ty)
144−
145−type family NullifyColumns columns where
146− NullifyColumns '[] = '[]
147− NullifyColumns ((column ::: ty) ': columns) =
148− (column ::: NullifyType ty) ': NullifyColumns columns
149−
150−type family NullifyTables tables where
151− NullifyTables '[] = '[]
152− NullifyTables ((column ::: ty) ': columns) =
153− (column ::: NullifyColumns ty) ': NullifyTables columns
154−
155−type family Create alias x xs where
156− Create alias x '[] = '[alias ::: x]
157− Create alias y (x ': xs) = x ': Create alias y xs
158−
159−type family Drop alias xs where
160− Drop alias ((alias ::: x) ': xs) = xs
161− Drop alias (x ': xs) = x ': Drop alias xs
162−
163−type family Alter alias xs x where
164− Alter alias ((alias ::: x0) ': xs) x1 = (alias ::: x1) ': xs
165− Alter alias (x0 ': xs) x1 = x0 ': Alter alias xs x1
166−
167−type family Rename alias0 alias1 xs where
168− Rename alias0 alias1 ((alias0 ::: x0) ': xs) = (alias1 ::: x0) ': xs
169− Rename alias0 alias1 (x ': xs) = x ': Rename alias0 alias1 xs
170−
171−type family Join xs ys where
172− Join '[] ys = ys
173− Join (x ': xs) ys = x ': Join xs ys
174−
175−data Grouping
176− = Ungrouped
177− | Grouped [(Symbol,Symbol)]
178−
179−class IsTableColumn table column expression where
180− (&.) :: Alias table -> Alias column -> expression
squeel-postgresql/src/Squeel/PostgreSQL/Statement.hsdeleted−1212
@@ -1,1212 +0,0 @@
1−{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
2−{-# LANGUAGE
3− DataKinds
4− , FlexibleContexts
5− , FlexibleInstances
6− , FunctionalDependencies
7− , GADTs
8− , LambdaCase
9− , MagicHash
10− , OverloadedStrings
11− , PolyKinds
12− , RankNTypes
13− , ScopedTypeVariables
14− , TypeApplications
15− , TypeFamilies
16− , TypeOperators
17− , UndecidableInstances
18−#-}
19−
20−module Squeel.PostgreSQL.Statement where
21−
22−import Control.Category
23−import Data.ByteString (ByteString)
24−import Data.Foldable
25−import Data.Maybe
26−import Data.Monoid
27−import Data.Ratio
28−import Data.String
29−import Data.Word
30−import Generics.SOP
31−import GHC.Exts
32−import GHC.OverloadedLabels
33−import GHC.TypeLits
34−import Prelude hiding (RealFrac(..), id, (.))
35−
36−import qualified Data.ByteString as ByteString
37−
38−import Squeel.PostgreSQL.Schema
39−
40−{-----------------------------------------
41−column expressions
42−-----------------------------------------}
43−
44−newtype Expression
45− (params :: [ColumnType])
46− (tables :: [(Symbol,[(Symbol,ColumnType)])])
47− (grouping :: Grouping)
48− (ty :: ColumnType)
49− = UnsafeExpression { renderExpression :: ByteString }
50− deriving (Show,Eq)
51−
52−class (PGTyped (BaseType ty), KnownNat n)
53− => HasParameter (n :: Nat) params ty | n params -> ty where
54− param :: proxy n -> Expression params tables grouping ty
55− param _ = UnsafeExpression $ parenthesized $
56− "$" <> paramNum <+> "::" <+> renderTypeExpression (pgtype @(BaseType ty))
57− where
58− paramNum = fromString $ show $ natVal (Proxy @n)
59−instance {-# OVERLAPPING #-} PGTyped (BaseType ty1)
60− => HasParameter 1 (ty1:tys) ty1
61−instance {-# OVERLAPPABLE #-} (KnownNat n, HasParameter (n-1) params ty)
62− => HasParameter n (ty' : params) ty
63−
64−class KnownSymbol column => HasColumn column columns ty
65− | column columns -> ty where
66− getColumn
67− :: Proxy# column
68− -> Expression params '[table ::: columns] 'Ungrouped ty
69− getColumn column = UnsafeExpression $ renderSymbol column
70−instance {-# OVERLAPPING #-} KnownSymbol column
71− => HasColumn column ((column ::: optionality ty) ': tys) ('Required ty)
72−instance {-# OVERLAPPABLE #-} (KnownSymbol column, HasColumn column table ty)
73− => HasColumn column (ty' ': table) ty
74−
75−instance (HasColumn column columns ty, tables ~ '[table ::: columns])
76− => IsLabel column (Expression params tables 'Ungrouped ty) where
77− fromLabel = getColumn
78−
79−instance (HasTable table tables columns, HasColumn column columns ty)
80− => IsTableColumn table column (Expression params tables 'Ungrouped ty) where
81− table &. column = UnsafeExpression $
82− renderAlias table <> "." <> renderAlias column
83−
84−def :: Expression params '[] grouping ('Optional (nullity ty))
85−def = UnsafeExpression "DEFAULT"
86−
87−unDef
88− :: Expression params '[] grouping ('Required (nullity ty))
89− -> Expression params '[] grouping ('Optional (nullity ty))
90−unDef = UnsafeExpression . renderExpression
91−
92−null :: Expression params tables grouping (optionality ('Null ty))
93−null = UnsafeExpression "NULL"
94−
95−unNull
96− :: Expression params tables grouping (optionality ('NotNull ty))
97− -> Expression params tables grouping (optionality ('Null ty))
98−unNull = UnsafeExpression . renderExpression
99−
100−coalesce
101− :: [Expression params tables grouping ('Required ('Null x))]
102− -> Expression params tables grouping ('Required ('NotNull x))
103− -> Expression params tables grouping ('Required ('NotNull x))
104−coalesce nulls isn'tNull = UnsafeExpression $
105− "COALESCE" <> parenthesized (commaSeparated
106− ((renderExpression <$> nulls) <> [renderExpression isn'tNull]))
107−
108−unsafeBinaryOp
109− :: ByteString
110− -> Expression params tables grouping ty0
111− -> Expression params tables grouping ty1
112− -> Expression params tables grouping ty2
113−unsafeBinaryOp op x y = UnsafeExpression $ parenthesized $
114− renderExpression x <+> op <+> renderExpression y
115−
116−unsafeUnaryOp
117− :: ByteString
118− -> Expression params tables grouping ty0
119− -> Expression params tables grouping ty1
120−unsafeUnaryOp op x = UnsafeExpression $ parenthesized $
121− op <+> renderExpression x
122−
123−unsafeFunction
124− :: ByteString
125− -> Expression params tables grouping xty
126− -> Expression params tables grouping yty
127−unsafeFunction fun x = UnsafeExpression $
128− fun <> parenthesized (renderExpression x)
129−
130−instance PGNum ty
131− => Num (Expression params tables grouping ('Required (nullity ty))) where
132− (+) = unsafeBinaryOp "+"
133− (-) = unsafeBinaryOp "-"
134− (*) = unsafeBinaryOp "*"
135− abs = unsafeFunction "abs"
136− signum = unsafeFunction "sign"
137− fromInteger
138− = UnsafeExpression
139− . (<> if decimal (Proxy :: Proxy ty) then "." else "")
140− . fromString
141− . show
142−
143−instance PGFractional ty => Fractional
144− (Expression params tables grouping ('Required (nullity ty))) where
145− (/) = unsafeBinaryOp "/"
146− fromRational x = fromInteger (numerator x) / fromInteger (denominator x)
147−
148−instance (PGFloating ty, PGCast 'PGNumeric ty, PGTyped ty) => Floating
149− (Expression params tables grouping ('Required (nullity ty))) where
150− pi = UnsafeExpression "pi()"
151− exp = unsafeFunction "exp"
152− log = unsafeFunction "ln"
153− sqrt = unsafeFunction "sqrt"
154− b ** x = UnsafeExpression $
155− "power(" <> renderExpression b <> ", " <> renderExpression x <> ")"
156− logBase b y = cast pgtype $ logBaseNumeric b y
157− where
158− logBaseNumeric
159− :: Expression params tables grouping ('Required (nullity ty))
160− -> Expression params tables grouping ('Required (nullity ty))
161− -> Expression params tables grouping ('Required (nullity 'PGNumeric))
162− logBaseNumeric b' y' = UnsafeExpression $ mconcat
163− [ "log("
164− , renderExpression b' <> "::numeric"
165− , ", "
166− , renderExpression y' <> "::numeric"
167− , ")"
168− ]
169− sin = unsafeFunction "sin"
170− cos = unsafeFunction "cos"
171− tan = unsafeFunction "tan"
172− asin = unsafeFunction "asin"
173− acos = unsafeFunction "acos"
174− atan = unsafeFunction "atan"
175− sinh x = (exp x - exp (-x)) / 2
176− cosh x = (exp x + exp (-x)) / 2
177− tanh x = sinh x / cosh x
178− asinh x = log (x + sqrt (x*x + 1))
179− acosh x = log (x + sqrt (x*x - 1))
180− atanh x = log ((1 + x) / (1 - x)) / 2
181−
182−atan2
183− :: PGFloating float
184− => Expression params tables grouping ('Required (nullity float))
185− -> Expression params tables grouping ('Required (nullity float))
186− -> Expression params tables grouping ('Required (nullity float))
187−atan2 y x = UnsafeExpression $
188− "atan2(" <> renderExpression y <> ", " <> renderExpression x <> ")"
189−
190−class PGCast (ty0 :: PGType) (ty1 :: PGType) where
191− cast
192− :: TypeExpression ('Required ('Null ty1))
193− -> Expression params tables grouping ('Required (nullity ty0))
194− -> Expression params tables grouping ('Required (nullity ty1))
195− cast ty x = UnsafeExpression $
196− "(" <> renderExpression x <> "::" <> renderTypeExpression ty <> ")"
197−instance PGCast 'PGInt2 'PGInt2
198−instance PGCast 'PGInt2 'PGInt4
199−instance PGCast 'PGInt2 'PGInt8
200−instance PGCast 'PGInt4 'PGInt2
201−instance PGCast 'PGInt4 'PGInt4
202−instance PGCast 'PGInt4 'PGInt8
203−instance PGCast 'PGInt8 'PGInt2
204−instance PGCast 'PGInt8 'PGInt4
205−instance PGCast 'PGInt8 'PGInt8
206−instance PGCast 'PGInt8 'PGFloat4
207−instance PGCast 'PGInt8 'PGFloat8
208−instance PGCast 'PGInt8 'PGNumeric
209−
210−div
211− :: (PGNum ty, PGTyped ty, PGCast 'PGInt8 ty, PGCast ty 'PGInt8)
212− => Expression params tables grouping ('Required (nullity ty))
213− -> Expression params tables grouping ('Required (nullity ty))
214− -> Expression params tables grouping ('Required (nullity ty))
215−div = unsafeBinaryOp "/"
216−
217−mod
218− :: (PGNum ty, PGTyped ty, PGCast 'PGInt8 ty, PGCast ty 'PGInt8)
219− => Expression params tables grouping ('Required (nullity ty))
220− -> Expression params tables grouping ('Required (nullity ty))
221− -> Expression params tables grouping ('Required (nullity ty))
222−mod = unsafeBinaryOp "%"
223−
224−truncate
225− :: (PGFractional frac, PGCast 'PGInt4 int, PGTyped int)
226− => Expression params tables grouping ('Required (nullity frac))
227− -> Expression params tables grouping ('Required (nullity int))
228−truncate = cast pgtype . truncate'
229− where
230− truncate'
231− :: Expression params tables grouping ('Required (nullity frac))
232− -> Expression params tables grouping ('Required (nullity 'PGInt4))
233− truncate' = unsafeFunction "trunc"
234−
235−round
236− :: (PGFractional frac, PGCast 'PGInt4 int, PGTyped int)
237− => Expression params tables grouping ('Required (nullity frac))
238− -> Expression params tables grouping ('Required (nullity int))
239−round = cast pgtype . round'
240− where
241− round'
242− :: Expression params tables grouping ('Required (nullity frac))
243− -> Expression params tables grouping ('Required (nullity 'PGInt4))
244− round' = unsafeFunction "round"
245−
246−ceiling
247− :: (PGFractional frac, PGCast 'PGInt4 int, PGTyped int)
248− => Expression params tables grouping ('Required (nullity frac))
249− -> Expression params tables grouping ('Required (nullity int))
250−ceiling = cast pgtype . ceiling'
251− where
252− ceiling'
253− :: Expression params tables grouping ('Required (nullity frac))
254− -> Expression params tables grouping ('Required (nullity 'PGInt4))
255− ceiling' = unsafeFunction "ceiling"
256−
257−instance IsString
258− (Expression params tables grouping ('Required (nullity 'PGText))) where
259− fromString str = UnsafeExpression $
260− "E\'" <> fromString (escape =<< str) <> "\'"
261− where
262− escape = \case
263− '\NUL' -> "\\0"
264− '\'' -> "''"
265− '"' -> "\\\""
266− '\b' -> "\\b"
267− '\n' -> "\\n"
268− '\r' -> "\\r"
269− '\t' -> "\\t"
270− '\\' -> "\\\\"
271− c -> [c]
272−
273−type Condition params tables grouping =
274− Expression params tables grouping ('Required ('NotNull 'PGBool))
275−
276−true :: Condition params tables grouping
277−true = UnsafeExpression "TRUE"
278−
279−false :: Condition params tables grouping
280−false = UnsafeExpression "FALSE"
281−
282−not_
283− :: Condition params tables grouping
284− -> Condition params tables grouping
285−not_ = unsafeUnaryOp "NOT"
286−
287−(&&*)
288− :: Condition params tables grouping
289− -> Condition params tables grouping
290− -> Condition params tables grouping
291−(&&*) = unsafeBinaryOp "AND"
292−
293−(||*)
294− :: Condition params tables grouping
295− -> Condition params tables grouping
296− -> Condition params tables grouping
297−(||*) = unsafeBinaryOp "OR"
298−
299−caseWhenThenElse
300− :: [(Condition params tables grouping, Expression params tables grouping ty)]
301− -> Expression params tables grouping ty
302− -> Expression params tables grouping ty
303−caseWhenThenElse whenThens else_ = UnsafeExpression $ mconcat
304− [ "CASE"
305− , mconcat
306− [ mconcat
307− [ " WHEN ", renderExpression when_
308− , " THEN ", renderExpression then_
309− ]
310− | (when_,then_) <- whenThens
311− ]
312− , " ELSE ", renderExpression else_
313− , " END"
314− ]
315−
316−ifThenElse
317− :: Condition params tables grouping
318− -> Expression params tables grouping ty
319− -> Expression params tables grouping ty
320− -> Expression params tables grouping ty
321−ifThenElse if_ then_ else_ = caseWhenThenElse [(if_,then_)] else_
322−
323−(==*)
324− :: Expression params tables grouping ('Required (nullity ty))
325− -> Expression params tables grouping ('Required (nullity ty))
326− -> Expression params tables grouping ('Required (nullity 'PGBool))
327−(==*) = unsafeBinaryOp "="
328−
329−(/=*)
330− :: Expression params tables grouping ('Required (nullity ty))
331− -> Expression params tables grouping ('Required (nullity ty))
332− -> Expression params tables grouping ('Required (nullity 'PGBool))
333−(/=*) = unsafeBinaryOp "<>"
334−
335−(>=*)
336− :: Expression params tables grouping ('Required (nullity ty))
337− -> Expression params tables grouping ('Required (nullity ty))
338− -> Expression params tables grouping ('Required (nullity 'PGBool))
339−(>=*) = unsafeBinaryOp ">="
340−
341−(<*)
342− :: Expression params tables grouping ('Required (nullity ty))
343− -> Expression params tables grouping ('Required (nullity ty))
344− -> Expression params tables grouping ('Required (nullity 'PGBool))
345−(<*) = unsafeBinaryOp "<"
346−
347−(<=*)
348− :: Expression params tables grouping ('Required (nullity ty))
349− -> Expression params tables grouping ('Required (nullity ty))
350− -> Expression params tables grouping ('Required (nullity 'PGBool))
351−(<=*) = unsafeBinaryOp "<="
352−
353−(>*)
354− :: Expression params tables grouping ('Required (nullity ty))
355− -> Expression params tables grouping ('Required (nullity ty))
356− -> Expression params tables grouping ('Required (nullity 'PGBool))
357−(>*) = unsafeBinaryOp ">"
358−
359−data SortExpression params tables grouping where
360− Asc
361− :: Expression params tables grouping ty
362− -> SortExpression params tables grouping
363− Desc
364− :: Expression params tables grouping ty
365− -> SortExpression params tables grouping
366−
367−renderSortExpression :: SortExpression params tables grouping -> ByteString
368−renderSortExpression = \case
369− Asc expression -> renderExpression expression <+> "ASC"
370− Desc expression -> renderExpression expression <+> "DESC"
371−
372−{-----------------------------------------
373−aggregation
374−-----------------------------------------}
375−
376−data By
377− (tables :: [(Symbol,[(Symbol,ColumnType)])])
378− (tabcol :: (Symbol,Symbol)) where
379− By
380− :: (tables ~ '[table ::: columns], HasColumn column columns ty)
381− => Alias column
382− -> By tables '(table, column)
383− By2
384− :: (HasTable table tables columns, HasColumn column columns ty)
385− => (Alias table, Alias column)
386− -> By tables '(table, column)
387−
388−renderBy :: By tables tabcolty -> ByteString
389−renderBy = \case
390− By column -> renderAlias column
391− By2 (table, column) -> renderAlias table <> "." <> renderAlias column
392−
393−data GroupByClause tables grouping where
394− NoGroups :: GroupByClause tables 'Ungrouped
395− Group
396− :: SListI bys
397− => NP (By tables) bys
398− -> GroupByClause tables ('Grouped bys)
399−
400−renderGroupByClause :: GroupByClause tables grouping -> ByteString
401−renderGroupByClause = \case
402− NoGroups -> ""
403− Group Nil -> ""
404− Group bys -> " GROUP BY" <+> renderCommaSeparated renderBy bys
405−
406−data HavingClause params tables grouping where
407− NoHaving :: HavingClause params tables 'Ungrouped
408− Having
409− :: [Condition params tables ('Grouped bys)]
410− -> HavingClause params tables ('Grouped bys)
411−
412−renderHavingClause :: HavingClause params tables grouping -> ByteString
413−renderHavingClause = \case
414− NoHaving -> ""
415− Having [] -> ""
416− Having conditions ->
417− " HAVING" <+> commaSeparated (renderExpression <$> conditions)
418−
419−class (KnownSymbol table, KnownSymbol column)
420− => GroupedBy table column bys where
421− getGroup1
422− :: (tables ~ '[table ::: columns], HasColumn column columns ty)
423− => Proxy# column
424− -> Expression params tables ('Grouped bys) ty
425− getGroup1 column = UnsafeExpression $ fromString (symbolVal' column)
426− getGroup2
427− :: (HasTable table tables columns, HasColumn column columns ty)
428− => Alias table
429− -> Alias column
430− -> Expression params tables ('Grouped bys) ty
431− getGroup2 table column = UnsafeExpression $
432− renderAlias table <> "." <> renderAlias column
433−instance {-# OVERLAPPING #-} (KnownSymbol table, KnownSymbol column)
434− => GroupedBy table column ('(table,column) ': bys)
435−instance {-# OVERLAPPABLE #-}
436− ( KnownSymbol table
437− , KnownSymbol column
438− , GroupedBy table column bys
439− ) => GroupedBy table column (tabcol ': bys)
440−
441−instance
442− ( tables ~ '[table ::: columns]
443− , HasColumn column columns ty
444− , GroupedBy table column bys
445− ) => IsLabel column
446− (Expression params tables ('Grouped bys) ty) where fromLabel = getGroup1
447−
448−instance
449− ( HasTable table tables columns
450− , HasColumn column columns ty
451− , GroupedBy table column bys
452− ) => IsTableColumn table column
453− (Expression params tables ('Grouped bys) ty) where (&.) = getGroup2
454−
455−unsafeAggregate
456− :: ByteString
457− -> Expression params tables 'Ungrouped xty
458− -> Expression params tables ('Grouped bys) yty
459−unsafeAggregate fun x = UnsafeExpression $ mconcat
460− [fun, "(", renderExpression x, ")"]
461−
462−sum_
463− :: PGNum ty
464− => Expression params tables 'Ungrouped ('Required (nullity ty))
465− -> Expression params tables ('Grouped bys) ('Required (nullity ty))
466−sum_ = unsafeAggregate "sum"
467−
468−{-----------------------------------------
469−tables
470−-----------------------------------------}
471−
472−newtype Table
473− (schema :: [(Symbol,[(Symbol,ColumnType)])])
474− (columns :: [(Symbol,ColumnType)])
475− = UnsafeTable { renderTable :: ByteString }
476− deriving (Show,Eq)
477−
478−class KnownSymbol table => HasTable table tables columns
479− | table tables -> columns where
480− getTable :: Proxy# table -> Table tables columns
481− getTable table = UnsafeTable $ fromString $ symbolVal' table
482−instance {-# OVERLAPPING #-} KnownSymbol table
483− => HasTable table ((table ::: columns) ': tables) columns
484−instance {-# OVERLAPPABLE #-}
485− (KnownSymbol table, HasTable table schema columns)
486− => HasTable table (table' ': schema) columns
487−
488−instance HasTable table schema columns
489− => IsLabel table (Table schema columns) where
490− fromLabel = getTable
491−
492−data TableReference params schema tables where
493− Table
494− :: Aliased (Table schema) table
495− -> TableReference params schema '[table]
496− Subquery
497− :: Aliased (Query schema params) table
498− -> TableReference params schema '[table]
499− CrossJoin
500− :: TableReference params schema right
501− -> TableReference params schema left
502− -> TableReference params schema (Join left right)
503− InnerJoin
504− :: TableReference params schema right
505− -> Condition params (Join left right) 'Ungrouped
506− -> TableReference params schema left
507− -> TableReference params schema (Join left right)
508− LeftOuterJoin
509− :: TableReference params schema right
510− -> Condition params (Join left right) 'Ungrouped
511− -> TableReference params schema left
512− -> TableReference params schema (Join left (NullifyTables right))
513− RightOuterJoin
514− :: TableReference params schema right
515− -> Condition params (Join left right) 'Ungrouped
516− -> TableReference params schema left
517− -> TableReference params schema (Join (NullifyTables left) right)
518− FullOuterJoin
519− :: TableReference params schema right
520− -> Condition params (Join left right) 'Ungrouped
521− -> TableReference params schema left
522− -> TableReference params schema
523− (Join (NullifyTables left) (NullifyTables right))
524−
525−renderTableReference :: TableReference params schema tables -> ByteString
526−renderTableReference = \case
527− Table table -> renderAliased renderTable table
528− Subquery selection -> renderAliased renderQuery selection
529− CrossJoin right left ->
530− renderTableReference left <+> "CROSS JOIN" <+> renderTableReference right
531− InnerJoin right on left -> renderJoin "INNER JOIN" right on left
532− LeftOuterJoin right on left -> renderJoin "LEFT OUTER JOIN" right on left
533− RightOuterJoin right on left -> renderJoin "RIGHT OUTER JOIN" right on left
534− FullOuterJoin right on left -> renderJoin "FULL OUTER JOIN" right on left
535− where
536− renderJoin op right on left =
537− renderTableReference left <+> op <+> renderTableReference right
538− <+> "ON" <+> renderExpression on
539−
540−data TableExpression
541− (params :: [ColumnType])
542− (schema :: [(Symbol,[(Symbol,ColumnType)])])
543− (tables :: [(Symbol,[(Symbol,ColumnType)])])
544− (grouping :: Grouping)
545− = TableExpression
546− { fromClause :: TableReference params schema tables
547− , whereClause :: [Condition params tables 'Ungrouped]
548− , groupByClause :: GroupByClause tables grouping
549− , havingClause :: HavingClause params tables grouping
550− , orderByClause :: [SortExpression params tables grouping]
551− , limitClause :: [Word64]
552− , offsetClause :: [Word64]
553− }
554−
555−renderTableExpression
556− :: TableExpression params schema tables grouping
557− -> ByteString
558−renderTableExpression
559− (TableExpression tables whs' grps' hvs' srts' lims' offs') = mconcat
560− [ "FROM ", renderTableReference tables
561− , renderWheres whs'
562− , renderGroupByClause grps'
563− , renderHavingClause hvs'
564− , renderSorts srts'
565− , renderLimits lims'
566− , renderOffsets offs'
567− ]
568− where
569− renderWheres = \case
570− [] -> ""
571− wh:[] -> " WHERE" <+> renderExpression wh
572− wh:whs -> " WHERE" <+> renderExpression (foldr (&&*) wh whs)
573− renderSorts = \case
574− [] -> ""
575− srts -> " SORT BY"
576− <+> commaSeparated (renderSortExpression <$> srts)
577− renderLimits = \case
578− [] -> ""
579− lims -> " LIMIT" <+> fromString (show (minimum lims))
580− renderOffsets = \case
581− [] -> ""
582− offs -> " OFFSET" <+> fromString (show (sum offs))
583−
584−from
585− :: TableReference params schema tables
586− -> TableExpression params schema tables 'Ungrouped
587−from tables = TableExpression tables [] NoGroups NoHaving [] [] []
588−
589−where_
590− :: Condition params tables 'Ungrouped
591− -> TableExpression params schema tables grouping
592− -> TableExpression params schema tables grouping
593−where_ wh tables = tables {whereClause = wh : whereClause tables}
594−
595−group
596− :: SListI bys
597− => NP (By tables) bys
598− -> TableExpression params schema tables 'Ungrouped
599− -> TableExpression params schema tables ('Grouped bys)
600−group bys tables = TableExpression
601− { fromClause = fromClause tables
602− , whereClause = whereClause tables
603− , groupByClause = Group bys
604− , havingClause = Having []
605− , orderByClause = []
606− , limitClause = limitClause tables
607− , offsetClause = offsetClause tables
608− }
609−
610−having
611− :: Condition params tables ('Grouped bys)
612− -> TableExpression params schema tables ('Grouped bys)
613− -> TableExpression params schema tables ('Grouped bys)
614−having hv tables = tables
615− { havingClause = case havingClause tables of Having hvs -> Having (hv:hvs) }
616−
617−orderBy
618− :: [SortExpression params tables grouping]
619− -> TableExpression params schema tables grouping
620− -> TableExpression params schema tables grouping
621−orderBy srts tables = tables {orderByClause = orderByClause tables ++ srts}
622−
623−limit
624− :: Word64
625− -> TableExpression params schema tables grouping
626− -> TableExpression params schema tables grouping
627−limit lim tables = tables {limitClause = lim : limitClause tables}
628−
629−offset
630− :: Word64
631− -> TableExpression params schema tables grouping
632− -> TableExpression params schema tables grouping
633−offset off tables = tables {offsetClause = off : offsetClause tables}
634−
635−{-----------------------------------------
636−type expressions
637−-----------------------------------------}
638−
639−newtype TypeExpression (ty :: ColumnType)
640− = UnsafeTypeExpression { renderTypeExpression :: ByteString }
641− deriving (Show,Eq)
642−
643−bool :: TypeExpression ('Required ('Null 'PGBool))
644−bool = UnsafeTypeExpression "bool"
645−int2 :: TypeExpression ('Required ('Null 'PGInt2))
646−int2 = UnsafeTypeExpression "int2"
647−smallint :: TypeExpression ('Required ('Null 'PGInt2))
648−smallint = UnsafeTypeExpression "smallint"
649−int4 :: TypeExpression ('Required ('Null 'PGInt4))
650−int4 = UnsafeTypeExpression "int4"
651−int :: TypeExpression ('Required ('Null 'PGInt4))
652−int = UnsafeTypeExpression "int"
653−integer :: TypeExpression ('Required ('Null 'PGInt4))
654−integer = UnsafeTypeExpression "integer"
655−int8 :: TypeExpression ('Required ('Null 'PGInt8))
656−int8 = UnsafeTypeExpression "int8"
657−bigint :: TypeExpression ('Required ('Null 'PGInt8))
658−bigint = UnsafeTypeExpression "bigint"
659−numeric :: TypeExpression ('Required ('Null 'PGNumeric))
660−numeric = UnsafeTypeExpression "numeric"
661−float4 :: TypeExpression ('Required ('Null 'PGFloat4))
662−float4 = UnsafeTypeExpression "float4"
663−real :: TypeExpression ('Required ('Null 'PGFloat4))
664−real = UnsafeTypeExpression "real"
665−float8 :: TypeExpression ('Required ('Null 'PGFloat8))
666−float8 = UnsafeTypeExpression "float8"
667−doublePrecision :: TypeExpression ('Required ('Null 'PGFloat8))
668−doublePrecision = UnsafeTypeExpression "double precision"
669−serial2 :: TypeExpression ('Optional ('NotNull 'PGInt2))
670−serial2 = UnsafeTypeExpression "serial2"
671−smallserial :: TypeExpression ('Optional ('NotNull 'PGInt2))
672−smallserial = UnsafeTypeExpression "smallserial"
673−serial4 :: TypeExpression ('Optional ('NotNull 'PGInt4))
674−serial4 = UnsafeTypeExpression "serial4"
675−serial :: TypeExpression ('Optional ('NotNull 'PGInt4))
676−serial = UnsafeTypeExpression "serial"
677−serial8 :: TypeExpression ('Optional ('NotNull 'PGInt8))
678−serial8 = UnsafeTypeExpression "serial8"
679−bigserial :: TypeExpression ('Optional ('NotNull 'PGInt8))
680−bigserial = UnsafeTypeExpression "bigserial"
681−money :: TypeExpression ('Required ('Null 'PGMoney))
682−money = UnsafeTypeExpression "money"
683−text :: TypeExpression ('Required ('Null 'PGText))
684−text = UnsafeTypeExpression "text"
685−char
686− :: KnownNat n
687− => proxy n
688− -> TypeExpression ('Required ('Null ('PGChar n)))
689−char (_ :: proxy n) = UnsafeTypeExpression $
690− "char(" <> fromString (show (natVal' (proxy# :: Proxy# n))) <> ")"
691−character
692− :: KnownNat n
693− => proxy n
694− -> TypeExpression ('Required ('Null ('PGChar n)))
695−character (_ :: proxy n) = UnsafeTypeExpression $
696− "character(" <> fromString (show (natVal' (proxy# :: Proxy# n))) <> ")"
697−varchar
698− :: KnownNat n
699− => proxy n
700− -> TypeExpression ('Required ('Null ('PGVarChar n)))
701−varchar (_ :: proxy n) = UnsafeTypeExpression $
702− "varchar(" <> fromString (show (natVal' (proxy# :: Proxy# n))) <> ")"
703−characterVarying
704− :: KnownNat n
705− => proxy n
706− -> TypeExpression ('Required ('Null ('PGVarChar n)))
707−characterVarying (_ :: proxy n) = UnsafeTypeExpression $
708− "character varying(" <> fromString (show (natVal' (proxy# :: Proxy# n))) <> ")"
709−bytea :: TypeExpression ('Required ('Null ('PGBytea)))
710−bytea = UnsafeTypeExpression "bytea"
711−timestamp :: TypeExpression ('Required ('Null ('PGTimestamp)))
712−timestamp = UnsafeTypeExpression "timestamp"
713−timestampWithTimeZone :: TypeExpression ('Required ('Null ('PGTimestampTZ)))
714−timestampWithTimeZone = UnsafeTypeExpression "timestamp with time zone"
715−date :: TypeExpression ('Required ('Null ('PGDate)))
716−date = UnsafeTypeExpression "date"
717−time :: TypeExpression ('Required ('Null ('PGTime)))
718−time = UnsafeTypeExpression "time"
719−timeWithTimeZone :: TypeExpression ('Required ('Null ('PGTimeTZ)))
720−timeWithTimeZone = UnsafeTypeExpression "time with time zone"
721−interval :: TypeExpression ('Required ('Null ('PGInterval)))
722−interval = UnsafeTypeExpression "interval"
723−uuid :: TypeExpression ('Required ('Null ('PGUuid)))
724−uuid = UnsafeTypeExpression "uuid"
725−json :: TypeExpression ('Required ('Null ('PGJson)))
726−json = UnsafeTypeExpression "json"
727−jsonb :: TypeExpression ('Required ('Null ('PGJsonb)))
728−jsonb = UnsafeTypeExpression "jsonb"
729−
730−notNull
731− :: TypeExpression (optionality ('Null ty))
732− -> TypeExpression (optionality ('NotNull ty))
733−notNull ty = UnsafeTypeExpression $ renderTypeExpression ty <+> "NOT NULL"
734−default_
735− :: Expression '[] '[] 'Ungrouped ('Required ty)
736− -> TypeExpression ('Required ty)
737− -> TypeExpression ('Optional ty)
738−default_ x ty = UnsafeTypeExpression $
739− renderTypeExpression ty <+> "DEFAULT" <+> renderExpression x
740−
741−class PGTyped (ty :: PGType) where
742− pgtype :: TypeExpression ('Required ('Null ty))
743−instance PGTyped 'PGBool where pgtype = bool
744−instance PGTyped 'PGInt2 where pgtype = int2
745−instance PGTyped 'PGInt4 where pgtype = int4
746−instance PGTyped 'PGInt8 where pgtype = int8
747−instance PGTyped 'PGNumeric where pgtype = numeric
748−instance PGTyped 'PGFloat4 where pgtype = float4
749−instance PGTyped 'PGFloat8 where pgtype = float8
750−instance PGTyped 'PGMoney where pgtype = money
751−instance PGTyped 'PGText where pgtype = text
752−instance KnownNat n => PGTyped ('PGChar n) where pgtype = char (Proxy @n)
753−instance KnownNat n => PGTyped ('PGVarChar n) where pgtype = varchar (Proxy @n)
754−instance PGTyped 'PGBytea where pgtype = bytea
755−instance PGTyped 'PGTimestamp where pgtype = timestamp
756−instance PGTyped 'PGTimestampTZ where pgtype = timestampWithTimeZone
757−instance PGTyped 'PGDate where pgtype = date
758−instance PGTyped 'PGTime where pgtype = time
759−instance PGTyped 'PGTimeTZ where pgtype = timeWithTimeZone
760−instance PGTyped 'PGInterval where pgtype = interval
761−instance PGTyped 'PGUuid where pgtype = uuid
762−instance PGTyped 'PGJson where pgtype = json
763−instance PGTyped 'PGJsonb where pgtype = jsonb
764−
765−{-----------------------------------------
766−statements
767−-----------------------------------------}
768−
769−newtype Definition
770− (schema0 :: [(Symbol,[(Symbol,ColumnType)])])
771− (schema1 :: [(Symbol,[(Symbol,ColumnType)])])
772− = UnsafeDefinition { renderDefinition :: ByteString }
773−
774−instance Category Definition where
775− id = UnsafeDefinition ";"
776− ddl1 . ddl0 = UnsafeDefinition $
777− renderDefinition ddl0 <+> renderDefinition ddl1
778−
779−newtype Manipulation
780− (schema :: [(Symbol,[(Symbol,ColumnType)])])
781− (params :: [ColumnType])
782− (columns :: [(Symbol,ColumnType)])
783− = UnsafeManipulation { renderManipulation :: ByteString }
784−
785−newtype Query
786− (schema :: [(Symbol,[(Symbol,ColumnType)])])
787− (params :: [ColumnType])
788− (columns :: [(Symbol,ColumnType)])
789− = UnsafeQuery { renderQuery :: ByteString }
790−
791−query
792− :: Query schema params columns
793− -> Manipulation schema params columns
794−query q = UnsafeManipulation $ renderQuery q <> ";"
795−
796−union, unionAll, intersect, intersectAll, except, exceptAll
797− :: Query schema params columns
798− -> Query schema params columns
799− -> Query schema params columns
800−q1 `union` q2 = UnsafeQuery $
801− parenthesized (renderQuery q1)
802− <+> "UNION"
803− <+> parenthesized (renderQuery q2)
804−q1 `unionAll` q2 = UnsafeQuery $
805− parenthesized (renderQuery q1)
806− <+> "UNION" <+> "ALL"
807− <+> parenthesized (renderQuery q2)
808−q1 `intersect` q2 = UnsafeQuery $
809− parenthesized (renderQuery q1)
810− <+> "INTERSECT"
811− <+> parenthesized (renderQuery q2)
812−q1 `intersectAll` q2 = UnsafeQuery $
813− parenthesized (renderQuery q1)
814− <+> "INTERSECT" <+> "ALL"
815− <+> parenthesized (renderQuery q2)
816−q1 `except` q2 = UnsafeQuery $
817− parenthesized (renderQuery q1)
818− <+> "EXCEPT"
819− <+> parenthesized (renderQuery q2)
820−q1 `exceptAll` q2 = UnsafeQuery $
821− parenthesized (renderQuery q1)
822− <+> "EXCEPT" <+> "ALL"
823− <+> parenthesized (renderQuery q2)
824−
825−{-----------------------------------------
826−SELECT statements
827−-----------------------------------------}
828−
829−select
830− :: SListI columns
831− => NP (Aliased (Expression params tables grouping)) columns
832− -> TableExpression params schema tables grouping
833− -> Query schema params columns
834−select list tabs = UnsafeQuery $
835− "SELECT"
836− <+> renderCommaSeparated (renderAliased renderExpression) list
837− <+> renderTableExpression tabs
838−
839−selectStar
840− :: (tables ~ '[table ::: columns])
841− => TableExpression params schema tables 'Ungrouped
842− -> Query schema params columns
843−selectStar tabs = UnsafeQuery $ "SELECT" <+> "*" <+> renderTableExpression tabs
844−
845−selectDotStar
846− :: HasTable table tables columns
847− => Alias table
848− -> TableExpression params schema tables 'Ungrouped
849− -> Query schema params columns
850−selectDotStar table tables = UnsafeQuery $
851− "SELECT" <+> renderAlias table <> ".*" <+> renderTableExpression tables
852−
853−selectRow
854− :: SListI columns
855− => NP (Aliased (Expression params '[] 'Ungrouped)) columns
856− -> Query schema params columns
857−selectRow row = UnsafeQuery $
858− "SELECT" <+> renderCommaSeparated (renderAliased renderExpression) row
859−
860−{-----------------------------------------
861−CREATE statements
862−-----------------------------------------}
863−
864−createTable
865− :: (KnownSymbol table, SListI columns)
866− => Alias table
867− -> NP (Aliased TypeExpression) columns
868− -> [TableConstraint schema columns]
869− -> Definition schema (Create table columns schema)
870−createTable table columns constraints = UnsafeDefinition $
871− "CREATE TABLE" <+> renderAlias table
872− <+> parenthesized
873− ( renderCommaSeparated renderColumnDef columns
874− <> renderConstraints constraints )
875− <> ";"
876− where
877− renderColumnDef :: Aliased TypeExpression x -> ByteString
878− renderColumnDef (ty `As` column) =
879− renderAlias column <+> renderTypeExpression ty
880− renderConstraints :: [TableConstraint schema columns] -> ByteString
881− renderConstraints = \case
882− [] -> ""
883− _ -> ", " <> commaSeparated (renderTableConstraint <$> constraints)
884−
885−data TableConstraint
886− (schema :: [(Symbol,[(Symbol,ColumnType)])])
887− (columns :: [(Symbol,ColumnType)])
888− = UnsafeTableConstraint { renderTableConstraint :: ByteString }
889−
890−check
891− :: Condition '[] '[table ::: columns] 'Ungrouped
892− -> TableConstraint schema columns
893−check condition = UnsafeTableConstraint $
894− "CHECK" <+> parenthesized (renderExpression condition)
895−
896−data Column
897− (columns :: [(Symbol,ColumnType)])
898− (columnty :: (Symbol,ColumnType))
899− where
900− Column
901− :: HasColumn column columns ty
902− => Alias column
903− -> Column columns (column ::: ty)
904−
905−renderColumn :: Column columns columnty -> ByteString
906−renderColumn (Column column) = renderAlias column
907−
908−unique
909− :: SListI subcolumns
910− => NP (Column columns) subcolumns
911− -> TableConstraint schema columns
912−unique columns = UnsafeTableConstraint $
913− "UNIQUE" <+> parenthesized (renderCommaSeparated renderColumn columns)
914−
915−primaryKey
916− :: (SListI subcolumns, NotNullTypes subcolumns)
917− => NP (Column columns) subcolumns
918− -> TableConstraint schema columns
919−primaryKey columns = UnsafeTableConstraint $
920− "PRIMARY KEY" <+> parenthesized (renderCommaSeparated renderColumn columns)
921−
922−type family SameTypes columns0 columns1 :: Constraint where
923− SameTypes '[] '[] = ()
924− SameTypes ((column0 ::: ty0) ': columns0) ((column1 ::: ty1) ': columns1)
925− = (ty0 ~ ty1, SameTypes columns0 columns1)
926−
927−type family NotNullTypes columns :: Constraint where
928− NotNullTypes '[] = ()
929− NotNullTypes ((column ::: (optionality ('NotNull ty))) ': columns)
930− = NotNullTypes columns
931−
932−foreignKey
933− :: ( HasTable reftable schema refcolumns
934− , SameTypes subcolumns refsubcolumns
935− , NotNullTypes subcolumns
936− , SListI subcolumns
937− , SListI refsubcolumns)
938− => NP (Column columns) subcolumns
939− -> Alias reftable
940− -> NP (Column refcolumns) refsubcolumns
941− -> TableConstraint schema columns
942−foreignKey columns reftable refcolumns = UnsafeTableConstraint $
943− "FOREIGN KEY" <+> parenthesized (renderCommaSeparated renderColumn columns)
944− <+> "REFERENCES" <+> renderAlias reftable
945− <+> parenthesized (renderCommaSeparated renderColumn refcolumns)
946−
947−{-----------------------------------------
948−DROP statements
949−-----------------------------------------}
950−
951−dropTable
952− :: KnownSymbol table
953− => Alias table
954− -> Definition schema (Drop table schema)
955−dropTable table = UnsafeDefinition $ "DROP TABLE" <+> renderAlias table <> ";"
956−
957−{-----------------------------------------
958−ALTER statements
959−-----------------------------------------}
960−
961−alterTable
962− :: HasTable table schema columns0
963− => Alias table
964− -> AlterTable columns0 columns1
965− -> Definition schema (Alter table schema columns1)
966−alterTable table alteration = UnsafeDefinition $
967− "ALTER TABLE"
968− <+> renderAlias table
969− <+> renderAlterTable alteration
970− <> ";"
971−
972−alterTableRename
973− :: (KnownSymbol table0, KnownSymbol table1)
974− => Alias table0
975− -> Alias table1
976− -> Definition schema (Rename table0 table1 schema)
977−alterTableRename table0 table1 = UnsafeDefinition $
978− "ALTER TABLE" <+> renderAlias table0
979− <+> "RENAME TO" <+> renderAlias table1 <> ";"
980−
981−data AlterTable
982− (columns0 :: [(Symbol, ColumnType)])
983− (columns1 :: [(Symbol, ColumnType)]) =
984− UnsafeAlterTable {renderAlterTable :: ByteString}
985−
986−addColumnDefault
987− :: KnownSymbol column
988− => Alias column
989− -> TypeExpression ('Optional ty)
990− -> AlterTable columns (Create column ('Optional ty) columns)
991−addColumnDefault column ty = UnsafeAlterTable $
992− "ADD COLUMN" <+> renderAlias column <+> renderTypeExpression ty
993−
994−addColumnNull
995− :: KnownSymbol column
996− => Alias column
997− -> TypeExpression ('Required ('Null ty))
998− -> AlterTable columns ((column ::: 'Required ('Null ty)) ': columns)
999−addColumnNull column ty = UnsafeAlterTable $
1000− "ADD COLUMN" <+> renderAlias column <+> renderTypeExpression ty
1001−
1002−dropColumn
1003− :: KnownSymbol column
1004− => Alias column
1005− -> AlterTable columns (Drop column columns)
1006−dropColumn column = UnsafeAlterTable $
1007− "DROP COLUMN" <+> renderAlias column
1008−
1009−renameColumn
1010− :: (KnownSymbol column0, KnownSymbol column1)
1011− => Alias column0
1012− -> Alias column1
1013− -> AlterTable columns (Rename column0 column1 columns)
1014−renameColumn column0 column1 = UnsafeAlterTable $
1015− "RENAME COLUMN" <+> renderAlias column0 <+> "TO" <+> renderAlias column1
1016−
1017−alterColumn
1018− :: (KnownSymbol column, HasColumn column columns ty0)
1019− => Alias column
1020− -> AlterColumn ty0 ty1
1021− -> AlterTable columns (Alter column columns ty1)
1022−alterColumn column alteration = UnsafeAlterTable $
1023− "ALTER COLUMN" <+> renderAlias column <+> renderAlterColumn alteration
1024−
1025−data AlterColumn (ty0 :: ColumnType) (ty1 :: ColumnType) =
1026− UnsafeAlterColumn {renderAlterColumn :: ByteString}
1027−
1028−setDefault
1029− :: Expression '[] '[] 'Ungrouped ('Required ty)
1030− -> AlterColumn ('Required ty) ('Optional ty)
1031−setDefault expression = UnsafeAlterColumn $
1032− "SET DEFAULT" <+> renderExpression expression
1033−
1034−dropDefault :: AlterColumn ('Optional ty) ('Required ty)
1035−dropDefault = UnsafeAlterColumn $ "DROP DEFAULT"
1036−
1037−setNotNull
1038− :: AlterColumn (optionality ('Null ty)) (optionality ('NotNull ty))
1039−setNotNull = UnsafeAlterColumn $ "SET NOT NULL"
1040−
1041−dropNotNull
1042− :: AlterColumn (optionality ('NotNull ty)) (optionality ('Null ty))
1043−dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL"
1044−
1045−alterType
1046− :: PGCast ty0 ty1
1047− => TypeExpression (optionality (nullity ty1))
1048− -> AlterColumn (optionality (nullity ty0)) (optionality (nullity ty1))
1049−alterType ty = UnsafeAlterColumn $ "TYPE " <> renderTypeExpression ty
1050−
1051−{-----------------------------------------
1052−INSERT statements
1053−-----------------------------------------}
1054−
1055−insertInto
1056− :: (SListI columns, SListI results, HasTable table schema columns)
1057− => Alias table
1058− -> ValuesClause schema params columns
1059− -> ConflictClause params columns
1060− -> ReturningClause params columns results
1061− -> Manipulation schema params results
1062−insertInto table insert conflict returning = UnsafeManipulation $
1063− "INSERT" <+> "INTO" <+> renderAlias table
1064− <+> renderValuesClause insert
1065− <> renderConflictClause conflict
1066− <> renderReturningClause returning
1067−
1068−data ValuesClause
1069− (schema :: [(Symbol,[(Symbol,ColumnType)])])
1070− (params :: [ColumnType])
1071− (columns :: [(Symbol,ColumnType)])
1072− = Values
1073− (NP (Aliased (Expression params '[] 'Ungrouped)) columns)
1074− [NP (Aliased (Expression params '[] 'Ungrouped)) columns]
1075− | ValuesQuery (Query schema params columns)
1076−
1077−renderValuesClause
1078− :: SListI columns
1079− => ValuesClause schema params columns
1080− -> ByteString
1081−renderValuesClause = \case
1082− Values row rows ->
1083− parenthesized (renderCommaSeparated renderAliasPart row)
1084− <+> "VALUES"
1085− <+> commaSeparated
1086− (parenthesized . renderCommaSeparated renderValuePart <$> row:rows)
1087− where
1088− renderAliasPart, renderValuePart
1089− :: Aliased (Expression params '[] 'Ungrouped) ty -> ByteString
1090− renderAliasPart (_ `As` name) = renderAlias name
1091− renderValuePart (value `As` _) = renderExpression value
1092− ValuesQuery q -> renderQuery q
1093−
1094−data ReturningClause
1095− (params :: [ColumnType])
1096− (columns :: [(Symbol,ColumnType)])
1097− (results :: [(Symbol,ColumnType)])
1098− where
1099− ReturningNil :: ReturningClause params columns '[]
1100− ReturningStar :: ReturningClause params columns columns
1101− Returning
1102− :: NP (Aliased (Expression params '[table ::: columns] 'Ungrouped)) results
1103− -> ReturningClause params columns results
1104−
1105−renderReturningClause
1106− :: SListI results
1107− => ReturningClause params columns results
1108− -> ByteString
1109−renderReturningClause = \case
1110− ReturningNil -> ";"
1111− ReturningStar -> " RETURNING *;"
1112− Returning results -> " RETURNING"
1113− <+> renderCommaSeparated (renderAliased renderExpression) results <> ";"
1114−
1115−data ConflictClause params columns where
1116− Conflict :: ConflictClause params columns
1117− OnConflictDoNothing :: ConflictClause params columns
1118− OnConflictDoUpdate
1119− :: NP (Aliased (UpdateExpression params '[table ::: columns])) columns
1120− -> Condition params '[table ::: columns] 'Ungrouped
1121− -> ConflictClause params columns
1122−
1123−renderConflictClause
1124− :: SListI columns
1125− => ConflictClause params columns
1126− -> ByteString
1127−renderConflictClause = \case
1128− Conflict -> ""
1129− OnConflictDoNothing -> " ON CONFLICT DO NOTHING"
1130− OnConflictDoUpdate updates wh
1131− -> " ON CONFLICT DO UPDATE SET"
1132− <+> renderCommaSeparatedMaybe renderUpdateExpression updates
1133− <+> "WHERE" <+> renderExpression wh
1134−
1135−{-----------------------------------------
1136−UPDATE statements
1137−-----------------------------------------}
1138−
1139−data UpdateExpression params table ty
1140− = Same
1141− | Set (Expression params table 'Ungrouped ty)
1142−
1143−renderUpdateExpression
1144− :: Aliased (UpdateExpression params '[table ::: columns]) column
1145− -> Maybe ByteString
1146−renderUpdateExpression = \case
1147− Same `As` _ -> Nothing
1148− Set expression `As` column -> Just $
1149− renderAlias column <+> "=" <+> renderExpression expression
1150−
1151−update
1152− :: (HasTable table schema columns, SListI columns, SListI results)
1153− => Alias table
1154− -> NP (Aliased (UpdateExpression params '[table ::: columns])) columns
1155− -> Condition params '[table ::: columns] 'Ungrouped
1156− -> ReturningClause params columns results
1157− -> Manipulation schema params results
1158−update table columns wh returning = UnsafeManipulation $
1159− "UPDATE"
1160− <+> renderAlias table
1161− <+> "SET"
1162− <+> renderCommaSeparatedMaybe renderUpdateExpression columns
1163− <+> "WHERE" <+> renderExpression wh
1164− <> renderReturningClause returning
1165−
1166−{-----------------------------------------
1167−DELETE statements
1168−-----------------------------------------}
1169−
1170−deleteFrom
1171− :: HasTable table schema columns
1172− => Alias table
1173− -> Condition params '[table ::: columns] 'Ungrouped
1174− -> Manipulation schema params '[]
1175−deleteFrom table wh = UnsafeManipulation $
1176− "DELETE FROM" <+> renderAlias table
1177− <+> "WHERE" <+> renderExpression wh <> ";"
1178−
1179−{-----------------------------------------
1180−render helper functions
1181−-----------------------------------------}
1182−
1183−parenthesized :: ByteString -> ByteString
1184−parenthesized str = "(" <> str <> ")"
1185−
1186−(<+>) :: ByteString -> ByteString -> ByteString
1187−str1 <+> str2 = str1 <> " " <> str2
1188−
1189−commaSeparated :: [ByteString] -> ByteString
1190−commaSeparated = ByteString.intercalate ", "
1191−
1192−renderCommaSeparated
1193− :: SListI xs
1194− => (forall x. expression x -> ByteString)
1195− -> NP expression xs -> ByteString
1196−renderCommaSeparated render
1197− = commaSeparated
1198− . hcollapse
1199− . hmap (K . render)
1200−
1201−renderCommaSeparatedMaybe
1202− :: SListI xs
1203− => (forall x. expression x -> Maybe ByteString)
1204− -> NP expression xs -> ByteString
1205−renderCommaSeparatedMaybe render
1206− = commaSeparated
1207− . catMaybes
1208− . hcollapse
1209− . hmap (K . render)
1210−
1211−renderSymbol :: KnownSymbol str => Proxy# str -> ByteString
1212−renderSymbol p = fromString $ symbolVal' p
squeel-postgresql/test/Spec.hsdeleted−1
@@ -1 +0,0 @@
1−{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
squeel-postgresql/test/Squeel/PostgreSQL/StatementSpec.hsdeleted−323
@@ -1,323 +0,0 @@
1−{-# LANGUAGE
2− DataKinds
3− , MagicHash
4− , OverloadedLabels
5− , OverloadedStrings
6− , TypeOperators
7−#-}
8−
9−module Squeel.PostgreSQL.StatementSpec where
10−
11−import Control.Category ((>>>))
12−import Data.Function
13−import Generics.SOP hiding (from)
14−import Test.Hspec
15−
16−import Squeel.PostgreSQL.Statement
17−import Squeel.PostgreSQL.Schema
18−
19−spec :: Spec
20−spec = do
21− let
22− qry `queryRenders` str = query qry `manipulationRenders` str
23− definition `definitionRenders` str =
24− renderDefinition definition `shouldBe` str
25− manipulation `manipulationRenders` str =
26− renderManipulation manipulation `shouldBe` str
27− it "correctly renders a simple SELECT query" $ do
28− let
29− statement :: Query Tables '[] SumAndCol1
30− statement =
31− select ((#col1 + #col2) `As` #sum :* #col1 `As` #col1 :* Nil)
32− (from (Table (#table1 `As` #table1)) & where_ (#col1 >* #col2))
33− statement `queryRenders`
34− "SELECT (col1 + col2) AS sum, col1 AS col1\
35− \ FROM table1 AS table1 WHERE (col1 > col2);"
36− it "combines WHEREs using AND" $ do
37− let
38− statement :: Query Tables '[] SumAndCol1
39− statement =
40− select ((#col1 + #col2) `As` #sum :* #col1 `As` #col1 :* Nil)
41− (from (Table (#table1 `As` #table1)) & where_ true & where_ false)
42− statement `queryRenders`
43− "SELECT (col1 + col2) AS sum, col1 AS col1\
44− \ FROM table1 AS table1 WHERE (TRUE AND FALSE);"
45− it "performs sub SELECTs" $ do
46− let
47− statement :: Query Tables '[] SumAndCol1
48− statement =
49− selectStar (from (Subquery
50− (select ((#col1 + #col2) `As` #sum :* #col1 `As` #col1 :* Nil)
51− (from (Table (#table1 `As` #table1))) `As` #sub)))
52− statement `queryRenders`
53− "SELECT * FROM\
54− \ SELECT (col1 + col2) AS sum, col1 AS col1\
55− \ FROM table1 AS table1 AS sub;"
56− it "does LIMIT clauses" $ do
57− let
58− statement :: Query Tables '[] Columns
59− statement = selectStar (from (Table (#table1 `As` #table1)) & limit 1)
60− statement `queryRenders` "SELECT * FROM table1 AS table1 LIMIT 1;"
61− it "should use the minimum of given LIMITs" $ do
62− let
63− statement :: Query Tables '[] Columns
64− statement =
65− selectStar (from (Table (#table1 `As` #table1)) & limit 1 & limit 2)
66− statement `queryRenders` "SELECT * FROM table1 AS table1 LIMIT 1;"
67− it "should render parameters using $ signs" $ do
68− let
69− statement :: Query Tables '[ 'Required ('NotNull 'PGBool)] Columns
70− statement =
71− selectStar (from (Table (#table1 `As` #table1)) & where_ param1)
72− statement `queryRenders` "SELECT * FROM table1 AS table1 WHERE $1;"
73− it "does OFFSET clauses" $ do
74− let
75− statement :: Query Tables '[] Columns
76− statement =
77− selectStar (from (Table (#table1 `As` #table1)) & offset 1)
78− statement `queryRenders` "SELECT * FROM table1 AS table1 OFFSET 1;"
79− it "should use the sum of given OFFSETs" $ do
80− let
81− statement :: Query Tables '[] Columns
82− statement = selectStar
83− (from (Table (#table1 `As` #table1)) & offset 1 & offset 2)
84− statement `queryRenders` "SELECT * FROM table1 AS table1 OFFSET 3;"
85− it "should render GROUP BY and HAVING clauses" $ do
86− let
87− statement :: Query Tables '[] SumAndCol1
88− statement =
89− select (sum_ #col2 `As` #sum :* #col1 `As` #col1 :* Nil)
90− ( from (Table (#table1 `As` #table1))
91− & group (By #col1 :* Nil)
92− & having ((#col1 + sum_ #col2) >* 1) )
93− statement `queryRenders`
94− "SELECT sum(col2) AS sum, col1 AS col1\
95− \ FROM table1 AS table1\
96− \ GROUP BY col1\
97− \ HAVING ((col1 + sum(col2)) > 1);"
98− it "correctly renders simple INSERTs" $ do
99− let
100− statement :: Manipulation Tables '[] '[]
101− statement =
102− insertInto #table1 (Values (2 `As` #col1 :* 4 `As` #col2 :* Nil) [])
103− Conflict ReturningNil
104− statement `manipulationRenders`
105− "INSERT INTO table1 (col1, col2) VALUES (2, 4);"
106− it "correctly renders returning INSERTs" $ do
107− let
108− statement :: Manipulation Tables '[] SumAndCol1
109− statement =
110− insertInto #table1 (Values (2 `As` #col1 :* 4 `As` #col2 :* Nil) [])
111− Conflict
112− (Returning $ (#col1 + #col2) `As` #sum :* #col1 `As` #col1 :* Nil)
113− statement `manipulationRenders`
114− "INSERT INTO table1 (col1, col2) VALUES (2, 4)\
115− \ RETURNING (col1 + col2) AS sum, col1 AS col1;"
116− it "correctly renders simple UPDATEs" $ do
117− let
118− statement :: Manipulation Tables '[] '[]
119− statement =
120− update #table1 (Set 2 `As` #col1 :* Same `As` #col2 :* Nil)
121− (#col1 /=* #col2) ReturningNil
122− statement `manipulationRenders`
123− "UPDATE table1 SET col1 = 2\
124− \ WHERE (col1 <> col2);"
125− it "correctly renders returning UPDATEs" $ do
126− let
127− statement :: Manipulation Tables '[] SumAndCol1
128− statement =
129− update #table1 (Set 2 `As` #col1 :* Same `As` #col2 :* Nil)
130− (#col1 /=* #col2)
131− (Returning $ (#col1 + #col2) `As` #sum :* #col1 `As` #col1 :* Nil)
132− statement `manipulationRenders`
133− "UPDATE table1 SET col1 = 2\
134− \ WHERE (col1 <> col2)\
135− \ RETURNING (col1 + col2) AS sum, col1 AS col1;"
136− it "correctly renders upsert INSERTs" $ do
137− let
138− statement :: Manipulation Tables '[] '[]
139− statement =
140− insertInto #table1 (Values (2 `As` #col1 :* 4 `As` #col2 :* Nil) [])
141− (OnConflictDoUpdate
142− (Set 2 `As` #col1 :* Same `As` #col2 :* Nil) (#col1 /=* #col2))
143− ReturningNil
144− statement `manipulationRenders`
145− "INSERT INTO table1 (col1, col2) VALUES (2, 4)\
146− \ ON CONFLICT DO UPDATE\
147− \ SET col1 = 2 WHERE (col1 <> col2);"
148− it "correctly renders returning upsert INSERTs" $ do
149− let
150− statement :: Manipulation Tables '[] SumAndCol1
151− statement =
152− insertInto #table1 (Values (2 `As` #col1 :* 4 `As` #col2 :* Nil) [])
153− (OnConflictDoUpdate
154− (Set 2 `As` #col1 :* Same `As` #col2 :* Nil)
155− (#col1 /=* #col2))
156− (Returning $ (#col1 + #col2) `As` #sum :* #col1 `As` #col1 :* Nil)
157− statement `manipulationRenders`
158− "INSERT INTO table1 (col1, col2) VALUES (2, 4)\
159− \ ON CONFLICT DO UPDATE\
160− \ SET col1 = 2\
161− \ WHERE (col1 <> col2)\
162− \ RETURNING (col1 + col2) AS sum, col1 AS col1;"
163− it "correctly renders DELETEs" $ do
164− let
165− statement :: Manipulation Tables '[] '[]
166− statement = deleteFrom #table1 (#col1 ==* #col2)
167− statement `manipulationRenders`
168− "DELETE FROM table1 WHERE (col1 = col2);"
169− it "should be safe against SQL injection in literal text" $ do
170− let
171− statement :: Manipulation StudentsTable '[] '[]
172− statement = insertInto #students
173− (Values ("Robert'); DROP TABLE students;" `As` #name :* Nil) [])
174− Conflict ReturningNil
175− statement `manipulationRenders`
176− "INSERT INTO students (name) VALUES (E'Robert''); DROP TABLE students;');"
177− describe "JOINs" $ do
178− it "should render CROSS JOINs" $ do
179− let
180− statement :: Query JoinTables '[] ValueColumns
181− statement = select
182− ( (#orders &. #orderVal) `As` #orderVal
183− :* (#customers &. #customerVal) `As` #customerVal
184− :* (#shippers &. #shipperVal) `As` #shipperVal :* Nil)
185− ( from (Table (#orders `As` #orders)
186− & CrossJoin (Table (#customers `As` #customers))
187− & CrossJoin (Table (#shippers `As` #shippers))))
188− statement `queryRenders`
189− "SELECT\
190− \ orders.orderVal AS orderVal,\
191− \ customers.customerVal AS customerVal,\
192− \ shippers.shipperVal AS shipperVal\
193− \ FROM orders AS orders\
194− \ CROSS JOIN customers AS customers\
195− \ CROSS JOIN shippers AS shippers;"
196− it "should render INNER JOINs" $ do
197− let
198− statement :: Query JoinTables '[] ValueColumns
199− statement = select
200− ( (#orders &. #orderVal) `As` #orderVal
201− :* (#customers &. #customerVal) `As` #customerVal
202− :* (#shippers &. #shipperVal) `As` #shipperVal :* Nil)
203− ( from (Table (#orders `As` #orders)
204− & InnerJoin (Table (#customers `As` #customers))
205− ((#orders &. #customerID) ==* (#customers &. #customerID))
206− & InnerJoin (Table (#shippers `As` #shippers))
207− ((#orders &. #shipperID) ==* (#shippers &. #shipperID))))
208− statement `queryRenders`
209− "SELECT\
210− \ orders.orderVal AS orderVal,\
211− \ customers.customerVal AS customerVal,\
212− \ shippers.shipperVal AS shipperVal\
213− \ FROM orders AS orders\
214− \ INNER JOIN customers AS customers\
215− \ ON (orders.customerID = customers.customerID)\
216− \ INNER JOIN shippers AS shippers\
217− \ ON (orders.shipperID = shippers.shipperID);"
218− it "should render self JOINs" $ do
219− let
220− statement :: Query JoinTables '[] OrderColumns
221− statement = selectDotStar #orders1
222− (from (Table (#orders `As` #orders1)
223− & CrossJoin (Table (#orders `As` #orders2))))
224− statement `queryRenders`
225− "SELECT orders1.*\
226− \ FROM orders AS orders1\
227− \ CROSS JOIN orders AS orders2;"
228− it "should render CREATE TABLE statements" $ do
229− createTable #table1
230− ((int4 & notNull) `As` #col1 :* (int4 & notNull) `As` #col2 :* Nil)
231− [primaryKey (Column #col1 :* Column #col2 :* Nil)]
232− `definitionRenders`
233− "CREATE TABLE table1\
234− \ (col1 int4 NOT NULL, col2 int4 NOT NULL,\
235− \ PRIMARY KEY (col1, col2));"
236− createTable #table2
237− ( serial `As` #col1 :*
238− text `As` #col2 :*
239− (int8 & notNull & default_ 8) `As` #col3 :* Nil )
240− [check (#col3 >* 0)]
241− `definitionRenders`
242− "CREATE TABLE table2\
243− \ (col1 serial,\
244− \ col2 text,\
245− \ col3 int8 NOT NULL DEFAULT 8,\
246− \ CHECK ((col3 > 0)));"
247− let
248− statement :: Definition '[]
249− '[ "users" :::
250− '[ "id" ::: 'Optional ('NotNull 'PGInt4)
251− , "username" ::: 'Required ('NotNull 'PGText)
252− ]
253− , "emails" :::
254− '[ "id" ::: 'Optional ('NotNull 'PGInt4)
255− , "userid" ::: 'Required ('NotNull 'PGInt4)
256− , "email" ::: 'Required ('NotNull 'PGText)
257− ]
258− ]
259− statement =
260− createTable #users
261− (serial `As` #id :* (text & notNull) `As` #username :* Nil)
262− [primaryKey (Column #id :* Nil)]
263− >>>
264− createTable #emails
265− ( serial `As` #id :*
266− (integer & notNull) `As` #userid :*
267− (text & notNull) `As` #email :* Nil )
268− [ primaryKey (Column #id :* Nil)
269− , foreignKey (Column #userid :* Nil) #users (Column #id :* Nil)
270− , unique (Column #email :* Nil)
271− , check (#email /=* "")
272− ]
273− statement `definitionRenders`
274− "CREATE TABLE users\
275− \ (id serial, username text NOT NULL,\
276− \ PRIMARY KEY (id));\
277− \ \
278− \CREATE TABLE emails\
279− \ (id serial,\
280− \ userid integer NOT NULL,\
281− \ email text NOT NULL,\
282− \ PRIMARY KEY (id),\
283− \ FOREIGN KEY (userid) REFERENCES users (id),\
284− \ UNIQUE (email),\
285− \ CHECK ((email <> E'')));"
286− it "should render DROP TABLE statements" $ do
287− let
288− statement :: Definition Tables '[]
289− statement = dropTable #table1
290− statement `definitionRenders` "DROP TABLE table1;"
291−
292−type Columns =
293− '[ "col1" ::: 'Required ('NotNull 'PGInt4)
294− , "col2" ::: 'Required ('NotNull 'PGInt4)
295− ]
296−type Tables = '[ "table1" ::: Columns ]
297−type SumAndCol1 = '[ "sum" ::: 'Required ('NotNull 'PGInt4), "col1" ::: 'Required ('NotNull 'PGInt4)]
298−type StudentsColumns = '["name" ::: 'Required ('NotNull 'PGText)]
299−type StudentsTable = '["students" ::: StudentsColumns]
300−type OrderColumns =
301− '[ "orderID" ::: 'Required ('NotNull 'PGInt4)
302− , "orderVal" ::: 'Required ('NotNull 'PGText)
303− , "customerID" ::: 'Required ('NotNull 'PGInt4)
304− , "shipperID" ::: 'Required ('NotNull 'PGInt4)
305− ]
306−type CustomerColumns =
307− '[ "customerID" ::: 'Required ('NotNull 'PGInt4)
308− , "customerVal" ::: 'Required ('NotNull 'PGFloat4)
309− ]
310−type ShipperColumns =
311− '[ "shipperID" ::: 'Required ('NotNull 'PGInt4)
312− , "shipperVal" ::: 'Required ('NotNull 'PGBool)
313− ]
314−type JoinTables =
315− '[ "orders" ::: OrderColumns
316− , "customers" ::: CustomerColumns
317− , "shippers" ::: ShipperColumns
318− ]
319−type ValueColumns =
320− '[ "orderVal" ::: 'Required ('NotNull 'PGText)
321− , "customerVal" ::: 'Required ('NotNull 'PGFloat4)
322− , "shipperVal" ::: 'Required ('NotNull 'PGBool)
323− ]
stack.yaml+7−2
@@ -1,3 +1,8 @@
1−resolver: nightly-2017-06-26
1+resolver: nightly-2019-07-14
2packages:
2packages:
3−- squeel-postgresql
3+- squeal-postgresql
4+
5+extra-deps:
6+- unliftio-pool-0.2.1.0
7+- github: morphismtech/free-categories
8+ commit: c0e555fbefb5c21619e532264c4dfeac556d0630